src/liburforth/urforth.c

   1 // and now for something completely different...
   2 // UrAsm built-in Forth Engine!
   3 // GPLv3 ONLY
   4 #ifdef WIN32
   5 #include <windows.h>
   6 #endif
   7 #include <stdarg.h>
   8 #include <setjmp.h>
   9 #include <stdio.h>
  10 #include <stdlib.h>
  11 #include <string.h>
  12 #include <time.h>
  13 #include <unistd.h>
  14
  15 #include <sys/stat.h>
  16 #include <sys/types.h>
  17
  18 #include "urforth.h"
  19
  20 #ifdef WIN32
  21 # define realpath(shit,fuck)  _fullpath(fuck, shit, 32768)
  22 #endif
  23
  24
  25 #define UFO_DEBUG_STARTUP_TIMES
  26 //#define UFO_DEBUG_FATAL_ABORT
  27 #define UFO_DEBUG_DEBUG  /* ;-) */
  28 //#define UFO_TRACE_VM_DOER
  29 //#define UFO_TRACE_VM_RUN
  30 //#define UFO_DEBUG_INCLUDE
  31 //#define UFO_DEBUG_DUMP_NEW_HEADERS
  32 //#define UFO_DEBUG_FIND_WORD
  33 //#define UFO_DEBUG_FIND_WORD_IN_VOC
  34 //#define UFO_DEBUG_FIND_WORD_COLON
  35
  36 // 2/8 msecs w/o inlining
  37 // 1/5 msecs with inlining
  38 #if 1
  39 # define UFO_FORCE_INLINE static inline __attribute__((always_inline))
  40 #else
  41 # define UFO_FORCE_INLINE static __attribute__((noinline)) __attribute__((unused))
  42 #endif
  43 #define UFO_DISABLE_INLINE static __attribute__((noinline)) __attribute__((unused))
  44
  45 // detect arch, and use faster memory access code on x86
  46 #if defined(__x86_64__) || defined(_M_X64) || \
  47     defined(i386) || defined(__i386__) || defined(__i386) || defined(_M_IX86)
  48 # define UFO_FAST_MEM_ACCESS
  49 #endif
  50
  51 // should not be bigger than this!
  52 #define UFO_MAX_WORD_LENGTH  (250)
  53
  54 #define UFO_ALIGN4(v_)  (((v_) + 3u) / 4u * 4u)
  55
  56
  57 // ////////////////////////////////////////////////////////////////////////// //
  58 static const char *ufo_assert_failure (const char *cond, const char *fname, int fline, const char *func) {
  59   for (const char *t = fname; *t; ++t) {
  60     #ifdef WIN32
  61     if (*t == '/' || *t == '\\') fname = t+1;
  62     #else
  63     if (*t == '/') fname = t+1;
  64     #endif
  65   }
  66   fflush(NULL);
  67   fprintf(stderr, "\n%s:%d: Assertion in `%s` failed: %s\n", fname, fline, func, cond);
  68   fflush(NULL);
  69   abort();
  70 }
  71
  72 #define ufo_assert(cond_)  do { if (__builtin_expect((!(cond_)), 0)) { ufo_assert_failure(#cond_, __FILE__, __LINE__, __PRETTY_FUNCTION__); } } while (0)
  73
  74
  75 static char ufoRealPathBuf[32769];
  76 static char ufoRealPathHashBuf[32769];
  77
  78
  79 //==========================================================================
  80 //
  81 //  ufoRealPath
  82 //
  83 //==========================================================================
  84 static char *ufoRealPath (const char *fname) {
  85   char *res;
  86   if (fname != NULL && fname[0] != 0) {
  87     res = realpath(fname, NULL);
  88     if (res != NULL) {
  89       const size_t slen = strlen(res);
  90       if (slen < 32768) {
  91         strcpy(ufoRealPathBuf, res);
  92         free(res);
  93         res = ufoRealPathBuf;
  94       } else {
  95         free(res);
  96         res = NULL;
  97       }
  98     }
  99   } else {
 100     res = NULL;
 101   }
 102   return res;
 103 }
 104
 105
 106 #ifndef WIN32
 107 static time_t secstart = 0;
 108 #endif
 109
 110
 111
 112 //==========================================================================
 113 //
 114 //  ufo_get_msecs
 115 //
 116 //==========================================================================
 117 static uint64_t ufo_get_msecs (void) {
 118   #ifdef WIN32
 119   return GetTickCount();
 120   #else
 121   struct timespec ts;
 122   #ifdef CLOCK_MONOTONIC
 123   ufo_assert(clock_gettime(CLOCK_MONOTONIC, &ts) == 0);
 124   #else
 125   // this should be available everywhere
 126   ufo_assert(clock_gettime(CLOCK_REALTIME, &ts) == 0);
 127   #endif
 128   // first run?
 129   if (secstart == 0) {
 130     secstart = ts.tv_sec+1;
 131     ufo_assert(secstart); // it should not be zero
 132   }
 133   return (uint64_t)(ts.tv_sec-secstart+2)*1000U+(uint32_t)ts.tv_nsec/1000000U;
 134   // nanoseconds
 135   //return (uint64_t)(ts.tv_sec-secstart+2)*1000000000U+(uint32_t)ts.tv_nsec;
 136   #endif
 137 }
 138
 139
 140 //==========================================================================
 141 //
 142 //  joaatHashBuf
 143 //
 144 //==========================================================================
 145 UFO_FORCE_INLINE uint32_t joaatHashBuf (const void *buf, size_t len, uint8_t orbyte) {
 146   uint32_t hash = 0x29a;
 147   const uint8_t *s = (const uint8_t *)buf;
 148   while (len--) {
 149     hash += (*s++)|orbyte;
 150     hash += hash<<10;
 151     hash ^= hash>>6;
 152   }
 153   // finalize
 154   hash += hash<<3;
 155   hash ^= hash>>11;
 156   hash += hash<<15;
 157   return hash;
 158 }
 159
 160
 161 // this converts ASCII capitals to locase (and destroys other, but who cares)
 162 #define joaatHashBufCI(buf_,len_)  joaatHashBuf((buf_), (len_), 0x20)
 163
 164
 165 //==========================================================================
 166 //
 167 //  toUpper
 168 //
 169 //==========================================================================
 170 UFO_FORCE_INLINE char toUpper (char ch) {
 171   return (ch >= 'a' && ch <= 'z' ? ch-'a'+'A' : ch);
 172 }
 173
 174
 175 //==========================================================================
 176 //
 177 //  toUpperU8
 178 //
 179 //==========================================================================
 180 UFO_FORCE_INLINE uint8_t toUpperU8 (uint8_t ch) {
 181   return (ch >= 'a' && ch <= 'z' ? ch-'a'+'A' : ch);
 182 }
 183
 184
 185 //==========================================================================
 186 //
 187 //  digitInBase
 188 //
 189 //==========================================================================
 190 UFO_FORCE_INLINE int digitInBase (char ch, int base) {
 191   switch (ch) {
 192     case '0' ... '9': ch = ch - '0'; break;
 193     case 'A' ... 'Z': ch = ch - 'A' + 10; break;
 194     case 'a' ... 'z': ch = ch - 'a' + 10; break;
 195     default: base = -1; break;
 196   }
 197   return (ch >= 0 && ch < base ? ch : -1);
 198 }
 199
 200
 201 /*
 202 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 203 ;; word header format:
 204 ;; note than name hash is ALWAYS calculated with ASCII-uppercased name
 205 ;; (actually, bit 5 is always reset for all bytes, because we don't need the
 206 ;; exact uppercase, only something that resembles it)
 207 ;; bfa points to next bfa or to 0 (this is "hash bucket pointer")
 208 ;; before nfa, we have such "hidden" fields:
 209 ;;   dd dfa       ; pointer to the debug data; can be 0 if debug info is missing
 210 ;;   dd xfa       ; points to the previous word header SFA, regardless of vocabularies (or 0)
 211 ;;   dd yfa       ; points to the previous word header SFA, regardless of vocabularies (or 0)
 212 ;;   dd bfa       ; next word in hashtable bucket; it is always here, even if hashtable is turned off
 213 ;;                ; if there is no hashtable, this field is not used
 214 ;; lfa:
 215 ;;   dd lfa       ; previous vocabulary word LFA or 0 (lfa links points here)
 216 ;;   dd namehash  ; it is always here, and always calculated, even if hashtable is turned off
 217 ;; nfa:
 218 ;;   dd flags-and-name-len   ; see below
 219 ;;   db name      ; no terminating zero or other "termination flag" here
 220 ;;  here could be some 0 bytes to align everything to 4 bytes
 221 ;;   db namelen   ; yes, name length again, so CFA->NFA can avoid guessing
 222 ;;                ; full length, including padding, but not including this byte
 223 ;; cfa:
 224 ;;   dd cfaidx    ; our internal CFA index, or image address for DOES>
 225 ;; pfa:
 226 ;;   word data follows
 227 ;;
 228 ;; first word cell contains combined name length (low byte), argtype and flags (other bytes)
 229 ;; layout:
 230 ;;   db namelen
 231 ;;   db argtype
 232 ;;   dw flags
 233 ;; i.e. we have 16 bits for flags, and 256 possible argument types. why not.
 234 ;;
 235 ;; flags:
 236 ;;  bit 0: immediate
 237 ;;  bit 1: smudge
 238 ;;  bit 2: noreturn
 239 ;;  bit 3: hidden
 240 ;;  bit 4: codeblock
 241 ;;  bit 5: vocabulary
 242 ;;  bit 6: *UNUSED* main scattered colon word (with "...")
 243 ;;  bit 7: protected
 244 ;;
 245 ;;  argtype is the type of the argument that this word reads from the threaded code.
 246 ;;  possible argument types:
 247 ;;    0: none
 248 ;;    1: branch address
 249 ;;    2: cell-size numeric literal
 250 ;;    3: cell-counted string with terminating zero (not counted)
 251 ;;    4: cfa of another word
 252 ;;    5: cblock
 253 ;;    6: vocid
 254 ;;    7: byte-counted string with terminating zero (not counted)
 255 ;;    8: *UNUSED* unsigned byte
 256 ;;    9: *UNUSED* signed byte
 257 ;;   10: *UNUSED* unsigned word
 258 ;;   11: *UNUSED* signed word
 259
 260
 261 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 262 ;; wordlist structure (at PFA)
 263 ;; -4: wordlist type id (used by structs, for example)
 264 ;;   dd latest
 265 ;;   dd voclink (voclink always points here)
 266 ;;   dd parent (if not zero, all parent words are visible)
 267 ;;   dd header-nfa (can be 0 for anonymous wordlists)
 268 ;;   hashtable (if enabled), or ~0U if no hash table
 269 */
 270
 271
 272 // ////////////////////////////////////////////////////////////////////////// //
 273 #define UFO_BFA_TO_LFA(bfa_)    ((bfa_) + 1u * 4u)
 274 #define UFO_LFA_TO_DFA(lfa_)    ((lfa_) - 4u * 4u)
 275 #define UFO_LFA_TO_XFA(lfa_)    ((lfa_) - 3u * 4u)
 276 #define UFO_LFA_TO_YFA(lfa_)    ((lfa_) - 2u * 4u)
 277 #define UFO_LFA_TO_BFA(lfa_)    ((lfa_) - 1u * 4u)
 278 #define UFO_LFA_TO_NFA(lfa_)    ((lfa_) + 2u * 4u)
 279 #define UFO_LFA_TO_CFA(lfa_)    UFO_ALIGN4((lfa_) + 3u * 4u + 1u + ufoImgGetU8((lfa_) + 2u * 4u))
 280 #define UFO_LFA_TO_NHASH(lfa_)  ((lfa_) + 1u * 4u)
 281 #define UFO_CFA_TO_NFA(cfa_)    ((cfa_) - 1u - 4u - ufoImgGetU8((cfa_) - 1u))
 282 #define UFO_CFA_TO_LFA(cfa_)    ((cfa_) - 1u - 4u * 3u - ufoImgGetU8((cfa_) - 1u))
 283 #define UFO_CFA_TO_PFA(cfa_)    ((cfa_) + 1u * 4u)
 284 #define UFO_PFA_TO_CFA(pfa_)    ((pfa_) - 1u * 4u)
 285 #define UFO_NFA_TO_CFA(nfa_)    UFO_ALIGN4((nfa_) + 4u + 1u + ufoImgGetU8((nfa_)))
 286 #define UFO_NFA_TO_LFA(nfa_)    ((nfa_) - 2u * 4u)
 287 #define UFO_XFA_TO_YFA(xfa_)    ((xfa_) + 4u)
 288 #define UFO_YFA_TO_XFA(yfa_)    ((xfa_) - 4u)
 289 #define UFO_XFA_TO_WST(xfa_)    ((xfa_) - 4u)
 290 #define UFO_YFA_TO_WST(yfa_)    ((yfa_) - 2u * 4u)
 291 #define UFO_YFA_TO_NFA(yfa_)    ((yfa_) + 4u * 4u)
 292
 293
 294 // ////////////////////////////////////////////////////////////////////////// //
 295 //#define UFW_WARG_U8      (8u<<8)
 296 //#define UFW_WARG_S8      (9u<<8)
 297 //#define UFW_WARG_U16     (10u<<8)
 298 //#define UFW_WARG_S16     (11u<<8)
 299
 300 #define UFW_VOCAB_OFS_LATEST   (0u * 4u)
 301 #define UFW_VOCAB_OFS_VOCLINK  (1u * 4u)
 302 #define UFW_VOCAB_OFS_PARENT   (2u * 4u)
 303 #define UFW_VOCAB_OFS_HEADER   (3u * 4u)
 304 #define UFW_VOCAB_OFS_HTABLE   (4u * 4u)
 305
 306 #define UFO_HASHTABLE_SIZE  (256)
 307
 308 #define UFO_NO_HTABLE_FLAG  (~(uint32_t)0)
 309
 310 #define UFO_MAX_NATIVE_CFAS  (1024u)
 311 static ufoNativeCFA *ufoForthCFAs = NULL;
 312 static uint32_t ufoCFAsUsed = 0;
 313
 314 static uint32_t ufoDoForthCFA;
 315 static uint32_t ufoDoVariableCFA;
 316 static uint32_t ufoDoValueCFA;
 317 static uint32_t ufoDoConstCFA;
 318 static uint32_t ufoDoDeferCFA;
 319 static uint32_t ufoDoVocCFA;
 320 static uint32_t ufoDoCreateCFA;
 321
 322 static uint32_t ufoStrLit8CFA;
 323
 324 // special address types:
 325 #define UFO_ADDR_CFA_BIT   ((uint32_t)1<<31)
 326 #define UFO_ADDR_CFA_MASK  (UFO_ADDR_CFA_BIT-1u)
 327
 328 // handles are somewhat special: first 12 bits can be used as offset for "@", and are ignored
 329 #define UFO_ADDR_HANDLE_BIT       ((uint32_t)1<<30)
 330 #define UFO_ADDR_HANDLE_MASK      ((UFO_ADDR_HANDLE_BIT-1u)&~((uint32_t)0xfff))
 331 #define UFO_ADDR_HANDLE_SHIFT     (12)
 332 #define UFO_ADDR_HANDLE_OFS_MASK  ((uint32_t)((1 << UFO_ADDR_HANDLE_SHIFT) - 1))
 333
 334 // temporary area is 1MB buffer out of the main image
 335 #define UFO_ADDR_TEMP_BIT   ((uint32_t)1<<29)
 336 #define UFO_ADDR_TEMP_MASK  (UFO_ADDR_TEMP_BIT-1u)
 337
 338 #define UFO_ADDR_SPECIAL_BITS_MASK  (UFO_ADDR_CFA_BIT|UFO_ADDR_HANDLE_BIT|UFO_ADDR_TEMP_BIT)
 339
 340 /*
 341   debug image stores mapping from dictionary addresses to source files and lines.
 342   it is used for backtraces and debuggers, so it doesn't need to be optimised for
 343   speed; therefore i choose to optimise it for size.
 344
 345   debug map format is this:
 346     dv filename-len
 347       ...filename...
 348       align, so next data starts at 4-byte boundary
 349     dxl line   ; 0: no more lines
 350     dxi ip-length
 351     ...next filename record
 352
 353   "dv" is variable-length number. each byte uses bit 7 as "continuation" bit.
 354
 355   "dx?" is delta-coded number.
 356   "dxi" is global, starts with 0, and incrementing.
 357   "dxl" resets to 0 on each new file.
 358   delta format is the same as "dv".
 359 */
 360
 361 static uint32_t *ufoImage = NULL;
 362 static uint32_t ufoImageSize = 0;
 363
 364 static uint8_t *ufoDebugImage = NULL;
 365 static uint32_t ufoDebugImageUsed = 0;
 366 static uint32_t ufoDebugImageSize = 0;
 367 static uint32_t ufoDebugFileId = 0;
 368 static uint32_t ufoDebugLastFRecAddr = 0;
 369 static uint32_t ufoDebugCurrDP = 0;
 370
 371 static uint32_t ufoInRunWord = 0;
 372
 373 static volatile int ufoVMAbort = 0;
 374 static volatile int ufoVMStop = 0;
 375
 376 #define ufoTrueValue  (~(uint32_t)0)
 377
 378 enum {
 379   UFO_MODE_NONE = -1,
 380   UFO_MODE_NATIVE = 0, // executing forth code
 381   UFO_MODE_MACRO = 1, // executing forth asm macro
 382 };
 383 static uint32_t ufoMode = UFO_MODE_NONE;
 384
 385 #define UFO_DSTACK_SIZE    (8192)
 386 #define UFO_RSTACK_SIZE    (4096)
 387 #define UFO_LSTACK_SIZE    (4096)
 388 #define UFO_MAX_TASK_NAME  (127)
 389
 390 // to support multitasking (required for the debugger),
 391 // our virtual machine state is encapsulated in a struct.
 392 typedef struct UfoState_t {
 393   uint32_t id;
 394   uint32_t dStack[UFO_DSTACK_SIZE];
 395   uint32_t rStack[UFO_RSTACK_SIZE];
 396   uint32_t lStack[UFO_LSTACK_SIZE];
 397   uint32_t IP; // in image
 398   uint32_t SP; // points AFTER the last value pushed
 399   uint32_t RP; // points AFTER the last value pushed
 400   uint32_t RPTop; // stop when RP is this
 401   // address register
 402   uint32_t regA;
 403   // for locals
 404   uint32_t LP;
 405   uint32_t LBP;
 406   uint32_t vmRPopCFA;
 407   // BASE is automatically saved and restored on task switch
 408   // this would better be done with "user data area", but meh... maybe later
 409   uint32_t baseValue;
 410   // temp image
 411   uint32_t *imageTemp;
 412   uint32_t imageTempSize;
 413   // linked list of all allocated states (tasks)
 414   char name[UFO_MAX_TASK_NAME + 1];
 415 } UfoState;
 416
 417 // 'cmon!
 418 #define UFO_MAX_STATES  (8192)
 419
 420 // this is indexed by id
 421 static UfoState *ufoStateMap[UFO_MAX_STATES] = {NULL};
 422 static uint32_t ufoStateUsedBitmap[UFO_MAX_STATES/32] = {0};
 423
 424 // currently active execution state
 425 static UfoState *ufoCurrState = NULL;
 426 // state we're yielded from
 427 static UfoState *ufoYieldedState = NULL;
 428 // if debug state is not NULL, VM will switch to it
 429 // after executing one instruction from the current state.
 430 // it will store current state in `ufoDebugeeState`.
 431 static UfoState *ufoDebuggerState = NULL;
 432 static uint32_t ufoSingleStep = 0;
 433
 434 #define ufoDStack  (ufoCurrState->dStack)
 435 #define ufoRStack  (ufoCurrState->rStack)
 436 #define ufoLStack  (ufoCurrState->lStack)
 437 #define ufoIP      (ufoCurrState->IP)
 438 #define ufoSP      (ufoCurrState->SP)
 439 #define ufoRP      (ufoCurrState->RP)
 440 #define ufoRPTop   (ufoCurrState->RPTop)
 441 #define ufoLP      (ufoCurrState->LP)
 442 #define ufoLBP     (ufoCurrState->LBP)
 443 #define ufoRegA    (ufoCurrState->regA)
 444 #define ufoImageTemp      (ufoCurrState->imageTemp)
 445 #define ufoImageTempSize  (ufoCurrState->imageTempSize)
 446 #define ufoVMRPopCFA      (ufoCurrState->vmRPopCFA)
 447
 448 // dynamically allocated text input buffer
 449 // always ends with zero (this is word name too)
 450 static uint32_t ufoAddrTIBx = 0; // TIB
 451 static uint32_t ufoAddrINx = 0; // >IN
 452 static uint32_t ufoDefTIB = 0; // default TIB (handle); user cannot change it
 453
 454 static uint32_t ufoAddrContext; // CONTEXT
 455 static uint32_t ufoAddrCurrent; // CURRENT (definitions will go there)
 456 static uint32_t ufoAddrVocLink;
 457 static uint32_t ufoAddrDP;
 458 static uint32_t ufoAddrDPTemp;
 459 static uint32_t ufoAddrSTATE;
 460 static uint32_t ufoAddrBASE;
 461 static uint32_t ufoAddrNewWordFlags;
 462 static uint32_t ufoAddrRedefineWarning;
 463 static uint32_t ufoAddrLastXFA;
 464
 465 // allows to redefine even protected words
 466 #define UFO_REDEF_WARN_DONT_CARE  (~(uint32_t)0)
 467 // do not warn about ordinary words, allow others
 468 #define UFO_REDEF_WARN_NONE    (0)
 469 // do warn
 470 #define UFO_REDEF_WARN_NORMAL  (1)
 471
 472 #define UFO_GET_DP()      (ufoImgGetU32(ufoAddrDPTemp) ?: ufoImgGetU32(ufoAddrDP))
 473 //#define UFO_SET_DP(val_)  ufoImgPutU32(ufoAddrDP, (val_))
 474
 475 #define UFO_MAX_NESTED_INCLUDES  (32)
 476 typedef struct {
 477   FILE *fl;
 478   char *fname;
 479   char *incpath;
 480   int fline;
 481   uint32_t id; // non-zero unique id
 482 } UFOFileStackEntry;
 483
 484 static UFOFileStackEntry ufoFileStack[UFO_MAX_NESTED_INCLUDES];
 485 static uint32_t ufoFileStackPos; // after the last used item
 486
 487 static FILE *ufoInFile = NULL;
 488 static char *ufoInFileName = NULL;
 489 static char *ufoLastIncPath = NULL;
 490 static int ufoInFileLine = 0;
 491 static uint32_t ufoFileId = 0;
 492 static uint32_t ufoLastUsedFileId = 0;
 493
 494 static int ufoLastEmitWasCR = 1;
 495
 496 #define UFO_VOCSTACK_SIZE  (16u)
 497 static uint32_t ufoVocStack[UFO_VOCSTACK_SIZE]; // cfas
 498 static uint32_t ufoVSP;
 499 static uint32_t ufoForthVocId;
 500 static uint32_t ufoCompilerVocId;
 501
 502 // dynamic handles
 503 typedef struct UHandleInfo_t {
 504   uint32_t ufoHandle;
 505   uint32_t typeid;
 506   uint8_t *data;
 507   uint32_t size;
 508   uint32_t used;
 509   // in free list
 510   struct UHandleInfo_t *next;
 511 } UHandleInfo;
 512
 513 static UHandleInfo *ufoHandleFreeList = NULL;
 514 static UHandleInfo **ufoHandles = NULL;
 515 static uint32_t ufoHandlesUsed = 0;
 516 static uint32_t ufoHandlesAlloted = 0;
 517
 518 #define UFO_HANDLE_FREE  (~(uint32_t)0)
 519
 520 static char ufoCurrFileLine[520];
 521
 522 // for `ufoFatal()`
 523 static uint32_t ufoInBacktrace = 0;
 524
 525
 526 // ////////////////////////////////////////////////////////////////////////// //
 527 static void ufoClearCondDefines (void);
 528
 529 static void ufoRunVMCFA (uint32_t cfa);
 530
 531 static void ufoBacktrace (uint32_t ip);
 532
 533 static void ufoClearCondDefines (void);
 534
 535 static UfoState *ufoNewState (uint32_t cfa);
 536 static void ufoFreeState (UfoState *st);
 537 static UfoState *ufoFindState (uint32_t stid);
 538 static void ufoSwitchToState (UfoState *newst);
 539
 540 __attribute__((unused)) static void ufoDumpWordHeader (const uint32_t lfa);
 541
 542 #ifdef UFO_DEBUG_DEBUG
 543 static void ufoDumpDebugImage (void);
 544 #endif
 545
 546
 547 // ////////////////////////////////////////////////////////////////////////// //
 548 #define UFWORD(name_) \
 549 static void ufoWord_##name_ (uint32_t mypfa)
 550
 551 #define UFCALL(name_)  ufoWord_##name_(0)
 552 #define UFCFA(name_)   (&ufoWord_##name_)
 553
 554 // for TIB words
 555 UFWORD(CPEEK_REGA_IDX);
 556 UFWORD(CPOKE_REGA_IDX);
 557
 558 // for peek and poke
 559 UFWORD(PAR_HANDLE_LOAD_BYTE);
 560 UFWORD(PAR_HANDLE_LOAD_WORD);
 561 UFWORD(PAR_HANDLE_LOAD_CELL);
 562 UFWORD(PAR_HANDLE_STORE_BYTE);
 563 UFWORD(PAR_HANDLE_STORE_WORD);
 564 UFWORD(PAR_HANDLE_STORE_CELL);
 565
 566
 567 //==========================================================================
 568 //
 569 //  ufoSetUserAbort
 570 //
 571 //==========================================================================
 572 void ufoSetUserAbort (void) {
 573   ufoVMAbort = 1;
 574 }
 575
 576
 577 //==========================================================================
 578 //
 579 //  ufoAllocHandle
 580 //
 581 //==========================================================================
 582 static UHandleInfo *ufoAllocHandle (uint32_t typeid) {
 583   ufo_assert(typeid != UFO_HANDLE_FREE);
 584   UHandleInfo *newh = ufoHandleFreeList;
 585   if (newh == NULL) {
 586     if (ufoHandlesUsed == ufoHandlesAlloted) {
 587       uint32_t newsz = ufoHandlesAlloted + 16384;
 588       // due to offsets, this is the maximum number of handles we can have
 589       if (newsz > 0x1ffffU) {
 590         if (ufoHandlesAlloted > 0x1ffffU) ufoFatal("too many dynamic handles");
 591         newsz = 0x1ffffU + 1U;
 592         ufo_assert(newsz > ufoHandlesAlloted);
 593       }
 594       UHandleInfo **nh = realloc(ufoHandles, sizeof(ufoHandles[0]) * newsz);
 595       if (nh == NULL) ufoFatal("out of memory for handle table");
 596       ufoHandles = nh;
 597       ufoHandlesAlloted = newsz;
 598     }
 599     newh = calloc(1, sizeof(UHandleInfo));
 600     if (newh == NULL) ufoFatal("out of memory for handle info");
 601     ufoHandles[ufoHandlesUsed] = newh;
 602     // setup new handle info
 603     newh->ufoHandle = (ufoHandlesUsed << UFO_ADDR_HANDLE_SHIFT) | UFO_ADDR_HANDLE_BIT;
 604     ufoHandlesUsed += 1;
 605   } else {
 606     ufo_assert(newh->typeid == UFO_HANDLE_FREE);
 607     ufoHandleFreeList = newh->next;
 608   }
 609   // setup new handle info
 610   newh->typeid = typeid;
 611   newh->data = NULL;
 612   newh->size = 0;
 613   newh->used = 0;
 614   newh->next = NULL;
 615   return newh;
 616 }
 617
 618
 619 //==========================================================================
 620 //
 621 //  ufoFreeHandle
 622 //
 623 //==========================================================================
 624 static void ufoFreeHandle (UHandleInfo *hh) {
 625   if (hh != NULL) {
 626     ufo_assert(hh->typeid != UFO_HANDLE_FREE);
 627     if (hh->data) free(hh->data);
 628     hh->typeid = UFO_HANDLE_FREE;
 629     hh->data = NULL;
 630     hh->size = 0;
 631     hh->used = 0;
 632     hh->next = ufoHandleFreeList;
 633     ufoHandleFreeList = hh;
 634   }
 635 }
 636
 637
 638 //==========================================================================
 639 //
 640 //  ufoGetHandle
 641 //
 642 //==========================================================================
 643 static UHandleInfo *ufoGetHandle (uint32_t hh) {
 644   UHandleInfo *res;
 645   if (hh != 0 && (hh & UFO_ADDR_HANDLE_BIT) != 0) {
 646     hh = (hh & UFO_ADDR_HANDLE_MASK) >> UFO_ADDR_HANDLE_SHIFT;
 647     if (hh < ufoHandlesUsed) {
 648       res = ufoHandles[hh];
 649       if (res->typeid == UFO_HANDLE_FREE) res = NULL;
 650     } else {
 651       res = NULL;
 652     }
 653   } else {
 654     res = NULL;
 655   }
 656   return res;
 657 }
 658
 659
 660 //==========================================================================
 661 //
 662 //  setLastIncPath
 663 //
 664 //==========================================================================
 665 static void setLastIncPath (const char *fname) {
 666   if (fname == NULL || fname[0] == 0) {
 667     if (ufoLastIncPath) free(ufoLastIncPath);
 668     ufoLastIncPath = strdup(".");
 669   } else {
 670     char *lslash;
 671     char *cpos;
 672     if (ufoLastIncPath) free(ufoLastIncPath);
 673     ufoLastIncPath = strdup(fname);
 674     lslash = ufoLastIncPath;
 675     cpos = ufoLastIncPath;
 676     while (*cpos) {
 677       #ifdef WIN32
 678       if (*cpos == '/' || *cpos == '\\') lslash = cpos;
 679       #else
 680       if (*cpos == '/') lslash = cpos;
 681       #endif
 682       cpos += 1;
 683     }
 684     *lslash = 0;
 685   }
 686 }
 687
 688
 689 //==========================================================================
 690 //
 691 //  ufoClearIncludePath
 692 //
 693 //  required for UrAsm
 694 //
 695 //==========================================================================
 696 void ufoClearIncludePath (void) {
 697   if (ufoLastIncPath != NULL) {
 698     free(ufoLastIncPath);
 699     ufoLastIncPath = NULL;
 700   }
 701 }
 702
 703
 704 //==========================================================================
 705 //
 706 //  ufoErrorPrintFile
 707 //
 708 //==========================================================================
 709 static void ufoErrorPrintFile (FILE *fo) {
 710   if (ufoInFileName) {
 711     fprintf(fo, "UFO ERROR at file %s, line %d: ", ufoInFileName, ufoInFileLine);
 712   } else {
 713     fprintf(fo, "UFO ERROR somewhere in time: ");
 714   }
 715 }
 716
 717
 718 //==========================================================================
 719 //
 720 //  ufoErrorMsgV
 721 //
 722 //==========================================================================
 723 static void ufoErrorMsgV (const char *fmt, va_list ap) {
 724   if (!ufoLastEmitWasCR) { printf("\n"); ufoLastEmitWasCR = 1; }
 725   fflush(stdout);
 726   ufoErrorPrintFile(stderr);
 727   vfprintf(stderr, fmt, ap);
 728   va_end(ap);
 729   fputc('\n', stderr);
 730   fflush(NULL);
 731 }
 732
 733
 734 //==========================================================================
 735 //
 736 //  ufoWarning
 737 //
 738 //==========================================================================
 739 __attribute__((format(printf, 1, 2)))
 740 void ufoWarning (const char *fmt, ...) {
 741   va_list ap;
 742   va_start(ap, fmt);
 743   ufoErrorMsgV(fmt, ap);
 744 }
 745
 746
 747 //==========================================================================
 748 //
 749 //  ufoFatal
 750 //
 751 //==========================================================================
 752 __attribute__((noreturn)) __attribute__((format(printf, 1, 2)))
 753 void ufoFatal (const char *fmt, ...) {
 754   va_list ap;
 755   va_start(ap, fmt);
 756   ufoErrorMsgV(fmt, ap);
 757   if (!ufoInBacktrace) {
 758     ufoInBacktrace = 1;
 759     ufoBacktrace(ufoIP);
 760     ufoInBacktrace = 0;
 761   } else {
 762     fprintf(stderr, "DOUBLE FATAL: error in backtrace!\n");
 763   }
 764   #ifdef UFO_DEBUG_FATAL_ABORT
 765   abort();
 766   #endif
 767   ufoFatalError();
 768 }
 769
 770
 771 // ////////////////////////////////////////////////////////////////////////// //
 772 // working with the stacks
 773 UFO_FORCE_INLINE void ufoPush (uint32_t v) { if (ufoSP >= UFO_DSTACK_SIZE) ufoFatal("data stack overflow"); ufoDStack[ufoSP++] = v; }
 774 UFO_FORCE_INLINE void ufoDrop (void) { if (ufoSP == 0) ufoFatal("data stack underflow"); --ufoSP; }
 775 UFO_FORCE_INLINE uint32_t ufoPop (void) { if (ufoSP == 0) { ufoFatal("data stack underflow"); } return ufoDStack[--ufoSP]; }
 776 UFO_FORCE_INLINE uint32_t ufoPeek (void) { if (ufoSP == 0) ufoFatal("data stack underflow"); return ufoDStack[ufoSP-1u]; }
 777 UFO_FORCE_INLINE void ufoDup (void) { if (ufoSP == 0) ufoFatal("data stack underflow"); ufoPush(ufoDStack[ufoSP-1u]); }
 778 UFO_FORCE_INLINE void ufoOver (void) { if (ufoSP < 2u) ufoFatal("data stack underflow"); ufoPush(ufoDStack[ufoSP-2u]); }
 779 UFO_FORCE_INLINE void ufoSwap (void) { if (ufoSP < 2u) ufoFatal("data stack underflow"); const uint32_t t = ufoDStack[ufoSP-1u]; ufoDStack[ufoSP-1u] = ufoDStack[ufoSP-2u]; ufoDStack[ufoSP-2u] = t; }
 780 UFO_FORCE_INLINE void ufoRot (void) { if (ufoSP < 3u) ufoFatal("data stack underflow"); const uint32_t t = ufoDStack[ufoSP-3u]; ufoDStack[ufoSP-3u] = ufoDStack[ufoSP-2u]; ufoDStack[ufoSP-2u] = ufoDStack[ufoSP-1u]; ufoDStack[ufoSP-1u] = t; }
 781 UFO_FORCE_INLINE void ufoNRot (void) { if (ufoSP < 3u) ufoFatal("data stack underflow"); const uint32_t t = ufoDStack[ufoSP-1u]; ufoDStack[ufoSP-1u] = ufoDStack[ufoSP-2u]; ufoDStack[ufoSP-2u] = ufoDStack[ufoSP-3u]; ufoDStack[ufoSP-3u] = t; }
 782
 783 UFO_FORCE_INLINE void ufo2Dup (void) { ufoOver(); ufoOver(); }
 784 UFO_FORCE_INLINE void ufo2Drop (void) { ufoDrop(); ufoDrop(); }
 785 UFO_FORCE_INLINE void ufo2Over (void) { if (ufoSP < 4u) ufoFatal("data stack underflow"); const uint32_t n0 = ufoDStack[ufoSP-4u]; const uint32_t n1 = ufoDStack[ufoSP-3u]; ufoPush(n0); ufoPush(n1); }
 786 UFO_FORCE_INLINE void ufo2Swap (void) { if (ufoSP < 4u) ufoFatal("data stack underflow"); const uint32_t n0 = ufoDStack[ufoSP-4u]; const uint32_t n1 = ufoDStack[ufoSP-3u]; ufoDStack[ufoSP-4u] = ufoDStack[ufoSP-2u]; ufoDStack[ufoSP-3u] = ufoDStack[ufoSP-1u]; ufoDStack[ufoSP-2u] = n0; ufoDStack[ufoSP-1u] = n1; }
 787
 788 UFO_FORCE_INLINE void ufoRPush (uint32_t v) { if (ufoRP >= UFO_RSTACK_SIZE) ufoFatal("return stack overflow"); ufoRStack[ufoRP++] = v; }
 789 UFO_FORCE_INLINE void ufoRDrop (void) { if (ufoRP == 0 || ufoRP == ufoRPTop) ufoFatal("return stack underflow"); --ufoRP; }
 790 UFO_FORCE_INLINE uint32_t ufoRPop (void) { if (ufoRP == 0 || ufoRP == ufoRPTop) ufoFatal("return stack underflow"); return ufoRStack[--ufoRP]; }
 791 UFO_FORCE_INLINE uint32_t ufoRPeek (void) { if (ufoRP == 0 || ufoRP == ufoRPTop) ufoFatal("return stack underflow"); return ufoRStack[ufoRP-1u]; }
 792 UFO_FORCE_INLINE void ufoRDup (void) { if (ufoRP == 0 || ufoRP == ufoRPTop) ufoFatal("return stack underflow"); ufoPush(ufoRStack[ufoRP-1u]); }
 793
 794 UFO_FORCE_INLINE void ufoPushBool (int v) { ufoPush(v ? ufoTrueValue : 0u); }
 795
 796
 797 //==========================================================================
 798 //
 799 //  ufoImgEnsureSize
 800 //
 801 //==========================================================================
 802 static void ufoImgEnsureSize (uint32_t addr) {
 803   if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) != 0) ufoFatal("ufoImgEnsureSize: internal error");
 804   if (addr >= ufoImageSize) {
 805     // 64MB should be enough for everyone!
 806     if (addr >= 0x04000000U) {
 807       ufoFatal("image grown too big (addr=0%08XH)", addr);
 808     }
 809     const const uint32_t osz = ufoImageSize;
 810     // grow by 1MB steps
 811     const uint32_t nsz = (addr|0x000fffffU) + 1U;
 812     ufo_assert(nsz > addr);
 813     uint32_t *nimg = realloc(ufoImage, nsz);
 814     if (nimg == NULL) {
 815       ufoFatal("out of memory for UFO image (%u -> %u MBs)",
 816                ufoImageSize / 1024u / 1024u,
 817                nsz / 1024u / 1024u);
 818     }
 819     ufoImage = nimg;
 820     ufoImageSize = nsz;
 821     memset((char *)ufoImage + osz, 0, (nsz - osz));
 822   }
 823 }
 824
 825
 826 //==========================================================================
 827 //
 828 //  ufoImgEnsureTemp
 829 //
 830 //==========================================================================
 831 static void ufoImgEnsureTemp (uint32_t addr) {
 832   if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) != 0) ufoFatal("ufoImgEnsureTemp: internal error");
 833   if (addr >= ufoImageTempSize) {
 834     if (addr >= 1024u * 1024u) {
 835       ufoFatal("Forth segmentation fault at address 0x%08X", addr|UFO_ADDR_TEMP_BIT);
 836     }
 837     const uint32_t osz = ufoImageTempSize;
 838     // grow by KB steps
 839     const uint32_t nsz = (addr|0x00000fffU) + 1U;
 840     uint32_t *nimg = realloc(ufoImageTemp, nsz);
 841     if (nimg == NULL) {
 842       ufoFatal("out of memory for temp UFO image (%u -> %u KBs)",
 843                ufoImageTempSize / 1024u,
 844                nsz / 1024u);
 845     }
 846     ufoImageTemp = nimg;
 847     ufoImageTempSize = nsz;
 848     memset(ufoImageTemp + osz, 0, (nsz - osz));
 849   }
 850 }
 851
 852
 853 #ifdef UFO_FAST_MEM_ACCESS
 854 //==========================================================================
 855 //
 856 //  ufoImgPutU8
 857 //
 858 //  fast
 859 //
 860 //==========================================================================
 861 UFO_FORCE_INLINE void ufoImgPutU8 (uint32_t addr, const uint32_t value) {
 862   if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
 863     if (addr >= ufoImageSize) ufoImgEnsureSize(addr);
 864     *((uint8_t *)ufoImage + addr) = (uint8_t)value;
 865   } else if (addr & UFO_ADDR_TEMP_BIT) {
 866     addr &= UFO_ADDR_TEMP_MASK;
 867     if (addr >= ufoImageTempSize) ufoImgEnsureTemp(addr);
 868     *((uint8_t *)ufoImageTemp + addr) = (uint8_t)value;
 869   } else {
 870     ufoFatal("Forth segmentation fault at address 0x%08X", addr);
 871   }
 872 }
 873
 874
 875 //==========================================================================
 876 //
 877 //  ufoImgPutU16
 878 //
 879 //  fast
 880 //
 881 //==========================================================================
 882 UFO_FORCE_INLINE void ufoImgPutU16 (uint32_t addr, const uint32_t value) {
 883   if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
 884     if (addr + 1u >= ufoImageSize) ufoImgEnsureSize(addr + 1u);
 885     *(uint16_t *)((uint8_t *)ufoImage + addr) = (uint16_t)value;
 886   } else if (addr & UFO_ADDR_TEMP_BIT) {
 887     addr &= UFO_ADDR_TEMP_MASK;
 888     if (addr + 1u >= ufoImageTempSize) ufoImgEnsureTemp(addr + 1u);
 889     *(uint16_t *)((uint8_t *)ufoImageTemp + addr) = (uint16_t)value;
 890   } else {
 891     ufoFatal("Forth segmentation fault at address 0x%08X", addr);
 892   }
 893 }
 894
 895
 896 //==========================================================================
 897 //
 898 //  ufoImgPutU32
 899 //
 900 //  fast
 901 //
 902 //==========================================================================
 903 UFO_FORCE_INLINE void ufoImgPutU32 (uint32_t addr, const uint32_t value) {
 904   if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
 905     if (addr + 3u >= ufoImageSize) ufoImgEnsureSize(addr + 3u);
 906     *(uint32_t *)((uint8_t *)ufoImage + addr) = value;
 907   } else if (addr & UFO_ADDR_TEMP_BIT) {
 908     addr &= UFO_ADDR_TEMP_MASK;
 909     if (addr + 3u >= ufoImageTempSize) ufoImgEnsureTemp(addr + 3u);
 910     *(uint32_t *)((uint8_t *)ufoImageTemp + addr) = value;
 911   } else {
 912     ufoFatal("Forth segmentation fault at address 0x%08X", addr);
 913   }
 914 }
 915
 916
 917 //==========================================================================
 918 //
 919 //  ufoImgGetU8
 920 //
 921 //  false
 922 //
 923 //==========================================================================
 924 UFO_FORCE_INLINE uint32_t ufoImgGetU8 (uint32_t addr) {
 925   if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
 926     if (addr >= ufoImageSize) {
 927       // accessing unallocated image area is segmentation fault
 928       ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr);
 929     }
 930     return *((const uint8_t *)ufoImage + addr);
 931   } else if (addr & UFO_ADDR_TEMP_BIT) {
 932     addr &= UFO_ADDR_TEMP_MASK;
 933     if (addr >= ufoImageTempSize) {
 934       // accessing unallocated image area is segmentation fault
 935       ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr | UFO_ADDR_TEMP_BIT);
 936     }
 937     return *((const uint8_t *)ufoImageTemp + addr);
 938   } else {
 939     ufoFatal("Forth segmentation fault at address 0x%08X", addr);
 940   }
 941 }
 942
 943
 944 //==========================================================================
 945 //
 946 //  ufoImgGetU16
 947 //
 948 //  fast
 949 //
 950 //==========================================================================
 951 UFO_FORCE_INLINE uint32_t ufoImgGetU16 (uint32_t addr) {
 952   if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
 953     if (addr + 1u >= ufoImageSize) {
 954       // accessing unallocated image area is segmentation fault
 955       ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr);
 956     }
 957     return *(const uint16_t *)((const uint8_t *)ufoImage + addr);
 958   } else if (addr & UFO_ADDR_TEMP_BIT) {
 959     addr &= UFO_ADDR_TEMP_MASK;
 960     if (addr + 1u >= ufoImageTempSize) {
 961       // accessing unallocated image area is segmentation fault
 962       ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr | UFO_ADDR_TEMP_BIT);
 963     }
 964     return *(const uint16_t *)((const uint8_t *)ufoImageTemp + addr);
 965   } else {
 966     ufoFatal("Forth segmentation fault at address 0x%08X", addr);
 967   }
 968 }
 969
 970
 971 //==========================================================================
 972 //
 973 //  ufoImgGetU32
 974 //
 975 //  fast
 976 //
 977 //==========================================================================
 978 UFO_FORCE_INLINE uint32_t ufoImgGetU32 (uint32_t addr) {
 979   if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
 980     if (addr + 3u >= ufoImageSize) {
 981       // accessing unallocated image area is segmentation fault
 982       ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr);
 983     }
 984     return *(const uint32_t *)((const uint8_t *)ufoImage + addr);
 985   } else if (addr & UFO_ADDR_TEMP_BIT) {
 986     addr &= UFO_ADDR_TEMP_MASK;
 987     if (addr + 3u >= ufoImageTempSize) {
 988       // accessing unallocated image area is segmentation fault
 989       ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr | UFO_ADDR_TEMP_BIT);
 990     }
 991     return *(const uint32_t *)((const uint8_t *)ufoImageTemp + addr);
 992   } else {
 993     ufoFatal("Forth segmentation fault at address 0x%08X", addr);
 994   }
 995 }
 996
 997 #else
 998
 999 //==========================================================================
1000 //
1001 //  ufoImgPutU8
1002 //
1003 //  general
1004 //
1005 //==========================================================================
1006 UFO_FORCE_INLINE void ufoImgPutU8 (uint32_t addr, const uint32_t value) {
1007   uint32_t *imgptr;
1008   if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
1009     if (addr >= ufoImageSize) ufoImgEnsureSize(addr);
1010     imgptr = &ufoImage[addr/4u];
1011   } else if (addr & UFO_ADDR_TEMP_BIT) {
1012     addr &= UFO_ADDR_TEMP_MASK;
1013     if (addr >= ufoImageTempSize) ufoImgEnsureTemp(addr);
1014     imgptr = &ufoImageTemp[addr/4u];
1015   } else {
1016     ufoFatal("Forth segmentation fault at address 0x%08X", addr);
1017   }
1018   const uint8_t val = (uint8_t)value;
1019   memcpy((uint8_t *)imgptr + (addr&3), &val, 1);
1020 }
1021
1022
1023 //==========================================================================
1024 //
1025 //  ufoImgPutU16
1026 //
1027 //  general
1028 //
1029 //==========================================================================
1030 UFO_FORCE_INLINE void ufoImgPutU16 (uint32_t addr, const uint32_t value) {
1031   ufoImgPutU8(addr, value&0xffU);
1032   ufoImgPutU8(addr + 1u, (value>>8)&0xffU);
1033 }
1034
1035
1036 //==========================================================================
1037 //
1038 //  ufoImgPutU32
1039 //
1040 //  general
1041 //
1042 //==========================================================================
1043 UFO_FORCE_INLINE void ufoImgPutU32 (uint32_t addr, const uint32_t value) {
1044   ufoImgPutU16(addr, value&0xffffU);
1045   ufoImgPutU16(addr + 2u, (value>>16)&0xffffU);
1046 }
1047
1048
1049 //==========================================================================
1050 //
1051 //  ufoImgGetU8
1052 //
1053 //  general
1054 //
1055 //==========================================================================
1056 UFO_FORCE_INLINE uint32_t ufoImgGetU8 (uint32_t addr) {
1057   uint32_t *imgptr;
1058   if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
1059     if (addr >= ufoImageSize) return 0;
1060     imgptr = &ufoImage[addr/4u];
1061   } else if (addr & UFO_ADDR_TEMP_BIT) {
1062     addr &= UFO_ADDR_TEMP_MASK;
1063     if (addr >= ufoImageTempSize) return 0;
1064     imgptr = &ufoImageTemp[addr/4u];
1065   } else {
1066     ufoFatal("Forth segmentation fault at address 0x%08X", addr);
1067   }
1068   uint8_t val;
1069   memcpy(&val, (uint8_t *)imgptr + (addr&3), 1);
1070   return (uint32_t)val;
1071 }
1072
1073
1074 //==========================================================================
1075 //
1076 //  ufoImgGetU16
1077 //
1078 //  general
1079 //
1080 //==========================================================================
1081 UFO_FORCE_INLINE uint32_t ufoImgGetU16 (uint32_t addr) {
1082   return ufoImgGetU8(addr) | (ufoImgGetU8(addr + 1u) << 8);
1083 }
1084
1085
1086 //==========================================================================
1087 //
1088 //  ufoImgGetU32
1089 //
1090 //  general
1091 //
1092 //==========================================================================
1093 UFO_FORCE_INLINE uint32_t ufoImgGetU32 (uint32_t addr) {
1094   return ufoImgGetU16(addr) | (ufoImgGetU16(addr + 2u) << 16);
1095 }
1096 #endif
1097
1098
1099 /*
1100 static uint32_t *ufoDebugImage = NULL;
1101 static uint32_t ufoDebugImageSize = 0;
1102 static uint32_t ufoDebugFileId = 0;
1103 static uint32_t ufoDebugLastFRecAddr = 0;
1104 static uint32_t ufoDebugLastFLine = 0;
1105 static uint32_t ufoDebugCurrDP = 0;
1106 */
1107
1108
1109 //==========================================================================
1110 //
1111 //  ufoEnsureDebug
1112 //
1113 //==========================================================================
1114 UFO_DISABLE_INLINE void ufoEnsureDebug (uint32_t sdelta) {
1115   ufo_assert(sdelta != 0);
1116   if (ufoDebugImageUsed != 0) {
1117     if (ufoDebugImageUsed + sdelta >= 0x40000000U) ufoFatal("debug info too big");
1118     if (ufoDebugImageUsed + sdelta > ufoDebugImageSize) {
1119       const uint32_t newsz = ((ufoDebugImageUsed + sdelta) | 0xffffU) + 1u;
1120       uint8_t *ndb = realloc(ufoDebugImage, newsz);
1121       if (ndb == NULL) ufoFatal("out of memory for debug info");
1122       ufoDebugImage = ndb;
1123       ufoDebugImageSize = newsz;
1124     }
1125   } else {
1126     // initial allocation
1127     ufoDebugImageSize = 1024 * 128;
1128     ufoDebugImage = malloc(ufoDebugImageSize);
1129     if (ufoDebugImage == NULL) ufoFatal("out of memory for debug info");
1130   }
1131 }
1132
1133
1134 #ifdef UFO_DEBUG_DEBUG
1135 //==========================================================================
1136 //
1137 //  ufoDumpDebugInfo
1138 //
1139 //==========================================================================
1140 static void ufoDumpDebugImage (void) {
1141   #if 0
1142   uint32_t dbgpos = 0u; // first item is always "next file record"
1143   while (dbgpos < ufoDebugImageUsed) {
1144     const uint32_t ln = *(const uint32_t *)(ufoDebugImage + dbgpos); dbgpos += 4u;
1145     if (ln == ~(uint32_t)0) {
1146       // next file record
1147       const uint32_t nlen = *(const uint32_t *)(ufoDebugImage + dbgpos); dbgpos += 4u;
1148       fprintf(stderr, "*** NEW FILE: %s\n", (const char *)(ufoDebugImage + dbgpos));
1149       dbgpos += nlen + 1u;
1150       if ((dbgpos & 0x03) != 0) dbgpos = (dbgpos | 0x03u) + 1u;
1151     } else {
1152       const uint32_t edp = *(const uint32_t *)(ufoDebugImage + dbgpos); dbgpos += 4u;
1153       fprintf(stderr, "  line %6u: edp=%u\n", ln, edp);
1154     }
1155   }
1156   #endif
1157 }
1158 #endif
1159
1160
1161 #define UFO_DBG_PUT_U4(val_)  do { \
1162   const uint32_t vv_ = (val_); \
1163   *((uint32_t *)(ufoDebugImage + ufoDebugImageUsed)) = vv_; \
1164   ufoDebugImageUsed += 4u; \
1165 } while (0)
1166
1167 //==========================================================================
1168 //
1169 //  ufoRecordDebug
1170 //
1171 //==========================================================================
1172 UFO_DISABLE_INLINE void ufoRecordDebug (uint32_t newhere) {
1173   if (newhere > ufoDebugCurrDP) {
1174     if (ufoInFileName != NULL) {
1175       // check if we're doing the same file
1176       const uint32_t slen = (uint32_t)strlen(ufoInFileName);
1177       const int newfrec = (ufoDebugLastFRecAddr == 0) ||
1178                           (*((const uint32_t *)(ufoDebugImage + ufoDebugLastFRecAddr)) != slen) ||
1179                           (memcmp((const char *)ufoDebugImage + ufoDebugLastFRecAddr + 4u, ufoInFileName, slen) != 0);
1180       uint32_t fline = (uint32_t)ufoInFileLine;
1181       if (fline == ~(uint32_t)0) fline -= 1u;
1182       if (newfrec) {
1183         ufoEnsureDebug(slen + 4u + 4u + 4u + 32u); // way too much ;-)
1184         // finish previous record
1185         UFO_DBG_PUT_U4(~(uint32_t)0);
1186         // create new file record
1187         ufoDebugLastFRecAddr = ufoDebugImageUsed;
1188         UFO_DBG_PUT_U4(slen);
1189         memcpy(ufoDebugImage + ufoDebugImageUsed, ufoInFileName, slen + 1u);
1190         ufoDebugImageUsed += slen + 1u;
1191         while ((ufoDebugImageUsed & 0x03u) != 0) {
1192           ufoDebugImage[ufoDebugImageUsed] = 0;
1193           ufoDebugImageUsed += 1;
1194         }
1195         UFO_DBG_PUT_U4(fline);
1196         UFO_DBG_PUT_U4(newhere);
1197       } else {
1198         // check if the line is the same
1199         if (*((const uint32_t *)(ufoDebugImage + ufoDebugImageUsed - 8u)) == fline) {
1200           *((uint32_t *)(ufoDebugImage + ufoDebugImageUsed - 4u)) = newhere;
1201         } else {
1202           // new line
1203           ufoEnsureDebug(8u);
1204           UFO_DBG_PUT_U4(fline);
1205           UFO_DBG_PUT_U4(newhere);
1206         }
1207       }
1208     } else {
1209       // we don't have a file, don't record debug info
1210       ufoDebugFileId = 0;
1211       ufoDebugLastFRecAddr = 0;
1212     }
1213     ufoDebugCurrDP = newhere;
1214   }
1215 }
1216
1217
1218 //==========================================================================
1219 //
1220 //  ufoGetWordEndAddrYFA
1221 //
1222 //==========================================================================
1223 static uint32_t ufoGetWordEndAddrYFA (uint32_t yfa) {
1224   if (yfa > 8u) {
1225     const uint32_t oyfa = yfa;
1226     yfa = ufoImgGetU32(yfa);
1227     if (yfa == 0) {
1228       if ((oyfa & UFO_ADDR_TEMP_BIT) == 0) {
1229         yfa = UFO_GET_DP();
1230         if ((yfa & UFO_ADDR_TEMP_BIT) != 0) {
1231           yfa = UFO_CFA_TO_PFA(UFO_NFA_TO_CFA(UFO_YFA_TO_NFA(oyfa)));
1232         }
1233       } else {
1234         yfa = UFO_CFA_TO_PFA(UFO_NFA_TO_CFA(UFO_YFA_TO_NFA(oyfa)));
1235       }
1236     } else {
1237       yfa = UFO_YFA_TO_WST(yfa);
1238     }
1239   } else {
1240     yfa = 0;
1241   }
1242   return yfa;
1243 }
1244
1245
1246 //==========================================================================
1247 //
1248 //  ufoGetWordEndAddr
1249 //
1250 //==========================================================================
1251 static uint32_t ufoGetWordEndAddr (const uint32_t cfa) {
1252   if (cfa != 0) {
1253     return ufoGetWordEndAddrYFA(UFO_LFA_TO_YFA(UFO_CFA_TO_LFA(cfa)));
1254   } else {
1255     return 0;
1256   }
1257 }
1258
1259
1260 //==========================================================================
1261 //
1262 //  ufoFindWordForIP
1263 //
1264 //  return NFA or 0
1265 //
1266 //  WARNING: this is SLOW!
1267 //
1268 //==========================================================================
1269 static uint32_t ufoFindWordForIP (const uint32_t ip) {
1270   uint32_t res = 0;
1271   if (ip != 0) {
1272     // iterate over all words
1273     uint32_t xfa = ufoImgGetU32(ufoAddrLastXFA);
1274     if (xfa != 0) {
1275       while (res == 0 && xfa != 0) {
1276         const uint32_t yfa = UFO_XFA_TO_YFA(xfa);
1277         const uint32_t wst = UFO_YFA_TO_WST(yfa);
1278         const uint32_t wend = ufoGetWordEndAddrYFA(yfa);
1279         if (ip >= wst && ip < wend) {
1280           res = UFO_YFA_TO_NFA(yfa);
1281         } else {
1282           xfa = ufoImgGetU32(xfa);
1283         }
1284       }
1285     }
1286   }
1287   return res;
1288 }
1289
1290
1291 //==========================================================================
1292 //
1293 //  ufoFindFileForIP
1294 //
1295 //  return file name or `NULL`
1296 //
1297 //  WARNING: this is SLOW!
1298 //
1299 //==========================================================================
1300 static const char *ufoFindFileForIP (uint32_t ip, uint32_t *line) {
1301   const char *res = NULL;
1302   if (ip != 0 && ufoDebugImageUsed != 0) {
1303     uint32_t lastfinfo = 0u;
1304     uint32_t lastip = 0u;
1305     uint32_t dbgpos = 0u; // first item is always "next file record"
1306     while (res == NULL && dbgpos < ufoDebugImageUsed) {
1307       const uint32_t ln = *(const uint32_t *)(ufoDebugImage + dbgpos); dbgpos += 4u;
1308       if (ln == ~(uint32_t)0) {
1309         // next file record
1310         lastfinfo = dbgpos;
1311         const uint32_t nlen = *(const uint32_t *)(ufoDebugImage + dbgpos); dbgpos += 4u;
1312         dbgpos += nlen + 1u;
1313         if ((dbgpos & 0x03) != 0) dbgpos = (dbgpos | 0x03u) + 1u;
1314       } else {
1315         const uint32_t edp = *(const uint32_t *)(ufoDebugImage + dbgpos); dbgpos += 4u;
1316         if (ip >= lastip && ip < edp) {
1317           if (line) *line = ln;
1318           res = (const char *)(ufoDebugImage + lastfinfo + 4u);
1319         }
1320         lastip = edp;
1321       }
1322     }
1323   }
1324   return res;
1325 }
1326
1327
1328 //==========================================================================
1329 //
1330 //  ufoBumpDP
1331 //
1332 //==========================================================================
1333 UFO_FORCE_INLINE void ufoBumpDP (uint32_t delta) {
1334   uint32_t dp = ufoImgGetU32(ufoAddrDPTemp);
1335   if (dp == 0) {
1336     dp = ufoImgGetU32(ufoAddrDP);
1337     if ((dp & UFO_ADDR_SPECIAL_BITS_MASK) == 0) ufoRecordDebug(dp + delta);
1338     dp += delta;
1339     ufoImgPutU32(ufoAddrDP, dp);
1340   } else {
1341     dp = ufoImgGetU32(ufoAddrDPTemp);
1342     if ((dp & UFO_ADDR_SPECIAL_BITS_MASK) == 0) ufoRecordDebug(dp + delta);
1343     dp += delta;
1344     ufoImgPutU32(ufoAddrDPTemp, dp);
1345   }
1346 }
1347
1348
1349 //==========================================================================
1350 //
1351 //  ufoImgEmitU8
1352 //
1353 //==========================================================================
1354 UFO_FORCE_INLINE void ufoImgEmitU8 (uint32_t value) {
1355   ufoImgPutU8(UFO_GET_DP(), value);
1356   ufoBumpDP(1);
1357 }
1358
1359
1360 //==========================================================================
1361 //
1362 //  ufoImgEmitU32
1363 //
1364 //==========================================================================
1365 UFO_FORCE_INLINE void ufoImgEmitU32 (uint32_t value) {
1366   ufoImgPutU32(UFO_GET_DP(), value);
1367   ufoBumpDP(4);
1368 }
1369
1370
1371 #ifdef UFO_FAST_MEM_ACCESS
1372
1373 //==========================================================================
1374 //
1375 //  ufoImgEmitU32_NoInline
1376 //
1377 //  false
1378 //
1379 //==========================================================================
1380 UFO_FORCE_INLINE void ufoImgEmitU32_NoInline (uint32_t value) {
1381   ufoImgPutU32(UFO_GET_DP(), value);
1382   ufoBumpDP(4);
1383 }
1384
1385 #else
1386
1387 //==========================================================================
1388 //
1389 //  ufoImgEmitU32_NoInline
1390 //
1391 //  general
1392 //
1393 //==========================================================================
1394 UFO_DISABLE_INLINE void ufoImgEmitU32_NoInline (uint32_t value) {
1395   ufoImgPutU32(UFO_GET_DP(), value);
1396   ufoBumpDP(4);
1397 }
1398
1399 #endif
1400
1401
1402 //==========================================================================
1403 //
1404 //  ufoImgGetU8Ext
1405 //
1406 //  this understands handle addresses
1407 //
1408 //==========================================================================
1409 UFO_FORCE_INLINE uint32_t ufoImgGetU8Ext (uint32_t addr) {
1410   if ((addr & UFO_ADDR_HANDLE_BIT) == 0) {
1411     return ufoImgGetU8(addr);
1412   } else {
1413     ufoPush(0);
1414     ufoPush(addr);
1415     UFCALL(PAR_HANDLE_LOAD_BYTE);
1416     return ufoPop();
1417   }
1418 }
1419
1420
1421 //==========================================================================
1422 //
1423 //  ufoImgPutU8Ext
1424 //
1425 //  this understands handle addresses
1426 //
1427 //==========================================================================
1428 UFO_FORCE_INLINE void ufoImgPutU8Ext (uint32_t addr, uint32_t value) {
1429   if ((addr & UFO_ADDR_HANDLE_BIT) == 0) {
1430     ufoImgPutU8(addr, value);
1431   } else {
1432     ufoPush(value);
1433     ufoPush(0);
1434     ufoPush(addr);
1435     UFCALL(PAR_HANDLE_STORE_BYTE);
1436   }
1437 }
1438
1439
1440 //==========================================================================
1441 //
1442 //  ufoImgEmitAlign
1443 //
1444 //==========================================================================
1445 UFO_FORCE_INLINE void ufoImgEmitAlign (void) {
1446   while ((UFO_GET_DP() & 3) != 0) ufoImgEmitU8(0);
1447 }
1448
1449
1450 //==========================================================================
1451 //
1452 //  ufoResetTib
1453 //
1454 //==========================================================================
1455 UFO_FORCE_INLINE void ufoResetTib (void) {
1456   if ((ufoDefTIB & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("default TIB is not allocated");
1457   UHandleInfo *hh = ufoGetHandle(ufoDefTIB);
1458   if (hh == NULL) ufoFatal("default TIB is not allocated");
1459   if (hh->size == 0) {
1460     ufo_assert(hh->data == NULL);
1461     hh->data = calloc(1, UFO_ADDR_HANDLE_OFS_MASK + 1);
1462     if (hh->data == NULL) ufoFatal("out of memory for default TIB");
1463     hh->size = UFO_ADDR_HANDLE_OFS_MASK + 1;
1464   }
1465   const uint32_t oldA = ufoRegA;
1466   ufoImgPutU32(ufoAddrTIBx, ufoDefTIB);
1467   ufoImgPutU32(ufoAddrINx, 0);
1468   ufoRegA = ufoDefTIB;
1469   ufoPush(0); // value
1470   ufoPush(0); // offset
1471   UFCALL(CPOKE_REGA_IDX);
1472   ufoRegA = oldA;
1473 }
1474
1475
1476 //==========================================================================
1477 //
1478 //  ufoTibEnsureSize
1479 //
1480 //==========================================================================
1481 UFO_DISABLE_INLINE void ufoTibEnsureSize (uint32_t size) {
1482   if (size > 1024u * 1024u * 256u) ufoFatal("TIB size too big");
1483   const uint32_t tib = ufoImgGetU32(ufoAddrTIBx);
1484   if ((tib & UFO_ADDR_HANDLE_BIT) == 0) {
1485     ufoFatal("cannot resize TIB, TIB is not a handle");
1486   }
1487   UHandleInfo *hh = ufoGetHandle(tib);
1488   if (hh == NULL) {
1489     ufoFatal("cannot resize TIB, TIB is not a handle");
1490   }
1491   if (hh->size < size) {
1492     const uint32_t newsz = (size | 0xfffU) + 1u;
1493     uint8_t *nx = realloc(hh->data, newsz);
1494     if (nx == NULL) ufoFatal("out of memory for restored TIB");
1495     hh->data = nx;
1496     hh->size = newsz;
1497   }
1498 }
1499
1500
1501 //==========================================================================
1502 //
1503 //  ufoTibGetSize
1504 //
1505 //==========================================================================
1506 UFO_DISABLE_INLINE uint32_t ufoTibGetSize (void) {
1507   const uint32_t tib = ufoImgGetU32(ufoAddrTIBx);
1508   if ((tib & UFO_ADDR_HANDLE_BIT) == 0) {
1509     ufoFatal("cannot query TIB, TIB is not a handle");
1510   }
1511   UHandleInfo *hh = ufoGetHandle(tib);
1512   if (hh == NULL) {
1513     ufoFatal("cannot query TIB, TIB is not a handle");
1514   }
1515   return hh->size;
1516 }
1517
1518
1519 //==========================================================================
1520 //
1521 //  ufoTibPeekCh
1522 //
1523 //==========================================================================
1524 UFO_FORCE_INLINE uint8_t ufoTibPeekCh (void) {
1525   return (uint8_t)ufoImgGetU8Ext(ufoImgGetU32(ufoAddrTIBx) + ufoImgGetU32(ufoAddrINx));
1526 }
1527
1528
1529 //==========================================================================
1530 //
1531 //  ufoTibPeekChOfs
1532 //
1533 //==========================================================================
1534 UFO_FORCE_INLINE uint8_t ufoTibPeekChOfs (uint32_t ofs) {
1535   const uint32_t tib = ufoImgGetU32(ufoAddrTIBx);
1536   if (ofs <= UFO_ADDR_HANDLE_OFS_MASK || (tib & UFO_ADDR_HANDLE_BIT) == 0) {
1537     return (uint8_t)ufoImgGetU8Ext(tib + ufoImgGetU32(ufoAddrINx) + ofs);
1538   } else {
1539     return 0;
1540   }
1541 }
1542
1543
1544 //==========================================================================
1545 //
1546 //  ufoTibPokeChOfs
1547 //
1548 //==========================================================================
1549 UFO_DISABLE_INLINE void ufoTibPokeChOfs (uint8_t ch, uint32_t ofs) {
1550   const uint32_t oldA = ufoRegA;
1551   ufoRegA = ufoImgGetU32(ufoAddrTIBx);
1552   ufoPush(ch);
1553   ufoPush(ufoImgGetU32(ufoAddrINx) + ofs);
1554   UFCALL(CPOKE_REGA_IDX);
1555   ufoRegA = oldA;
1556 }
1557
1558
1559 //==========================================================================
1560 //
1561 //  ufoTibGetCh
1562 //
1563 //==========================================================================
1564 UFO_FORCE_INLINE uint8_t ufoTibGetCh (void) {
1565   const uint8_t ch = ufoTibPeekCh();
1566   if (ch) ufoImgPutU32(ufoAddrINx, ufoImgGetU32(ufoAddrINx) + 1u);
1567   return ch;
1568 }
1569
1570
1571 //==========================================================================
1572 //
1573 //  ufoTibSkipCh
1574 //
1575 //==========================================================================
1576 UFO_FORCE_INLINE void ufoTibSkipCh (void) {
1577   (void)ufoTibGetCh();
1578 }
1579
1580
1581 // ////////////////////////////////////////////////////////////////////////// //
1582 // native CFA implementations
1583 //
1584
1585 //==========================================================================
1586 //
1587 //  ufoDoForth
1588 //
1589 //==========================================================================
1590 static void ufoDoForth (uint32_t pfa) {
1591   ufoRPush(ufoIP);
1592   ufoIP = pfa;
1593 }
1594
1595
1596 //==========================================================================
1597 //
1598 //  ufoDoVariable
1599 //
1600 //==========================================================================
1601 static void ufoDoVariable (uint32_t pfa) {
1602   ufoPush(pfa);
1603 }
1604
1605
1606 //==========================================================================
1607 //
1608 //  ufoDoValue
1609 //
1610 //==========================================================================
1611 static void ufoDoValue (uint32_t pfa) {
1612   ufoPush(ufoImgGetU32(pfa));
1613 }
1614
1615
1616 //==========================================================================
1617 //
1618 //  ufoDoConst
1619 //
1620 //==========================================================================
1621 static void ufoDoConst (uint32_t pfa) {
1622   ufoPush(ufoImgGetU32(pfa));
1623 }
1624
1625
1626 //==========================================================================
1627 //
1628 //  ufoDoDefer
1629 //
1630 //==========================================================================
1631 static void ufoDoDefer (uint32_t pfa) {
1632   const uint32_t cfa = ufoImgGetU32(pfa);
1633   if (cfa != 0) {
1634     ufoRPush(cfa);
1635     ufoVMRPopCFA = 1;
1636   }
1637 }
1638
1639
1640 //==========================================================================
1641 //
1642 //  ufoDoVoc
1643 //
1644 //==========================================================================
1645 static void ufoDoVoc (uint32_t pfa) {
1646   ufoImgPutU32(ufoAddrContext, ufoImgGetU32(pfa));
1647 }
1648
1649
1650 //==========================================================================
1651 //
1652 //  ufoDoCreate
1653 //
1654 //==========================================================================
1655 static void ufoDoCreate (uint32_t pfa) {
1656   ufoPush(pfa);
1657 }
1658
1659
1660 //==========================================================================
1661 //
1662 //  ufoPushInFile
1663 //
1664 //  this also increments last used file id
1665 //
1666 //==========================================================================
1667 static void ufoPushInFile (void) {
1668   if (ufoFileStackPos >= UFO_MAX_NESTED_INCLUDES) ufoFatal("too many includes");
1669   UFOFileStackEntry *stk = &ufoFileStack[ufoFileStackPos];
1670   stk->fl = ufoInFile;
1671   stk->fname = ufoInFileName;
1672   stk->fline = ufoInFileLine;
1673   stk->id = ufoFileId;
1674   stk->incpath = (ufoLastIncPath ? strdup(ufoLastIncPath) : NULL);
1675   ufoFileStackPos += 1;
1676   ufoInFile = NULL;
1677   ufoInFileName = NULL;
1678   ufoInFileLine = 0;
1679   ufoLastUsedFileId += 1;
1680   ufo_assert(ufoLastUsedFileId != 0); // just in case ;-)
1681   //ufoLastIncPath = NULL;
1682 }
1683
1684
1685 //==========================================================================
1686 //
1687 //  ufoWipeIncludeStack
1688 //
1689 //==========================================================================
1690 static void ufoWipeIncludeStack (void) {
1691   if (ufoInFileName) { free(ufoInFileName); ufoInFileName = NULL; }
1692   if (ufoInFile) { fclose(ufoInFile); ufoInFile = NULL; }
1693   if (ufoLastIncPath) { free(ufoLastIncPath); ufoLastIncPath = NULL; }
1694   while (ufoFileStackPos != 0) {
1695     ufoFileStackPos -= 1;
1696     UFOFileStackEntry *stk = &ufoFileStack[ufoFileStackPos];
1697     if (stk->fl) fclose(stk->fl);
1698     if (stk->fname) free(stk->fname);
1699     if (stk->incpath) free(stk->incpath);
1700   }
1701 }
1702
1703
1704 //==========================================================================
1705 //
1706 //  ufoPopInFile
1707 //
1708 //==========================================================================
1709 static void ufoPopInFile (void) {
1710   if (ufoFileStackPos == 0) ufoFatal("trying to pop include from empty stack");
1711   if (ufoInFileName) { free(ufoInFileName); ufoInFileName = NULL; }
1712   if (ufoInFile) { fclose(ufoInFile); ufoInFile = NULL; }
1713   if (ufoLastIncPath) { free(ufoLastIncPath); ufoLastIncPath = NULL; }
1714   ufoFileStackPos -= 1;
1715   UFOFileStackEntry *stk = &ufoFileStack[ufoFileStackPos];
1716   ufoInFile = stk->fl;
1717   ufoInFileName = stk->fname;
1718   ufoInFileLine = stk->fline;
1719   ufoLastIncPath = stk->incpath;
1720   ufoFileId = stk->id;
1721   ufoResetTib();
1722   #ifdef UFO_DEBUG_INCLUDE
1723   if (ufoInFileName == NULL) {
1724     fprintf(stderr, "INC-POP: no more files.\n");
1725   } else {
1726     fprintf(stderr, "INC-POP: fname: %s\n", ufoInFileName);
1727   }
1728   #endif
1729 }
1730
1731
1732 //==========================================================================
1733 //
1734 //  ufoDeinit
1735 //
1736 //==========================================================================
1737 void ufoDeinit (void) {
1738   #ifdef UFO_DEBUG_DEBUG
1739   fprintf(stderr, "UFO: debug image used: %u; size: %u\n",
1740           ufoDebugImageUsed, ufoDebugImageSize);
1741   ufoDumpDebugImage();
1742   #endif
1743
1744   free(ufoDebugImage);
1745   ufoDebugImage = NULL;
1746   ufoDebugImageUsed = 0;
1747   ufoDebugImageSize = 0;
1748   ufoDebugFileId = 0;
1749   ufoDebugLastFRecAddr = 0;
1750   ufoDebugCurrDP = 0;
1751
1752   ufoInBacktrace = 0;
1753   ufoClearCondDefines();
1754   ufoWipeIncludeStack();
1755
1756   // free all handles
1757   for (uint32_t f = 0; f < ufoHandlesUsed; f += 1) {
1758     UHandleInfo *hh = ufoHandles[f];
1759     if (hh != NULL) {
1760       if (hh->data != NULL) free(hh->data);
1761       free(hh);
1762     }
1763   }
1764   if (ufoHandles != NULL) free(ufoHandles);
1765   ufoHandles = NULL; ufoHandlesUsed = 0; ufoHandlesAlloted = 0;
1766   ufoHandleFreeList = NULL;
1767
1768   ufoDefTIB = 0;
1769
1770   // release all includes
1771   ufoInFile = NULL;
1772   if (ufoInFileName) free(ufoInFileName);
1773   if (ufoLastIncPath) free(ufoLastIncPath);
1774   ufoInFileName = NULL; ufoLastIncPath = NULL;
1775   ufoInFileLine = 0;
1776
1777   free(ufoForthCFAs);
1778   ufoForthCFAs = NULL;
1779   ufoCFAsUsed = 0;
1780
1781   free(ufoImage);
1782   ufoImage = NULL;
1783   ufoImageSize = 0;
1784
1785   free(ufoImageTemp);
1786   ufoImageTemp = NULL;
1787   ufoImageTempSize = 0;
1788
1789   ufoIP = 0;
1790   ufoSP = 0; ufoRP = 0; ufoRPTop = 0;
1791   ufoLP = 0; ufoLBP = 0;
1792   ufoMode = UFO_MODE_NATIVE;
1793   ufoVSP = 0;
1794   ufoForthVocId = 0; ufoCompilerVocId = 0;
1795   ufoSingleStep = 0;
1796
1797   // free all states
1798   ufoCurrState = NULL;
1799   ufoYieldedState = NULL;
1800   ufoDebuggerState = NULL;
1801   for (uint32_t fidx = 0; fidx < (uint32_t)(UFO_MAX_STATES/32); fidx += 1u) {
1802     uint32_t bmp = ufoStateUsedBitmap[fidx];
1803     if (bmp != 0) {
1804       uint32_t stid = fidx * 32u;
1805       while (bmp != 0) {
1806         if ((bmp & 0x01) != 0) ufoFreeState(ufoStateMap[stid]);
1807         stid += 1u; bmp >>= 1;
1808       }
1809     }
1810   }
1811
1812   ufoAddrTIBx = 0; ufoAddrINx = 0; ufoDefTIB = 0;
1813
1814   ufoLastEmitWasCR = 1;
1815
1816   ufoClearCondDefines();
1817 }
1818
1819
1820 //==========================================================================
1821 //
1822 //  ufoDumpWordHeader
1823 //
1824 //==========================================================================
1825 __attribute__((unused)) static void ufoDumpWordHeader (const uint32_t lfa) {
1826   fprintf(stderr, "=== WORD: LFA: 0x%08x ===\n", lfa);
1827   if (lfa != 0) {
1828     fprintf(stderr, "  (DFA): 0x%08x\n", ufoImgGetU32(UFO_LFA_TO_DFA(lfa)));
1829     fprintf(stderr, "  (XFA): 0x%08x\n", ufoImgGetU32(UFO_LFA_TO_XFA(lfa)));
1830     fprintf(stderr, "  (YFA): 0x%08x\n", ufoImgGetU32(UFO_LFA_TO_YFA(lfa)));
1831     fprintf(stderr, "  (BFA): 0x%08x\n", ufoImgGetU32(UFO_LFA_TO_BFA(lfa)));
1832     fprintf(stderr, "  (LFA): 0x%08x\n", ufoImgGetU32(lfa));
1833     fprintf(stderr, "  (NHH): 0x%08x\n", ufoImgGetU32(UFO_LFA_TO_NHASH(lfa)));
1834     const uint32_t cfa = UFO_LFA_TO_CFA(lfa);
1835     fprintf(stderr, "    CFA: 0x%08x\n", cfa);
1836     fprintf(stderr, "    PFA: 0x%08x\n", UFO_CFA_TO_PFA(cfa));
1837     fprintf(stderr, "  (CFA): 0x%08x\n", ufoImgGetU32(cfa));
1838     const uint32_t nfa = UFO_LFA_TO_NFA(lfa);
1839     const uint32_t nlen = ufoImgGetU8(nfa);
1840     fprintf(stderr, "    NFA: 0x%08x  (nlen: %u)\n", nfa, nlen);
1841     const uint32_t flags = ufoImgGetU32(nfa);
1842     fprintf(stderr, "  FLAGS: 0x%08x\n", flags);
1843     if ((flags & 0xffff0000U) != 0) {
1844       fprintf(stderr, "  FLAGS:");
1845       if (flags & UFW_FLAG_IMMEDIATE) fprintf(stderr, " IMM");
1846       if (flags & UFW_FLAG_SMUDGE) fprintf(stderr, " SMUDGE");
1847       if (flags & UFW_FLAG_NORETURN) fprintf(stderr, " NORET");
1848       if (flags & UFW_FLAG_HIDDEN) fprintf(stderr, " HIDDEN");
1849       if (flags & UFW_FLAG_CBLOCK) fprintf(stderr, " CBLOCK");
1850       if (flags & UFW_FLAG_VOCAB) fprintf(stderr, " VOCAB");
1851       if (flags & UFW_FLAG_SCOLON) fprintf(stderr, " SCOLON");
1852       if (flags & UFW_FLAG_PROTECTED) fprintf(stderr, " PROTECTED");
1853       fputc('\n', stderr);
1854     }
1855     if ((flags & 0xff00U) != 0) {
1856       fprintf(stderr, "   ARGS: ");
1857       switch (flags & UFW_WARG_MASK) {
1858         case UFW_WARG_NONE: fprintf(stderr, "NONE"); break;
1859         case UFW_WARG_BRANCH: fprintf(stderr, "BRANCH"); break;
1860         case UFW_WARG_LIT: fprintf(stderr, "LIT"); break;
1861         case UFW_WARG_C4STRZ: fprintf(stderr, "C4STRZ"); break;
1862         case UFW_WARG_CFA: fprintf(stderr, "CFA"); break;
1863         case UFW_WARG_CBLOCK: fprintf(stderr, "CBLOCK"); break;
1864         case UFW_WARG_VOCID: fprintf(stderr, "VOCID"); break;
1865         case UFW_WARG_C1STRZ: fprintf(stderr, "C1STRZ"); break;
1866         default: fprintf(stderr, "wtf?!"); break;
1867       }
1868       fputc('\n', stderr);
1869     }
1870     fprintf(stderr, "  BACKLEN: %u (nfa at 0x%08x)\n", ufoImgGetU8(cfa - 1u), UFO_CFA_TO_NFA(cfa));
1871     fprintf(stderr, "  NAME(%u): ", nlen);
1872     for (uint32_t f = 0; f < nlen; f += 1) {
1873       const uint8_t ch = ufoImgGetU8(nfa + 4u + f);
1874       if (ch <= 32 || ch >= 127) {
1875         fprintf(stderr, "\\x%02x", ch);
1876       } else {
1877         fprintf(stderr, "%c", (char)ch);
1878       }
1879     }
1880     fprintf(stderr, "\n");
1881     ufo_assert(UFO_CFA_TO_LFA(cfa) == lfa);
1882   }
1883 }
1884
1885
1886 //==========================================================================
1887 //
1888 //  ufoVocCheckName
1889 //
1890 //  return 0 or CFA
1891 //
1892 //==========================================================================
1893 static uint32_t ufoVocCheckName (uint32_t lfa, const void *wname, uint32_t wnlen, uint32_t hash,
1894                                  int allowvochid)
1895 {
1896   uint32_t res = 0;
1897   #ifdef UFO_DEBUG_FIND_WORD
1898   fprintf(stderr, "CHECK-NAME: %.*s; LFA: 0x%08x; hash: 0x%08x (wname: 0x%08x)\n",
1899           (unsigned) wnlen, (const char *)wname,
1900           lfa, (lfa != 0 ? ufoImgGetU32(UFO_LFA_TO_NHASH(lfa)) : 0), hash);
1901   ufoDumpWordHeader(lfa);
1902   #endif
1903   if (lfa != 0 && ufoImgGetU32(UFO_LFA_TO_NHASH(lfa)) == hash) {
1904     const uint32_t lenflags = ufoImgGetU32(UFO_LFA_TO_NFA(lfa));
1905     if ((lenflags & UFW_FLAG_SMUDGE) == 0 &&
1906         (allowvochid || (lenflags & UFW_FLAG_HIDDEN) == 0))
1907     {
1908       const uint32_t nlen = lenflags&0xffU;
1909       if (nlen == wnlen) {
1910         uint32_t naddr = UFO_LFA_TO_NFA(lfa) + 4u;
1911         uint32_t pos = 0;
1912         while (pos < nlen) {
1913           uint8_t c0 = ((const unsigned char *)wname)[pos];
1914           if (c0 >= 'a' && c0 <= 'z') c0 = c0 - 'a' + 'A';
1915           uint8_t c1 = ufoImgGetU8(naddr + pos);
1916           if (c1 >= 'a' && c1 <= 'z') c1 = c1 - 'a' + 'A';
1917           if (c0 != c1) break;
1918           pos += 1u;
1919         }
1920         if (pos == nlen) {
1921           // i found her!
1922           naddr += pos + 1u;
1923           res = UFO_ALIGN4(naddr);
1924         }
1925       }
1926     }
1927   }
1928   return res;
1929 }
1930
1931
1932 //==========================================================================
1933 //
1934 //  ufoFindWordInVoc
1935 //
1936 //  return 0 or CFA
1937 //
1938 //==========================================================================
1939 static uint32_t ufoFindWordInVoc (const void *wname, uint32_t wnlen, uint32_t hash,
1940                                   uint32_t vocid, int allowvochid)
1941 {
1942   uint32_t res = 0;
1943   if (wname == NULL) ufo_assert(wnlen == 0);
1944   if (wnlen != 0 && vocid != 0) {
1945     if (hash == 0) hash = joaatHashBufCI(wname, wnlen);
1946     #if defined(UFO_DEBUG_FIND_WORD) || defined(UFO_DEBUG_FIND_WORD_IN_VOC)
1947     fprintf(stderr, "IN-VOC: %.*s; VOCID: 0x%08x; whash: 0x%08x; htbl[0]: 0x%08x\n",
1948             (unsigned) wnlen, (const char *)wname,
1949             vocid, hash, ufoImgGetU32(vocid + UFW_VOCAB_OFS_HTABLE));
1950     #endif
1951     const uint32_t htbl = vocid + UFW_VOCAB_OFS_HTABLE;
1952     if (ufoImgGetU32(htbl) != UFO_NO_HTABLE_FLAG) {
1953       // hash table present, use it
1954       uint32_t bfa = htbl + (hash % (uint32_t)UFO_HASHTABLE_SIZE) * 4u;
1955       bfa = ufoImgGetU32(bfa);
1956       while (res == 0 && bfa != 0) {
1957         #if defined(UFO_DEBUG_FIND_WORD) || defined(UFO_DEBUG_FIND_WORD_IN_VOC)
1958         fprintf(stderr, "IN-VOC:   bfa: 0x%08x\n", bfa);
1959         #endif
1960         res = ufoVocCheckName(UFO_BFA_TO_LFA(bfa), wname, wnlen, hash, allowvochid);
1961         bfa = ufoImgGetU32(bfa);
1962       }
1963     } else {
1964       // no hash table, use linear search
1965       uint32_t lfa = vocid + UFW_VOCAB_OFS_LATEST;
1966       lfa = ufoImgGetU32(lfa);
1967       while (res == 0 && lfa != 0) {
1968         res = ufoVocCheckName(lfa, wname, wnlen, hash, allowvochid);
1969         lfa = ufoImgGetU32(lfa);
1970       }
1971     }
1972   }
1973   return res;
1974 }
1975
1976
1977 //==========================================================================
1978 //
1979 //  ufoFindColon
1980 //
1981 //  return part after the colon, or `NULL`
1982 //
1983 //==========================================================================
1984 static const void *ufoFindColon (const void *wname, uint32_t wnlen) {
1985   const void *res = NULL;
1986   if (wnlen != 0) {
1987     ufo_assert(wname != NULL);
1988     const char *str = (const char *)wname;
1989     while (wnlen != 0 && str[0] != ':') {
1990       str += 1; wnlen -= 1;
1991     }
1992     if (wnlen != 0) {
1993       res = (const void *)(str + 1); // skip colon
1994     }
1995   }
1996   return res;
1997 }
1998
1999
2000 //==========================================================================
2001 //
2002 //  ufoFindWordInVocAndParents
2003 //
2004 //==========================================================================
2005 static uint32_t ufoFindWordInVocAndParents (const void *wname, uint32_t wnlen, uint32_t hash,
2006                                             uint32_t vocid, int allowvochid)
2007 {
2008   uint32_t res = 0;
2009   if (hash == 0) hash = joaatHashBufCI(wname, wnlen);
2010   while (res == 0 && vocid != 0) {
2011     res = ufoFindWordInVoc(wname, wnlen, hash, vocid, allowvochid);
2012     vocid = ufoImgGetU32(vocid + UFW_VOCAB_OFS_PARENT);
2013   }
2014   return res;
2015 }
2016
2017
2018 //==========================================================================
2019 //
2020 //  ufoFindWordNameRes
2021 //
2022 //  find with name resolution
2023 //
2024 //  return 0 or CFA
2025 //
2026 //==========================================================================
2027 static uint32_t ufoFindWordNameRes (const void *wname, uint32_t wnlen) {
2028   uint32_t res = 0;
2029   if (wnlen != 0 && *(const char *)wname != ':') {
2030     ufo_assert(wname != NULL);
2031
2032     const void *stx = wname;
2033     wname = ufoFindColon(wname, wnlen);
2034     if (wname != NULL) {
2035       // look in all vocabs (excluding hidden ones)
2036       uint32_t xlen = (uint32_t)(ptrdiff_t)(wname - stx) - 1u;
2037       ufo_assert(xlen > 0 && xlen < 255);
2038       uint32_t xhash = joaatHashBufCI(stx, xlen);
2039       uint32_t voclink = ufoImgGetU32(ufoAddrVocLink);
2040       #ifdef UFO_DEBUG_FIND_WORD_COLON
2041       fprintf(stderr, "COLON-FIND: first voc: {%.*s}; xhash=0x%08x; voc-link: 0x%08x\n",
2042               (unsigned)xlen, (const char *)stx, xhash, voclink);
2043       #endif
2044       while (res == 0 && voclink != 0) {
2045         const uint32_t vhdraddr = voclink - UFW_VOCAB_OFS_VOCLINK + UFW_VOCAB_OFS_HEADER;
2046         const uint32_t vhdr = ufoImgGetU32(vhdraddr);
2047         if (vhdr != 0) {
2048           res = ufoVocCheckName(UFO_NFA_TO_LFA(vhdr), stx, xlen, xhash, 0);
2049         }
2050         if (res == 0) voclink = ufoImgGetU32(voclink);
2051       }
2052       if (res != 0) {
2053         uint32_t vocid = voclink - UFW_VOCAB_OFS_VOCLINK;
2054         ufo_assert(voclink != 0);
2055         wnlen -= xlen + 1;
2056         #ifdef UFO_DEBUG_FIND_WORD_COLON
2057         fprintf(stderr, "searching {%.*s}(%u) in {%.*s}\n",
2058                 (unsigned)wnlen, wname, wnlen, (unsigned)xlen, stx);
2059         #endif
2060         while (res != 0 && wname != NULL) {
2061           stx = wname;
2062           wname = ufoFindColon(wname, wnlen);
2063           if (wname == NULL) xlen = wnlen; else xlen = (uint32_t)(ptrdiff_t)(wname - stx) - 1u;
2064           ufo_assert(xlen > 0 && xlen < 255);
2065           res = ufoFindWordInVocAndParents(stx, xlen, 0, vocid, 1);
2066           if (res != 0) {
2067             wnlen -= xlen + 1;
2068             if (wname != NULL) {
2069               // it should be a vocabulary
2070               const uint32_t nfa = UFO_CFA_TO_NFA(res);
2071               if ((ufoImgGetU32(nfa) & UFW_FLAG_VOCAB) != 0) {
2072                 vocid = ufoImgGetU32(UFO_CFA_TO_PFA(res)); // pfa points to vocabulary
2073               } else {
2074                 res = 0;
2075               }
2076             }
2077           }
2078         }
2079       }
2080     }
2081   }
2082
2083   return res;
2084 }
2085
2086
2087 //==========================================================================
2088 //
2089 //  ufoFindWord
2090 //
2091 //  doesn't look in CURRENT, does name resolution ("a:b" is word "b" in "a")
2092 //
2093 //  return 0 or CFA
2094 //
2095 //==========================================================================
2096 static uint32_t ufoFindWord (const char *wname) {
2097   uint32_t res = 0;
2098   if (wname && wname[0] != 0) {
2099     const size_t wnlen = strlen(wname);
2100     ufo_assert(wnlen < 8192);
2101     uint32_t ctx = ufoImgGetU32(ufoAddrContext);
2102     const uint32_t hash = joaatHashBufCI(wname, (uint32_t)wnlen);
2103
2104     //fprintf(stderr, "FIND-WORD: whash: 0x%08x; name:{%s}\n", hash, wname);
2105
2106     // first search in context
2107     res = ufoFindWordInVocAndParents(wname, (uint32_t)wnlen, hash, ctx, (ctx == ufoImgGetU32(ufoAddrCurrent)));
2108
2109     // now try vocabulary stack
2110     uint32_t vstp = ufoVSP;
2111     while (res == 0 && vstp != 0) {
2112       vstp -= 1;
2113       ctx = ufoVocStack[vstp];
2114       res = ufoFindWordInVocAndParents(wname, (uint32_t)wnlen, hash, ctx, (ctx == ufoImgGetU32(ufoAddrCurrent)));
2115     }
2116
2117     // if not found, try name resolution
2118     if (res == 0) res = ufoFindWordNameRes(wname, (uint32_t)wnlen);
2119   }
2120
2121   return res;
2122 }
2123
2124
2125 //==========================================================================
2126 //
2127 //  ufoCreateWordHeader
2128 //
2129 //  create word header up to CFA, link to the current dictionary
2130 //
2131 //==========================================================================
2132 static void ufoCreateWordHeader (const char *wname, uint32_t flags) {
2133   if (wname == NULL) wname = "";
2134   const size_t wnlen = strlen(wname);
2135   ufo_assert(wnlen < UFO_MAX_WORD_LENGTH);
2136   const uint32_t hash = joaatHashBufCI(wname, (uint32_t)wnlen);
2137   const uint32_t curr = ufoImgGetU32(ufoAddrCurrent);
2138   ufo_assert(curr != 0);
2139   // redefine check
2140   if (wnlen != 0 && ufoImgGetU32(ufoAddrRedefineWarning) != UFO_REDEF_WARN_DONT_CARE) {
2141     const uint32_t cfa = ufoFindWordInVoc(wname, wnlen, hash, curr, 1);
2142     if (cfa) {
2143       const uint32_t nfa = UFO_CFA_TO_NFA(cfa);
2144       const uint32_t flags = ufoImgGetU32(nfa);
2145       if ((flags & UFW_FLAG_PROTECTED) != 0) {
2146         ufoFatal("trying to redefine protected word '%s'", wname);
2147       } else if (ufoImgGetU32(ufoAddrRedefineWarning) != UFO_REDEF_WARN_NONE) {
2148         ufoWarning("redefining word '%s'", wname);
2149       }
2150     }
2151   }
2152   //fprintf(stderr, "000: HERE: 0x%08x\n", UFO_GET_DP());
2153   const uint32_t bkt = (hash % (uint32_t)UFO_HASHTABLE_SIZE) * 4u;
2154   const uint32_t htbl = curr + UFW_VOCAB_OFS_HTABLE;
2155   ufoImgEmitAlign();
2156   ufoImgEmitU32(0); // dfa
2157   const uint32_t xfaAddr = UFO_GET_DP();
2158   if ((xfaAddr & UFO_ADDR_TEMP_BIT) == 0) {
2159     // link previous yfa here
2160     const uint32_t lastxfa = ufoImgGetU32(ufoAddrLastXFA);
2161     // fix YFA of the previous word
2162     if (lastxfa != 0) {
2163       ufoImgPutU32(UFO_XFA_TO_YFA(lastxfa), UFO_XFA_TO_YFA(xfaAddr));
2164     }
2165     // our XFA points to the previous XFA
2166     ufoImgEmitU32(lastxfa); // xfa
2167     // update last XFA
2168     ufoImgPutU32(ufoAddrLastXFA, xfaAddr);
2169   } else {
2170     ufoImgEmitU32(0); // xfa
2171   }
2172   ufoImgEmitU32(0); // yfa
2173   // bucket link (bfa)
2174   if (wnlen == 0 || ufoImgGetU32(htbl) == UFO_NO_HTABLE_FLAG) {
2175     ufoImgEmitU32(0);
2176   } else {
2177     #ifdef UFO_DEBUG_DUMP_NEW_HEADERS
2178     fprintf(stderr, "NEW HEADER: %s; curr: 0x%08x; htbl: 0x%08x; bkt: 0x%08x\n",
2179             wname, curr, htbl, bkt);
2180     fprintf(stderr, "  [bkt]: 0x%08x; nbk: 0x%08x\n", ufoImgGetU32(htbl + bkt), UFO_GET_DP());
2181     #endif
2182     // bfa points to bfa
2183     const uint32_t bfa = UFO_GET_DP();
2184     ufoImgEmitU32(ufoImgGetU32(htbl + bkt));
2185     ufoImgPutU32(htbl + bkt, bfa);
2186   }
2187   // lfa
2188   const uint32_t lfa = UFO_GET_DP();
2189   ufoImgEmitU32(ufoImgGetU32(curr + UFW_VOCAB_OFS_LATEST));
2190   // fix voc latest
2191   ufoImgPutU32(curr + UFW_VOCAB_OFS_LATEST, lfa);
2192   // name hash
2193   ufoImgEmitU32(hash);
2194   // name length
2195   const uint32_t nfa = UFO_GET_DP();
2196   ufoImgEmitU32(((uint32_t)wnlen&0xffU) | (flags & 0xffffff00U));
2197   const uint32_t nstart = UFO_GET_DP();
2198   // put name
2199   for (size_t f = 0; f < wnlen; f += 1) {
2200     ufoImgEmitU8(((const unsigned char *)wname)[f]);
2201   }
2202   while ((UFO_GET_DP() & 3) != 3) ufoImgEmitU8(0);
2203   const uint32_t nend = UFO_GET_DP(); // length byte itself is not included
2204   // name length, again
2205   ufo_assert(nend - nstart <= 255);
2206   ufoImgEmitU8((uint8_t)(nend - nstart));
2207   ufo_assert((UFO_GET_DP() & 3) == 0);
2208   ufo_assert(UFO_CFA_TO_NFA(UFO_GET_DP()) == nfa);
2209   if ((nend & UFO_ADDR_SPECIAL_BITS_MASK) == 0) ufoRecordDebug(nend);
2210   #ifdef UFO_DEBUG_DUMP_NEW_HEADERS
2211   fprintf(stderr, "*** NEW HEADER ***\n");
2212   fprintf(stderr, "CFA: 0x%08x\n", UFO_GET_DP());
2213   fprintf(stderr, "NSTART: 0x%08x\n", nstart);
2214   fprintf(stderr, "NEND: 0x%08x\n", nend);
2215   fprintf(stderr, "NLEN: %u (%u)\n", nend - nstart, ufoImgGetU8(UFO_GET_DP() - 1u));
2216   ufoDumpWordHeader(lfa);
2217   #endif
2218   #if 0
2219   fprintf(stderr, "NEW WORD CFA 0x%08x: %s\n", UFO_GET_DP(), wname);
2220   #endif
2221 }
2222
2223
2224 //==========================================================================
2225 //
2226 //  ufoDecompilePart
2227 //
2228 //==========================================================================
2229 static void ufoDecompilePart (uint32_t addr, uint32_t eaddr, int indent) {
2230   uint32_t count;
2231   FILE *fo = stdout;
2232   while (addr < eaddr) {
2233     uint32_t cfa = ufoImgGetU32(addr);
2234     for (int n = 0; n < indent; n += 1) fputc(' ', fo);
2235     fprintf(fo, "%6u: 0x%08x: ", addr, cfa);
2236     uint32_t nfa = UFO_CFA_TO_NFA(cfa);
2237     uint32_t flags = ufoImgGetU32(nfa);
2238     //fprintf(fo, "[0x%08x] ", flags & UFW_WARG_MASK);
2239     uint32_t nlen = flags & 0xffU;
2240     for (uint32_t f = 0; f < nlen; f += 1) {
2241       const uint8_t ch = ufoImgGetU8(nfa + 4u + f);
2242       if (ch <= 32 || ch >= 127) {
2243         fprintf(fo, "\\x%02x", ch);
2244       } else {
2245         fprintf(fo, "%c", (char)ch);
2246       }
2247     }
2248     addr += 4u;
2249     switch (flags & UFW_WARG_MASK) {
2250       case UFW_WARG_NONE:
2251         break;
2252       case UFW_WARG_BRANCH:
2253         fprintf(fo, "  @%u", ufoImgGetU32(addr)); addr += 4u;
2254         break;
2255       case UFW_WARG_LIT:
2256         fprintf(fo, "  %u : %d : 0x%08x", ufoImgGetU32(addr),
2257                 (int32_t)ufoImgGetU32(addr), ufoImgGetU32(addr)); addr += 4u;
2258         break;
2259       case UFW_WARG_C4STRZ:
2260         count = ufoImgGetU32(addr); addr += 4;
2261        print_str:
2262         fprintf(fo, "  str:");
2263         for (int f = 0; f < count; f += 1) {
2264           const uint8_t ch = ufoImgGetU8(addr); addr += 1u;
2265           if (ch <= 32 || ch >= 127) {
2266             fprintf(fo, "\\x%02x", ch);
2267           } else {
2268             fprintf(fo, "%c", (char)ch);
2269           }
2270         }
2271         addr += 1u; // skip zero byte
2272         addr = UFO_ALIGN4(addr);
2273         break;
2274       case UFW_WARG_CFA:
2275         cfa = ufoImgGetU32(addr); addr += 4u;
2276         fprintf(fo, "  CFA:%u: ", cfa);
2277         nfa = UFO_CFA_TO_NFA(cfa);
2278         nlen = ufoImgGetU8(nfa);
2279         for (uint32_t f = 0; f < nlen; f += 1) {
2280           const uint8_t ch = ufoImgGetU8(nfa + 4u + f);
2281           if (ch <= 32 || ch >= 127) {
2282             fprintf(fo, "\\x%02x", ch);
2283           } else {
2284             fprintf(fo, "%c", (char)ch);
2285           }
2286         }
2287         break;
2288       case UFW_WARG_CBLOCK:
2289         fprintf(fo, "  CBLOCK:%u", ufoImgGetU32(addr)); addr += 4u;
2290         break;
2291       case UFW_WARG_VOCID:
2292         fprintf(fo, "  VOCID:%u", ufoImgGetU32(addr)); addr += 4u;
2293         break;
2294       case UFW_WARG_C1STRZ:
2295         count = ufoImgGetU8(addr); addr += 1;
2296         goto print_str;
2297       /*
2298       case UFW_WARG_U8:
2299         fprintf(fo, "  ubyte:%u", ufoImgGetU8(addr)); addr += 1u;
2300         break;
2301       case UFW_WARG_S8:
2302         fprintf(fo, "  sbyte:%u", ufoImgGetU8(addr)); addr += 1u;
2303         break;
2304       case UFW_WARG_U16:
2305         fprintf(fo, "  uword:%u", ufoImgGetU16(addr)); addr += 2u;
2306         break;
2307       case UFW_WARG_S16:
2308         fprintf(fo, "  sword:%u", ufoImgGetU16(addr)); addr += 2u;
2309         break;
2310       */
2311       default:
2312         fprintf(fo, " -- WTF?!\n");
2313         abort();
2314     }
2315     fputc('\n', fo);
2316   }
2317 }
2318
2319
2320 //==========================================================================
2321 //
2322 //  ufoDecompileWord
2323 //
2324 //==========================================================================
2325 static void ufoDecompileWord (const uint32_t cfa) {
2326   if (cfa != 0) {
2327     const uint32_t lfa = UFO_CFA_TO_LFA(cfa);
2328     fprintf(stdout, "#### DECOMPILING CFA %u ###\n", cfa);
2329     ufoDumpWordHeader(lfa);
2330     const uint32_t yfa = ufoGetWordEndAddr(cfa);
2331     if (ufoImgGetU32(cfa) == ufoDoForthCFA) {
2332       fprintf(stdout, "--- DECOMPILED CODE ---\n");
2333       ufoDecompilePart(UFO_CFA_TO_PFA(cfa), yfa, 0);
2334       fprintf(stdout, "=======================\n");
2335     }
2336   }
2337 }
2338
2339
2340 //==========================================================================
2341 //
2342 //  ufoBTShowWordName
2343 //
2344 //==========================================================================
2345 static void ufoBTShowWordName (uint32_t nfa) {
2346   if (nfa != 0) {
2347     uint32_t len = ufoImgGetU8(nfa); nfa += 4u;
2348     //fprintf(stderr, "(0x%08x)", ufoImgGetU32(nfa - 4u));
2349     while (len != 0) {
2350       uint8_t ch = ufoImgGetU8(nfa); nfa += 1u; len -= 1u;
2351       if (ch <= 32 || ch >= 127) {
2352         fprintf(stderr, "\\x%02x", ch);
2353       } else {
2354         fprintf(stderr, "%c", (char)ch);
2355       }
2356     }
2357   }
2358 }
2359
2360
2361 //==========================================================================
2362 //
2363 //  ufoBacktrace
2364 //
2365 //==========================================================================
2366 static void ufoBacktrace (uint32_t ip) {
2367   // dump data stack (top 16)
2368   if (!ufoLastEmitWasCR) { printf("\n"); ufoLastEmitWasCR = 1; }
2369   fflush(NULL);
2370
2371   fprintf(stderr, "***UFO STACK DEPTH: %u\n", ufoSP);
2372   uint32_t xsp = ufoSP;
2373   if (xsp > 16) xsp = 16;
2374   for (uint32_t sp = 0; sp < xsp; ++sp) {
2375     fprintf(stderr, "  %2u: 0x%08x  %d\n", sp,
2376             ufoDStack[xsp - sp - 1], (int32_t)ufoDStack[xsp - sp - 1]);
2377   }
2378   if (ufoSP > 16) fprintf(stderr, "    ...more...\n");
2379
2380   // dump return stack (top 32)
2381   uint32_t nfa;
2382   fprintf(stderr, "***UFO RETURN STACK DEPTH: %u\n", ufoRP);
2383   if (ip != 0) {
2384     nfa = ufoFindWordForIP(ip);
2385     if (nfa != 0) {
2386       uint32_t fline;
2387       fprintf(stderr, "  **: %8u -- ", ip);
2388       ufoBTShowWordName(nfa);
2389       const char *fname = ufoFindFileForIP(ip, &fline);
2390       if (fname != NULL) { fprintf(stderr, " (at %s:%u)", fname, fline); }
2391       fputc('\n', stderr);
2392     }
2393   }
2394   uint32_t rp = ufoRP;
2395   uint32_t rscount = 0;
2396   if (rp > UFO_RSTACK_SIZE) rp = UFO_RSTACK_SIZE;
2397   while (rscount != 32 && rp != 0) {
2398     rp -= 1;
2399     const uint32_t val = ufoRStack[rp];
2400     nfa = ufoFindWordForIP(val);
2401     if (nfa != 0) {
2402       fprintf(stderr, "  %2u: %8u -- ", ufoRP - rp - 1u, val);
2403       ufoBTShowWordName(nfa);
2404       fputc('\n', stderr);
2405     } else {
2406       fprintf(stderr, "  %2u: 0x%08x  %d\n", ufoRP - rp - 1u, val, (int32_t)val);
2407     }
2408     rscount += 1;
2409   }
2410   if (ufoRP > 32) fprintf(stderr, "    ...more...\n");
2411
2412   fflush(NULL);
2413 }
2414
2415
2416 //==========================================================================
2417 //
2418 //  ufoDumpVocab
2419 //
2420 //==========================================================================
2421 /*
2422 static void ufoDumpVocab (uint32_t vocid) {
2423   if (vocid != 0) {
2424     fprintf(stderr, "*** VOCID: 0x%08x ***\n", vocid);
2425     uint32_t vochdr = vocid + UFW_VOCAB_OFS_HEADER;
2426     vochdr = ufoImgGetU32(vochdr);
2427     if (vochdr != 0) {
2428       fprintf(stderr, "--- HEADER ---\n");
2429       ufoDumpWordHeader(UFO_NFA_TO_LFA(vochdr));
2430       fprintf(stderr, "========\n");
2431       uint32_t htbl = vocid + UFW_VOCAB_OFS_HTABLE;
2432       if (ufoImgGetU32(htbl) != UFO_NO_HTABLE_FLAG) {
2433         fprintf(stderr, "--- HASH TABLE ---\n");
2434         for (int f = 0; f < UFO_HASHTABLE_SIZE; f += 1) {
2435           uint32_t bfa = ufoImgGetU32(htbl);
2436           if (bfa != 0) {
2437             fprintf(stderr, "**** %2d: 0x%08x\n", f, bfa);
2438             do {
2439               ufoDumpWordHeader(UFO_BFA_TO_LFA(bfa));
2440               bfa = ufoImgGetU32(bfa);
2441             } while (bfa != 0);
2442           }
2443           htbl += 4u;
2444         }
2445       }
2446     }
2447   }
2448 }
2449 */
2450
2451
2452 // if set, this will be used when we are out of include files. intended for UrAsm.
2453 // return 0 if there is no more lines, otherwise the string should be copied
2454 // to buffer, `*fname` and `*fline` should be properly set.
2455 int (*ufoFileReadLine) (void *buf, size_t bufsize, const char **fname, int *fline) = NULL;
2456
2457
2458 //==========================================================================
2459 //
2460 //  ufoLoadNextUserLine
2461 //
2462 //==========================================================================
2463 static int ufoLoadNextUserLine (void) {
2464   uint32_t tibPos = 0;
2465   const char *fname = NULL;
2466   int fline = 0;
2467   ufoResetTib();
2468   if (ufoFileReadLine != NULL && ufoFileReadLine(ufoCurrFileLine, 510, &fname, &fline) != 0) {
2469     ufoCurrFileLine[510] = 0;
2470     uint32_t slen = (uint32_t)strlen(ufoCurrFileLine);
2471     while (slen != 0 && (ufoCurrFileLine[slen - 1u] == 10 || ufoCurrFileLine[slen - 1u] == 13)) {
2472       slen -= 1u;
2473     }
2474     if (tibPos + slen + 1u > UFO_ADDR_HANDLE_OFS_MASK) {
2475       ufoFatal("input text line too long (at least %u bytes)", tibPos + slen);
2476     }
2477     ufoTibEnsureSize(tibPos + slen + 1u);
2478     for (uint32_t f = 0; f < slen; f += 1) {
2479       ufoTibPokeChOfs(((const unsigned char *)ufoCurrFileLine)[f], tibPos + f);
2480     }
2481     ufoTibPokeChOfs(0, tibPos + slen);
2482     tibPos += slen;
2483     if (fname == NULL) fname = "<user>";
2484     if (ufoInFileName == NULL || strcmp(ufoInFileName, fname) != 0) {
2485       free(ufoInFileName);
2486       ufoInFileName = strdup(fname);
2487       if (ufoInFileName == NULL) ufoFatal("out of memory");
2488     }
2489     ufoInFileLine = fline;
2490     return 1;
2491   } else {
2492     return 0;
2493   }
2494 }
2495
2496
2497 //==========================================================================
2498 //
2499 //  ufoLoadNextLine_NativeMode
2500 //
2501 //  load next file line into TIB
2502 //  always strips final '\n'
2503 //
2504 //  return 0 on EOF, 1 on success
2505 //
2506 //==========================================================================
2507 static int ufoLoadNextLine (int crossInclude) {
2508   int done = 0;
2509   uint32_t tibPos = 0;
2510   ufoResetTib();
2511
2512   if (ufoMode == UFO_MODE_MACRO) {
2513     //fprintf(stderr, "***MAC!\n");
2514     return 0;
2515   }
2516
2517   while (ufoInFile != NULL && !done) {
2518     if (fgets(ufoCurrFileLine, 510, ufoInFile) != NULL) {
2519       // check for a newline
2520       // if there is no newline char at the end, the string was truncated
2521       ufoCurrFileLine[510] = 0;
2522       const uint32_t slen = (uint32_t)strlen(ufoCurrFileLine);
2523       if (tibPos + slen + 1u > UFO_ADDR_HANDLE_OFS_MASK) {
2524         ufoFatal("input text line too long (at least %u bytes)", tibPos + slen);
2525       }
2526       ufoTibEnsureSize(tibPos + slen + 1u);
2527       for (uint32_t f = 0; f < slen; f += 1) {
2528         ufoTibPokeChOfs(((const unsigned char *)ufoCurrFileLine)[f], tibPos + f);
2529       }
2530       ufoTibPokeChOfs(0, tibPos + slen);
2531       tibPos += slen;
2532       if (slen != 0 && (ufoCurrFileLine[slen - 1u] == 13 || ufoCurrFileLine[slen - 1u] == 10)) {
2533         ++ufoInFileLine;
2534         done = 1;
2535       } else {
2536         // continuation, nothing to do
2537       }
2538     } else {
2539       // if we read nothing, this is EOF
2540       if (tibPos == 0 && crossInclude) {
2541         // we read nothing, and allowed to cross include boundaries
2542         ufoPopInFile();
2543       } else {
2544         done = 1;
2545       }
2546     }
2547   }
2548
2549   if (tibPos == 0) {
2550     // eof, try user-supplied input
2551     if (ufoFileStackPos == 0) {
2552       return ufoLoadNextUserLine();
2553     } else {
2554       return 0;
2555     }
2556   } else {
2557     // if we read at least something, this is not EOF
2558     return 1;
2559   }
2560 }
2561
2562
2563 // ////////////////////////////////////////////////////////////////////////// //
2564 // debug
2565
2566 // DUMP-STACK
2567 // ( -- )
2568 UFWORD(DUMP_STACK) {
2569   if (!ufoLastEmitWasCR) { printf("\n"); ufoLastEmitWasCR = 1; }
2570   printf("***UFO STACK DEPTH: %u\n", ufoSP);
2571   uint32_t left = 32;
2572   uint32_t sp = ufoSP;
2573   while (sp != 0 && left != 0) {
2574     sp -= 1; left -= 1;
2575     printf("  %4u: 0x%08x  %d\n", sp, ufoDStack[sp], (int32_t)ufoDStack[sp]);
2576   }
2577   if (sp != 0) printf("...more...\n");
2578   ufoLastEmitWasCR = 1;
2579 }
2580
2581 // BACKTRACE
2582 UFWORD(UFO_BACKTRACE) {
2583   if (!ufoLastEmitWasCR) { printf("\n"); ufoLastEmitWasCR = 1; }
2584   fflush(NULL);
2585   if (ufoInFile != NULL) {
2586     fprintf(stderr, "*** at file %s, line %d ***\n", ufoInFileName, ufoInFileLine);
2587   } else {
2588     fprintf(stderr, "*** somewhere in time ***\n");
2589   }
2590   ufoBacktrace(ufoIP);
2591 }
2592
2593
2594 // ////////////////////////////////////////////////////////////////////////// //
2595 // SP0!
2596 // ( -- )
2597 UFWORD(SP0_STORE) { ufoSP = 0; }
2598
2599 // RP0!
2600 // ( -- )
2601 UFWORD(RP0_STORE) {
2602   if (ufoRP != ufoRPTop) {
2603     ufoRP = ufoRPTop;
2604     // we need to push a dummy value
2605     ufoRPush(0xdeadf00d);
2606   }
2607 }
2608
2609 // PAD
2610 // ( -- pad )
2611 // PAD is at the beginning of temp area
2612 UFWORD(PAD) {
2613   ufoPush(UFO_ADDR_TEMP_BIT);
2614 }
2615
2616
2617 // ////////////////////////////////////////////////////////////////////////// //
2618 // peeks and pokes with address register
2619 //
2620
2621 // A@
2622 // ( -- regA )
2623 UFWORD(REGA_LOAD) {
2624   ufoPush(ufoRegA);
2625 }
2626
2627 // A!
2628 // ( regA -- )
2629 UFWORD(REGA_STORE) {
2630   ufoRegA = ufoPop();
2631 }
2632
2633 // ////////////////////////////////////////////////////////////////////////// //
2634 // useful to work with handles and normal addreses uniformly
2635 //
2636
2637 // C@A+
2638 // ( idx -- byte )
2639 UFWORD(CPEEK_REGA_IDX) {
2640   if ((ufoRegA & UFO_ADDR_HANDLE_BIT) == 0) {
2641     const uint32_t idx = ufoPop();
2642     const uint32_t newaddr = ufoRegA + idx;
2643     if ((ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == (newaddr & UFO_ADDR_SPECIAL_BITS_MASK)) {
2644       ufoPush(ufoImgGetU8Ext(newaddr));
2645     } else {
2646       ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
2647                ufoRegA, idx, newaddr);
2648     }
2649   } else {
2650     ufoPush(ufoRegA);
2651     UFCALL(PAR_HANDLE_LOAD_BYTE);
2652   }
2653 }
2654
2655 // W@A+
2656 // ( idx -- word )
2657 UFWORD(WPEEK_REGA_IDX) {
2658   if ((ufoRegA & UFO_ADDR_HANDLE_BIT) == 0) {
2659     const uint32_t idx = ufoPop();
2660     const uint32_t newaddr = ufoRegA + idx;
2661     if ((ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == (newaddr & UFO_ADDR_SPECIAL_BITS_MASK) &&
2662         (ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == ((newaddr + 1u) & UFO_ADDR_SPECIAL_BITS_MASK))
2663     {
2664       ufoPush(ufoImgGetU16(newaddr));
2665     } else {
2666       ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
2667                ufoRegA, idx, newaddr);
2668     }
2669   } else {
2670     ufoPush(ufoRegA);
2671     UFCALL(PAR_HANDLE_LOAD_WORD);
2672   }
2673 }
2674
2675 // @A+
2676 // ( idx -- value )
2677 UFWORD(PEEK_REGA_IDX) {
2678   if ((ufoRegA & UFO_ADDR_HANDLE_BIT) == 0) {
2679     const uint32_t idx = ufoPop();
2680     const uint32_t newaddr = ufoRegA + idx;
2681     if ((ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == (newaddr & UFO_ADDR_SPECIAL_BITS_MASK) &&
2682         (ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == ((newaddr + 3u) & UFO_ADDR_SPECIAL_BITS_MASK))
2683     {
2684       ufoPush(ufoImgGetU32(newaddr));
2685     } else {
2686       ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
2687                ufoRegA, idx, newaddr);
2688     }
2689   } else {
2690     ufoPush(ufoRegA);
2691     UFCALL(PAR_HANDLE_LOAD_CELL);
2692   }
2693 }
2694
2695 // C!A+
2696 // ( byte idx -- )
2697 UFWORD(CPOKE_REGA_IDX) {
2698   if ((ufoRegA & UFO_ADDR_HANDLE_BIT) == 0) {
2699     const uint32_t idx = ufoPop();
2700     const uint32_t newaddr = ufoRegA + idx;
2701     if ((ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == (newaddr & UFO_ADDR_SPECIAL_BITS_MASK)) {
2702       const uint32_t value = ufoPop();
2703       ufoImgPutU8(newaddr, value);
2704     } else {
2705       ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
2706                ufoRegA, idx, newaddr);
2707     }
2708   } else {
2709     ufoPush(ufoRegA);
2710     UFCALL(PAR_HANDLE_STORE_BYTE);
2711   }
2712 }
2713
2714 // W!A+
2715 // ( word idx -- )
2716 UFWORD(WPOKE_REGA_IDX) {
2717   if ((ufoRegA & UFO_ADDR_HANDLE_BIT) == 0) {
2718     const uint32_t idx = ufoPop();
2719     const uint32_t newaddr = ufoRegA + idx;
2720     if ((ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == (newaddr & UFO_ADDR_SPECIAL_BITS_MASK) &&
2721         (ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == ((newaddr + 1u) & UFO_ADDR_SPECIAL_BITS_MASK))
2722     {
2723       const uint32_t value = ufoPop();
2724       ufoImgPutU16(newaddr, value);
2725     } else {
2726       ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
2727                ufoRegA, idx, newaddr);
2728     }
2729   } else {
2730     ufoPush(ufoRegA);
2731     UFCALL(PAR_HANDLE_STORE_WORD);
2732   }
2733 }
2734
2735 // !A+
2736 // ( value idx -- )
2737 UFWORD(POKE_REGA_IDX) {
2738   if ((ufoRegA & UFO_ADDR_HANDLE_BIT) == 0) {
2739     const uint32_t idx = ufoPop();
2740     const uint32_t newaddr = ufoRegA + idx;
2741     if ((ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == (newaddr & UFO_ADDR_SPECIAL_BITS_MASK) &&
2742         (ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == ((newaddr + 3u) & UFO_ADDR_SPECIAL_BITS_MASK))
2743     {
2744       const uint32_t value = ufoPop();
2745       ufoImgPutU32(newaddr, value);
2746     } else {
2747       ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
2748                ufoRegA, idx, newaddr);
2749     }
2750   } else {
2751     ufoPush(ufoRegA);
2752     UFCALL(PAR_HANDLE_STORE_CELL);
2753   }
2754 }
2755
2756
2757 // ////////////////////////////////////////////////////////////////////////// //
2758 // peeks and pokes
2759 //
2760
2761 // C@
2762 // ( addr -- value8 )
2763 UFWORD(CPEEK) {
2764   ufoPush(ufoImgGetU8Ext(ufoPop()));
2765 }
2766
2767 // W@
2768 // ( addr -- value16 )
2769 UFWORD(WPEEK) {
2770   const uint32_t addr = ufoPop();
2771   if ((addr & UFO_ADDR_HANDLE_BIT) == 0) {
2772     ufoPush(ufoImgGetU16(addr));
2773   } else {
2774     ufoPush(0);
2775     ufoPush(addr);
2776     UFCALL(PAR_HANDLE_LOAD_WORD);
2777   }
2778 }
2779
2780 // @
2781 // ( addr -- value32 )
2782 UFWORD(PEEK) {
2783   const uint32_t addr = ufoPop();
2784   if ((addr & UFO_ADDR_HANDLE_BIT) == 0) {
2785     ufoPush(ufoImgGetU32(addr));
2786   } else {
2787     ufoPush(0);
2788     ufoPush(addr);
2789     UFCALL(PAR_HANDLE_LOAD_CELL);
2790   }
2791 }
2792
2793 // C!
2794 // ( val8 addr -- )
2795 UFWORD(CPOKE) {
2796   const uint32_t addr = ufoPop();
2797   const uint32_t val = ufoPop();
2798   ufoImgPutU8Ext(addr, val);
2799 }
2800
2801 // W!
2802 // ( val16 addr -- )
2803 UFWORD(WPOKE) {
2804   const uint32_t addr = ufoPop();
2805   const uint32_t val = ufoPop();
2806   if ((addr & UFO_ADDR_HANDLE_BIT) == 0) {
2807     ufoImgPutU16(addr, val);
2808   } else {
2809     ufoPush(val);
2810     ufoPush(0);
2811     ufoPush(addr);
2812     UFCALL(PAR_HANDLE_STORE_WORD);
2813   }
2814 }
2815
2816 // !
2817 // ( val32 addr -- )
2818 UFWORD(POKE) {
2819   const uint32_t addr = ufoPop();
2820   const uint32_t val = ufoPop();
2821   if ((addr & UFO_ADDR_HANDLE_BIT) == 0) {
2822     ufoImgPutU32(addr, val);
2823   } else {
2824     ufoPush(val);
2825     ufoPush(0);
2826     ufoPush(addr);
2827     UFCALL(PAR_HANDLE_STORE_CELL);
2828   }
2829 }
2830
2831
2832 // ////////////////////////////////////////////////////////////////////////// //
2833 // dictionary emitters
2834 //
2835
2836 // C,
2837 // ( val8 -- )
2838 UFWORD(CCOMMA) { const uint32_t val = ufoPop(); ufoImgEmitU8(val); }
2839
2840 // W,
2841 // ( val16 -- )
2842 UFWORD(WCOMMA) { const uint32_t val = ufoPop(); ufoImgEmitU8(val&0xffU); ufoImgEmitU8((val >> 8)&0xffU); }
2843
2844 // ,
2845 // ( val -- )
2846 UFWORD(COMMA) { const uint32_t val = ufoPop(); ufoImgEmitU32(val); }
2847
2848
2849 // ////////////////////////////////////////////////////////////////////////// //
2850 // literal pushers
2851 //
2852
2853
2854 // (LIT) ( -- n )
2855 UFWORD(PAR_LIT) {
2856   const uint32_t v = ufoImgGetU32(ufoIP); ufoIP += 4;
2857   ufoPush(v);
2858 }
2859
2860 // (LITCFA) ( -- n )
2861 UFWORD(PAR_LITCFA) {
2862   const uint32_t v = ufoImgGetU32(ufoIP); ufoIP += 4;
2863   ufoPush(v);
2864 }
2865
2866 // (LITVOCID) ( -- n )
2867 UFWORD(PAR_LITVOCID) {
2868   const uint32_t v = ufoImgGetU32(ufoIP); ufoIP += 4;
2869   ufoPush(v);
2870 }
2871
2872 // (STRLIT8)
2873 UFWORD(PAR_STRLIT8) {
2874   const uint32_t count = ufoImgGetU8(ufoIP); ufoIP += 1;
2875   ufoPush(ufoIP);
2876   ufoPush(count);
2877   ufoIP += count + 1; // 1 for terminating 0
2878   // align
2879   ufoIP = UFO_ALIGN4(ufoIP);
2880 }
2881
2882
2883 // ////////////////////////////////////////////////////////////////////////// //
2884 // jumps, etc.
2885 //
2886
2887
2888 // (BRANCH) ( -- )
2889 UFWORD(PAR_BRANCH) {
2890   ufoIP = ufoImgGetU32(ufoIP);
2891 }
2892
2893 // (TBRANCH) ( flag )
2894 UFWORD(PAR_TBRANCH) {
2895   if (ufoPop()) {
2896     ufoIP = ufoImgGetU32(ufoIP);
2897   } else {
2898     ufoIP += 4;
2899   }
2900 }
2901
2902 // (0BRANCH) ( flag )
2903 UFWORD(PAR_0BRANCH) {
2904   if (!ufoPop()) {
2905     ufoIP = ufoImgGetU32(ufoIP);
2906   } else {
2907     ufoIP += 4;
2908   }
2909 }
2910
2911
2912 // ////////////////////////////////////////////////////////////////////////// //
2913 // execute words by CFA
2914 //
2915
2916
2917 // EXECUTE ( cfa )
2918 UFWORD(EXECUTE) {
2919   ufoRPush(ufoPop());
2920   ufoVMRPopCFA = 1;
2921 }
2922
2923 // EXECUTE-TAIL ( cfa )
2924 UFWORD(EXECUTE_TAIL) {
2925   ufoIP = ufoRPop();
2926   ufoRPush(ufoPop());
2927   ufoVMRPopCFA = 1;
2928 }
2929
2930
2931 // ////////////////////////////////////////////////////////////////////////// //
2932 // word termination, locals support
2933 //
2934
2935
2936 // (EXIT)
2937 UFWORD(PAR_EXIT) {
2938   ufoIP = ufoRPop();
2939 }
2940
2941 // (L-ENTER)
2942 // ( loccount -- )
2943 UFWORD(PAR_LENTER) {
2944   // low byte of loccount is total number of locals
2945   // high byte is the number of args
2946   uint32_t lcount = ufoImgGetU32(ufoIP); ufoIP += 4u;
2947   uint32_t acount = (lcount >> 8) & 0xff;
2948   lcount &= 0xff;
2949   if (lcount == 0 || lcount < acount) ufoFatal("invalid call to (L-ENTER)");
2950   if ((ufoLBP != 0 && ufoLBP >= ufoLP) || UFO_LSTACK_SIZE - ufoLP <= lcount + 2) {
2951     ufoFatal("out of locals stack");
2952   }
2953   uint32_t newbp;
2954   if (ufoLP == 0) { ufoLP = 1; newbp = 1; } else newbp = ufoLP;
2955   //fprintf(stderr, "LP: %u; LBP: %u; locs: %u; word: %s\n", ufoLP, ufoLBP, fw->locs, fw->name);
2956   ufoLStack[ufoLP] = ufoLBP; ufoLP += 1;
2957   ufoLBP = newbp; ufoLP += lcount;
2958   // and copy args
2959   newbp += acount;
2960   while (newbp != ufoLBP) {
2961     ufoLStack[newbp] = ufoPop();
2962     newbp -= 1;
2963   }
2964 }
2965
2966 // (L-LEAVE)
2967 UFWORD(PAR_LLEAVE) {
2968   if (ufoLBP == 0) ufoFatal("(L-LEAVE) with empty locals stack");
2969   if (ufoLBP >= ufoLP) ufoFatal("(L-LEAVE) broken locals stack");
2970   ufoLP = ufoLBP;
2971   ufoLBP = ufoLStack[ufoLBP];
2972 }
2973
2974
2975 //==========================================================================
2976 //
2977 //  ufoLoadLocal
2978 //
2979 //==========================================================================
2980 UFO_FORCE_INLINE void ufoLoadLocal (const uint32_t lidx) {
2981   if (lidx == 0 || lidx >= UFO_LSTACK_SIZE) ufoFatal("invalid local index");
2982   if (ufoLBP == 0 || ufoLBP >= ufoLP || ufoLP - ufoLBP <= lidx) ufoFatal("invalid local index");
2983   ufoPush(ufoLStack[ufoLBP + lidx]);
2984 }
2985
2986
2987 //==========================================================================
2988 //
2989 //  ufoStoreLocal
2990 //
2991 //==========================================================================
2992 UFO_FORCE_INLINE void ufoStoreLocal (const uint32_t lidx) {
2993   const uint32_t value = ufoPop();
2994   if (lidx == 0 || lidx >= UFO_LSTACK_SIZE) ufoFatal("invalid local index");
2995   if (ufoLBP == 0 || ufoLBP >= ufoLP || ufoLP - ufoLBP <= lidx) ufoFatal("invalid local index");
2996   ufoLStack[ufoLBP + lidx] = value;
2997 }
2998
2999
3000 // (LOCAL@)
3001 // ( idx -- value )
3002 UFWORD(PAR_LOCAL_LOAD) { ufoLoadLocal(ufoPop()); }
3003
3004 // (LOCAL!)
3005 // ( value idx -- )
3006 UFWORD(PAR_LOCAL_STORE) { ufoStoreLocal(ufoPop()); }
3007
3008
3009 // ////////////////////////////////////////////////////////////////////////// //
3010 // stack manipulation
3011 //
3012
3013
3014 // DUP
3015 // ( n -- n n )
3016 UFWORD(DUP) { ufoDup(); }
3017 // ?DUP
3018 // ( n -- n n ) | ( 0 -- 0 )
3019 UFWORD(QDUP) { if (ufoPeek()) ufoDup(); }
3020 // 2DUP
3021 // ( n0 n1 -- n0 n1 n0 n1 )
3022 UFWORD(DDUP) { ufo2Dup(); }
3023 // DROP
3024 // ( n -- )
3025 UFWORD(DROP) { ufoDrop(); }
3026 // 2DROP
3027 // ( n0 n1 -- )
3028 UFWORD(DDROP) { ufo2Drop(); }
3029 // SWAP
3030 // ( n0 n1 -- n1 n0 )
3031 UFWORD(SWAP) { ufoSwap(); }
3032 // 2SWAP
3033 // ( n0 n1 -- n1 n0 )
3034 UFWORD(DSWAP) { ufo2Swap(); }
3035 // OVER
3036 // ( n0 n1 -- n0 n1 n0 )
3037 UFWORD(OVER) { ufoOver(); }
3038 // 2OVER
3039 // ( n0 n1 -- n0 n1 n0 )
3040 UFWORD(DOVER) { ufo2Over(); }
3041 // ROT
3042 // ( n0 n1 n2 -- n1 n2 n0 )
3043 UFWORD(ROT) { ufoRot(); }
3044 // NROT
3045 // ( n0 n1 n2 -- n2 n0 n1 )
3046 UFWORD(NROT) { ufoNRot(); }
3047
3048 // RDUP
3049 // ( n -- n n )
3050 UFWORD(RDUP) { ufoRDup(); }
3051 // RDROP
3052 // ( n -- )
3053 UFWORD(RDROP) { ufoRDrop(); }
3054
3055 // >R
3056 // ( n -- | n )
3057 UFWORD(DTOR) { ufoRPush(ufoPop()); }
3058 // R>
3059 // ( | n -- n )
3060 UFWORD(RTOD) { ufoPush(ufoRPop()); }
3061 // R@
3062 // ( | n -- n | n)
3063 UFWORD(RPEEK) { ufoPush(ufoRPeek()); }
3064
3065
3066 // PICK
3067 // ( idx -- n )
3068 UFWORD(PICK) {
3069   const uint32_t n = ufoPop();
3070   if (n >= ufoSP) ufoFatal("invalid PICK index %u", n);
3071   ufoPush(ufoDStack[ufoSP - n - 1u]);
3072 }
3073
3074 // RPICK
3075 // ( idx -- n )
3076 UFWORD(RPICK) {
3077   const uint32_t n = ufoPop();
3078   if (n >= ufoRP - ufoRPTop) ufoFatal("invalid RPICK index %u", n);
3079   const uint32_t rp = ufoRP - n - 1u;
3080   ufoPush(ufoRStack[rp]);
3081 }
3082
3083 // ROLL
3084 // ( idx -- n )
3085 UFWORD(ROLL) {
3086   const uint32_t n = ufoPop();
3087   if (n >= ufoSP) ufoFatal("invalid ROLL index %u", n);
3088   switch (n) {
3089     case 0: break; // do nothing
3090     case 1: ufoSwap(); break;
3091     case 2: ufoRot(); break;
3092     default:
3093       {
3094         const uint32_t val = ufoDStack[ufoSP - n - 1u];
3095         for (uint32_t f = ufoSP - n; f < ufoSP; f += 1) ufoDStack[f - 1] = ufoDStack[f];
3096         ufoDStack[ufoSP - 1u] = val;
3097       }
3098       break;
3099   }
3100 }
3101
3102 // RROLL
3103 // ( idx -- n )
3104 UFWORD(RROLL) {
3105   const uint32_t n = ufoPop();
3106   if (n >= ufoRP - ufoRPTop) ufoFatal("invalid RROLL index %u", n);
3107   if (n != 0) {
3108     const uint32_t rp = ufoRP - n - 1u;
3109     const uint32_t val = ufoRStack[rp];
3110     for (uint32_t f = rp + 1u; f < ufoRP; f += 1u) ufoRStack[f - 1u] = ufoRStack[f];
3111     ufoRStack[ufoRP - 1u] = val;
3112   }
3113 }
3114
3115 // RSWAP
3116 // ( | a b -- | b a )
3117 UFWORD(RSWAP) {
3118   const uint32_t b = ufoRPop();
3119   const uint32_t a = ufoRPop();
3120   ufoRPush(b); ufoRPush(a);
3121 }
3122
3123 // ROVER
3124 // ( | a b -- | a b a )
3125 UFWORD(ROVER) {
3126   const uint32_t b = ufoRPop();
3127   const uint32_t a = ufoRPop();
3128   ufoRPush(a); ufoRPush(b); ufoRPush(a);
3129 }
3130
3131 // RROT
3132 // ( | a b c -- | b c a )
3133 UFWORD(RROT) {
3134   const uint32_t c = ufoRPop();
3135   const uint32_t b = ufoRPop();
3136   const uint32_t a = ufoRPop();
3137   ufoRPush(b); ufoRPush(c); ufoRPush(a);
3138 }
3139
3140 // RNROT
3141 // ( | a b c -- | c a b )
3142 UFWORD(RNROT) {
3143   const uint32_t c = ufoRPop();
3144   const uint32_t b = ufoRPop();
3145   const uint32_t a = ufoRPop();
3146   ufoRPush(c); ufoRPush(a); ufoRPush(b);
3147 }
3148
3149
3150 // ////////////////////////////////////////////////////////////////////////// //
3151 // TIB API
3152 //
3153
3154 // REFILL
3155 // ( -- eofflag )
3156 UFWORD(REFILL) {
3157   ufoPushBool(ufoLoadNextLine(1));
3158 }
3159
3160 // REFILL-NOCROSS
3161 // ( -- eofflag )
3162 UFWORD(REFILL_NOCROSS) {
3163   ufoPushBool(ufoLoadNextLine(0));
3164 }
3165
3166 // (TIB-IN)
3167 // ( -- addr )
3168 UFWORD(TIB_IN) {
3169   ufoPush(ufoImgGetU32(ufoAddrTIBx) + ufoImgGetU32(ufoAddrINx));
3170 }
3171
3172 // TIB-PEEKCH
3173 // ( -- char )
3174 UFWORD(TIB_PEEKCH) {
3175   ufoPush(ufoTibPeekCh());
3176 }
3177
3178 // TIB-PEEKCH-OFS
3179 // ( ofs -- char )
3180 UFWORD(TIB_PEEKCH_OFS) {
3181   const uint32_t ofs = ufoPop();
3182   ufoPush(ufoTibPeekChOfs(ofs));
3183 }
3184
3185 // TIB-GETCH
3186 // ( -- char )
3187 UFWORD(TIB_GETCH) {
3188   ufoPush(ufoTibGetCh());
3189 }
3190
3191 // TIB-SKIPCH
3192 // ( -- )
3193 UFWORD(TIB_SKIPCH) {
3194   ufoTibSkipCh();
3195 }
3196
3197
3198 // ////////////////////////////////////////////////////////////////////////// //
3199 // TIB parsing
3200 //
3201
3202 //==========================================================================
3203 //
3204 //  ufoIsDelim
3205 //
3206 //==========================================================================
3207 UFO_FORCE_INLINE int ufoIsDelim (uint8_t ch, uint8_t delim) {
3208   return (delim == 32 ? (ch <= 32) : (ch == delim));
3209 }
3210
3211
3212 // (PARSE)
3213 // ( delim skip-leading-delim? -- addr count TRUE / FALSE )
3214 // does base TIB parsing; never copies anything.
3215 // as our reader is line-based, returns FALSE on EOL.
3216 // EOL is detected after skipping leading delimiters.
3217 // passing -1 as delimiter skips the whole line, and always returns FALSE.
3218 // trailing delimiter is always skipped.
3219 UFWORD(PAR_PARSE) {
3220   const uint32_t skipDelim = ufoPop();
3221   const uint32_t delim = ufoPop();
3222   uint8_t ch;
3223
3224   if (delim == 0 || delim > 0xffU) {
3225     // skip everything
3226     while (ufoTibGetCh() != 0) {}
3227     ufoPushBool(0);
3228   } else {
3229     ch = ufoTibPeekCh();
3230     // skip initial delimiters
3231     if (skipDelim) {
3232       while (ch != 0 && ufoIsDelim(ch, delim)) {
3233         ufoTibSkipCh();
3234         ch = ufoTibPeekCh();
3235       }
3236     }
3237     // parse
3238     const uint32_t staddr = ufoImgGetU32(ufoAddrTIBx) + ufoImgGetU32(ufoAddrINx);
3239     uint32_t count = 0;
3240     while (ch != 0 && !ufoIsDelim(ch, delim)) {
3241       count += 1u;
3242       ufoTibSkipCh();
3243       ch = ufoTibPeekCh();
3244     }
3245     // skip delimiter
3246     if (ch != 0) ufoTibSkipCh();
3247     if (count != 0) {
3248       ufoPush(staddr);
3249       ufoPush(count);
3250       ufoPushBool(1);
3251     } else {
3252       ufoPushBool(0);
3253     }
3254   }
3255 }
3256
3257 // PARSE-SKIP-BLANKS
3258 // ( -- )
3259 UFWORD(PARSE_SKIP_BLANKS) {
3260   uint8_t ch = ufoTibPeekCh();
3261   while (ch != 0 && ch <= 32) {
3262     ufoTibSkipCh();
3263     ch = ufoTibPeekCh();
3264   }
3265 }
3266
3267
3268 //==========================================================================
3269 //
3270 //  ufoParseMLComment
3271 //
3272 //  initial two chars are skipped
3273 //
3274 //==========================================================================
3275 static void ufoParseMLComment (uint32_t allowMulti, int nested) {
3276   uint32_t level = 1;
3277   uint8_t ch, ch1;
3278   while (level != 0) {
3279     ch = ufoTibGetCh();
3280     if (ch == 0) {
3281       if (allowMulti) {
3282         UFCALL(REFILL_NOCROSS);
3283         if (ufoPop() == 0) ufoFatal("unexpected end of file in comment");
3284       } else {
3285         ufoFatal("unexpected end of line in comment");
3286       }
3287     } else {
3288       ch1 = ufoTibPeekCh();
3289       if (nested && ch == '(' && ch1 == '(') { ufoTibSkipCh(); level += 1; }
3290       else if (nested && ch == ')' && ch1 == ')') { ufoTibSkipCh(); level -= 1; }
3291       else if (!nested && ch == '*' && ch1 == ')') { ufo_assert(level == 1); ufoTibSkipCh(); level = 0; }
3292     }
3293   }
3294 }
3295
3296
3297 // (PARSE-SKIP-COMMENTS)
3298 // ( allow-multiline? -- )
3299 // skip all blanks and comments
3300 UFWORD(PAR_PARSE_SKIP_COMMENTS) {
3301   const uint32_t allowMulti = ufoPop();
3302   uint8_t ch, ch1;
3303   ch = ufoTibPeekCh();
3304   #if 0
3305   fprintf(stderr, "(PARSE-SKIP-COMMENTS): first-ch:'%c'\n", (char)ch);
3306   #endif
3307   while (ch != 0) {
3308     if (ch <= 32) {
3309       ufoTibSkipCh();
3310       ch = ufoTibPeekCh();
3311       #if 0
3312       fprintf(stderr, "(PARSE-SKIP-COMMENTS): blank-ch:'%c'\n", (char)ch);
3313       #endif
3314     } else if (ch == '(') {
3315       #if 0
3316       fprintf(stderr, "(PARSE-SKIP-COMMENTS): ch:'%c'; ch1:'%c' ('%c')\n", (char)ch, (char)ch1,
3317               ufoTibPeekChOfs(0));
3318       #endif
3319       ch1 = ufoTibPeekChOfs(1);
3320       if (ch1 <= 32) {
3321         // single-line comment
3322         do { ch = ufoTibGetCh(); } while (ch != 0 && ch != ')');
3323         ch = ufoTibPeekCh();
3324       } else if (ch1 == '*' || ch1 == '(') {
3325         // possibly multiline
3326         ufoTibSkipCh(); ufoTibSkipCh(); // skip opening
3327         ufoParseMLComment(allowMulti, (ch1 == '('));
3328         ch = ufoTibPeekCh();
3329       } else {
3330         ch = 0;
3331       }
3332     } else if (ch == '\\' && ufoTibPeekChOfs(1) <= 32) {
3333       // single-line comment
3334       while (ch != 0) ch = ufoTibGetCh();
3335     } else if ((ch == ';' || ch == '-' || ch == '/') && (ufoTibPeekChOfs(1) == ch)) {
3336       // skip to EOL
3337       while (ch != 0) ch = ufoTibGetCh();
3338     } else {
3339       ch = 0;
3340     }
3341   }
3342   #if 0
3343   fprintf(stderr, "(PARSE-SKIP-COMMENTS): end-ch:'%c'\n", ufoTibPeekCh());
3344   #endif
3345 }
3346
3347 // PARSE-SKIP-LINE
3348 // ( -- )
3349 UFWORD(PARSE_SKIP_LINE) {
3350   ufoPush(0); ufoPushBool(0); UFCALL(PAR_PARSE);
3351   if (ufoPop() != 0) {
3352     ufo2Drop();
3353   }
3354 }
3355
3356 // PARSE-NAME
3357 // ( -- addr count )
3358 // parse with leading blanks skipping. doesn't copy anything.
3359 // return empty string on EOL.
3360 UFWORD(PARSE_NAME) {
3361   ufoPush(32); ufoPushBool(1); UFCALL(PAR_PARSE);
3362   if (ufoPop() == 0) {
3363     ufoPush(0);
3364     ufoPush(0);
3365   }
3366 }
3367
3368 // PARSE
3369 // ( delim -- addr count TRUE / FALSE )
3370 // parse without skipping delimiters; never copies anything.
3371 // as our reader is line-based, returns FALSE on EOL.
3372 // passing 0 as delimiter skips the whole line, and always returns FALSE.
3373 // trailing delimiter is always skipped.
3374 UFWORD(PARSE) {
3375   ufoPushBool(0); UFCALL(PAR_PARSE);
3376 }
3377
3378 // (WORD-OR-PARSE)
3379 // ( delim skip-leading-delim? -- here TRUE / FALSE )
3380 // parse word, copy it to HERE as counted string.
3381 // adds trailing zero after the string, but doesn't include it in count.
3382 // doesn't advance line.
3383
3384 // WORD
3385 // ( delim -- here )
3386 // parse word, copy it to HERE as counted string.
3387 // adds trailing zero after the string, but doesn't include it in count.
3388 // doesn't advance line.
3389 // return empty string on EOL.
3390
3391 // PARSE-TO-HERE
3392 // ( delim -- addr count TRUE / FALSE )
3393 // parse word w/o skipping delimiters, copy it to HERE as counted string.
3394 // adds trailing zero after the string, but doesn't include it in count.
3395 // doesn't advance line.
3396
3397
3398 // ////////////////////////////////////////////////////////////////////////// //
3399 // char output
3400 //
3401
3402 // EMIT
3403 // ( n -- )
3404 UFWORD(EMIT) {
3405   uint32_t ch = ufoPop()&0xffU;
3406   /*
3407   if (ch < 32 || ch == 127) {
3408     if (ch != 9 && ch != 10 && ch != 13) ch = '?';
3409   }
3410   */
3411   ufoLastEmitWasCR = (ch == 10);
3412   putchar((char)ch);
3413 }
3414
3415 // XEMIT
3416 // ( n -- )
3417 UFWORD(XEMIT) {
3418   uint32_t ch = ufoPop()&0xffU;
3419   putchar(ch < 32 || ch == 127 ? '?' : (char)ch);
3420   ufoLastEmitWasCR = 0;
3421 }
3422
3423 // LASTCR?
3424 // ( -- bool )
3425 UFWORD(LASTCRQ) {
3426   ufoPushBool(ufoLastEmitWasCR);
3427 }
3428
3429 // LASTCR!
3430 // ( bool -- )
3431 UFWORD(LASTCRSET) {
3432   ufoLastEmitWasCR = !!ufoPop();
3433 }
3434
3435 // CR
3436 // ( -- )
3437 UFWORD(CR) {
3438   putchar('\n');
3439   ufoLastEmitWasCR = 1;
3440 }
3441
3442 // SPACE
3443 // ( -- )
3444 UFWORD(SPACE) {
3445   putchar(' ');
3446   ufoLastEmitWasCR = 0;
3447 }
3448
3449 // SPACES
3450 // ( n -- )
3451 UFWORD(SPACES) {
3452   char tmpbuf[64];
3453   int32_t n = (int32_t)ufoPop();
3454   if (n > 0) {
3455     memset(tmpbuf, 32, sizeof(tmpbuf));
3456     while (n > 0) {
3457       int32_t xwr = n;
3458       if (xwr > (int32_t)sizeof(tmpbuf) - 1) xwr = (int32_t)sizeof(tmpbuf) - 1;
3459       tmpbuf[xwr] = 0;
3460       printf("%s", tmpbuf);
3461       n -= xwr;
3462     }
3463     ufoLastEmitWasCR = 0;
3464   }
3465 }
3466
3467 // ENDCR
3468 // ( -- )
3469 UFWORD(ENDCR) {
3470   if (ufoLastEmitWasCR == 0) {
3471     putchar('\n');
3472     ufoLastEmitWasCR = 1;
3473   }
3474 }
3475
3476 // TYPE
3477 // ( addr count -- )
3478 UFWORD(TYPE) {
3479   int32_t count = (int32_t)ufoPop();
3480   uint32_t addr = ufoPop();
3481   while (count > 0) {
3482     const uint8_t ch = ufoImgGetU8Ext(addr);
3483     ufoPush(ch);
3484     UFCALL(EMIT);
3485     addr += 1; count -= 1;
3486   }
3487 }
3488
3489 // XTYPE
3490 // ( addr count -- )
3491 UFWORD(XTYPE) {
3492   int32_t count = (int32_t)ufoPop();
3493   uint32_t addr = ufoPop();
3494   while (count > 0) {
3495     const uint8_t ch = ufoImgGetU8Ext(addr);
3496     ufoPush(ch);
3497     UFCALL(XEMIT);
3498     addr += 1; count -= 1;
3499   }
3500 }
3501
3502 // FLUSH-EMIT
3503 // ( -- )
3504 UFWORD(FLUSH_EMIT) {
3505   fflush(NULL);
3506 }
3507
3508
3509 // ////////////////////////////////////////////////////////////////////////// //
3510 // simple math
3511 //
3512
3513 #define UF_UMATH(name_,op_)  \
3514 UFWORD(name_) { \
3515   const uint32_t a = ufoPop(); \
3516   ufoPush(op_); \
3517 }
3518
3519 #define UF_BMATH(name_,op_)  \
3520 UFWORD(name_) { \
3521   const uint32_t b = ufoPop(); \
3522   const uint32_t a = ufoPop(); \
3523   ufoPush(op_); \
3524 }
3525
3526 #define UF_BDIV(name_,op_)  \
3527 UFWORD(name_) { \
3528   const uint32_t b = ufoPop(); \
3529   const uint32_t a = ufoPop(); \
3530   if (b == 0) ufoFatal("division by zero"); \
3531   ufoPush(op_); \
3532 }
3533
3534
3535 // +
3536 // ( a b -- a+b )
3537 UF_BMATH(PLUS, a + b);
3538
3539 // -
3540 // ( a b -- a-b )
3541 UF_BMATH(MINUS, a - b);
3542
3543 // *
3544 // ( a b -- a*b )
3545 UF_BMATH(MUL, (uint32_t)((int32_t)a * (int32_t)b));
3546
3547 // U*
3548 // ( a b -- a*b )
3549 UF_BMATH(UMUL, a * b);
3550
3551 // /
3552 // ( a b -- a/b )
3553 UF_BDIV(DIV, (uint32_t)((int32_t)a / (int32_t)b));
3554
3555 // U/
3556 // ( a b -- a/b )
3557 UF_BDIV(UDIV, a / b);
3558
3559 // MOD
3560 // ( a b -- a%b )
3561 UF_BDIV(MOD, (uint32_t)((int32_t)a % (int32_t)b));
3562
3563 // UMOD
3564 // ( a b -- a%b )
3565 UF_BDIV(UMOD, a % b);
3566
3567 // /MOD
3568 // ( a b -- a/b, a%b )
3569 UFWORD(DIVMOD) {
3570   const int32_t b = (int32_t)ufoPop();
3571   const int32_t a = (int32_t)ufoPop();
3572   if (b == 0) ufoFatal("division by zero");
3573   ufoPush((uint32_t)(a/b));
3574   ufoPush((uint32_t)(a%b));
3575 }
3576
3577 // U/MOD
3578 // ( a b -- a/b, a%b )
3579 UFWORD(UDIVMOD) {
3580   const uint32_t b = ufoPop();
3581   const uint32_t a = ufoPop();
3582   if (b == 0) ufoFatal("division by zero");
3583   ufoPush((uint32_t)(a/b));
3584   ufoPush((uint32_t)(a%b));
3585 }
3586
3587 // */
3588 // ( a b c -- a*b/c )
3589 // this uses 64-bit intermediate value
3590 UFWORD(MULDIV) {
3591   const int32_t c = (int32_t)ufoPop();
3592   const int32_t b = (int32_t)ufoPop();
3593   const int32_t a = (int32_t)ufoPop();
3594   if (c == 0) ufoFatal("division by zero");
3595   int64_t xval = a; xval *= b; xval /= c;
3596   ufoPush((uint32_t)(int32_t)xval);
3597 }
3598
3599 // U*/
3600 // ( a b c -- a*b/c )
3601 // this uses 64-bit intermediate value
3602 UFWORD(UMULDIV) {
3603   const uint32_t c = ufoPop();
3604   const uint32_t b = ufoPop();
3605   const uint32_t a = ufoPop();
3606   if (c == 0) ufoFatal("division by zero");
3607   uint64_t xval = a; xval *= b; xval /= c;
3608   ufoPush((uint32_t)xval);
3609 }
3610
3611 // */MOD
3612 // ( a b c -- a*b/c a*b%c )
3613 // this uses 64-bit intermediate value
3614 UFWORD(MULDIVMOD) {
3615   const int32_t c = (int32_t)ufoPop();
3616   const int32_t b = (int32_t)ufoPop();
3617   const int32_t a = (int32_t)ufoPop();
3618   if (c == 0) ufoFatal("division by zero");
3619   int64_t xval = a; xval *= b;
3620   ufoPush((uint32_t)(int32_t)(xval / c));
3621   ufoPush((uint32_t)(int32_t)(xval % c));
3622 }
3623
3624 // U*/
3625 // ( a b c -- a*b/c )
3626 // this uses 64-bit intermediate value
3627 UFWORD(UMULDIVMOD) {
3628   const uint32_t c = ufoPop();
3629   const uint32_t b = ufoPop();
3630   const uint32_t a = ufoPop();
3631   if (c == 0) ufoFatal("division by zero");
3632   uint64_t xval = a; xval *= b;
3633   ufoPush((uint32_t)(xval / c));
3634   ufoPush((uint32_t)(xval % c));
3635 }
3636
3637 // M*
3638 // ( a b -- lo(a*b) hi(a*b) )
3639 // this leaves 64-bit result
3640 UFWORD(MMUL) {
3641   const int32_t b = (int32_t)ufoPop();
3642   const int32_t a = (int32_t)ufoPop();
3643   int64_t xval = a; xval *= b;
3644   ufoPush((uint32_t)(int32_t)xval);
3645   ufoPush((uint32_t)(int32_t)(xval >> 32));
3646 }
3647
3648 // UM*
3649 // ( a b -- lo(a*b) hi(a*b) )
3650 // this leaves 64-bit result
3651 UFWORD(UMMUL) {
3652   const uint32_t b = ufoPop();
3653   const uint32_t a = ufoPop();
3654   uint64_t xval = a; xval *= b;
3655   ufoPush((uint32_t)xval);
3656   ufoPush((uint32_t)(xval >> 32));
3657 }
3658
3659 // M/MOD
3660 // ( alo ahi b -- a/b a%b )
3661 UFWORD(MDIVMOD) {
3662   const int32_t b = (int32_t)ufoPop();
3663   const uint32_t alo = ufoPop();
3664   const uint32_t ahi = ufoPop();
3665   if (b == 0) ufoFatal("division by zero");
3666   // this is UB by the idiotic C standard. i don't care.
3667   int64_t a = alo; a |= ((int64_t)ahi) << 32;
3668   int64_t adiv = a / b;
3669   int64_t amod = a % b;
3670   ufoPush((uint32_t)(int32_t)adiv);
3671   ufoPush((uint32_t)(int32_t)amod);
3672 }
3673
3674 // UM/MOD
3675 // ( alo ahi b -- a/b a%b )
3676 UFWORD(UMDIVMOD) {
3677   const uint32_t b = ufoPop();
3678   const uint32_t alo = ufoPop();
3679   const uint32_t ahi = ufoPop();
3680   if (b == 0) ufoFatal("division by zero");
3681   uint64_t a = alo; a |= ((uint64_t)ahi) << 32;
3682   uint64_t adiv = a / b;
3683   uint64_t amod = a % b;
3684   ufoPush((uint32_t)adiv);
3685   ufoPush((uint32_t)amod);
3686 }
3687
3688
3689 // ////////////////////////////////////////////////////////////////////////// //
3690 // simple logic and bit manipulation
3691 //
3692
3693 #define UF_CMP(name_,op_)  \
3694 UFWORD(name_) { \
3695   const uint32_t b = ufoPop(); \
3696   const uint32_t a = ufoPop(); \
3697   ufoPushBool(op_); \
3698 }
3699
3700 // <
3701 // ( a b -- a<b )
3702 UF_CMP(LESS, (int32_t)a < (int32_t)b);
3703
3704 // U<
3705 // ( a b -- a<b )
3706 UF_CMP(ULESS, a < b);
3707
3708 // >
3709 // ( a b -- a>b )
3710 UF_CMP(GREAT, (int32_t)a > (int32_t)b);
3711
3712 // U>
3713 // ( a b -- a>b )
3714 UF_CMP(UGREAT, a > b);
3715
3716 // <=
3717 // ( a b -- a<=b )
3718 UF_CMP(LESSEQU, (int32_t)a <= (int32_t)b);
3719
3720 // U<=
3721 // ( a b -- a<=b )
3722 UF_CMP(ULESSEQU, a <= b);
3723
3724 // >=
3725 // ( a b -- a>=b )
3726 UF_CMP(GREATEQU, (int32_t)a >= (int32_t)b);
3727
3728 // U>=
3729 // ( a b -- a>=b )
3730 UF_CMP(UGREATEQU, a >= b);
3731
3732 // =
3733 // ( a b -- a=b )
3734 UF_CMP(EQU, a == b);
3735
3736 // <>
3737 // ( a b -- a<>b )
3738 UF_CMP(NOTEQU, a != b);
3739
3740 // NOT
3741 // ( a -- !a )
3742 UFWORD(NOT) {
3743   const uint32_t a = ufoPop();
3744   ufoPushBool(!a);
3745 }
3746
3747 // LAND
3748 // ( a b -- a&&b )
3749 UF_CMP(LOGAND, a && b);
3750
3751 // LOR
3752 // ( a b -- a||b )
3753 UF_CMP(LOGOR, a || b);
3754
3755 // AND
3756 // ( a b -- a&b )
3757 UFWORD(AND) {
3758   const uint32_t b = ufoPop();
3759   const uint32_t a = ufoPop();
3760   ufoPush(a&b);
3761 }
3762
3763 // OR
3764 // ( a b -- a|b )
3765 UFWORD(OR) {
3766   const uint32_t b = ufoPop();
3767   const uint32_t a = ufoPop();
3768   ufoPush(a|b);
3769 }
3770
3771 // XOR
3772 // ( a b -- a^b )
3773 UFWORD(XOR) {
3774   const uint32_t b = ufoPop();
3775   const uint32_t a = ufoPop();
3776   ufoPush(a^b);
3777 }
3778
3779 // BITNOT
3780 // ( a -- ~a )
3781 UFWORD(BITNOT) {
3782   const uint32_t a = ufoPop();
3783   ufoPush(~a);
3784 }
3785
3786 UFWORD(ONESHL) { uint32_t n = ufoPop(); ufoPush(n << 1); }
3787 UFWORD(ONESHR) { uint32_t n = ufoPop(); ufoPush(n >> 1); }
3788 UFWORD(TWOSHL) { uint32_t n = ufoPop(); ufoPush(n << 2); }
3789 UFWORD(TWOSHR) { uint32_t n = ufoPop(); ufoPush(n >> 2); }
3790
3791 // ASH
3792 // ( n count -- )
3793 // arithmetic shift; positive `n` shifts to the left
3794 UFWORD(ASH) {
3795   int32_t c = (int32_t)ufoPop();
3796   if (c < 0) {
3797     // right
3798     int32_t n = (int32_t)ufoPop();
3799     if (c < -30) {
3800       if (n < 0) n = -1; else n = 0;
3801     } else {
3802       n >>= (uint8_t)(-c);
3803     }
3804     ufoPush((uint32_t)n);
3805   } else if (c > 0) {
3806     // left
3807     uint32_t u = ufoPop();
3808     if (c > 31) {
3809       u = 0;
3810     } else {
3811       u <<= (uint8_t)c;
3812     }
3813     ufoPush(u);
3814   }
3815 }
3816
3817 // LSH
3818 // ( n count -- )
3819 // logical shift; positive `n` shifts to the left
3820 UFWORD(LSH) {
3821   int32_t c = (int32_t) ufoPop();
3822   uint32_t u = ufoPop();
3823   if (c < 0) {
3824     // right
3825     if (c < -31) {
3826       u = 0;
3827     } else {
3828       u >>= (uint8_t)(-c);
3829     }
3830   } else if (c > 0) {
3831     // left
3832     if (c > 31) {
3833       u = 0;
3834     } else {
3835       u <<= (uint8_t)c;
3836     }
3837   }
3838   ufoPush(u);
3839 }
3840
3841
3842 // ////////////////////////////////////////////////////////////////////////// //
3843 // string unescaping
3844 //
3845
3846 // (UNESCAPE)
3847 // ( addr count -- addr count )
3848 UFWORD(PAR_UNESCAPE) {
3849   const uint32_t count = ufoPop();
3850   const uint32_t addr = ufoPeek();
3851   if ((count & ((uint32_t)1<<31)) == 0) {
3852     const uint32_t eaddr = addr + count;
3853     uint32_t caddr = addr;
3854     uint32_t daddr = addr;
3855     while (caddr != eaddr) {
3856       uint8_t ch = ufoImgGetU8Ext(caddr); caddr += 1u;
3857       if (ch == '\\' && caddr != eaddr) {
3858         ch = ufoImgGetU8Ext(caddr); caddr += 1u;
3859         switch (ch) {
3860           case 'r': ch = '\r'; break;
3861           case 'n': ch = '\n'; break;
3862           case 't': ch = '\t'; break;
3863           case 'e': ch = '\x1b'; break;
3864           case '`': ch = '"'; break; // special escape to insert double-quote
3865           case '"': ch = '"'; break;
3866           case '\\': ch = '\\'; break;
3867           case 'x': case 'X':
3868             if (eaddr - daddr >= 1) {
3869               const int dg0 = digitInBase((char)(ufoImgGetU8Ext(caddr)), 16);
3870               if (dg0 < 0) ufoFatal("invalid hex string escape");
3871               if (eaddr - daddr >= 2) {
3872                 const int dg1 = digitInBase((char)(ufoImgGetU8Ext(caddr + 1u)), 16);
3873                 if (dg1 < 0) ufoFatal("invalid hex string escape");
3874                 ch = (uint8_t)(dg0 * 16 + dg1);
3875                 caddr += 2u;
3876               } else {
3877                 ch = (uint8_t)dg0;
3878                 caddr += 1u;
3879               }
3880             } else {
3881               ufoFatal("invalid hex string escape");
3882             }
3883             break;
3884           default: ufoFatal("invalid string escape");
3885         }
3886       }
3887       ufoImgPutU8Ext(daddr, ch); daddr += 1u;
3888     }
3889     ufoPush(daddr - addr);
3890   } else {
3891     ufoPush(count);
3892   }
3893 }
3894
3895
3896 // ////////////////////////////////////////////////////////////////////////// //
3897 // numeric conversions
3898 //
3899
3900 // (BASED-NUMBER) ( addr count allowsign? base -- num TRUE / FALSE )
3901 UFWORD(PAR_BASED_NUMBER) {
3902   const uint32_t xbase = ufoPop();
3903   const uint32_t allowSign = ufoPop();
3904   int32_t count = (int32_t)ufoPop();
3905   uint32_t addr = ufoPop();
3906   uint32_t n = 0;
3907   int base = 0;
3908   int neg = 0;
3909   uint8_t ch;
3910
3911   if (allowSign && count > 1) {
3912     ch = ufoImgGetU8Ext(addr);
3913     if (ch == '-') { neg = 1; addr += 1u; count -= 1; }
3914     else if (ch == '+') { neg = 0; addr += 1u; count -= 1; }
3915   }
3916
3917   // special-based numbers
3918   if (count >= 3 && ufoImgGetU8Ext(addr) == '0') {
3919     switch (ufoImgGetU8Ext(addr + 1u)) {
3920       case 'x': case 'X': base = 16; break;
3921       case 'o': case 'O': base = 8; break;
3922       case 'b': case 'B': base = 2; break;
3923       case 'd': case 'D': base = 10; break;
3924       default: break;
3925     }
3926     if (base) { addr += 2; count -= 2; }
3927   } else if (count >= 2 && ufoImgGetU8Ext(addr) == '$') {
3928     base = 16;
3929     addr += 1; count -= 1;
3930   } else if (count >= 2 && ufoImgGetU8Ext(addr) == '#') {
3931     base = 16;
3932     addr += 1; count -= 1;
3933   } else if (count >= 2 && ufoImgGetU8Ext(addr) == '%') {
3934     base = 2;
3935     addr += 1; count -= 1;
3936   } else if (count >= 3 && ufoImgGetU8Ext(addr) == '&') {
3937     switch (ufoImgGetU8Ext(addr + 1u)) {
3938       case 'h': case 'H': base = 16; break;
3939       case 'o': case 'O': base = 8; break;
3940       case 'b': case 'B': base = 2; break;
3941       case 'd': case 'D': base = 10; break;
3942       default: break;
3943     }
3944     if (base) { addr += 2; count -= 2; }
3945   } else if (xbase < 12 && count > 2 && toUpperU8(ufoImgGetU8Ext(addr + (uint32_t)count - 1u)) == 'B') {
3946     base = 2;
3947     count -= 1;
3948   } else if (xbase < 18 && count > 2 && toUpperU8(ufoImgGetU8Ext(addr + (uint32_t)count - 1u)) == 'H') {
3949     base = 16;
3950     count -= 1;
3951   } else if (xbase < 25 && count > 2 && toUpperU8(ufoImgGetU8Ext(addr + (uint32_t)count - 1u)) == 'O') {
3952     base = 8;
3953     count -= 1;
3954   }
3955
3956   // in current base?
3957   if (!base && xbase < 255) base = xbase;
3958
3959   if (count <= 0 || base < 1 || base > 36) {
3960     ufoPushBool(0);
3961   } else {
3962     uint32_t nc;
3963     int wasDig = 0, wasUnder = 1, error = 0, dig;
3964     while (!error && count != 0) {
3965       ch = ufoImgGetU8Ext(addr); addr += 1u; count -= 1;
3966       if (ch != '_') {
3967         error = 1; wasUnder = 0; wasDig = 1;
3968         dig = digitInBase((char)ch, (int)base);
3969         if (dig >= 0) {
3970           nc = n * (uint32_t)base;
3971           if (nc >= n) {
3972             nc += (uint32_t)dig;
3973             if (nc >= n) {
3974               n = nc;
3975               error = 0;
3976             }
3977           }
3978         }
3979       } else {
3980         error = wasUnder;
3981         wasUnder = 1;
3982       }
3983     }
3984
3985     if (!error && wasDig && !wasUnder) {
3986       if (allowSign && neg) n = ~n + 1u;
3987       ufoPush(n);
3988       ufoPushBool(1);
3989     } else {
3990       ufoPushBool(0);
3991     }
3992   }
3993 }
3994
3995
3996 // ////////////////////////////////////////////////////////////////////////// //
3997 // compiler-related, dictionary-related
3998 //
3999
4000 static char ufoWNameBuf[256];
4001
4002
4003 // [
4004 UFWORD(LBRACKET_IMM) {
4005   if (ufoImgGetU32(ufoAddrSTATE) == 0) ufoFatal("expects compiling mode");
4006   ufoImgPutU32(ufoAddrSTATE, 0);
4007 }
4008
4009 // ]
4010 UFWORD(RBRACKET) {
4011   if (ufoImgGetU32(ufoAddrSTATE) != 0) ufoFatal("expects interpreting mode");
4012   ufoImgPutU32(ufoAddrSTATE, 1);
4013 }
4014
4015 // (CREATE-WORD-HEADER)
4016 // ( addr count word-flags -- )
4017 UFWORD(PAR_CREATE_WORD_HEADER) {
4018   const uint32_t flags = ufoPop();
4019   const uint32_t wlen = ufoPop();
4020   const uint32_t waddr = ufoPop();
4021   if (wlen == 0) ufoFatal("word name expected");
4022   if (wlen >= UFO_MAX_WORD_LENGTH) ufoFatal("word name too long");
4023   // copy to separate buffer
4024   for (uint32_t f = 0; f < wlen; f += 1) {
4025     ufoWNameBuf[f] = (char)ufoImgGetU8Ext(waddr + f);
4026   }
4027   ufoWNameBuf[wlen] = 0;
4028   ufoCreateWordHeader(ufoWNameBuf, flags);
4029 }
4030
4031 // (CREATE-NAMELESS-WORD-HEADER)
4032 // ( word-flags -- )
4033 UFWORD(PAR_CREATE_NAMELESS_WORD_HEADER) {
4034   const uint32_t flags = ufoPop();
4035   ufoCreateWordHeader("", flags);
4036 }
4037
4038 // FIND-WORD
4039 // ( addr count -- cfa TRUE / FALSE)
4040 UFWORD(FIND_WORD) {
4041   const uint32_t wlen = ufoPop();
4042   const uint32_t waddr = ufoPop();
4043   if (wlen > 0 && wlen < UFO_MAX_WORD_LENGTH) {
4044     // copy to separate buffer
4045     for (uint32_t f = 0; f < wlen; f += 1) {
4046       ufoWNameBuf[f] = (char)ufoImgGetU8Ext(waddr + f);
4047     }
4048     ufoWNameBuf[wlen] = 0;
4049     const uint32_t cfa = ufoFindWord(ufoWNameBuf);
4050     if (cfa != 0) {
4051       ufoPush(cfa);
4052       ufoPushBool(1);
4053     } else {
4054       ufoPushBool(0);
4055     }
4056   } else {
4057     ufoPushBool(0);
4058   }
4059 }
4060
4061 // FIND-WORD-IN-VOC
4062 // ( addr count vocid allowhidden -- cfa TRUE / FALSE)
4063 // find only in the given voc; no name resolution
4064 UFWORD(FIND_WORD_IN_VOC) {
4065   const uint32_t allowHidden = ufoPop();
4066   const uint32_t vocid = ufoPop();
4067   const uint32_t wlen = ufoPop();
4068   const uint32_t waddr = ufoPop();
4069   if (wlen > 0 && wlen < UFO_MAX_WORD_LENGTH) {
4070     // copy to separate buffer
4071     for (uint32_t f = 0; f < wlen; f += 1) {
4072       ufoWNameBuf[f] = (char)ufoImgGetU8Ext(waddr + f);
4073     }
4074     ufoWNameBuf[wlen] = 0;
4075     const uint32_t cfa = ufoFindWordInVoc(ufoWNameBuf, wlen, 0, vocid, (allowHidden ? 1 : 0));
4076     if (cfa != 0) {
4077       ufoPush(cfa);
4078       ufoPushBool(1);
4079     } else {
4080       ufoPushBool(0);
4081     }
4082   } else {
4083     ufoPushBool(0);
4084   }
4085 }
4086
4087 // FIND-WORD-IN-VOC-AND-PARENTS
4088 // ( addr count vocid allowhidden -- cfa TRUE / FALSE)
4089 // find only in the given voc; no name resolution
4090 UFWORD(FIND_WORD_IN_VOC_AND_PARENTS) {
4091   const uint32_t allowHidden = ufoPop();
4092   const uint32_t vocid = ufoPop();
4093   const uint32_t wlen = ufoPop();
4094   const uint32_t waddr = ufoPop();
4095   if (wlen > 0 && wlen < UFO_MAX_WORD_LENGTH) {
4096     // copy to separate buffer
4097     for (uint32_t f = 0; f < wlen; f += 1) {
4098       ufoWNameBuf[f] = (char)ufoImgGetU8Ext(waddr + f);
4099     }
4100     ufoWNameBuf[wlen] = 0;
4101     const uint32_t cfa = ufoFindWordInVocAndParents(ufoWNameBuf, wlen, 0, vocid, (allowHidden ? 1 : 0));
4102     if (cfa != 0) {
4103       ufoPush(cfa);
4104       ufoPushBool(1);
4105     } else {
4106       ufoPushBool(0);
4107     }
4108   } else {
4109     ufoPushBool(0);
4110   }
4111 }
4112
4113
4114 // ////////////////////////////////////////////////////////////////////////// //
4115 // more compiler words
4116 //
4117
4118 // ?EXEC
4119 UFWORD(QEXEC) {
4120   if (ufoImgGetU32(ufoAddrSTATE) != 0) ufoFatal("expecting execution mode");
4121 }
4122
4123 // ?COMP
4124 UFWORD(QCOMP) {
4125   if (ufoImgGetU32(ufoAddrSTATE) == 0) ufoFatal("expecting compilation mode");
4126 }
4127
4128 // "
4129 // string literal
4130 UFWORD(QUOTE_IMM) {
4131   ufoPush(34); UFCALL(PARSE);
4132   if (ufoPop() == 0) ufoFatal("string literal expected");
4133   UFCALL(PAR_UNESCAPE);
4134   if (ufoImgGetU32(ufoAddrSTATE) != 0) {
4135     // compiling
4136     const uint32_t wlen = ufoPop();
4137     const uint32_t waddr = ufoPop();
4138     if (wlen > 255) ufoFatal("string literal too long");
4139     ufoImgEmitU32(ufoStrLit8CFA);
4140     ufoImgEmitU8(wlen);
4141     for (uint32_t f = 0; f < wlen; f += 1) {
4142       ufoImgEmitU8(ufoImgGetU8Ext(waddr + f));
4143     }
4144     ufoImgEmitU8(0);
4145     ufoImgEmitAlign();
4146   }
4147 }
4148
4149
4150 // ////////////////////////////////////////////////////////////////////////// //
4151 // vocabulary and wordlist utilities
4152 //
4153
4154 // (VSP@)
4155 // ( -- vsp )
4156 UFWORD(PAR_GET_VSP) {
4157   ufoPush(ufoVSP);
4158 }
4159
4160 // (VSP!)
4161 // ( vsp -- )
4162 UFWORD(PAR_SET_VSP) {
4163   const uint32_t vsp = ufoPop();
4164   if (vsp >= UFO_VOCSTACK_SIZE) ufoFatal("VSP %u out of range (%u)", vsp, UFO_VOCSTACK_SIZE);
4165   ufoVSP = vsp;
4166 }
4167
4168 // (VSP-AT@)
4169 // ( idx -- value )
4170 UFWORD(PAR_VSP_LOAD) {
4171   const uint32_t vsp = ufoPop();
4172   if (vsp >= UFO_VOCSTACK_SIZE) ufoFatal("VSP %u out of range (%u)", vsp, UFO_VOCSTACK_SIZE);
4173   ufoPush(ufoVocStack[vsp]);
4174 }
4175
4176 // (VSP-AT!)
4177 // ( value idx -- )
4178 UFWORD(PAR_VSP_STORE) {
4179   const uint32_t vsp = ufoPop();
4180   const uint32_t value = ufoPop();
4181   if (vsp > UFO_VOCSTACK_SIZE) ufoFatal("VSP %u out of range (%u)", vsp, UFO_VOCSTACK_SIZE);
4182   ufoVocStack[vsp] = value;
4183 }
4184
4185
4186 // ////////////////////////////////////////////////////////////////////////// //
4187 // word field address conversion
4188 //
4189
4190 // CFA->PFA
4191 // ( cfa -- pfa )
4192 UFWORD(CFA2PFA) {
4193   const uint32_t cfa = ufoPop();
4194   ufoPush(UFO_CFA_TO_PFA(cfa));
4195 }
4196
4197 // PFA->CFA
4198 // ( pfa -- cfa )
4199 UFWORD(PFA2CFA) {
4200   const uint32_t pfa = ufoPop();
4201   ufoPush(UFO_PFA_TO_CFA(pfa));
4202 }
4203
4204 // CFA->NFA
4205 // ( cfa -- nfa )
4206 UFWORD(CFA2NFA) {
4207   const uint32_t cfa = ufoPop();
4208   ufoPush(UFO_CFA_TO_NFA(cfa));
4209 }
4210
4211 // NFA->CFA
4212 // ( nfa -- cfa )
4213 UFWORD(NFA2CFA) {
4214   const uint32_t nfa = ufoPop();
4215   ufoPush(UFO_NFA_TO_CFA(nfa));
4216 }
4217
4218 // CFA->LFA
4219 // ( cfa -- lfa )
4220 UFWORD(CFA2LFA) {
4221   const uint32_t cfa = ufoPop();
4222   ufoPush(UFO_CFA_TO_LFA(cfa));
4223 }
4224
4225 // LFA->CFA
4226 // ( lfa -- cfa )
4227 UFWORD(LFA2CFA) {
4228   const uint32_t lfa = ufoPop();
4229   ufoPush(UFO_LFA_TO_CFA(lfa));
4230 }
4231
4232 // LFA->PFA
4233 // ( lfa -- pfa )
4234 UFWORD(LFA2PFA) {
4235   const uint32_t lfa = ufoPop();
4236   const uint32_t cfa = UFO_LFA_TO_CFA(lfa);
4237   ufoPush(UFO_CFA_TO_PFA(cfa));
4238 }
4239
4240 // LFA->BFA
4241 // ( lfa -- bfa )
4242 UFWORD(LFA2BFA) {
4243   const uint32_t lfa = ufoPop();
4244   ufoPush(UFO_LFA_TO_BFA(lfa));
4245 }
4246
4247 // LFA->XFA
4248 // ( lfa -- xfa )
4249 UFWORD(LFA2XFA) {
4250   const uint32_t lfa = ufoPop();
4251   ufoPush(UFO_LFA_TO_XFA(lfa));
4252 }
4253
4254 // LFA->YFA
4255 // ( lfa -- yfa )
4256 UFWORD(LFA2YFA) {
4257   const uint32_t lfa = ufoPop();
4258   ufoPush(UFO_LFA_TO_YFA(lfa));
4259 }
4260
4261 // LFA->NFA
4262 // ( lfa -- nfa )
4263 UFWORD(LFA2NFA) {
4264   const uint32_t lfa = ufoPop();
4265   ufoPush(UFO_LFA_TO_NFA(lfa));
4266 }
4267
4268 // NFA->LFA
4269 // ( nfa -- lfa )
4270 UFWORD(NFA2LFA) {
4271   const uint32_t nfa = ufoPop();
4272   ufoPush(UFO_NFA_TO_LFA(nfa));
4273 }
4274
4275 // CFA->WEND
4276 // ( cfa -- wend-addr )
4277 UFWORD(CFA2WEND) {
4278   const uint32_t cfa = ufoPop();
4279   ufoPush(ufoGetWordEndAddr(cfa));
4280 }
4281
4282 // IP->NFA
4283 // ( ip -- nfa / 0 )
4284 UFWORD(IP2NFA) {
4285   const uint32_t ip = ufoPop();
4286   ufoPush(ufoFindWordForIP(ip));
4287 }
4288
4289
4290 // ////////////////////////////////////////////////////////////////////////// //
4291 // string operations
4292 //
4293
4294 UFO_FORCE_INLINE uint32_t ufoHashBuf (uint32_t addr, uint32_t size, uint8_t orbyte) {
4295   uint32_t hash = 0x29a;
4296   if ((size & ((uint32_t)1<<31)) == 0) {
4297     while (size != 0) {
4298       hash += ufoImgGetU8Ext(addr) | orbyte;
4299       hash += hash<<10;
4300       hash ^= hash>>6;
4301       addr += 1u; size -= 1u;
4302     }
4303   }
4304   // finalize
4305   hash += hash<<3;
4306   hash ^= hash>>11;
4307   hash += hash<<15;
4308   return hash;
4309 }
4310
4311 // STRING:=
4312 // ( a0 c0 a1 c1 -- bool )
4313 UFWORD(STREQU) {
4314   int32_t c1 = (int32_t)ufoPop();
4315   uint32_t a1 = ufoPop();
4316   int32_t c0 = (int32_t)ufoPop();
4317   uint32_t a0 = ufoPop();
4318   if (c0 < 0) c0 = 0;
4319   if (c1 < 0) c1 = 0;
4320   if (c0 == c1) {
4321     int res = 1;
4322     while (res != 0 && c0 != 0) {
4323       res = (ufoImgGetU8Ext(a0) == ufoImgGetU8Ext(a1));
4324       a0 += 1; a1 += 1; c0 -= 1;
4325     }
4326     ufoPushBool(res);
4327   } else {
4328     ufoPushBool(0);
4329   }
4330 }
4331
4332 // STRING:=CI
4333 // ( a0 c0 a1 c1 -- bool )
4334 UFWORD(STREQUCI) {
4335   int32_t c1 = (int32_t)ufoPop();
4336   uint32_t a1 = ufoPop();
4337   int32_t c0 = (int32_t)ufoPop();
4338   uint32_t a0 = ufoPop();
4339   if (c0 < 0) c0 = 0;
4340   if (c1 < 0) c1 = 0;
4341   if (c0 == c1) {
4342     int res = 1;
4343     while (res != 0 && c0 != 0) {
4344       res = (toUpperU8(ufoImgGetU8Ext(a0)) == toUpperU8(ufoImgGetU8Ext(a1)));
4345       a0 += 1; a1 += 1; c0 -= 1;
4346     }
4347     ufoPushBool(res);
4348   } else {
4349     ufoPushBool(0);
4350   }
4351 }
4352
4353 // STRING:HASH
4354 // ( addr count -- hash )
4355 UFWORD(STRHASH) {
4356   uint32_t count = ufoPop();
4357   uint32_t addr = ufoPop();
4358   ufoPush(ufoHashBuf(addr, count, 0));
4359 }
4360
4361 // STRING:HASH-CI
4362 // ( addr count -- hash )
4363 UFWORD(STRHASHCI) {
4364   uint32_t count = ufoPop();
4365   uint32_t addr = ufoPop();
4366   ufoPush(ufoHashBuf(addr, count, 0x20));
4367 }
4368
4369
4370 // ////////////////////////////////////////////////////////////////////////// //
4371 // conditional defines
4372 //
4373
4374 typedef struct UForthCondDefine_t UForthCondDefine;
4375 struct UForthCondDefine_t {
4376   char *name;
4377   uint32_t namelen;
4378   uint32_t hash;
4379   UForthCondDefine *next;
4380 };
4381
4382 static UForthCondDefine *ufoCondDefines = NULL;
4383 static char ufoErrMsgBuf[4096];
4384
4385
4386 //==========================================================================
4387 //
4388 //  ufoStrEquCI
4389 //
4390 //==========================================================================
4391 UFO_DISABLE_INLINE int ufoStrEquCI (const void *str0, const void *str1) {
4392   const unsigned char *s0 = (const unsigned char *)str0;
4393   const unsigned char *s1 = (const unsigned char *)str1;
4394   while (*s0 && *s1) {
4395     if (toUpperU8(*s0) != toUpperU8(*s1)) return 0;
4396     s0 += 1; s1 += 1;
4397   }
4398   return (*s0 == 0 && *s1 == 0);
4399 }
4400
4401
4402 //==========================================================================
4403 //
4404 //  ufoBufEquCI
4405 //
4406 //==========================================================================
4407 UFO_FORCE_INLINE int ufoBufEquCI (uint32_t addr, uint32_t count, const void *buf) {
4408   int res;
4409   if ((count & ((uint32_t)1<<31)) == 0) {
4410     const unsigned char *src = (const unsigned char *)buf;
4411     res = 1;
4412     while (res != 0 && count != 0) {
4413       res = (toUpperU8(*src) == toUpperU8(ufoImgGetU8Ext(addr)));
4414       src += 1; addr += 1u; count -= 1u;
4415     }
4416   } else {
4417     res = 0;
4418   }
4419   return res;
4420 }
4421
4422
4423 //==========================================================================
4424 //
4425 //  ufoClearCondDefines
4426 //
4427 //==========================================================================
4428 static void ufoClearCondDefines (void) {
4429   while (ufoCondDefines) {
4430     UForthCondDefine *df = ufoCondDefines;
4431     ufoCondDefines = df->next;
4432     if (df->name) free(df->name);
4433     free(df);
4434   }
4435 }
4436
4437
4438 //==========================================================================
4439 //
4440 //  ufoHasCondDefine
4441 //
4442 //==========================================================================
4443 int ufoHasCondDefine (const char *name) {
4444   int res = 0;
4445   if (name != NULL && name[0] != 0) {
4446     const size_t nlen = strlen(name);
4447     if (nlen <= 255) {
4448       const uint32_t hash = joaatHashBufCI(name, nlen);
4449       UForthCondDefine *dd = ufoCondDefines;
4450       while (res == 0 && dd != NULL) {
4451         if (dd->hash == hash && dd->namelen == (uint32_t)nlen) {
4452           res = ufoStrEquCI(name, dd->name);
4453         }
4454         dd = dd->next;
4455       }
4456     }
4457   }
4458   return res;
4459 }
4460
4461
4462 //==========================================================================
4463 //
4464 //  ufoCondDefine
4465 //
4466 //==========================================================================
4467 void ufoCondDefine (const char *name) {
4468   if (name != NULL && name[0] != 0) {
4469     const size_t nlen = strlen(name);
4470     if (nlen > 255) ufoFatal("conditional define name too long");
4471     const uint32_t hash = joaatHashBufCI(name, nlen);
4472     UForthCondDefine *dd = ufoCondDefines;
4473     int res = 0;
4474     while (res == 0 && dd != NULL) {
4475       if (dd->hash == hash && dd->namelen == (uint32_t)nlen) {
4476         res = ufoStrEquCI(name, dd->name);
4477       }
4478       dd = dd->next;
4479     }
4480     if (res == 0) {
4481       // new define
4482       dd = calloc(1, sizeof(UForthCondDefine));
4483       if (dd == NULL) ufoFatal("out of memory for defines");
4484       dd->name = strdup(name);
4485       if (dd->name == NULL) { free(dd); ufoFatal("out of memory for defines"); }
4486       dd->namelen = (uint32_t)nlen;
4487       dd->hash = hash;
4488       dd->next = ufoCondDefines;
4489       ufoCondDefines = dd;
4490     }
4491   }
4492 }
4493
4494
4495 //==========================================================================
4496 //
4497 //  ufoCondUndef
4498 //
4499 //==========================================================================
4500 void ufoCondUndef (const char *name) {
4501   if (name != NULL && name[0] != 0) {
4502     const size_t nlen = strlen(name);
4503     if (nlen <= 255) {
4504       const uint32_t hash = joaatHashBufCI(name, nlen);
4505       UForthCondDefine *dd = ufoCondDefines;
4506       UForthCondDefine *prev = NULL;
4507       while (dd != NULL) {
4508         if (dd->hash == hash && dd->namelen == (uint32_t)nlen) {
4509           if (ufoStrEquCI(name, dd->name)) {
4510             if (prev != NULL) prev->next = dd->next; else ufoCondDefines = dd->next;
4511             free(dd->name);
4512             free(dd);
4513             dd = NULL;
4514           }
4515         }
4516         if (dd != NULL) { prev = dd; dd = dd->next; }
4517       }
4518     }
4519   }
4520 }
4521
4522
4523 // ($DEFINE)
4524 // ( addr count -- )
4525 UFWORD(PAR_DLR_DEFINE) {
4526   uint32_t count = ufoPop();
4527   uint32_t addr = ufoPop();
4528   if (count == 0) ufoFatal("empty define");
4529   if (count >= UFO_MAX_WORD_LENGTH) ufoFatal("define too long");
4530   const uint32_t hash = ufoHashBuf(addr, count, 0x20);
4531   UForthCondDefine *dd;
4532   for (dd = ufoCondDefines; dd != NULL; dd = dd->next) {
4533     if (dd->hash == hash && dd->namelen == count) {
4534       if (ufoBufEquCI(addr, count, dd->name)) return;
4535     }
4536   }
4537   // new define
4538   dd = calloc(1, sizeof(UForthCondDefine));
4539   if (dd == NULL) ufoFatal("out of memory for defines");
4540   dd->name = calloc(1, count + 1u);
4541   if (dd->name == NULL) { free(dd); ufoFatal("out of memory for defines"); }
4542   for (uint32_t f = 0; f < count; f += 1) {
4543     ((unsigned char *)dd->name)[f] = ufoImgGetU8Ext(addr + f);
4544   }
4545   dd->namelen = count;
4546   dd->hash = hash;
4547   dd->next = ufoCondDefines;
4548   ufoCondDefines = dd;
4549 }
4550
4551 // ($UNDEF)
4552 // ( addr count -- )
4553 UFWORD(PAR_DLR_UNDEF) {
4554   uint32_t count = ufoPop();
4555   uint32_t addr = ufoPop();
4556   if (count == 0) ufoFatal("empty define");
4557   if (count >= UFO_MAX_WORD_LENGTH) ufoFatal("define too long");
4558   const uint32_t hash = ufoHashBuf(addr, count, 0x20);
4559   UForthCondDefine *prev = NULL;
4560   UForthCondDefine *dd;
4561   for (dd = ufoCondDefines; dd != NULL; prev = dd, dd = dd->next) {
4562     if (dd->hash == hash && dd->namelen == count) {
4563       if (ufoBufEquCI(addr, count, dd->name)) {
4564         if (prev == NULL) ufoCondDefines = dd->next; else prev->next = dd->next;
4565         free(dd->name);
4566         free(dd);
4567         return;
4568       }
4569     }
4570   }
4571 }
4572
4573 // ($DEFINED?)
4574 // ( addr count -- bool )
4575 UFWORD(PAR_DLR_DEFINEDQ) {
4576   uint32_t count = ufoPop();
4577   uint32_t addr = ufoPop();
4578   if (count == 0) ufoFatal("empty define");
4579   if (count >= UFO_MAX_WORD_LENGTH) ufoFatal("define too long");
4580   const uint32_t hash = ufoHashBuf(addr, count, 0x20);
4581   int found = 0;
4582   UForthCondDefine *dd = ufoCondDefines;
4583   while (!found && dd != NULL) {
4584     if (dd->hash == hash && dd->namelen == count) {
4585       found = ufoBufEquCI(addr, count, dd->name);
4586     }
4587     dd = dd->next;
4588   }
4589   ufoPushBool(found);
4590 }
4591
4592
4593 // ////////////////////////////////////////////////////////////////////////// //
4594 // error reporting
4595 //
4596
4597 // ERROR
4598 // ( addr count -- )
4599 UFWORD(ERROR) {
4600   uint32_t count = ufoPop();
4601   uint32_t addr = ufoPop();
4602   if (count & (1u<<31)) ufoFatal("invalid error message");
4603   if (count == 0) ufoFatal("some error");
4604   if (count > (uint32_t)sizeof(ufoErrMsgBuf) - 1u) count = (uint32_t)sizeof(ufoErrMsgBuf) - 1u;
4605   for (uint32_t f = 0; f < count; f += 1) {
4606     ufoErrMsgBuf[f] = (char)ufoImgGetU8Ext(addr + f);
4607   }
4608   ufoErrMsgBuf[count] = 0;
4609   ufoFatal("%s", ufoErrMsgBuf);
4610 }
4611
4612 // ?ERROR
4613 // ( errflag addr count -- )
4614 UFWORD(QERROR) {
4615   const uint32_t count = ufoPop();
4616   const uint32_t addr = ufoPop();
4617   if (ufoPop()) {
4618     ufoPush(addr);
4619     ufoPush(count);
4620     UFCALL(ERROR);
4621   }
4622 }
4623
4624
4625 // ////////////////////////////////////////////////////////////////////////// //
4626 // includes
4627 //
4628
4629 static char ufoFNameBuf[4096];
4630
4631
4632 //==========================================================================
4633 //
4634 //  ufoScanIncludeFileName
4635 //
4636 //  `*psys` and `*psoft` must be initialised!
4637 //
4638 //==========================================================================
4639 static void ufoScanIncludeFileName (uint32_t addr, uint32_t count, char *dest, size_t destsz,
4640                                     uint32_t *psys, uint32_t *psoft)
4641 {
4642   uint8_t ch;
4643   uint32_t dpos;
4644   ufo_assert(dest != NULL);
4645   ufo_assert(destsz > 0);
4646
4647   while (count != 0) {
4648     ch = ufoImgGetU8Ext(addr);
4649     if (ch == '!') {
4650       //if (system) ufoFatal("invalid file name (duplicate system mark)");
4651       *psys = 1;
4652     } else if (ch == '?') {
4653       //if (softinclude) ufoFatal("invalid file name (duplicate soft mark)");
4654       *psoft = 1;
4655     } else {
4656       break;
4657     }
4658     do {
4659       addr += 1; count -= 1;
4660       ch = ufoImgGetU8Ext(addr);
4661     } while (ch <= 32 && count != 0);
4662   }
4663
4664   if (count == 0) ufoFatal("empty include file name");
4665   if (count >= destsz) ufoFatal("include file name too long");
4666
4667   dpos = 0;
4668   while (count != 0) {
4669     dest[dpos] = (char)ufoImgGetU8Ext(addr); dpos += 1;
4670     addr += 1; count -= 1;
4671   }
4672   dest[dpos] = 0;
4673 }
4674
4675
4676 // (INCLUDE-DEPTH)
4677 // ( -- depth )
4678 // return number of items in include stack
4679 UFWORD(PAR_INCLUDE_DEPTH) {
4680   ufoPush(ufoFileStackPos);
4681 }
4682
4683 // (INCLUDE-FILE-ID)
4684 // ( isp -- id ) -- isp 0 is current, then 1, etc.
4685 // each include file has unique non-zero id.
4686 UFWORD(PAR_INCLUDE_FILE_ID) {
4687   const uint32_t isp = ufoPop();
4688   if (isp == 0) {
4689     ufoPush(ufoFileId);
4690   } else if (isp <= ufoFileStackPos) {
4691     UFOFileStackEntry *stk = &ufoFileStack[ufoFileStackPos - isp];
4692     ufoPush(stk->id);
4693   } else {
4694     ufoFatal("invalid include stack index");
4695   }
4696 }
4697
4698 // (INCLUDE-FILE-LINE)
4699 // ( isp -- line )
4700 UFWORD(PAR_INCLUDE_FILE_LINE) {
4701   const uint32_t isp = ufoPop();
4702   if (isp == 0) {
4703     ufoPush(ufoInFileLine);
4704   } else if (isp <= ufoFileStackPos) {
4705     UFOFileStackEntry *stk = &ufoFileStack[ufoFileStackPos - isp];
4706     ufoPush(stk->fline);
4707   } else {
4708     ufoFatal("invalid include stack index");
4709   }
4710   ufoPush(ufoInFileLine);
4711 }
4712
4713 // (INCLUDE-FILE-NAME)
4714 // ( isp -- addr count )
4715 // current file name; at PAD
4716 UFWORD(PAR_INCLUDE_FILE_NAME) {
4717   const uint32_t isp = ufoPop();
4718   const char *fname = NULL;
4719   if (isp == 0) {
4720     fname = ufoInFileName;
4721   } else if (isp <= ufoFileStackPos) {
4722     UFOFileStackEntry *stk = &ufoFileStack[ufoFileStackPos - isp];
4723     fname = stk->fname;
4724   } else {
4725     ufoFatal("invalid include stack index");
4726   }
4727   UFCALL(PAD);
4728   uint32_t addr = ufoPop();
4729   uint32_t count = 0;
4730   while (fname[count] != 0) {
4731     ufoImgPutU8Ext(addr + count, ((const unsigned char *)fname)[count]);
4732     count += 1;
4733   }
4734   ufoImgPutU8Ext(addr + count, 0);
4735   ufoPush(addr);
4736   ufoPush(count);
4737 }
4738
4739 // (INCLUDE)
4740 // ( addr count soft? system? -- )
4741 UFWORD(PAR_INCLUDE) {
4742   uint32_t system = ufoPop();
4743   uint32_t softinclude = ufoPop();
4744   uint32_t count = ufoPop();
4745   uint32_t addr = ufoPop();
4746
4747   if (ufoMode == UFO_MODE_MACRO) ufoFatal("macros cannot include files");
4748
4749   if ((count & ((uint32_t)1<<31)) != 0) ufoFatal("invalid include name");
4750
4751   ufoScanIncludeFileName(addr, count, ufoFNameBuf, sizeof(ufoFNameBuf),
4752                          &system, &softinclude);
4753
4754   char *ffn = ufoCreateIncludeName(ufoFNameBuf, system, ufoLastIncPath);
4755   #ifdef WIN32
4756   FILE *fl = fopen(ffn, "rb");
4757   #else
4758   FILE *fl = fopen(ffn, "r");
4759   #endif
4760   if (!fl) {
4761     if (softinclude) { free(ffn); return; }
4762     ufoFatal("include file '%s' not found", ffn);
4763   }
4764   ufoPushInFile();
4765   ufoInFile = fl;
4766   ufoInFileLine = 0;
4767   ufoInFileName = ffn;
4768   ufoFileId = ufoLastUsedFileId;
4769   setLastIncPath(ufoInFileName);
4770   #ifdef UFO_DEBUG_INCLUDE
4771   fprintf(stderr, "INC-PUSH: new fname: %s\n", ffn);
4772   #endif
4773
4774   // trigger next line loading
4775   UFCALL(REFILL);
4776   if (!ufoPop()) ufoFatal("(INCLUDE) internal error");
4777 }
4778
4779 // $INCLUDE "str"
4780 UFWORD(DLR_INCLUDE_IMM) {
4781   int soft = 0, system = 0;
4782   // parse include filename
4783   //UFCALL(PARSE_SKIP_BLANKS);
4784   ufoPushBool(0); UFCALL(PAR_PARSE_SKIP_COMMENTS);
4785   uint8_t ch = ufoTibPeekCh();
4786   if (ch == '"') {
4787     ufoTibSkipCh(); // skip quote
4788     ufoPush(34);
4789   } else if (ch == '<') {
4790     ufoTibSkipCh(); // skip quote
4791     ufoPush(62);
4792     system = 1;
4793   } else {
4794     ufoFatal("expected quoted string");
4795   }
4796   UFCALL(PARSE);
4797   if (!ufoPop()) ufoFatal("file name expected");
4798   ufoPushBool(0); UFCALL(PAR_PARSE_SKIP_COMMENTS);
4799   if (ufoTibPeekCh() != 0) {
4800     ufoFatal("$INCLUDE doesn't accept extra args yet");
4801   }
4802   // ( addr count soft? system? -- )
4803   ufoPushBool(soft); ufoPushBool(system); UFCALL(PAR_INCLUDE);
4804 }
4805
4806
4807 //==========================================================================
4808 //
4809 //  ufoCreateFileGuard
4810 //
4811 //==========================================================================
4812 static const char *ufoCreateFileGuard (const char *fname) {
4813   if (fname == NULL || fname[0] == 0) return NULL;
4814   char *rp = ufoRealPath(fname);
4815   if (rp == NULL) return NULL;
4816   #ifdef WIN32
4817   for (char *s = rp; *s; s += 1) if (*s == '\\') *s = '/';
4818   #endif
4819   // hash the buffer; extract file name; create string with path len, file name, and hash
4820   const size_t orgplen = strlen(rp);
4821   const uint32_t phash = joaatHashBuf(rp, orgplen, 0);
4822   size_t plen = orgplen;
4823   while (plen != 0 && rp[plen - 1u] != '/') plen -= 1;
4824   snprintf(ufoRealPathHashBuf, sizeof(ufoRealPathHashBuf),
4825            "__INCLUDE_GUARD_%08X_%08X_%s__", phash, (uint32_t)orgplen, rp + plen);
4826   return ufoRealPathHashBuf;
4827 }
4828
4829
4830 // $INCLUDE-ONCE "str"
4831 // includes file only once; unreliable on shitdoze, i believe
4832 UFWORD(DLR_INCLUDE_ONCE_IMM) {
4833   uint32_t softinclude = 0, system = 0;
4834   // parse include filename
4835   //UFCALL(PARSE_SKIP_BLANKS);
4836   ufoPushBool(0); UFCALL(PAR_PARSE_SKIP_COMMENTS);
4837   uint8_t ch = ufoTibPeekCh();
4838   if (ch == '"') {
4839     ufoTibSkipCh(); // skip quote
4840     ufoPush(34);
4841   } else if (ch == '<') {
4842     ufoTibSkipCh(); // skip quote
4843     ufoPush(62);
4844     system = 1;
4845   } else {
4846     ufoFatal("expected quoted string");
4847   }
4848   UFCALL(PARSE);
4849   if (!ufoPop()) ufoFatal("file name expected");
4850   const uint32_t count = ufoPop();
4851   const uint32_t addr = ufoPop();
4852   ufoPushBool(0); UFCALL(PAR_PARSE_SKIP_COMMENTS);
4853   if (ufoTibPeekCh() != 0) {
4854     ufoFatal("$REQUIRE doesn't accept extra args yet");
4855   }
4856   ufoScanIncludeFileName(addr, count, ufoRealPathHashBuf, sizeof(ufoRealPathHashBuf),
4857                          &system, &softinclude);
4858   char *incfname = ufoCreateIncludeName(ufoRealPathHashBuf, system, ufoLastIncPath);
4859   if (incfname == NULL) ufoFatal("cannot resolve include file '%s'", ufoRealPathHashBuf);
4860   // this will overwrite `ufoRealPathHashBuf`
4861   const char *guard = ufoCreateFileGuard(incfname);
4862   free(incfname);
4863   if (guard == NULL) {
4864     if (!softinclude) ufoFatal("cannot include file '%s'", ufoRealPathHashBuf);
4865     return;
4866   }
4867   #if 0
4868   fprintf(stderr, "GUARD: <%s>\n", guard);
4869   #endif
4870   // now check for the guard
4871   const uint32_t glen = (uint32_t)strlen(guard);
4872   const uint32_t ghash = joaatHashBuf(guard, glen, 0);
4873   UForthCondDefine *dd;
4874   for (dd = ufoCondDefines; dd != NULL; dd = dd->next) {
4875     if (dd->hash == ghash && dd->namelen == glen && strcmp(guard, dd->name) == 0) {
4876       // nothing to do: already included
4877       return;
4878     }
4879   }
4880   // add guard
4881   dd = calloc(1, sizeof(UForthCondDefine));
4882   if (dd == NULL) ufoFatal("out of memory for defines");
4883   dd->name = calloc(1, glen + 1u);
4884   if (dd->name == NULL) { free(dd); ufoFatal("out of memory for defines"); }
4885   strcpy(dd->name, guard);
4886   dd->namelen = glen;
4887   dd->hash = ghash;
4888   dd->next = ufoCondDefines;
4889   ufoCondDefines = dd;
4890   // ( addr count soft? system? -- )
4891   ufoPush(addr); ufoPush(count); ufoPushBool(0); ufoPushBool(0);
4892   UFCALL(PAR_INCLUDE);
4893 }
4894
4895
4896 // ////////////////////////////////////////////////////////////////////////// //
4897 // handles
4898 //
4899
4900 // HANDLE:NEW
4901 // ( typeid -- hx )
4902 UFWORD(PAR_NEW_HANDLE) {
4903   const uint32_t typeid = ufoPop();
4904   if (typeid == UFO_HANDLE_FREE) ufoFatal("invalid handle typeid");
4905   UHandleInfo *hh = ufoAllocHandle(typeid);
4906   ufoPush(hh->ufoHandle);
4907 }
4908
4909 // HANDLE:FREE
4910 // ( hx -- )
4911 UFWORD(PAR_FREE_HANDLE) {
4912   const uint32_t hx = ufoPop();
4913   if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("trying to free something that is not a handle");
4914   UHandleInfo *hh = ufoGetHandle(hx);
4915   if (hh == NULL) ufoFatal("trying to free invalid handle");
4916   ufoFreeHandle(hh);
4917 }
4918
4919 // HANDLE:TYPEID@
4920 // ( hx -- typeid )
4921 UFWORD(PAR_HANDLE_GET_TYPEID) {
4922   const uint32_t hx = ufoPop();
4923   if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle");
4924   UHandleInfo *hh = ufoGetHandle(hx);
4925   if (hh == NULL) ufoFatal("invalid handle");
4926   ufoPush(hh->typeid);
4927 }
4928
4929 // HANDLE:TYPEID!
4930 // ( typeid hx -- )
4931 UFWORD(PAR_HANDLE_SET_TYPEID) {
4932   const uint32_t hx = ufoPop();
4933   const uint32_t typeid = ufoPop();
4934   if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle");
4935   if (typeid == UFO_HANDLE_FREE) ufoFatal("invalid handle typeid");
4936   UHandleInfo *hh = ufoGetHandle(hx);
4937   if (hh == NULL) ufoFatal("invalid handle");
4938   hh->typeid = typeid;
4939 }
4940
4941 // HANDLE:SIZE@
4942 // ( hx -- size )
4943 UFWORD(PAR_HANDLE_GET_SIZE) {
4944   const uint32_t hx = ufoPop();
4945   if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle");
4946   UHandleInfo *hh = ufoGetHandle(hx);
4947   if (hh == NULL) ufoFatal("invalid handle");
4948   ufoPush(hh->size);
4949 }
4950
4951 // HANDLE:SIZE!
4952 // ( size hx -- )
4953 UFWORD(PAR_HANDLE_SET_SIZE) {
4954   const uint32_t hx = ufoPop();
4955   const uint32_t size = ufoPop();
4956   if (size > 0x04000000) ufoFatal("invalid handle size");
4957   if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle");
4958   UHandleInfo *hh = ufoGetHandle(hx);
4959   if (hh == NULL) ufoFatal("invalid handle");
4960   if (hh->size != size) {
4961     if (size == 0) {
4962       free(hh->data);
4963       hh->data = NULL;
4964     } else {
4965       uint8_t *nx = realloc(hh->data, size * sizeof(hh->data[0]));
4966       if (nx == NULL) ufoFatal("out of memory for handle of size %u", size);
4967       hh->data = nx;
4968       if (size > hh->size) memset(hh->data, 0, size - hh->size);
4969     }
4970     hh->size = size;
4971     if (hh->used > size) hh->used = size;
4972   }
4973 }
4974
4975 // HANDLE:USED@
4976 // ( hx -- used )
4977 UFWORD(PAR_HANDLE_GET_USED) {
4978   const uint32_t hx = ufoPop();
4979   if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle");
4980   UHandleInfo *hh = ufoGetHandle(hx);
4981   if (hh == NULL) ufoFatal("invalid handle");
4982   ufoPush(hh->used);
4983 }
4984
4985 // HANDLE:USED!
4986 // ( size hx -- )
4987 UFWORD(PAR_HANDLE_SET_USED) {
4988   const uint32_t hx = ufoPop();
4989   const uint32_t used = ufoPop();
4990   if (used > 0x04000000) ufoFatal("invalid handle used");
4991   if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle");
4992   UHandleInfo *hh = ufoGetHandle(hx);
4993   if (hh == NULL) ufoFatal("invalid handle");
4994   if (used > hh->size) ufoFatal("handle used %u out of range (%u)", used, hh->size);
4995   hh->used = used;
4996 }
4997
4998 #define POP_PREPARE_HANDLE() \
4999   const uint32_t hx = ufoPop(); \
5000   uint32_t idx = ufoPop(); \
5001   if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle"); \
5002   if (idx > 0x1fffffffU - UFO_ADDR_HANDLE_OFS_MASK) ufoFatal("handle index %u out of range", idx); \
5003   idx += (hx & UFO_ADDR_HANDLE_OFS_MASK); \
5004   UHandleInfo *hh = ufoGetHandle(hx); \
5005   if (hh == NULL) ufoFatal("invalid handle")
5006
5007 // HANDLE:C@
5008 // ( idx hx -- value )
5009 UFWORD(PAR_HANDLE_LOAD_BYTE) {
5010   POP_PREPARE_HANDLE();
5011   if (idx >= hh->size) ufoFatal("handle index %u out of range (%u)", idx, hh->size);
5012   ufoPush(hh->data[idx]);
5013 }
5014
5015 // HANDLE:W@
5016 // ( idx hx -- value )
5017 UFWORD(PAR_HANDLE_LOAD_WORD) {
5018   POP_PREPARE_HANDLE();
5019   if (idx >= hh->size || hh->size - idx < 2u) {
5020     ufoFatal("handle index %u out of range (%u)", idx, hh->size);
5021   }
5022   #ifdef UFO_FAST_MEM_ACCESS
5023   ufoPush(*(const uint16_t *)(hh->data + idx));
5024   #else
5025   uint32_t res = hh->data[idx];
5026   res |= hh->data[idx + 1u] << 8;
5027   ufoPush(res);
5028   #endif
5029 }
5030
5031 // HANDLE:@
5032 // ( idx hx -- value )
5033 UFWORD(PAR_HANDLE_LOAD_CELL) {
5034   POP_PREPARE_HANDLE();
5035   if (idx >= hh->size || hh->size - idx < 4u) {
5036     ufoFatal("handle index %u out of range (%u)", idx, hh->size);
5037   }
5038   #ifdef UFO_FAST_MEM_ACCESS
5039   ufoPush(*(const uint32_t *)(hh->data + idx));
5040   #else
5041   uint32_t res = hh->data[idx];
5042   res |= hh->data[idx + 1u] << 8;
5043   res |= hh->data[idx + 2u] << 16;
5044   res |= hh->data[idx + 3u] << 24;
5045   ufoPush(res);
5046   #endif
5047 }
5048
5049 // HANDLE:C!
5050 // ( value idx hx -- value )
5051 UFWORD(PAR_HANDLE_STORE_BYTE) {
5052   POP_PREPARE_HANDLE();
5053   const uint32_t value = ufoPop();
5054   if (idx >= hh->size) ufoFatal("handle index %u out of range (%u)", idx, hh->size);
5055   hh->data[idx] = value;
5056 }
5057
5058 // HANDLE:W!
5059 // ( value idx hx -- )
5060 UFWORD(PAR_HANDLE_STORE_WORD) {
5061   POP_PREPARE_HANDLE();
5062   const uint32_t value = ufoPop();
5063   if (idx >= hh->size || hh->size - idx < 2u) {
5064     ufoFatal("handle index %u out of range (%u)", idx, hh->size);
5065   }
5066   #ifdef UFO_FAST_MEM_ACCESS
5067   *(uint16_t *)(hh->data + idx) = (uint16_t)value;
5068   #else
5069   hh->data[idx] = (uint8_t)value;
5070   hh->data[idx + 1u] = (uint8_t)(value >> 8);
5071   #endif
5072 }
5073
5074 // HANDLE:!
5075 // ( value idx hx -- )
5076 UFWORD(PAR_HANDLE_STORE_CELL) {
5077   POP_PREPARE_HANDLE();
5078   const uint32_t value = ufoPop();
5079   if (idx >= hh->size || hh->size - idx < 4u) {
5080     ufoFatal("handle index %u out of range (%u)", idx, hh->size);
5081   }
5082   #ifdef UFO_FAST_MEM_ACCESS
5083   *(uint32_t *)(hh->data + idx) = value;
5084   #else
5085   hh->data[idx] = (uint8_t)value;
5086   hh->data[idx + 1u] = (uint8_t)(value >> 8);
5087   hh->data[idx + 2u] = (uint8_t)(value >> 16);
5088   hh->data[idx + 3u] = (uint8_t)(value >> 24);
5089   #endif
5090 }
5091
5092
5093 // ////////////////////////////////////////////////////////////////////////// //
5094 // utils
5095 //
5096
5097 // DEBUG:(DECOMPILE-CFA)
5098 // ( cfa -- )
5099 UFWORD(DEBUG_DECOMPILE_CFA) {
5100   const uint32_t cfa = ufoPop();
5101   ufoDecompileWord(cfa);
5102 }
5103
5104 // GET-MSECS
5105 // ( -- u32 )
5106 UFWORD(GET_MSECS) {
5107   ufoPush((uint32_t)ufo_get_msecs());
5108 }
5109
5110 // this is called by INTERPRET when it is out of input stream
5111 UFWORD(UFO_INTERPRET_FINISHED) {
5112   ufoVMStop = 1;
5113 }
5114
5115 // MTASK:NEW-STATE
5116 // ( cfa -- stid )
5117 UFWORD(MT_NEW_STATE) {
5118   UfoState *st = ufoNewState(ufoPop());
5119   ufoPush(st->id);
5120 }
5121
5122 // MTASK:FREE-STATE
5123 // ( stid -- )
5124 UFWORD(MT_FREE_STATE) {
5125   UfoState *st = ufoFindState(ufoPop());
5126   if (st == NULL) ufoFatal("cannot free unknown state");
5127   if (st == ufoCurrState) ufoFatal("cannot free current state");
5128   ufoFreeState(st);
5129 }
5130
5131 // MTASK:STATE-NAME@
5132 // ( stid -- addr count )
5133 // to PAD
5134 UFWORD(MT_GET_STATE_NAME) {
5135   UfoState *st = ufoFindState(ufoPop());
5136   if (st == NULL) ufoFatal("unknown state");
5137   UFCALL(PAD);
5138   uint32_t addr = ufoPop();
5139   uint32_t count = 0;
5140   while (st->name[count] != 0) {
5141     ufoImgPutU8Ext(addr + count, ((const unsigned char *)st->name)[count]);
5142     count += 1u;
5143   }
5144   ufoImgPutU8Ext(addr + count, 0);
5145   ufoPush(addr);
5146   ufoPush(count);
5147 }
5148
5149 // MTASK:STATE-NAME!
5150 // ( addr count stid -- )
5151 UFWORD(MT_SET_STATE_NAME) {
5152   UfoState *st = ufoFindState(ufoPop());
5153   if (st == NULL) ufoFatal("unknown state");
5154   uint32_t count = ufoPop();
5155   uint32_t addr = ufoPop();
5156   if ((count & ((uint32_t)1 << 31)) == 0) {
5157     if (count > UFO_MAX_TASK_NAME) ufoFatal("task name too long");
5158     for (uint32_t f = 0; f < count; f += 1u) {
5159       ((unsigned char *)st->name)[f] = ufoImgGetU8Ext(addr + f);
5160     }
5161     st->name[count] = 0;
5162   }
5163 }
5164
5165 // MTASK:STATE-FIRST
5166 // ( -- stid )
5167 UFWORD(MT_STATE_FIRST) {
5168   uint32_t fidx = 0;
5169   while (fidx != (uint32_t)(UFO_MAX_STATES/32) && ufoStateUsedBitmap[fidx] == 0) fidx += 1u;
5170   // there should be at least one allocated state
5171   ufo_assert(fidx != (uint32_t)(UFO_MAX_STATES/32));
5172   uint32_t bmp = ufoStateUsedBitmap[fidx];
5173   fidx *= 32u;
5174   while ((bmp & 0x01) == 0) { fidx += 1u; bmp >>= 1; }
5175   ufoPush(fidx + 1u);
5176 }
5177
5178 // MTASK:STATE-NEXT
5179 // ( stid -- stid / 0 )
5180 UFWORD(MT_STATE_NEXT) {
5181   uint32_t stid = ufoPop();
5182   if (stid != 0 && stid < (uint32_t)(UFO_MAX_STATES/32)) {
5183     // it is already incremented for us, yay!
5184     uint32_t fidx = stid / 32u;
5185     uint8_t fofs = stid & 0x1f;
5186     while (fidx < (uint32_t)(UFO_MAX_STATES/32)) {
5187       const uint32_t bmp = ufoStateUsedBitmap[fidx];
5188       if (bmp != 0) {
5189         while (fofs != 32u) {
5190           if ((bmp & ((uint32_t)1 << (fofs & 0x1f))) == 0) fofs += 1u;
5191         }
5192         if (fofs != 32u) {
5193           ufoPush(fidx * 32u + fofs + 1u);
5194           return; // sorry!
5195         }
5196       }
5197       fidx += 1u; fofs = 0;
5198     }
5199   }
5200   ufoPush(0);
5201 }
5202
5203
5204 // MTASK:YIELD-TO
5205 // ( ... argc stid -- )
5206 UFWORD(MT_YIELD_TO) {
5207   UfoState *st = ufoFindState(ufoPop());
5208   if (st == NULL) ufoFatal("cannot yield to unknown state");
5209   //if (st == ufoDebuggerState) ufoFatal("cannot yield to debugger"); // why not?
5210   const uint32_t argc = ufoPop();
5211   if (argc > 256) ufoFatal("too many YIELD-TO arguments");
5212   UfoState *curst = ufoCurrState;
5213   if (st != ufoCurrState) {
5214     for (uint32_t f = 0; f < argc; f += 1) {
5215       ufoCurrState = curst;
5216       const uint32_t n = ufoPop();
5217       ufoCurrState = st;
5218       ufoPush(n);
5219     }
5220     ufoCurrState = curst; // we need to use API call to switch states
5221   }
5222   ufoSwitchToState(st); // always use API call for this!
5223   ufoPush(argc);
5224   ufoPush(curst->id);
5225 }
5226
5227 // MTASK:SET-SELF-AS-DEBUGGER
5228 // ( -- )
5229 UFWORD(MT_SET_SELF_AS_DEBUGGER) {
5230   ufoDebuggerState = ufoCurrState;
5231 }
5232
5233 // DEBUG:(BP)
5234 // ( -- )
5235 // debugger task receives debugge stid on the data stack, and -1 as argc.
5236 // i.e. debugger stask is: ( -1 old-stid )
5237 UFWORD(MT_DEBUGGER_BP) {
5238   if (ufoDebuggerState != NULL && ufoCurrState != ufoDebuggerState) {
5239     UfoState *st = ufoCurrState;
5240     ufoSwitchToState(ufoDebuggerState); // always use API call for this!
5241     ufoPush(-1);
5242     ufoPush(st->id);
5243     ufoSingleStep = 0;
5244   }
5245 }
5246
5247 // MTASK:DEBUGGER-RESUME
5248 // ( stid -- )
5249 UFWORD(MT_RESUME_DEBUGEE) {
5250   if (ufoCurrState != ufoDebuggerState) ufoFatal("cannot resume from non-debugger");
5251   UfoState *st = ufoFindState(ufoPop());
5252   if (st == NULL) ufoFatal("cannot yield to unknown state");
5253   if (st == ufoCurrState) ufoFatal("cannot resume into debugger itself");
5254   ufoSwitchToState(st); // always use API call for this!
5255   ufoSingleStep = 0;
5256 }
5257
5258 // MTASK:DEBUGGER-SINGLE-STEP
5259 // ( stid -- )
5260 UFWORD(MT_SINGLE_STEP_DEBUGEE) {
5261   if (ufoCurrState != ufoDebuggerState) ufoFatal("cannot resume from non-debugger");
5262   UfoState *st = ufoFindState(ufoPop());
5263   if (st == NULL) ufoFatal("cannot yield to unknown state");
5264   if (st == ufoCurrState) ufoFatal("cannot resume into debugger itself");
5265   ufoSwitchToState(st); // always use API call for this!
5266   ufoSingleStep = 2; // it will be decremented after returning from this word
5267 }
5268
5269 // MTASK:STATE-IP@
5270 // ( stid -- ip )
5271 UFWORD(MT_STATE_IP_GET) {
5272   UfoState *st = ufoFindState(ufoPop());
5273   if (st == NULL) ufoFatal("unknown state");
5274   ufoPush(st->IP);
5275 }
5276
5277 // MTASK:STATE-IP!
5278 // ( ip stid -- )
5279 UFWORD(MT_STATE_IP_SET) {
5280   UfoState *st = ufoFindState(ufoPop());
5281   if (st == NULL) ufoFatal("unknown state");
5282   st->IP = ufoPop();
5283 }
5284
5285 // MTASK:STATE-A@
5286 // ( stid -- ip )
5287 UFWORD(MT_STATE_REGA_GET) {
5288   UfoState *st = ufoFindState(ufoPop());
5289   if (st == NULL) ufoFatal("unknown state");
5290   ufoPush(st->regA);
5291 }
5292
5293 // MTASK:STATE-A!
5294 // ( ip stid -- )
5295 UFWORD(MT_STATE_REGA_SET) {
5296   UfoState *st = ufoFindState(ufoPop());
5297   if (st == NULL) ufoFatal("unknown state");
5298   st->regA = ufoPop();
5299 }
5300
5301 // MTASK:STATE-BASE@
5302 // ( stid -- base )
5303 UFWORD(MT_STATE_BASE_GET) {
5304   UfoState *st = ufoFindState(ufoPop());
5305   if (st == NULL) ufoFatal("unknown state");
5306   if (st == ufoCurrState) {
5307     ufoPush(ufoImgGetU32(ufoAddrBASE));
5308   } else {
5309     ufoPush(st->baseValue);
5310   }
5311 }
5312
5313 // MTASK:STATE-BASE!
5314 // ( base stid -- )
5315 UFWORD(MT_STATE_BASE_SET) {
5316   UfoState *st = ufoFindState(ufoPop());
5317   if (st == NULL) ufoFatal("unknown state");
5318   uint32_t base = ufoPop();
5319   if (st == ufoCurrState) {
5320     ufoImgPutU32(ufoAddrBASE, base);
5321   } else {
5322     st->baseValue = base;
5323   }
5324 }
5325
5326 // MTASK:STATE-RPOPCFA@
5327 // ( -- flag )
5328 UFWORD(MT_STATE_RPOPCFA_GET) {
5329   UfoState *st = ufoFindState(ufoPop());
5330   if (st == NULL) ufoFatal("unknown state");
5331   ufoPush(st->vmRPopCFA);
5332 }
5333
5334 // MTASK:STATE-RPOPCFA!
5335 // ( flag -- )
5336 UFWORD(MT_STATE_RPOPCFA_SET) {
5337   UfoState *st = ufoFindState(ufoPop());
5338   if (st == NULL) ufoFatal("unknown state");
5339   st->vmRPopCFA = ufoPop();
5340 }
5341
5342 // MTASK:ACTIVE-STATE
5343 // ( -- stid )
5344 UFWORD(MT_ACTIVE_STATE) {
5345   ufoPush(ufoCurrState->id);
5346 }
5347
5348 // MTASK:YIELDED-FROM
5349 // ( -- stid / 0 )
5350 UFWORD(MT_YIELDED_FROM) {
5351   if (ufoYieldedState != NULL) {
5352     ufoPush(ufoYieldedState->id);
5353   } else {
5354     ufoPush(0);
5355   }
5356 }
5357
5358 // MTASK:STATE-SP@
5359 // ( stid -- depth )
5360 UFWORD(MT_DSTACK_DEPTH_GET) {
5361   UfoState *st = ufoFindState(ufoPop());
5362   if (st == NULL) ufoFatal("unknown state");
5363   ufoPush(st->SP);
5364 }
5365
5366 // MTASK:STATE-RP@
5367 // ( stid -- depth )
5368 UFWORD(MT_RSTACK_DEPTH_GET) {
5369   UfoState *st = ufoFindState(ufoPop());
5370   if (st == NULL) ufoFatal("unknown state");
5371   ufoPush(st->RP - st->RPTop);
5372 }
5373
5374 // MTASK:STATE-LP@
5375 // ( stid -- lp )
5376 UFWORD(MT_LP_GET) {
5377   UfoState *st = ufoFindState(ufoPop());
5378   if (st == NULL) ufoFatal("unknown state");
5379   ufoPush(st->LP);
5380 }
5381
5382 // MTASK:STATE-LBP@
5383 // ( stid -- lbp )
5384 UFWORD(MT_LBP_GET) {
5385   UfoState *st = ufoFindState(ufoPop());
5386   if (st == NULL) ufoFatal("unknown state");
5387   ufoPush(st->LBP);
5388 }
5389
5390 // MTASK:STATE-SP!
5391 // ( depth stid -- )
5392 UFWORD(MT_DSTACK_DEPTH_SET) {
5393   UfoState *st = ufoFindState(ufoPop());
5394   if (st == NULL) ufoFatal("unknown state");
5395   uint32_t idx = ufoPop();
5396   if (idx >= UFO_DSTACK_SIZE) ufoFatal("invalid stack index %u (%u)", idx, UFO_DSTACK_SIZE);
5397   st->SP = idx;
5398 }
5399
5400 // MTASK:STATE-RP!
5401 // ( stid -- depth )
5402 UFWORD(MT_RSTACK_DEPTH_SET) {
5403   UfoState *st = ufoFindState(ufoPop());
5404   if (st == NULL) ufoFatal("unknown state");
5405   uint32_t idx = ufoPop();
5406   const uint32_t left = UFO_RSTACK_SIZE - st->RPTop;
5407   if (idx >= left) ufoFatal("invalid stack index %u (%u)", idx, left);
5408   st->RP = st->RPTop + idx;
5409 }
5410
5411 // MTASK:STATE-LP!
5412 // ( lp stid -- )
5413 UFWORD(MT_LP_SET) {
5414   UfoState *st = ufoFindState(ufoPop());
5415   if (st == NULL) ufoFatal("unknown state");
5416   st->LP = ufoPop();
5417 }
5418
5419 // MTASK:STATE-LBP!
5420 // ( lbp stid -- )
5421 UFWORD(MT_LBP_SET) {
5422   UfoState *st = ufoFindState(ufoPop());
5423   if (st == NULL) ufoFatal("unknown state");
5424   st->LBP = ufoPop();
5425 }
5426
5427 // MTASK:STATE-DS@
5428 // ( idx stid -- value )
5429 UFWORD(MT_DSTACK_LOAD) {
5430   UfoState *st = ufoFindState(ufoPop());
5431   if (st == NULL) ufoFatal("unknown state");
5432   uint32_t idx = ufoPop();
5433   if (idx >= st->SP) ufoFatal("invalid stack index %u (%u)", idx, st->SP);
5434   ufoPush(st->dStack[st->SP - idx - 1u]);
5435 }
5436
5437 // MTASK:STATE-RS@
5438 // ( idx stid -- value )
5439 UFWORD(MT_RSTACK_LOAD) {
5440   UfoState *st = ufoFindState(ufoPop());
5441   if (st == NULL) ufoFatal("unknown state");
5442   uint32_t idx = ufoPop();
5443   if (idx >= st->RP - st->RPTop) ufoFatal("invalid stack index %u (%u)", idx, st->RP - st->RPTop);
5444   ufoPush(st->dStack[st->RP - idx - 1u]);
5445 }
5446
5447 // MTASK:STATE-LS@
5448 // ( idx stid -- value )
5449 UFWORD(MT_LSTACK_LOAD) {
5450   UfoState *st = ufoFindState(ufoPop());
5451   if (st == NULL) ufoFatal("unknown state");
5452   uint32_t idx = ufoPop();
5453   if (idx >= st->LP) ufoFatal("invalid lstack index %u (%u)", idx, st->LP);
5454   ufoPush(st->lStack[st->LP - idx - 1u]);
5455 }
5456
5457 // MTASK:STATE-DS!
5458 // ( value idx stid -- )
5459 UFWORD(MT_DSTACK_STORE) {
5460   UfoState *st = ufoFindState(ufoPop());
5461   if (st == NULL) ufoFatal("unknown state");
5462   uint32_t idx = ufoPop();
5463   uint32_t value = ufoPop();
5464   if (idx >= st->SP) ufoFatal("invalid stack index %u (%u)", idx, st->SP);
5465   st->dStack[st->SP - idx - 1u] = value;
5466 }
5467
5468 // MTASK:STATE-RS!
5469 // ( value idx stid -- )
5470 UFWORD(MT_RSTACK_STORE) {
5471   UfoState *st = ufoFindState(ufoPop());
5472   if (st == NULL) ufoFatal("unknown state");
5473   uint32_t idx = ufoPop();
5474   uint32_t value = ufoPop();
5475   if (idx >= st->RP - st->RPTop) ufoFatal("invalid stack index %u (%u)", idx, st->RP - st->RPTop);
5476   st->dStack[st->RP - idx - 1u] = value;
5477 }
5478
5479 // MTASK:STATE-LS!
5480 // ( value idx stid -- )
5481 UFWORD(MT_LSTACK_STORE) {
5482   UfoState *st = ufoFindState(ufoPop());
5483   if (st == NULL) ufoFatal("unknown state");
5484   uint32_t idx = ufoPop();
5485   uint32_t value = ufoPop();
5486   if (idx >= st->LP) ufoFatal("invalid stack index %u (%u)", idx, st->LP);
5487   st->dStack[st->LP - idx - 1u] = value;
5488 }
5489
5490
5491 // ////////////////////////////////////////////////////////////////////////// //
5492 // initial dictionary definitions
5493 //
5494
5495 #undef UFWORD
5496
5497 #define UFWORD(name_)  do { \
5498   const uint32_t xcfa_ = ufoCFAsUsed; \
5499   ufo_assert(xcfa_ < UFO_MAX_NATIVE_CFAS); \
5500   ufoForthCFAs[xcfa_] = &ufoWord_##name_; \
5501   ufoCFAsUsed += 1; \
5502   ufoDefineNative(""#name_, xcfa_, 0); \
5503 } while (0)
5504
5505 #define UFWORDX(strname_,name_)  do { \
5506   const uint32_t xcfa_ = ufoCFAsUsed; \
5507   ufo_assert(xcfa_ < UFO_MAX_NATIVE_CFAS); \
5508   ufoForthCFAs[xcfa_] = &ufoWord_##name_; \
5509   ufoCFAsUsed += 1; \
5510   ufoDefineNative(strname_, xcfa_, 0); \
5511 } while (0)
5512
5513 #define UFWORD_IMM(name_)  do { \
5514   const uint32_t xcfa_ = ufoCFAsUsed; \
5515   ufo_assert(xcfa_ < UFO_MAX_NATIVE_CFAS); \
5516   ufoForthCFAs[xcfa_] = &ufoWord_##name_; \
5517   ufoCFAsUsed += 1; \
5518   ufoDefineNative(""#name_, xcfa_, 1); \
5519 } while (0)
5520
5521 #define UFWORDX_IMM(strname_,name_)  do { \
5522   const uint32_t xcfa_ = ufoCFAsUsed; \
5523   ufo_assert(xcfa_ < UFO_MAX_NATIVE_CFAS); \
5524   ufoForthCFAs[xcfa_] = &ufoWord_##name_; \
5525   ufoCFAsUsed += 1; \
5526   ufoDefineNative(strname_, xcfa_, 1); \
5527 } while (0)
5528
5529 #define UFC(name_)  ufoImgEmitU32_NoInline(ufoFindWordChecked(name_))
5530
5531
5532 //==========================================================================
5533 //
5534 //  ufoFindWordChecked
5535 //
5536 //==========================================================================
5537 UFO_DISABLE_INLINE uint32_t ufoFindWordChecked (const char *wname) {
5538   const uint32_t cfa = ufoFindWord(wname);
5539   if (cfa == 0) ufoFatal("word '%s' not found", wname);
5540   return cfa;
5541 }
5542
5543
5544 //==========================================================================
5545 //
5546 //  ufoGetForthVocId
5547 //
5548 //  get "FORTH" vocid
5549 //
5550 //==========================================================================
5551 uint32_t ufoGetForthVocId (void) {
5552   return ufoForthVocId;
5553 }
5554
5555
5556 //==========================================================================
5557 //
5558 //  ufoVocSetOnlyDefs
5559 //
5560 //==========================================================================
5561 void ufoVocSetOnlyDefs (uint32_t vocid) {
5562   ufoImgPutU32(ufoAddrCurrent, vocid);
5563   ufoImgPutU32(ufoAddrContext, vocid);
5564 }
5565
5566
5567 //==========================================================================
5568 //
5569 //  ufoCreateVoc
5570 //
5571 //  return voc PFA (vocid)
5572 //
5573 //==========================================================================
5574 uint32_t ufoCreateVoc (const char *wname, uint32_t parentvocid, uint32_t flags) {
5575   // create wordlist struct
5576   // typeid, used by Forth code (structs and such)
5577   ufoImgEmitU32(0); // typeid
5578   // vocid points here, to "LATEST-LFA"
5579   const uint32_t vocid = UFO_GET_DP();
5580   //fprintf(stderr, "NEW VOCID (%s): 0x%08x\n", wname, vocid);
5581   ufoImgEmitU32(0); // latest
5582   const uint32_t vlink = UFO_GET_DP();
5583   if ((vocid & UFO_ADDR_TEMP_BIT) == 0) {
5584     ufoImgEmitU32(ufoImgGetU32(ufoAddrVocLink)); // voclink
5585     ufoImgPutU32(ufoAddrVocLink, vlink); // update voclink
5586   } else {
5587     abort();
5588     ufoImgEmitU32(0);
5589   }
5590   ufoImgEmitU32(parentvocid); // parent
5591   const uint32_t hdraddr = UFO_GET_DP();
5592   ufoImgEmitU32(0); // word header
5593   // create empty hash table
5594   for (int f = 0; f < UFO_HASHTABLE_SIZE; f += 1) ufoImgEmitU32(0);
5595   // update CONTEXT and CURRENT if this is the first wordlist ever
5596   if (ufoImgGetU32(ufoAddrContext) == 0) {
5597     ufoImgPutU32(ufoAddrContext, vocid);
5598   }
5599   if (ufoImgGetU32(ufoAddrCurrent) == 0) {
5600     ufoImgPutU32(ufoAddrCurrent, vocid);
5601   }
5602   // create word header
5603   if (wname != NULL && wname[0] != 0) {
5604     /*
5605     uint32_t flags = ufoImgGetU32(ufoAddrNewWordFlags);
5606     flags &=
5607       //UFW_FLAG_IMMEDIATE|
5608       //UFW_FLAG_SMUDGE|
5609       //UFW_FLAG_NORETURN|
5610       UFW_FLAG_HIDDEN|
5611       //UFW_FLAG_CBLOCK|
5612       //UFW_FLAG_VOCAB|
5613       //UFW_FLAG_SCOLON|
5614       UFW_FLAG_PROTECTED;
5615     flags |= UFW_FLAG_VOCAB;
5616     */
5617     flags &= 0xffffff00u;
5618     flags |= UFW_FLAG_VOCAB;
5619     ufoCreateWordHeader(wname, flags);
5620     const uint32_t cfa = UFO_GET_DP();
5621     ufoImgEmitU32(ufoDoVocCFA); // cfa
5622     ufoImgEmitU32(vocid); // pfa
5623     // update vocab header pointer
5624     const uint32_t lfa = UFO_CFA_TO_LFA(cfa);
5625     ufoImgPutU32(hdraddr, UFO_LFA_TO_NFA(lfa));
5626     #ifdef UFO_DEBUG_DUMP_NEW_HEADERS
5627     ufoDumpWordHeader(lfa);
5628     #endif
5629   }
5630   return vocid;
5631 }
5632
5633
5634 //==========================================================================
5635 //
5636 //  ufoSetLatestArgs
5637 //
5638 //==========================================================================
5639 static void ufoSetLatestArgs (uint32_t warg) {
5640   const uint32_t curr = ufoImgGetU32(ufoAddrCurrent);
5641   const uint32_t lfa = ufoImgGetU32(curr);
5642   const uint32_t nfa = UFO_LFA_TO_NFA(lfa);
5643   uint32_t flags = ufoImgGetU32(nfa);
5644   //fprintf(stderr, "OLD FLAGS: 0x%08x\n", flags);
5645   flags &= ~UFW_WARG_MASK;
5646   flags |= warg & UFW_WARG_MASK;
5647   //fprintf(stderr, "NEW FLAGS: 0x%08x\n", flags);
5648   ufoImgPutU32(nfa, flags);
5649   #ifdef UFO_DEBUG_DUMP_NEW_HEADERS
5650   ufoDumpWordHeader(lfa);
5651   #endif
5652 }
5653
5654
5655 //==========================================================================
5656 //
5657 //  ufoDefine
5658 //
5659 //==========================================================================
5660 static void ufoDefineNative (const char *wname, uint32_t cfaidx, int immed) {
5661   cfaidx |= UFO_ADDR_CFA_BIT;
5662   uint32_t flags = ufoImgGetU32(ufoAddrNewWordFlags);
5663   flags &=
5664       //UFW_FLAG_IMMEDIATE|
5665       //UFW_FLAG_SMUDGE|
5666       //UFW_FLAG_NORETURN|
5667       UFW_FLAG_HIDDEN|
5668       //UFW_FLAG_CBLOCK|
5669       //UFW_FLAG_VOCAB|
5670       //UFW_FLAG_SCOLON|
5671       UFW_FLAG_PROTECTED;
5672   if (immed) flags |= UFW_FLAG_IMMEDIATE;
5673   ufoCreateWordHeader(wname, flags);
5674   ufoImgEmitU32(cfaidx);
5675 }
5676
5677
5678 //==========================================================================
5679 //
5680 //  ufoDefineConstant
5681 //
5682 //==========================================================================
5683 static void ufoDefineConstant (const char *name, uint32_t value) {
5684   ufoDefineNative(name, ufoDoConstCFA, 0);
5685   ufoImgEmitU32(value);
5686 }
5687
5688
5689 //==========================================================================
5690 //
5691 //  ufoDefineVar
5692 //
5693 //==========================================================================
5694 /*
5695 static void ufoDefineVar (const char *name, uint32_t value) {
5696   ufoDefineNative(name, ufoDoVarCFA, 0);
5697   ufoImgEmitU32(value);
5698 }
5699 */
5700
5701
5702 //==========================================================================
5703 //
5704 //  ufoDefineDefer
5705 //
5706 //==========================================================================
5707 /*
5708 static void ufoDefineDefer (const char *name, uint32_t value) {
5709   ufoDefineNative(name, ufoDoDeferCFA, 0);
5710   ufoImgEmitU32(value);
5711 }
5712 */
5713
5714
5715 //==========================================================================
5716 //
5717 //  ufoHiddenWords
5718 //
5719 //==========================================================================
5720 static void ufoHiddenWords (void) {
5721   const uint32_t flags = ufoImgGetU32(ufoAddrNewWordFlags);
5722   ufoImgPutU32(ufoAddrNewWordFlags, flags | UFW_FLAG_HIDDEN);
5723 }
5724
5725
5726 //==========================================================================
5727 //
5728 //  ufoPublicWords
5729 //
5730 //==========================================================================
5731 static void ufoPublicWords (void) {
5732   const uint32_t flags = ufoImgGetU32(ufoAddrNewWordFlags);
5733   ufoImgPutU32(ufoAddrNewWordFlags, flags & ~UFW_FLAG_HIDDEN);
5734 }
5735
5736
5737 //==========================================================================
5738 //
5739 //  ufoDefineForth
5740 //
5741 //==========================================================================
5742 static void ufoDefineForth (const char *name) {
5743   ufoDefineNative(name, ufoDoForthCFA, 0);
5744 }
5745
5746
5747 //==========================================================================
5748 //
5749 //  ufoDefineForthImm
5750 //
5751 //==========================================================================
5752 static void ufoDefineForthImm (const char *name) {
5753   ufoDefineNative(name, ufoDoForthCFA, 1);
5754 }
5755
5756
5757 //==========================================================================
5758 //
5759 //  ufoDefineForthHidden
5760 //
5761 //==========================================================================
5762 static void ufoDefineForthHidden (const char *name) {
5763   const uint32_t flags = ufoImgGetU32(ufoAddrNewWordFlags);
5764   ufoImgPutU32(ufoAddrNewWordFlags, flags | UFW_FLAG_HIDDEN);
5765   ufoDefineNative(name, ufoDoForthCFA, 0);
5766   ufoImgPutU32(ufoAddrNewWordFlags, flags);
5767 }
5768
5769
5770 //==========================================================================
5771 //
5772 //  ufoDefineSColonForth
5773 //
5774 //  create word suitable for scattered colon extension
5775 //
5776 //==========================================================================
5777 static void ufoDefineSColonForth (const char *name) {
5778   ufoDefineNative(name, ufoDoForthCFA, 0);
5779   // placeholder for scattered colon
5780   // it will compile two branches:
5781   // the first branch will jump to the first "..:" word (or over the two branches)
5782   // the second branch is never taken, and works as a pointer to the latest branch addr in the list
5783   // this way, each extension word will simply fix the last branch address, and update list tail
5784   // at the creation time, second branch points to the first branch
5785   UFC("FORTH:(BRANCH)");
5786   const uint32_t xjmp = UFO_GET_DP();
5787   ufoImgEmitU32(0);
5788   UFC("FORTH:(BRANCH)"); ufoImgEmitU32(xjmp);
5789   ufoImgPutU32(xjmp, UFO_GET_DP());
5790 }
5791
5792
5793 //==========================================================================
5794 //
5795 //  ufoDoneForth
5796 //
5797 //==========================================================================
5798 UFO_FORCE_INLINE void ufoDoneForth (void) {
5799 }
5800
5801
5802 //==========================================================================
5803 //
5804 //  ufoNewState
5805 //
5806 //  create a new state, its execution will start from the given CFA.
5807 //  state is not automatically activated.
5808 //
5809 //==========================================================================
5810 static UfoState *ufoNewState (uint32_t cfa) {
5811   // find free state id
5812   uint32_t fidx = 0;
5813   uint32_t bmp = ufoStateUsedBitmap[0];
5814   while (fidx != (uint32_t)(UFO_MAX_STATES/32) && bmp == ~(uint32_t)0) {
5815     fidx += 1u;
5816     bmp = ufoStateUsedBitmap[fidx];
5817   }
5818   if (fidx == (uint32_t)(UFO_MAX_STATES/32)) ufoFatal("too many execution states");
5819   //fprintf(stderr, "NST:000: fidx=%u; bmp=0x%08x\n", fidx, bmp);
5820   fidx *= 32u;
5821   while ((bmp & 0x01) != 0) { fidx += 1u; bmp >>= 1; }
5822   ufo_assert(fidx < UFO_MAX_STATES);
5823   ufo_assert((ufoStateUsedBitmap[fidx / 32u] & ((uint32_t)1 << (fidx & 0x1f))) == 0);
5824   ufo_assert(ufoStateMap[fidx] == NULL);
5825   UfoState *st = calloc(1, sizeof(UfoState));
5826   if (st == NULL) ufoFatal("out of memory for states");
5827   st->id = fidx + 1u;
5828   st->vmRPopCFA = 1;
5829   st->rStack[0] = 0xdeadf00d; // dummy value
5830   st->rStack[1] = cfa;
5831   st->RP = 2;
5832   st->baseValue = 10; // default
5833   ufoStateMap[fidx] = st;
5834   ufoStateUsedBitmap[fidx / 32u] |= ((uint32_t)1 << (fidx & 0x1f));
5835   //fprintf(stderr, "NST: fidx=%u; 0x%08x\n", fidx, ufoStateUsedBitmap[fidx / 32u]);
5836   return st;
5837 }
5838
5839
5840 //==========================================================================
5841 //
5842 //  ufoFreeState
5843 //
5844 //  free all memory used for the state, remove it from state list.
5845 //  WARNING! never free current state!
5846 //
5847 //==========================================================================
5848 static void ufoFreeState (UfoState *st) {
5849   if (st != NULL) {
5850     if (st == ufoCurrState) ufoFatal("cannot free active state");
5851     if (ufoYieldedState == st) ufoYieldedState = NULL;
5852     if (ufoDebuggerState == st) ufoDebuggerState = NULL;
5853     const uint32_t fidx = st->id - 1u;
5854     //fprintf(stderr, "FST: fidx=%u; 0x%08x\n", fidx, ufoStateUsedBitmap[fidx / 32u]);
5855     ufo_assert(fidx < UFO_MAX_STATES);
5856     ufo_assert((ufoStateUsedBitmap[fidx / 32u] & (1u << (fidx & 0x1f))) != 0);
5857     ufo_assert(ufoStateMap[fidx] == st);
5858     free(st);
5859     ufoStateMap[fidx] = NULL;
5860     ufoStateUsedBitmap[fidx / 32u] &= ~((uint32_t)1 << (fidx & 0x1f));
5861   }
5862 }
5863
5864
5865 //==========================================================================
5866 //
5867 //  ufoFindState
5868 //
5869 //==========================================================================
5870 static UfoState *ufoFindState (uint32_t stid) {
5871   UfoState *res = NULL;
5872   if (stid != 0 && stid <= UFO_MAX_STATES) {
5873     stid -= 1u;
5874     res = ufoStateMap[stid];
5875     if (res != NULL) {
5876       ufo_assert((ufoStateUsedBitmap[stid / 32u] & (1u << (stid & 0x1f))) != 0);
5877       ufo_assert(res->id == stid + 1u);
5878     } else {
5879       ufo_assert((ufoStateUsedBitmap[stid / 32u] & (1u << (stid & 0x1f))) == 0);
5880     }
5881   }
5882   return res;
5883 }
5884
5885
5886 //==========================================================================
5887 //
5888 //  ufoSwitchToState
5889 //
5890 //==========================================================================
5891 static void ufoSwitchToState (UfoState *newst) {
5892   ufo_assert(newst != NULL);
5893   if (newst != ufoCurrState) {
5894     ufoCurrState->baseValue = ufoImgGetU32(ufoAddrBASE);
5895     ufoImgPutU32(ufoAddrBASE, newst->baseValue);
5896     ufoCurrState = newst;
5897   }
5898 }
5899
5900
5901
5902 //==========================================================================
5903 //
5904 //  ufoReset
5905 //
5906 //==========================================================================
5907 UFO_DISABLE_INLINE void ufoReset (void) {
5908   if (ufoCurrState == NULL) ufoFatal("no active execution state");
5909
5910   ufoSP = 0; ufoRP = 0;
5911   ufoLP = 0; ufoLBP = 0;
5912
5913   ufoInRunWord = 0;
5914   ufoVMStop = 0; ufoVMAbort = 0;
5915
5916   ufoInBacktrace = 0;
5917
5918   ufoImgPutU32(ufoAddrSTATE, 0);
5919   ufoImgPutU32(ufoAddrBASE, 10);
5920   ufoImgPutU32(ufoAddrRedefineWarning, UFO_REDEF_WARN_NORMAL);
5921   ufoResetTib();
5922
5923   ufoImgPutU32(ufoAddrDPTemp, 0);
5924
5925   ufoImgPutU32(ufoAddrNewWordFlags, 0);
5926   ufoVocSetOnlyDefs(ufoForthVocId);
5927 }
5928
5929
5930 //==========================================================================
5931 //
5932 //  ufoCompileStrLit
5933 //
5934 //  compile string literal, the same as QUOTE_IMM
5935 //
5936 //==========================================================================
5937 static void ufoCompileStrLit (const char *str) {
5938   if (str == NULL) str = "";
5939   const size_t slen = strlen(str);
5940   if (slen > 255) ufoFatal("string literal too long");
5941   UFC("FORTH:(STRLIT8)");
5942   ufoImgEmitU8((uint8_t)slen);
5943   for (size_t f = 0; f < slen; f += 1) {
5944     ufoImgEmitU8(((const unsigned char *)str)[f]);
5945   }
5946   ufoImgEmitU8(0);
5947   ufoImgEmitAlign();
5948 }
5949
5950
5951 //==========================================================================
5952 //
5953 //  ufoCompileLit
5954 //
5955 //==========================================================================
5956 static __attribute__((unused)) void ufoCompileLit (uint32_t value) {
5957   UFC("FORTH:(LIT)");
5958   ufoImgEmitU32(value);
5959 }
5960
5961
5962 //==========================================================================
5963 //
5964 //  ufoMarkFwd
5965 //
5966 //==========================================================================
5967 UFO_FORCE_INLINE uint32_t ufoMarkFwd (void) {
5968   const uint32_t res = UFO_GET_DP();
5969   ufoImgEmitU32(0);
5970   return res;
5971 }
5972
5973
5974 //==========================================================================
5975 //
5976 //  ufoResolveFwd
5977 //
5978 //==========================================================================
5979 UFO_FORCE_INLINE void ufoResolveFwd (uint32_t jaddr) {
5980   ufoImgPutU32(jaddr, UFO_GET_DP());
5981 }
5982
5983
5984 //==========================================================================
5985 //
5986 //  ufoMarkBwd
5987 //
5988 //==========================================================================
5989 UFO_FORCE_INLINE uint32_t ufoMarkBwd (void) {
5990   return UFO_GET_DP();
5991 }
5992
5993
5994 //==========================================================================
5995 //
5996 //  ufoResolveBwd
5997 //
5998 //==========================================================================
5999 UFO_FORCE_INLINE void ufoResolveBwd (uint32_t jaddr) {
6000   ufoImgEmitU32(jaddr);
6001 }
6002
6003
6004 //==========================================================================
6005 //
6006 //  ufoDefineInterpret
6007 //
6008 //  define "INTERPRET" in Forth
6009 //
6010 //==========================================================================
6011 UFO_DISABLE_INLINE void ufoDefineInterpret (void) {
6012   // skip comments, parse name, refilling lines if necessary
6013   ufoDefineForthHidden("(INTERPRET-PARSE-NAME)");
6014     const uint32_t label_ipn_again = ufoMarkBwd();
6015     UFC("TRUE"); UFC("(PARSE-SKIP-COMMENTS)");
6016     UFC("PARSE-NAME");
6017     UFC("DUP");
6018     UFC("FORTH:(TBRANCH)"); const uint32_t label_ipn_exit_fwd = ufoMarkFwd();
6019     UFC("2DROP");
6020     UFC("REFILL");
6021     UFC("FORTH:(TBRANCH)"); ufoResolveBwd(label_ipn_again);
6022     // refill failed
6023     UFC("FORTH:STATE"); UFC("@");
6024     ufoCompileStrLit("unexpected end of file"); UFC("?ERROR");
6025     UFC("FORTH:(UFO-INTERPRET-FINISHED)");
6026     // patch the jump above
6027     ufoResolveFwd(label_ipn_exit_fwd);
6028     UFC("FORTH:(EXIT)");
6029   ufoDoneForth();
6030   //ufoDecompileWord(ufoFindWordChecked("(INTERPRET-PARSE-NAME)"));
6031
6032   ufoDefineForth("INTERPRET");
6033     const uint32_t label_it_again = ufoMarkBwd();
6034     UFC("FORTH:(INTERPRET-PARSE-NAME)");
6035     // try defered checker
6036     // ( addr count FALSE -- addr count FALSE / TRUE )
6037     UFC("FALSE"); UFC("(INTERPRET-CHECK-WORD)");
6038     UFC("FORTH:(TBRANCH)"); ufoResolveBwd(label_it_again);
6039     UFC("2DUP"); UFC("FIND-WORD");  // ( addr count cfa TRUE / addr count FALSE )
6040     UFC("FORTH:(0BRANCH)"); const uint32_t label_it_try_num = ufoMarkFwd();
6041       UFC("NROT"); UFC("2DROP"); // drop word string
6042       UFC("STATE"); UFC("@");
6043       UFC("FORTH:(0BRANCH)"); const uint32_t label_it_exec_fwd = ufoMarkFwd();
6044         // compiling; check immediate bit
6045         UFC("DUP"); UFC("CFA->NFA"); UFC("@");
6046         UFC("COMPILER:(WFLAG-IMMEDIATE)"); UFC("AND");
6047         UFC("FORTH:(TBRANCH)"); const uint32_t label_it_exec_imm = ufoMarkFwd();
6048           // compile it
6049           UFC("FORTH:COMPILE,");
6050           UFC("FORTH:(BRANCH)"); ufoResolveBwd(label_it_again);
6051         // execute it
6052         ufoResolveFwd(label_it_exec_imm);
6053         ufoResolveFwd(label_it_exec_fwd);
6054           UFC("EXECUTE");
6055           UFC("FORTH:(BRANCH)"); ufoResolveBwd(label_it_again);
6056     // not a word, try a number
6057     ufoResolveFwd(label_it_try_num);
6058     UFC("2DUP"); UFC("TRUE"); UFC("BASE"); UFC("@"); UFC("(BASED-NUMBER)");
6059     // (BASED-NUMBER) ( addr count allowsign? base -- num TRUE / FALSE )
6060     UFC("FORTH:(0BRANCH)"); const uint32_t label_it_num_error = ufoMarkFwd();
6061       // number
6062       UFC("NROT"); UFC("2DROP"); // drop word string
6063       // do we need to compile it?
6064       UFC("STATE"); UFC("@");
6065       UFC("FORTH:(0BRANCH)"); ufoResolveBwd(label_it_again);
6066       // compile "(LITERAL)" (do it properly, with "LITCFA")
6067       UFC("FORTH:(LITCFA)"); UFC("FORTH:(LIT)");
6068       UFC("FORTH:COMPILE,"); // compile "(LIT)" CFA
6069       UFC("FORTH:,"); // compile number
6070       UFC("FORTH:(BRANCH)"); ufoResolveBwd(label_it_again);
6071     // error
6072     ufoResolveFwd(label_it_num_error);
6073       // ( addr count FALSE -- addr count FALSE / TRUE )
6074       UFC("FALSE"); UFC("(INTERPRET-WORD-NOT-FOUND)");
6075       UFC("FORTH:(TBRANCH)"); ufoResolveBwd(label_it_again);
6076       UFC("ENDCR"); UFC("SPACE"); UFC("XTYPE");
6077       ufoCompileStrLit(" -- wut?\n"); UFC("TYPE");
6078       ufoCompileStrLit("unknown word");
6079       UFC("ERROR");
6080   ufoDoneForth();
6081   //ufoDecompileWord(ufoFindWordChecked("INTERPRET"));
6082 }
6083
6084
6085 //==========================================================================
6086 //
6087 //  ufoInitBaseDict
6088 //
6089 //==========================================================================
6090 UFO_DISABLE_INLINE void ufoInitBaseDict (void) {
6091   uint32_t imgAddr = 0;
6092
6093   // reserve 64 bytes for nothing
6094   for (uint32_t f = 0; f < 64; f += 1) {
6095     ufoImgPutU8(imgAddr, 0);
6096     imgAddr += 1;
6097   }
6098   // align
6099   while ((imgAddr & 3) != 0) {
6100     ufoImgPutU8(imgAddr, 0);
6101     imgAddr += 1;
6102   }
6103
6104   // BASE
6105   ufoAddrBASE = imgAddr;
6106   ufoImgPutU32(imgAddr, 10); imgAddr += 4u;
6107
6108   // STATE
6109   ufoAddrSTATE = imgAddr;
6110   ufoImgPutU32(imgAddr, 0); imgAddr += 4u;
6111
6112   // DP
6113   ufoAddrDP = imgAddr;
6114   ufoImgPutU32(imgAddr, 0); imgAddr += 4u;
6115
6116   // DP-TEMP
6117   ufoAddrDPTemp = imgAddr;
6118   ufoImgPutU32(imgAddr, 0); imgAddr += 4u;
6119
6120   // TIB
6121   ufoAddrTIBx = imgAddr;
6122   ufoImgPutU32(imgAddr, 0); imgAddr += 4u;
6123
6124   // >IN
6125   ufoAddrINx = imgAddr;
6126   ufoImgPutU32(imgAddr, 0); imgAddr += 4u;
6127
6128   // CONTEXT
6129   ufoAddrContext = imgAddr;
6130   ufoImgPutU32(imgAddr, 0); imgAddr += 4u;
6131
6132   // CURRENT
6133   ufoAddrCurrent = imgAddr;
6134   ufoImgPutU32(imgAddr, 0); imgAddr += 4u;
6135
6136   // (LATEST-XFA)
6137   ufoAddrLastXFA = imgAddr;
6138   ufoImgPutU32(imgAddr, 0); imgAddr += 4u;
6139
6140   // (VOC-LINK)
6141   ufoAddrVocLink = imgAddr;
6142   ufoImgPutU32(imgAddr, 0); imgAddr += 4u;
6143
6144   // (NEW-WORD-FLAGS)
6145   ufoAddrNewWordFlags = imgAddr;
6146   ufoImgPutU32(imgAddr, UFW_FLAG_PROTECTED); imgAddr += 4u;
6147
6148   // WORD-REDEFINE-WARN-MODE
6149   ufoAddrRedefineWarning = imgAddr;
6150   ufoImgPutU32(imgAddr, UFO_REDEF_WARN_NORMAL); imgAddr += 4u;
6151
6152   ufoImgPutU32(ufoAddrDP, imgAddr);
6153   ufoImgPutU32(ufoAddrDPTemp, 0);
6154
6155   #if 0
6156   fprintf(stderr, "INITIAL HERE: 0x%08x (0x%08x)\n", imgAddr, UFO_GET_DP());
6157   #endif
6158 }
6159
6160
6161 //==========================================================================
6162 //
6163 //  ufoInitBasicWords
6164 //
6165 //==========================================================================
6166 UFO_DISABLE_INLINE void ufoInitBasicWords (void) {
6167   ufoDefineConstant("FALSE", 0);
6168   ufoDefineConstant("TRUE", ufoTrueValue);
6169
6170   ufoDefineConstant("BL", 32);
6171   ufoDefineConstant("NL", 10);
6172
6173   // basic vars
6174   ufoDefineConstant("BASE", ufoAddrBASE);
6175   ufoDefineConstant("STATE", ufoAddrSTATE);
6176   ufoDefineConstant("TIB", ufoAddrTIBx);
6177   ufoDefineConstant(">IN", ufoAddrINx);
6178   ufoDefineConstant("(STD-TIB-ADDR)", ufoDefTIB);
6179   ufoDefineConstant("CONTEXT", ufoAddrContext);
6180   ufoDefineConstant("CURRENT", ufoAddrCurrent);
6181
6182   ufoHiddenWords();
6183   ufoDefineConstant("(LATEST-XFA)", ufoAddrLastXFA);
6184   ufoDefineConstant("(VOC-LINK)", ufoAddrVocLink);
6185   ufoDefineConstant("(NEW-WORD-FLAGS)", ufoAddrNewWordFlags);
6186   ufoDefineConstant("(ADDR-TEMP-BIT)", UFO_ADDR_TEMP_BIT);
6187   ufoDefineConstant("(ADDR-CFA-BIT)", UFO_ADDR_CFA_BIT);
6188   ufoDefineConstant("(ADDR-HANDLE-BIT)", UFO_ADDR_HANDLE_BIT);
6189   ufoDefineConstant("(MAX-HANDLE-OFS)", UFO_ADDR_HANDLE_OFS_MASK);
6190
6191   ufoDefineConstant("(DP)", ufoAddrDP);
6192   ufoDefineConstant("(DP-TEMP)", ufoAddrDPTemp);
6193   ufoPublicWords();
6194
6195   //UFWORDX("(UFO-BUCKET-STATS)", PAR_UFO_BUCKET_STATS);
6196   UFWORDX("SP0!", SP0_STORE);
6197   UFWORDX("RP0!", RP0_STORE);
6198
6199   UFWORDX("PAD", PAD);
6200
6201   UFWORDX("@", PEEK);
6202   UFWORDX("C@", CPEEK);
6203   UFWORDX("W@", WPEEK);
6204
6205   UFWORDX("!", POKE);
6206   UFWORDX("C!", CPOKE);
6207   UFWORDX("W!", WPOKE);
6208
6209   UFWORDX(",", COMMA);
6210   UFWORDX("C,", CCOMMA);
6211   UFWORDX("W,", WCOMMA);
6212
6213   UFWORDX("A@", REGA_LOAD);
6214   UFWORDX("A!", REGA_STORE);
6215
6216   UFWORDX("@A+", PEEK_REGA_IDX);
6217   UFWORDX("C@A+", CPEEK_REGA_IDX);
6218   UFWORDX("W@A+", WPEEK_REGA_IDX);
6219
6220   UFWORDX("!A+", POKE_REGA_IDX);
6221   UFWORDX("C!A+", CPOKE_REGA_IDX);
6222   UFWORDX("W!A+", WPOKE_REGA_IDX);
6223
6224   ufoHiddenWords();
6225   UFWORDX("(LIT)", PAR_LIT); ufoSetLatestArgs(UFW_WARG_LIT);
6226   UFWORDX("(LITCFA)", PAR_LITCFA); ufoSetLatestArgs(UFW_WARG_CFA);
6227   UFWORDX("(LITVOCID)", PAR_LITVOCID); ufoSetLatestArgs(UFW_WARG_VOCID);
6228   UFWORDX("(STRLIT8)", PAR_STRLIT8); ufoSetLatestArgs(UFW_WARG_C1STRZ);
6229   UFWORDX("(EXIT)", PAR_EXIT);
6230
6231   UFWORDX("(UFO-INTERPRET-FINISHED)", UFO_INTERPRET_FINISHED);
6232
6233   ufoStrLit8CFA = ufoFindWordChecked("FORTH:(STRLIT8)");
6234
6235   UFWORDX("(L-ENTER)", PAR_LENTER); ufoSetLatestArgs(UFW_WARG_LIT);
6236   UFWORDX("(L-LEAVE)", PAR_LLEAVE);
6237   UFWORDX("(LOCAL@)", PAR_LOCAL_LOAD);
6238   UFWORDX("(LOCAL!)", PAR_LOCAL_STORE);
6239
6240   UFWORDX("(BRANCH)", PAR_BRANCH); ufoSetLatestArgs(UFW_WARG_BRANCH);
6241   UFWORDX("(TBRANCH)", PAR_TBRANCH); ufoSetLatestArgs(UFW_WARG_BRANCH);
6242   UFWORDX("(0BRANCH)", PAR_0BRANCH); ufoSetLatestArgs(UFW_WARG_BRANCH);
6243   ufoPublicWords();
6244
6245   UFWORDX("GET-MSECS", GET_MSECS);
6246 }
6247
6248
6249 //==========================================================================
6250 //
6251 //  ufoInitBasicCompilerWords
6252 //
6253 //==========================================================================
6254 UFO_DISABLE_INLINE void ufoInitBasicCompilerWords (void) {
6255   ufoVocSetOnlyDefs(ufoCompilerVocId);
6256
6257   ufoDefineConstant("(CFAIDX-DO-FORTH)", ufoDoForthCFA);
6258   ufoDefineConstant("(CFAIDX-DO-VAR)", ufoDoVariableCFA);
6259   ufoDefineConstant("(CFAIDX-DO-VALUE)", ufoDoValueCFA);
6260   ufoDefineConstant("(CFAIDX-DO-CONST)", ufoDoConstCFA);
6261   ufoDefineConstant("(CFAIDX-DO-DEFER)", ufoDoDeferCFA);
6262   ufoDefineConstant("(CFAIDX-DO-VOC)", ufoDoVocCFA);
6263   ufoDefineConstant("(CFAIDX-DO-CREATE)", ufoDoCreateCFA);
6264
6265   ufoDefineConstant("(WFLAG-IMMEDIATE)", UFW_FLAG_IMMEDIATE);
6266   ufoDefineConstant("(WFLAG-SMUDGE)", UFW_FLAG_SMUDGE);
6267   ufoDefineConstant("(WFLAG-NORETURN)", UFW_FLAG_NORETURN);
6268   ufoDefineConstant("(WFLAG-HIDDEN)", UFW_FLAG_HIDDEN);
6269   ufoDefineConstant("(WFLAG-CBLOCK)", UFW_FLAG_CBLOCK);
6270   ufoDefineConstant("(WFLAG-VOCAB)", UFW_FLAG_VOCAB);
6271   ufoDefineConstant("(WFLAG-SCOLON)", UFW_FLAG_SCOLON);
6272   ufoDefineConstant("(WFLAG-PROTECTED)", UFW_FLAG_PROTECTED);
6273
6274   ufoDefineConstant("(WARG-MASK)", UFW_WARG_MASK);
6275   ufoDefineConstant("(WARG-NONE)", UFW_WARG_NONE);
6276   ufoDefineConstant("(WARG-BRANCH)", UFW_WARG_BRANCH);
6277   ufoDefineConstant("(WARG-LIT)", UFW_WARG_LIT);
6278   ufoDefineConstant("(WARG-C4STRZ)", UFW_WARG_C4STRZ);
6279   ufoDefineConstant("(WARG-CFA)", UFW_WARG_CFA);
6280   ufoDefineConstant("(WARG-CBLOCK)", UFW_WARG_CBLOCK);
6281   ufoDefineConstant("(WARG-VOCID)", UFW_WARG_VOCID);
6282   ufoDefineConstant("(WARG-C1STRZ)", UFW_WARG_C1STRZ);
6283
6284   ufoDefineConstant("(VOCOFS-LATEST)", UFW_VOCAB_OFS_LATEST);
6285   ufoDefineConstant("(VOCOFS-VOCLINK)", UFW_VOCAB_OFS_VOCLINK);
6286   ufoDefineConstant("(VOCOFS-PARENT)", UFW_VOCAB_OFS_PARENT);
6287   ufoDefineConstant("(VOCOFS-HEADER)", UFW_VOCAB_OFS_HEADER);
6288   ufoDefineConstant("(VOCOFS-HTABLE)", UFW_VOCAB_OFS_HTABLE);
6289   ufoDefineConstant("(VOC-HTABLE-SIZE)", UFO_HASHTABLE_SIZE);
6290   ufoDefineConstant("(VOC-HTABLE-NOFLAG)", UFO_NO_HTABLE_FLAG);
6291
6292   ufoDefineConstant("(REDEFINE-WARN-DON'T-CARE)", UFO_REDEF_WARN_DONT_CARE);
6293   ufoDefineConstant("(REDEFINE-WARN-NONE)", UFO_REDEF_WARN_NONE);
6294   ufoDefineConstant("(REDEFINE-WARN-NORMAL)", UFO_REDEF_WARN_NORMAL);
6295
6296   ufoDefineConstant("WORD-REDEFINE-WARN-MODE", ufoAddrRedefineWarning);
6297
6298   UFWORDX("(UNESCAPE)", PAR_UNESCAPE);
6299
6300   UFWORDX("?EXEC", QEXEC);
6301   UFWORDX("?COMP", QCOMP);
6302
6303   // interpreter
6304   /*
6305   UFWORDX("(INTERPRET-DUMB)", PAR_INTERPRET_DUMB); UFCALL(PAR_HIDDEN);
6306   const uint32_t idumbCFA = UFO_LFA_TO_CFA(ufoImgGetU32(ufoImgGetU32(ufoAddrCurrent)));
6307   ufo_assert(idumbCFA == UFO_PFA_TO_CFA(UFO_GET_DP()));
6308   */
6309
6310   UFWORDX("(CREATE-WORD-HEADER)", PAR_CREATE_WORD_HEADER);
6311   UFWORDX("(CREATE-NAMELESS-WORD-HEADER)", PAR_CREATE_NAMELESS_WORD_HEADER);
6312
6313
6314   // more FORTH words
6315   ufoVocSetOnlyDefs(ufoForthVocId);
6316 }
6317
6318
6319 //==========================================================================
6320 //
6321 //  ufoInitMoreWords
6322 //
6323 //==========================================================================
6324 UFO_DISABLE_INLINE void ufoInitMoreWords (void) {
6325   UFWORDX("COMPILE,", COMMA); // just an alias, for clarity
6326
6327   UFWORDX("CFA->PFA", CFA2PFA);
6328   UFWORDX("PFA->CFA", PFA2CFA);
6329   UFWORDX("CFA->NFA", CFA2NFA);
6330   UFWORDX("NFA->CFA", NFA2CFA);
6331   UFWORDX("CFA->LFA", CFA2LFA);
6332   UFWORDX("LFA->CFA", LFA2CFA);
6333   UFWORDX("LFA->PFA", LFA2PFA);
6334   UFWORDX("LFA->BFA", LFA2BFA);
6335   UFWORDX("LFA->XFA", LFA2XFA);
6336   UFWORDX("LFA->YFA", LFA2YFA);
6337   UFWORDX("LFA->NFA", LFA2NFA);
6338   UFWORDX("NFA->LFA", NFA2LFA);
6339   UFWORDX("CFA->WEND", CFA2WEND);
6340
6341   UFWORDX("ERROR", ERROR);
6342   UFWORDX("?ERROR", QERROR);
6343
6344   UFWORDX("(BASED-NUMBER)", PAR_BASED_NUMBER);
6345   UFWORDX("FIND-WORD", FIND_WORD);
6346   UFWORDX("FIND-WORD-IN-VOC", FIND_WORD_IN_VOC);
6347   UFWORDX("FIND-WORD-IN-VOC-AND-PARENTS", FIND_WORD_IN_VOC_AND_PARENTS);
6348
6349   UFWORDX_IMM("\"", QUOTE_IMM);
6350
6351   UFWORD(EXECUTE);
6352   UFWORDX("EXECUTE-TAIL", EXECUTE_TAIL);
6353
6354   UFWORD(DUP);
6355   UFWORDX("?DUP", QDUP);
6356   UFWORDX("2DUP", DDUP);
6357   UFWORD(DROP);
6358   UFWORDX("2DROP", DDROP);
6359   UFWORD(SWAP);
6360   UFWORDX("2SWAP", DSWAP);
6361   UFWORD(OVER);
6362   UFWORDX("2OVER", DOVER);
6363   UFWORD(ROT);
6364   UFWORD(NROT);
6365   UFWORDX("PICK", PICK);
6366   UFWORDX("ROLL", ROLL);
6367
6368   UFWORD(RDUP);
6369   UFWORD(RDROP);
6370   UFWORDX(">R", DTOR);
6371   UFWORDX("R>", RTOD);
6372   UFWORDX("R@", RPEEK);
6373   UFWORDX("RPICK", RPICK);
6374   UFWORDX("RROLL", RROLL);
6375   UFWORDX("RSWAP", RSWAP);
6376   UFWORDX("ROVER", ROVER);
6377   UFWORDX("RROT", RROT);
6378   UFWORDX("RNROT", RNROT);
6379
6380   UFWORDX("FLUSH-EMIT", FLUSH_EMIT);
6381   UFWORD(EMIT);
6382   UFWORD(XEMIT);
6383   UFWORD(TYPE);
6384   UFWORD(XTYPE);
6385   UFWORD(SPACE);
6386   UFWORD(SPACES);
6387   UFWORD(CR);
6388   UFWORD(ENDCR);
6389   UFWORDX("LASTCR?", LASTCRQ);
6390   UFWORDX("LASTCR!", LASTCRSET);
6391
6392   // simple math
6393   UFWORDX("+", PLUS);
6394   UFWORDX("-", MINUS);
6395   UFWORDX("*", MUL);
6396   UFWORDX("U*", UMUL);
6397   UFWORDX("/", DIV);
6398   UFWORDX("U/", UDIV);
6399   UFWORDX("MOD", MOD);
6400   UFWORDX("UMOD", UMOD);
6401   UFWORDX("/MOD", DIVMOD);
6402   UFWORDX("U/MOD", UDIVMOD);
6403   UFWORDX("*/", MULDIV);
6404   UFWORDX("U*/", UMULDIV);
6405   UFWORDX("*/MOD", MULDIVMOD);
6406   UFWORDX("U*/MOD", UMULDIVMOD);
6407   UFWORDX("M*", MMUL);
6408   UFWORDX("UM*", UMMUL);
6409   UFWORDX("M/MOD", MDIVMOD);
6410   UFWORDX("UM/MOD", UMDIVMOD);
6411
6412   UFWORDX("2U*", ONESHL);
6413   UFWORDX("2U/", ONESHR);
6414   UFWORDX("4U*", TWOSHL);
6415   UFWORDX("4U/", TWOSHR);
6416
6417   UFWORD(ASH);
6418   UFWORD(LSH);
6419
6420   // logic
6421   UFWORDX("<", LESS);
6422   UFWORDX(">", GREAT);
6423   UFWORDX("<=", LESSEQU);
6424   UFWORDX(">=", GREATEQU);
6425   UFWORDX("U<", ULESS);
6426   UFWORDX("U>", UGREAT);
6427   UFWORDX("U<=", ULESSEQU);
6428   UFWORDX("U>=", UGREATEQU);
6429   UFWORDX("=", EQU);
6430   UFWORDX("<>", NOTEQU);
6431
6432   UFWORD(NOT);
6433   UFWORD(BITNOT);
6434   UFWORD(AND);
6435   UFWORD(OR);
6436   UFWORD(XOR);
6437   UFWORDX("LOGAND", LOGAND);
6438   UFWORDX("LOGOR", LOGOR);
6439
6440   // TIB and parser
6441   UFWORDX("(TIB-IN)", TIB_IN);
6442   UFWORDX("TIB-PEEKCH", TIB_PEEKCH);
6443   UFWORDX("TIB-PEEKCH-OFS", TIB_PEEKCH_OFS);
6444   UFWORDX("TIB-GETCH", TIB_GETCH);
6445   UFWORDX("TIB-SKIPCH", TIB_SKIPCH);
6446
6447   UFWORDX("REFILL", REFILL);
6448   UFWORDX("REFILL-NOCROSS", REFILL_NOCROSS);
6449
6450   ufoHiddenWords();
6451   UFWORDX("(PARSE)", PAR_PARSE);
6452   UFWORDX("(PARSE-SKIP-COMMENTS)", PAR_PARSE_SKIP_COMMENTS);
6453   ufoPublicWords();
6454   UFWORDX("PARSE-SKIP-BLANKS", PARSE_SKIP_BLANKS);
6455   UFWORDX("PARSE-NAME", PARSE_NAME);
6456   UFWORDX("PARSE-SKIP-LINE", PARSE_SKIP_LINE);
6457   UFWORDX("PARSE", PARSE);
6458
6459   UFWORDX_IMM("[", LBRACKET_IMM);
6460   UFWORDX("]", RBRACKET);
6461
6462   ufoHiddenWords();
6463   UFWORDX("(VSP@)", PAR_GET_VSP);
6464   UFWORDX("(VSP!)", PAR_SET_VSP);
6465   UFWORDX("(VSP-AT@)", PAR_VSP_LOAD);
6466   UFWORDX("(VSP-AT!)", PAR_VSP_STORE);
6467   ufoDefineConstant("(VSP-SIZE)", UFO_VOCSTACK_SIZE);
6468
6469   ufoDefineConstant("(SP-SIZE)", UFO_DSTACK_SIZE);
6470   ufoDefineConstant("(RP-SIZE)", UFO_RSTACK_SIZE);
6471   ufoDefineConstant("(LP-SIZE)", UFO_LSTACK_SIZE);
6472   ufoPublicWords();
6473 }
6474
6475
6476 //==========================================================================
6477 //
6478 //  ufoInitHandleWords
6479 //
6480 //==========================================================================
6481 UFO_DISABLE_INLINE void ufoInitHandleWords (uint32_t handleVocId) {
6482   ufoVocSetOnlyDefs(handleVocId);
6483   UFWORDX("NEW", PAR_NEW_HANDLE);
6484   UFWORDX("FREE", PAR_FREE_HANDLE);
6485   UFWORDX("TYPEID@", PAR_HANDLE_GET_TYPEID);
6486   UFWORDX("TYPEID!", PAR_HANDLE_SET_TYPEID);
6487   UFWORDX("SIZE@", PAR_HANDLE_GET_SIZE);
6488   UFWORDX("SIZE!", PAR_HANDLE_SET_SIZE);
6489   UFWORDX("USED@", PAR_HANDLE_GET_USED);
6490   UFWORDX("USED!", PAR_HANDLE_SET_USED);
6491   UFWORDX("C@", PAR_HANDLE_LOAD_BYTE);
6492   UFWORDX("W@", PAR_HANDLE_LOAD_WORD);
6493   UFWORDX("@", PAR_HANDLE_LOAD_CELL);
6494   UFWORDX("C!", PAR_HANDLE_STORE_BYTE);
6495   UFWORDX("W!", PAR_HANDLE_STORE_WORD);
6496   UFWORDX("!", PAR_HANDLE_STORE_CELL);
6497   ufoVocSetOnlyDefs(ufoForthVocId);
6498 }
6499
6500
6501 //==========================================================================
6502 //
6503 //  ufoInitHigherWords
6504 //
6505 //==========================================================================
6506 UFO_DISABLE_INLINE void ufoInitHigherWords (void) {
6507   UFWORDX("(INCLUDE)", PAR_INCLUDE);
6508
6509   UFWORDX("(INCLUDE-DEPTH)", PAR_INCLUDE_DEPTH);
6510   UFWORDX("(INCLUDE-FILE-ID)", PAR_INCLUDE_FILE_ID);
6511   UFWORDX("(INCLUDE-FILE-LINE)", PAR_INCLUDE_FILE_LINE);
6512   UFWORDX("(INCLUDE-FILE-NAME)", PAR_INCLUDE_FILE_NAME);
6513
6514   UFWORDX("($DEFINED?)", PAR_DLR_DEFINEDQ);
6515   UFWORDX("($DEFINE)", PAR_DLR_DEFINE);
6516   UFWORDX("($UNDEF)", PAR_DLR_UNDEF);
6517
6518   UFWORDX_IMM("$INCLUDE", DLR_INCLUDE_IMM);
6519   UFWORDX_IMM("$INCLUDE-ONCE", DLR_INCLUDE_ONCE_IMM);
6520 }
6521
6522
6523 //==========================================================================
6524 //
6525 //  ufoInitStringWords
6526 //
6527 //==========================================================================
6528 UFO_DISABLE_INLINE void ufoInitStringWords (uint32_t stringVocId) {
6529   ufoVocSetOnlyDefs(stringVocId);
6530   UFWORDX("=", STREQU);
6531   UFWORDX("=CI", STREQUCI);
6532   UFWORDX("HASH", STRHASH);
6533   UFWORDX("HASH-CI", STRHASHCI);
6534   ufoVocSetOnlyDefs(ufoForthVocId);
6535 }
6536
6537
6538 //==========================================================================
6539 //
6540 //  ufoInitDebugWords
6541 //
6542 //==========================================================================
6543 UFO_DISABLE_INLINE void ufoInitDebugWords (uint32_t debugVocId) {
6544   ufoVocSetOnlyDefs(debugVocId);
6545   UFWORDX("(DECOMPILE-CFA)", DEBUG_DECOMPILE_CFA);
6546   UFWORDX("BACKTRACE", UFO_BACKTRACE);
6547   UFWORDX("DUMP-STACK", DUMP_STACK);
6548   UFWORDX("(BP)", MT_DEBUGGER_BP);
6549   UFWORDX("IP->NFA", IP2NFA);
6550   ufoVocSetOnlyDefs(ufoForthVocId);
6551 }
6552
6553
6554 //==========================================================================
6555 //
6556 //  ufoInitMTWords
6557 //
6558 //==========================================================================
6559 UFO_DISABLE_INLINE void ufoInitMTWords (uint32_t mtVocId) {
6560   ufoVocSetOnlyDefs(mtVocId);
6561   UFWORDX("NEW-STATE", MT_NEW_STATE);
6562   UFWORDX("FREE-STATE", MT_FREE_STATE);
6563   UFWORDX("STATE-NAME@", MT_GET_STATE_NAME);
6564   UFWORDX("STATE-NAME!", MT_SET_STATE_NAME);
6565   UFWORDX("STATE-FIRST", MT_STATE_FIRST);
6566   UFWORDX("STATE-NEXT", MT_STATE_NEXT);
6567   UFWORDX("YIELD-TO", MT_YIELD_TO);
6568   UFWORDX("SET-SELF-AS-DEBUGGER", MT_SET_SELF_AS_DEBUGGER);
6569   UFWORDX("DEBUGGER-RESUME", MT_RESUME_DEBUGEE);
6570   UFWORDX("DEBUGGER-SINGLE-STEP", MT_SINGLE_STEP_DEBUGEE);
6571   UFWORDX("ACTIVE-STATE", MT_ACTIVE_STATE);
6572   UFWORDX("STATE-IP@", MT_STATE_IP_GET);
6573   UFWORDX("STATE-IP!", MT_STATE_IP_SET);
6574   UFWORDX("STATE-A@", MT_STATE_REGA_GET);
6575   UFWORDX("STATE-A!", MT_STATE_REGA_SET);
6576   UFWORDX("STATE-BASE@", MT_STATE_BASE_GET);
6577   UFWORDX("STATE-BASE!", MT_STATE_BASE_SET);
6578   UFWORDX("STATE-RPOPCFA@", MT_STATE_RPOPCFA_GET);
6579   UFWORDX("STATE-RPOPCFA!", MT_STATE_RPOPCFA_SET);
6580   UFWORDX("YIELDED-FROM", MT_YIELDED_FROM);
6581   UFWORDX("STATE-SP@", MT_DSTACK_DEPTH_GET);
6582   UFWORDX("STATE-RP@", MT_RSTACK_DEPTH_GET);
6583   UFWORDX("STATE-LP@", MT_LP_GET);
6584   UFWORDX("STATE-LBP@", MT_LBP_GET);
6585   UFWORDX("STATE-SP!", MT_DSTACK_DEPTH_SET);
6586   UFWORDX("STATE-RP!", MT_RSTACK_DEPTH_SET);
6587   UFWORDX("STATE-LP!", MT_LP_SET);
6588   UFWORDX("STATE-LBP!", MT_LBP_SET);
6589   UFWORDX("STATE-DS@", MT_DSTACK_LOAD);
6590   UFWORDX("STATE-RS@", MT_RSTACK_LOAD);
6591   UFWORDX("STATE-LS@", MT_LSTACK_LOAD);
6592   UFWORDX("STATE-DS!", MT_DSTACK_STORE);
6593   UFWORDX("STATE-RS!", MT_RSTACK_STORE);
6594   UFWORDX("STATE-LS!", MT_LSTACK_STORE);
6595   ufoVocSetOnlyDefs(ufoForthVocId);
6596 }
6597
6598
6599 //==========================================================================
6600 //
6601 //  ufoInitVeryVeryHighWords
6602 //
6603 //==========================================================================
6604 UFO_DISABLE_INLINE void ufoInitVeryVeryHighWords (void) {
6605   // interpret defer
6606   //ufoDefineDefer("INTERPRET", idumbCFA);
6607
6608   // ( addr count FALSE -- addr count FALSE / TRUE )
6609   ufoDefineSColonForth("(INTERPRET-CHECK-WORD)");
6610     UFC("FORTH:(EXIT)");
6611   ufoDoneForth();
6612   // ( addr count FALSE -- addr count FALSE / TRUE )
6613   ufoDefineSColonForth("(INTERPRET-WORD-NOT-FOUND)");
6614     UFC("FORTH:(EXIT)");
6615   ufoDoneForth();
6616   // ( FALSE -- FALSE / TRUE ) -- called in "EXIT", before compiling "FORTH:(EXIT)"
6617   // return TRUE to stop calling other chained words, and omit default exit
6618   ufoDefineSColonForth("(EXIT-EXTENDER)");
6619     UFC("FORTH:(EXIT)");
6620   ufoDoneForth();
6621
6622   // create "FORTH:EXIT"
6623   // : EXIT  ?COMP COMPILE FORTH:(EXIT) ;
6624   ufoDefineForthImm("EXIT");
6625     UFC("COMPILER:?COMP");
6626     UFC("FALSE"); UFC("(EXIT-EXTENDER)");
6627     UFC("FORTH:(TBRANCH)"); const uint32_t exit_branch_end = ufoMarkFwd();
6628     UFC("FORTH:(LITCFA)"); UFC("FORTH:(EXIT)");
6629     UFC("FORTH:COMPILE,");
6630     ufoResolveFwd(exit_branch_end);
6631     UFC("FORTH:(EXIT)");
6632   ufoDoneForth();
6633
6634   ufoDefineInterpret();
6635
6636   //ufoDumpVocab(ufoCompilerVocId);
6637
6638   ufoDefineForth("RUN-INTERPRET-LOOP");
6639     const uint32_t addrAgain = UFO_GET_DP();
6640     UFC("RP0!");
6641     UFC("INTERPRET");
6642     UFC("FORTH:(BRANCH)");
6643     ufoImgEmitU32(addrAgain);
6644   ufoDoneForth();
6645 }
6646
6647 #define UFO_ADD_DO_CFA(cfx_)  do { \
6648   ufoDo##cfx_##CFA = ufoCFAsUsed | UFO_ADDR_CFA_BIT; \
6649   ufoForthCFAs[ufoCFAsUsed] = &ufoDo##cfx_; \
6650   ufoCFAsUsed += 1; \
6651 } while (0)
6652
6653
6654 //==========================================================================
6655 //
6656 //  ufoInitCommon
6657 //
6658 //==========================================================================
6659 UFO_DISABLE_INLINE void ufoInitCommon (void) {
6660   ufoVSP = 0;
6661   ufoForthVocId = 0; ufoCompilerVocId = 0;
6662
6663   ufoForthCFAs = calloc(UFO_MAX_NATIVE_CFAS, sizeof(ufoForthCFAs[0]));
6664
6665   // allocate default TIB handle
6666   UHandleInfo *tibh = ufoAllocHandle(0x69a029a6); // arbitrary number
6667   ufoDefTIB = tibh->ufoHandle;
6668
6669   ufoForthCFAs[0] = NULL; ufoCFAsUsed = 1u;
6670   UFO_ADD_DO_CFA(Forth);
6671   UFO_ADD_DO_CFA(Variable);
6672   UFO_ADD_DO_CFA(Value);
6673   UFO_ADD_DO_CFA(Const);
6674   UFO_ADD_DO_CFA(Defer);
6675   UFO_ADD_DO_CFA(Voc);
6676   UFO_ADD_DO_CFA(Create);
6677
6678   //fprintf(stderr, "DO-FORTH-CFA: 0x%08x\n", ufoDoForthCFA);
6679
6680   ufoInitBaseDict();
6681
6682   // create "FORTH" vocabulary
6683   ufoForthVocId = ufoCreateVoc("FORTH", 0, UFW_FLAG_PROTECTED);
6684   ufoVocSetOnlyDefs(ufoForthVocId);
6685
6686   // create "COMPILER" vocabulary
6687   ufoCompilerVocId = ufoCreateVoc("COMPILER", 0, UFW_FLAG_PROTECTED);
6688
6689   // create "STRING" vocabulary
6690   uint32_t stringVocId = ufoCreateVoc("STRING", 0, UFW_FLAG_PROTECTED);
6691
6692   // create "HANDLE" vocabulary
6693   uint32_t handleVocId = ufoCreateVoc("HANDLE", 0, UFW_FLAG_PROTECTED);
6694
6695   // create "DEBUG" vocabulary
6696   uint32_t debugVocId = ufoCreateVoc("DEBUG", 0, UFW_FLAG_PROTECTED);
6697
6698   // create "MTASK" vocabulary
6699   uint32_t mtVocId = ufoCreateVoc("MTASK", 0, UFW_FLAG_PROTECTED);
6700
6701   // base low-level interpreter words
6702   ufoInitBasicWords();
6703
6704   // some COMPILER words
6705   ufoInitBasicCompilerWords();
6706
6707   // more FORTH words
6708   ufoInitMoreWords();
6709
6710   // HANDLE vocabulary
6711   ufoInitHandleWords(handleVocId);
6712
6713   // some higher-level FORTH words (includes, etc.)
6714   ufoInitHigherWords();
6715
6716   // STRING vocabulary
6717   ufoInitStringWords(stringVocId);
6718
6719   // DEBUG vocabulary
6720   ufoInitDebugWords(debugVocId);
6721
6722   // MTASK vocabulary
6723   ufoInitMTWords(mtVocId);
6724
6725   // very-very high-level FORTH words
6726   ufoInitVeryVeryHighWords();
6727
6728   #if 0
6729   ufoDecompileWord(ufoFindWordChecked("RUN-INTERPRET-LOOP"));
6730   #endif
6731
6732   ufoReset();
6733 }
6734
6735 #undef UFC
6736
6737
6738 // ////////////////////////////////////////////////////////////////////////// //
6739 // virtual machine executor
6740 //
6741
6742
6743 //==========================================================================
6744 //
6745 //  ufoRunVM
6746 //
6747 //  address interpreter
6748 //
6749 //==========================================================================
6750 static void ufoRunVMCFA (uint32_t cfa) {
6751   const uint32_t oldRPTop = ufoRPTop;
6752   ufoRPTop = ufoRP;
6753   #ifdef UFO_TRACE_VM_RUN
6754   fprintf(stderr, "**VM-INITIAL**: cfa=%u\n", cfa);
6755   UFCALL(DUMP_STACK);
6756   #endif
6757   ufoRPush(cfa);
6758   ufoVMRPopCFA = 1;
6759   ufoVMStop = 0;
6760   // VM execution loop
6761   do {
6762     if (ufoVMAbort) ufoFatal("user abort");
6763     if (ufoVMStop) { ufoRP = oldRPTop; break; }
6764     if (ufoCurrState == NULL) ufoFatal("execution state is lost");
6765     if (ufoVMRPopCFA == 0) {
6766       // check IP
6767       if (ufoIP == 0) ufoFatal("IP is NULL");
6768       if (ufoIP & UFO_ADDR_HANDLE_BIT) ufoFatal("IP is a handle");
6769       cfa = ufoImgGetU32(ufoIP); ufoIP += 4u;
6770     } else {
6771       cfa = ufoRPop(); ufoVMRPopCFA = 0;
6772     }
6773     // check CFA sanity
6774     if (cfa == 0) ufoFatal("EXECUTE: NULL CFA");
6775     if (cfa & UFO_ADDR_HANDLE_BIT) ufoFatal("cannot execute handle");
6776     // get next word CFAIDX, and check it
6777     uint32_t cfaidx = ufoImgGetU32(cfa);
6778     if (cfaidx & UFO_ADDR_HANDLE_BIT) ufoFatal("cannot execute CFAIDX-handle");
6779     #ifdef UFO_TRACE_VM_RUN
6780     fprintf(stderr, "**VM**: IP=%u; cfa=%u; cfaidx=0x%08x\n", ufoIP - 4u, cfa, cfaidx);
6781     UFCALL(DUMP_STACK);
6782     ufoDumpWordHeader(UFO_CFA_TO_LFA(cfa));
6783     fprintf(stderr, "######################################\n");
6784     #endif
6785     if (cfaidx & UFO_ADDR_CFA_BIT) {
6786       cfaidx &= UFO_ADDR_CFA_MASK;
6787       if (cfaidx >= ufoCFAsUsed || ufoForthCFAs[cfaidx] == NULL) {
6788         ufoFatal("tried to execute an unknown word: %u (max is %u); IP=%u",
6789                  cfaidx, ufoCFAsUsed, ufoIP - 4u);
6790       }
6791       #ifdef UFO_TRACE_VM_RUN
6792       fprintf(stderr, "**VM-NATIVE**: cfaidx=%u (doForth=%u)\n", cfaidx,
6793               (ufoDoForthCFA & UFO_ADDR_CFA_MASK));
6794       #endif
6795       ufoForthCFAs[cfaidx](UFO_CFA_TO_PFA(cfa));
6796     } else {
6797       // if CFA points somewhere inside a dict, this is "DOES>" word
6798       // IP points to PFA we need to push
6799       // CFA points to Forth word we need to jump to
6800       #ifdef UFO_TRACE_VM_DOER
6801       fprintf(stderr, "*** DOER! IP=%u; cfa=%u; cfaidx=%u ***\n", ufoIP, cfa, cfaidx);
6802       UFCALL(UFO_BACKTRACE);
6803       #endif
6804       ufoPush(UFO_CFA_TO_PFA(cfa)); // push PFA
6805       ufoRPush(ufoIP); // push IP
6806       ufoIP = cfaidx; // fix IP
6807     }
6808     // that's all we need to activate the debugger
6809     if (ufoSingleStep) {
6810       ufoSingleStep -= 1;
6811       if (ufoSingleStep == 0 && ufoDebuggerState != NULL) {
6812         if (ufoCurrState == ufoDebuggerState) ufoFatal("debugger cannot debug itself");
6813         UfoState *ost = ufoCurrState;
6814         ufoSwitchToState(ufoDebuggerState); // always use API call for this!
6815         ufoPush(-2);
6816         ufoPush(ost->id);
6817       }
6818     }
6819   } while (ufoRP != oldRPTop);
6820   //ufoVMStop = 0;
6821 }
6822
6823
6824 // ////////////////////////////////////////////////////////////////////////// //
6825 // high-level API
6826 //
6827
6828 //==========================================================================
6829 //
6830 //  ufoRegisterWord
6831 //
6832 //  register new word
6833 //
6834 //==========================================================================
6835 uint32_t ufoRegisterWord (const char *wname, ufoNativeCFA cfa, uint32_t flags) {
6836   ufo_assert(cfa != NULL);
6837   ufo_assert(wname != NULL && wname[0] != 0);
6838   uint32_t cfaidx = ufoCFAsUsed;
6839   if (cfaidx >= UFO_MAX_NATIVE_CFAS) ufoFatal("too many native words");
6840   ufoForthCFAs[cfaidx] = cfa;
6841   ufoCFAsUsed += 1;
6842   //ufoDefineNative(wname, xcfa, 0);
6843   cfaidx |= UFO_ADDR_CFA_BIT;
6844   flags &= 0xffffff00u;
6845   ufoCreateWordHeader(wname, flags);
6846   const uint32_t res = UFO_GET_DP();
6847   ufoImgEmitU32(cfaidx);
6848   return res;
6849 }
6850
6851
6852 //==========================================================================
6853 //
6854 //  ufoRegisterDataWord
6855 //
6856 //==========================================================================
6857 static uint32_t ufoRegisterDataWord (const char *wname, uint32_t cfaidx, uint32_t value,
6858                                      uint32_t flags)
6859 {
6860   ufo_assert(wname != NULL && wname[0] != 0);
6861   flags &= 0xffffff00u;
6862   ufoCreateWordHeader(wname, flags);
6863   ufoImgEmitU32(cfaidx);
6864   const uint32_t res = UFO_GET_DP();
6865   ufoImgEmitU32(value);
6866   return res;
6867 }
6868
6869
6870 //==========================================================================
6871 //
6872 //  ufoRegisterConstant
6873 //
6874 //==========================================================================
6875 void ufoRegisterConstant (const char *wname, uint32_t value, uint32_t flags) {
6876   (void)ufoRegisterDataWord(wname, ufoDoConstCFA, value, flags);
6877 }
6878
6879
6880 //==========================================================================
6881 //
6882 //  ufoRegisterVariable
6883 //
6884 //==========================================================================
6885 uint32_t ufoRegisterVariable (const char *wname, uint32_t value, uint32_t flags) {
6886   return ufoRegisterDataWord(wname, ufoDoVariableCFA, value, flags);
6887 }
6888
6889
6890 //==========================================================================
6891 //
6892 //  ufoRegisterValue
6893 //
6894 //==========================================================================
6895 uint32_t ufoRegisterValue (const char *wname, uint32_t value, uint32_t flags) {
6896   return ufoRegisterDataWord(wname, ufoDoValueCFA, value, flags);
6897 }
6898
6899
6900 //==========================================================================
6901 //
6902 //  ufoRegisterDefer
6903 //
6904 //==========================================================================
6905 uint32_t ufoRegisterDefer (const char *wname, uint32_t value, uint32_t flags) {
6906   return ufoRegisterDataWord(wname, ufoDoDeferCFA, value, flags);
6907 }
6908
6909
6910 //==========================================================================
6911 //
6912 //  ufoFindWordInVocabulary
6913 //
6914 //  check if we have the corresponding word.
6915 //  return CFA suitable for executing, or 0.
6916 //
6917 //==========================================================================
6918 uint32_t ufoFindWordInVocabulary (const char *wname, uint32_t vocid) {
6919   if (wname == NULL || wname[0] == 0) return 0;
6920   size_t wlen = strlen(wname);
6921   if (wlen >= UFO_MAX_WORD_LENGTH) return 0;
6922   return ufoFindWordInVocAndParents(wname, (uint32_t)wlen, 0, vocid, 0);
6923 }
6924
6925
6926 //==========================================================================
6927 //
6928 //  ufoGetIP
6929 //
6930 //==========================================================================
6931 uint32_t ufoGetIP (void) {
6932   return ufoIP;
6933 }
6934
6935
6936 //==========================================================================
6937 //
6938 //  ufoSetIP
6939 //
6940 //==========================================================================
6941 void ufoSetIP (uint32_t newip) {
6942   ufoIP = newip;
6943 }
6944
6945
6946 //==========================================================================
6947 //
6948 //  ufoIsExecuting
6949 //
6950 //==========================================================================
6951 int ufoIsExecuting (void) {
6952   return (ufoImgGetU32(ufoAddrSTATE) == 0);
6953 }
6954
6955
6956 //==========================================================================
6957 //
6958 //  ufoIsCompiling
6959 //
6960 //==========================================================================
6961 int ufoIsCompiling (void) {
6962   return (ufoImgGetU32(ufoAddrSTATE) != 0);
6963 }
6964
6965
6966 //==========================================================================
6967 //
6968 //  ufoSetExecuting
6969 //
6970 //==========================================================================
6971 void ufoSetExecuting (void) {
6972   ufoImgPutU32(ufoAddrSTATE, 0);
6973 }
6974
6975
6976 //==========================================================================
6977 //
6978 //  ufoSetCompiling
6979 //
6980 //==========================================================================
6981 void ufoSetCompiling (void) {
6982   ufoImgPutU32(ufoAddrSTATE, 1);
6983 }
6984
6985
6986 //==========================================================================
6987 //
6988 //  ufoGetHere
6989 //
6990 //==========================================================================
6991 uint32_t ufoGetHere () {
6992   return UFO_GET_DP();
6993 }
6994
6995
6996 //==========================================================================
6997 //
6998 //  ufoGetPad
6999 //
7000 //==========================================================================
7001 uint32_t ufoGetPad () {
7002   UFCALL(PAD);
7003   return ufoPop();
7004 }
7005
7006
7007 //==========================================================================
7008 //
7009 //  ufoTIBPeekCh
7010 //
7011 //==========================================================================
7012 uint8_t ufoTIBPeekCh (uint32_t ofs) {
7013   return ufoTibPeekChOfs(ofs);
7014 }
7015
7016
7017 //==========================================================================
7018 //
7019 //  ufoTIBGetCh
7020 //
7021 //==========================================================================
7022 uint8_t ufoTIBGetCh (void) {
7023   return ufoTibGetCh();
7024 }
7025
7026
7027 //==========================================================================
7028 //
7029 //  ufoTIBSkipCh
7030 //
7031 //==========================================================================
7032 void ufoTIBSkipCh (void) {
7033   ufoTibSkipCh();
7034 }
7035
7036
7037 //==========================================================================
7038 //
7039 //  ufoTIBSRefill
7040 //
7041 //  returns 0 on EOF
7042 //
7043 //==========================================================================
7044 int ufoTIBSRefill (int allowCrossIncludes) {
7045   return ufoLoadNextLine(allowCrossIncludes);
7046 }
7047
7048
7049 //==========================================================================
7050 //
7051 //  ufoPeekData
7052 //
7053 //==========================================================================
7054 uint32_t ufoPeekData (void) {
7055   return ufoPeek();
7056 }
7057
7058
7059 //==========================================================================
7060 //
7061 //  ufoPopData
7062 //
7063 //==========================================================================
7064 uint32_t ufoPopData (void) {
7065   return ufoPop();
7066 }
7067
7068
7069 //==========================================================================
7070 //
7071 //  ufoPushData
7072 //
7073 //==========================================================================
7074 void ufoPushData (uint32_t value) {
7075   return ufoPush(value);
7076 }
7077
7078
7079 //==========================================================================
7080 //
7081 //  ufoPushBoolData
7082 //
7083 //==========================================================================
7084 void ufoPushBoolData (int val) {
7085   ufoPushBool(val);
7086 }
7087
7088
7089 //==========================================================================
7090 //
7091 //  ufoPeekRet
7092 //
7093 //==========================================================================
7094 uint32_t ufoPeekRet (void) {
7095   return ufoRPeek();
7096 }
7097
7098
7099 //==========================================================================
7100 //
7101 //  ufoPopRet
7102 //
7103 //==========================================================================
7104 uint32_t ufoPopRet (void) {
7105   return ufoRPop();
7106 }
7107
7108
7109 //==========================================================================
7110 //
7111 //  ufoPushRet
7112 //
7113 //==========================================================================
7114 void ufoPushRet (uint32_t value) {
7115   return ufoRPush(value);
7116 }
7117
7118
7119 //==========================================================================
7120 //
7121 //  ufoPushBoolRet
7122 //
7123 //==========================================================================
7124 void ufoPushBoolRet (int val) {
7125   ufoRPush(val ? ufoTrueValue : 0);
7126 }
7127
7128
7129 //==========================================================================
7130 //
7131 //  ufoPeekByte
7132 //
7133 //==========================================================================
7134 uint8_t ufoPeekByte (uint32_t addr) {
7135   return ufoImgGetU8Ext(addr);
7136 }
7137
7138
7139 //==========================================================================
7140 //
7141 //  ufoPeekWord
7142 //
7143 //==========================================================================
7144 uint16_t ufoPeekWord (uint32_t addr) {
7145   ufoPush(addr);
7146   UFCALL(WPEEK);
7147   return ufoPop();
7148 }
7149
7150
7151 //==========================================================================
7152 //
7153 //  ufoPeekCell
7154 //
7155 //==========================================================================
7156 uint32_t ufoPeekCell (uint32_t addr) {
7157   ufoPush(addr);
7158   UFCALL(PEEK);
7159   return ufoPop();
7160 }
7161
7162
7163 //==========================================================================
7164 //
7165 //  ufoPokeByte
7166 //
7167 //==========================================================================
7168 void ufoPokeByte (uint32_t addr, uint32_t value) {
7169   ufoImgPutU8(addr, value);
7170 }
7171
7172
7173 //==========================================================================
7174 //
7175 //  ufoPokeWord
7176 //
7177 //==========================================================================
7178 void ufoPokeWord (uint32_t addr, uint32_t value) {
7179   ufoPush(value);
7180   ufoPush(addr);
7181   UFCALL(WPOKE);
7182 }
7183
7184
7185 //==========================================================================
7186 //
7187 //  ufoPokeCell
7188 //
7189 //==========================================================================
7190 void ufoPokeCell (uint32_t addr, uint32_t value) {
7191   ufoPush(value);
7192   ufoPush(addr);
7193   UFCALL(POKE);
7194 }
7195
7196
7197 //==========================================================================
7198 //
7199 //  ufoEmitByte
7200 //
7201 //==========================================================================
7202 void ufoEmitByte (uint32_t value) {
7203   ufoImgEmitU8(value);
7204 }
7205
7206
7207 //==========================================================================
7208 //
7209 //  ufoEmitWord
7210 //
7211 //==========================================================================
7212 void ufoEmitWord (uint32_t value) {
7213   ufoImgEmitU8(value & 0xff);
7214   ufoImgEmitU8((value >> 8) & 0xff);
7215 }
7216
7217
7218 //==========================================================================
7219 //
7220 //  ufoEmitCell
7221 //
7222 //==========================================================================
7223 void ufoEmitCell (uint32_t value) {
7224   ufoImgEmitU32(value);
7225 }
7226
7227
7228 //==========================================================================
7229 //
7230 //  ufoIsInited
7231 //
7232 //==========================================================================
7233 int ufoIsInited (void) {
7234   return (ufoMode != UFO_MODE_NONE);
7235 }
7236
7237
7238 static void (*ufoUserPostInitCB) (void);
7239
7240
7241 //==========================================================================
7242 //
7243 //  ufoSetUserPostInit
7244 //
7245 //  called after main initialisation
7246 //
7247 //==========================================================================
7248 void ufoSetUserPostInit (void (*cb) (void)) {
7249   ufoUserPostInitCB = cb;
7250 }
7251
7252
7253 //==========================================================================
7254 //
7255 //  ufoInit
7256 //
7257 //==========================================================================
7258 void ufoInit (void) {
7259   if (ufoMode != UFO_MODE_NONE) return;
7260   ufoMode = UFO_MODE_NATIVE;
7261
7262   ufoInFileLine = 0;
7263   ufoInFileName = NULL;
7264   ufoInFile = NULL;
7265   ufoLastIncPath = NULL;
7266
7267   for (uint32_t f = 0; f < UFO_MAX_STATES; f += 1u) ufoStateMap[f] = NULL;
7268   memset(ufoStateUsedBitmap, 0, sizeof(ufoStateUsedBitmap));
7269
7270   ufoCurrState = ufoNewState(0); // CFA doesn't matter here
7271   strcpy(ufoCurrState->name, "MAIN");
7272   ufoYieldedState = NULL;
7273   ufoDebuggerState = NULL;
7274   ufoSingleStep = 0;
7275
7276   #ifdef UFO_DEBUG_STARTUP_TIMES
7277   uint32_t stt = ufo_get_msecs();
7278   ufoCondDefine("UFO-DEBUG-STARTUP-TIMES");
7279   #endif
7280   ufoInitCommon();
7281   #ifdef UFO_DEBUG_STARTUP_TIMES
7282   uint32_t ett = ufo_get_msecs();
7283   fprintf(stderr, "UrForth init time: %u msecs\n", (unsigned)(ett - stt));
7284   #endif
7285
7286   ufoReset();
7287
7288   if (ufoUserPostInitCB) {
7289     ufoUserPostInitCB();
7290     ufoReset();
7291   }
7292
7293   // load ufo modules
7294   char *ufmname = ufoCreateIncludeName("init", 1, NULL);
7295   #ifdef WIN32
7296   FILE *ufl = fopen(ufmname, "rb");
7297   #else
7298   FILE *ufl = fopen(ufmname, "r");
7299   #endif
7300   if (ufl) {
7301     ufoPushInFile();
7302     ufoInFileName = ufmname;
7303     ufoInFile = ufl;
7304     ufoFileId = ufoLastUsedFileId;
7305     setLastIncPath(ufoInFileName);
7306   } else {
7307     free(ufmname);
7308     ufoFatal("cannot load init code");
7309   }
7310
7311   if (ufoInFile != NULL) {
7312     ufoRunInterpretLoop();
7313   }
7314 }
7315
7316
7317 //==========================================================================
7318 //
7319 //  ufoFinishVM
7320 //
7321 //==========================================================================
7322 void ufoFinishVM (void) {
7323   ufoVMStop = 1;
7324 }
7325
7326
7327 //==========================================================================
7328 //
7329 //  ufoWasVMFinished
7330 //
7331 //  check if VM was exited due to `ufoFinishVM()`
7332 //
7333 //==========================================================================
7334 int ufoWasVMFinished (void) {
7335   return (ufoVMStop != 0);
7336 }
7337
7338
7339 //==========================================================================
7340 //
7341 //  ufoCallParseIntr
7342 //
7343 //  ( -- addr count TRUE / FALSE )
7344 //  does base TIB parsing; never copies anything.
7345 //  as our reader is line-based, returns FALSE on EOL.
7346 //  EOL is detected after skipping leading delimiters.
7347 //  passing -1 as delimiter skips the whole line, and always returns FALSE.
7348 //  trailing delimiter is always skipped.
7349 //  result is on the data stack.
7350 //
7351 //==========================================================================
7352 void ufoCallParseIntr (uint32_t delim, int skipLeading) {
7353   ufoPush(delim); ufoPushBool(skipLeading);
7354   UFCALL(PAR_PARSE);
7355 }
7356
7357 //==========================================================================
7358 //
7359 //  ufoCallParseName
7360 //
7361 //  ( -- addr count )
7362 //  parse with leading blanks skipping. doesn't copy anything.
7363 //  return empty string on EOL.
7364 //
7365 //==========================================================================
7366 void ufoCallParseName (void) {
7367   UFCALL(PARSE_NAME);
7368 }
7369
7370
7371 //==========================================================================
7372 //
7373 //  ufoCallParse
7374 //
7375 //  ( -- addr count TRUE / FALSE )
7376 //  parse without skipping delimiters; never copies anything.
7377 //  as our reader is line-based, returns FALSE on EOL.
7378 //  passing 0 as delimiter skips the whole line, and always returns FALSE.
7379 //  trailing delimiter is always skipped.
7380 //
7381 //==========================================================================
7382 void ufoCallParse (uint32_t delim) {
7383   ufoPush(delim);
7384   UFCALL(PARSE);
7385 }
7386
7387
7388 //==========================================================================
7389 //
7390 //  ufoCallParseSkipBlanks
7391 //
7392 //==========================================================================
7393 void ufoCallParseSkipBlanks (void) {
7394   UFCALL(PARSE_SKIP_BLANKS);
7395 }
7396
7397
7398 //==========================================================================
7399 //
7400 //  ufoCallParseSkipComments
7401 //
7402 //==========================================================================
7403 void ufoCallParseSkipComments (void) {
7404   ufoPushBool(1); UFCALL(PAR_PARSE_SKIP_COMMENTS);
7405 }
7406
7407
7408 //==========================================================================
7409 //
7410 //  ufoCallParseSkipLineComments
7411 //
7412 //==========================================================================
7413 void ufoCallParseSkipLineComments (void) {
7414   ufoPushBool(0); UFCALL(PAR_PARSE_SKIP_COMMENTS);
7415 }
7416
7417
7418 //==========================================================================
7419 //
7420 //  ufoCallParseSkipLine
7421 //
7422 //  to the end of line; doesn't refill
7423 //
7424 //==========================================================================
7425 void ufoCallParseSkipLine (void) {
7426   UFCALL(PARSE_SKIP_LINE);
7427 }
7428
7429
7430 //==========================================================================
7431 //
7432 //  ufoCallBasedNumber
7433 //
7434 //  convert number from addrl+1
7435 //  returns address of the first inconvertible char
7436 //  (BASED-NUMBER) ( addr count allowsign? base -- num TRUE / FALSE )
7437 //
7438 //==========================================================================
7439 void ufoCallBasedNumber (uint32_t addr, uint32_t count, int allowSign, int base) {
7440   ufoPush(addr); ufoPush(count); ufoPushBool(allowSign);
7441   if (base < 0) ufoPush(0); else ufoPush((uint32_t)base);
7442   UFCALL(PAR_BASED_NUMBER);
7443 }
7444
7445
7446 //==========================================================================
7447 //
7448 //  ufoRunWord
7449 //
7450 //==========================================================================
7451 void ufoRunWord (uint32_t cfa) {
7452   if (cfa != 0) {
7453     if (ufoMode == UFO_MODE_NONE) ufoFatal("UrForth is not properly inited");
7454     if (ufoInRunWord) ufoFatal("`ufoRunWord` cannot be called recursively");
7455     ufoMode = UFO_MODE_NATIVE;
7456     ufoInRunWord = 1;
7457     ufoRunVMCFA(cfa);
7458     ufoInRunWord = 0;
7459   }
7460 }
7461
7462
7463 //==========================================================================
7464 //
7465 //  ufoRunMacroWord
7466 //
7467 //==========================================================================
7468 void ufoRunMacroWord (uint32_t cfa) {
7469   if (cfa != 0) {
7470     if (ufoMode == UFO_MODE_NONE) ufoFatal("UrForth is not properly inited");
7471     if (ufoInRunWord) ufoFatal("`ufoRunWord` cannot be called recursively");
7472     ufoMode = UFO_MODE_MACRO;
7473     const uint32_t oisp = ufoFileStackPos;
7474     ufoPushInFile();
7475     ufoFileId = 0;
7476     (void)ufoLoadNextUserLine();
7477     ufoInRunWord = 1;
7478     ufoRunVMCFA(cfa);
7479     ufoInRunWord = 0;
7480     ufoPopInFile();
7481     ufo_assert(ufoFileStackPos == oisp); // sanity check
7482   }
7483 }
7484
7485
7486 //==========================================================================
7487 //
7488 //  ufoIsInMacroMode
7489 //
7490 //  check if we are currently in "MACRO" mode.
7491 //  should be called from registered words.
7492 //
7493 //==========================================================================
7494 int ufoIsInMacroMode (void) {
7495   return (ufoMode == UFO_MODE_MACRO);
7496 }
7497
7498
7499 //==========================================================================
7500 //
7501 //  ufoRunInterpretLoop
7502 //
7503 //  run default interpret loop.
7504 //
7505 //==========================================================================
7506 void ufoRunInterpretLoop (void) {
7507   if (ufoMode == UFO_MODE_NONE) {
7508     ufoInit();
7509   }
7510   const uint32_t cfa = ufoFindWord("RUN-INTERPRET-LOOP");
7511   if (cfa == 0) ufoFatal("'RUN-INTERPRET-LOOP' word not found");
7512   ufoReset();
7513   ufoMode = UFO_MODE_NATIVE;
7514   ufoInRunWord = 1;
7515   ufoRunVMCFA(cfa);
7516   ufoInRunWord = 0;
7517   while (ufoFileStackPos != 0) ufoPopInFile();
7518 }
7519
7520
7521 //==========================================================================
7522 //
7523 //  ufoRunFile
7524 //
7525 //==========================================================================
7526 void ufoRunFile (const char *fname) {
7527   if (ufoMode == UFO_MODE_NONE) {
7528     ufoInit();
7529   }
7530   if (ufoInRunWord) ufoFatal("`ufoRunFile` cannot be called recursively");
7531   ufoMode = UFO_MODE_NATIVE;
7532
7533   ufoReset();
7534   char *ufmname = ufoCreateIncludeName(fname, 0, ".");
7535   #ifdef WIN32
7536   FILE *ufl = fopen(ufmname, "rb");
7537   #else
7538   FILE *ufl = fopen(ufmname, "r");
7539   #endif
7540   if (ufl) {
7541     ufoPushInFile();
7542     ufoInFileName = ufmname;
7543     ufoInFile = ufl;
7544     ufoFileId = ufoLastUsedFileId;
7545     setLastIncPath(ufoInFileName);
7546   } else {
7547     free(ufmname);
7548     ufoFatal("cannot load source file '%s'", fname);
7549   }
7550   ufoRunInterpretLoop();
7551 }