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