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