src/urforth.c

   1 // and now for something completely different...
   2 // UrAsm built-in Forth Engine!
   3 // GPLv3 ONLY
   4 #include <stdarg.h>
   5 #include <setjmp.h>
   6 #include <stdio.h>
   7 #include <stdlib.h>
   8 #include <string.h>
   9 #include <unistd.h>
  10
  11 #include <sys/stat.h>
  12 #include <sys/types.h>
  13
  14 #include "urforth.h"
  15
  16
  17 #define UFO_DEBUG_FATAL_ABORT
  18 //#define UFO_TRACE_VM_RUN
  19 //#define UFO_DEBUG_INCLUDE
  20 //#define UFO_DEBUG_DUMP_NEW_HEADERS
  21 //#define UFO_DEBUG_FIND_WORD
  22 //#define UFO_DEBUG_FIND_WORD_IN_VOC
  23 //#define UFO_DEBUG_FIND_WORD_COLON
  24 //#define UFO_DEBUG_SEMI
  25
  26 #define UFO_FORCE_INLINE static inline __attribute__((always_inline))
  27 #define UFO_INLINE static inline
  28
  29
  30 #define UFO_QPAIRS_BEGIN  (1)
  31 #define UFO_QPAIRS_IF     (2)
  32 #define UFO_QPAIRS_DO     (3)
  33 #define UFO_QPAIRS_CASE   (4)
  34 #define UFO_QPAIRS_OF     (5)
  35 #define UFO_QPAIRS_OTHER  (6)
  36 #define UFO_QPAIRS_WHILE  (7)
  37 #define UFO_QPAIRS_FOR    (8)
  38 #define UFO_QPAIRS_CBLOCK (666)
  39
  40 // should not be bigger than this!
  41 #define UFO_MAX_WORD_LENGTH  (250)
  42
  43 #define UFO_ALIGN4(v_)  (((v_) + 3u) / 4u * 4u)
  44
  45
  46 static const char *ufo_assert_failure (const char *cond, const char *fname, int fline,
  47                                        const char *func)
  48 {
  49   for (const char *t = fname; *t; ++t) {
  50     #ifdef WIN32
  51     if (*t == '/' || *t == '\\') fname = t+1;
  52     #else
  53     if (*t == '/') fname = t+1;
  54     #endif
  55   }
  56   fflush(stdout);
  57   fprintf(stderr, "\n%s:%d: Assertion in `%s` failed: %s\n", fname, fline, func, cond);
  58   fflush(stderr);
  59   abort();
  60 }
  61
  62 #define ufo_assert(cond_)  do { if (__builtin_expect((!(cond_)), 0)) { ufo_assert_failure(#cond_, __FILE__, __LINE__, __PRETTY_FUNCTION__); } } while (0)
  63
  64
  65 //==========================================================================
  66 //
  67 //  joaatHashBufCI
  68 //
  69 //==========================================================================
  70 static uint32_t joaatHashBufCI (const void *buf, size_t len) {
  71   uint32_t hash = 0x29a;
  72   const uint8_t *s = (const uint8_t *)buf;
  73   while (len--) {
  74     //hash += (uint8_t)locase1251(*s++);
  75     hash += (*s++)|0x20; // this converts ASCII capitals to locase (and destroys other, but who cares)
  76     hash += hash<<10;
  77     hash ^= hash>>6;
  78   }
  79   // finalize
  80   hash += hash<<3;
  81   hash ^= hash>>11;
  82   hash += hash<<15;
  83   return hash;
  84 }
  85
  86
  87 //==========================================================================
  88 //
  89 //  toUpper
  90 //
  91 //==========================================================================
  92 static char toUpper (char ch) {
  93   return (ch >= 'a' && ch <= 'z' ? ch-'a'+'A' : ch);
  94 }
  95
  96
  97 //==========================================================================
  98 //
  99 //  toUpperU8
 100 //
 101 //==========================================================================
 102 static uint8_t toUpperU8 (uint8_t ch) {
 103   return (ch >= 'a' && ch <= 'z' ? ch-'a'+'A' : ch);
 104 }
 105
 106
 107 //==========================================================================
 108 //
 109 //  digitInBase
 110 //
 111 //==========================================================================
 112 static int digitInBase (char ch, int base) {
 113   switch (ch) {
 114     case '0' ... '9': ch = ch - '0'; break;
 115     case 'A' ... 'Z': ch = ch - 'A' + 10; break;
 116     case 'a' ... 'z': ch = ch - 'a' + 10; break;
 117     default: base = -1; break;
 118   }
 119   return (ch >= 0 && ch < base ? ch : -1);
 120 }
 121
 122
 123 /*
 124 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 125 ;; word header format:
 126 ;; note than name hash is ALWAYS calculated with ASCII-uppercased name
 127 ;; (actually, bit 5 is always reset for all bytes, because we don't need the
 128 ;; exact uppercase, only something that resembles it)
 129 ;; bfa points to next bfa or to 0 (this is "hash bucket pointer")
 130 ;; before nfa, we have such "hidden" fields:
 131 ;;   dd dfa       ; pointer to the debug data; can be 0 if debug info is missing
 132 ;;   dd sfa       ; points *after* the last word byte
 133 ;;   dd bfa       ; next word in hashtable bucket; it is always here, even if hashtable is turned off
 134 ;;                ; if there is no hashtable, this field is not used
 135 ;; lfa:
 136 ;;   dd lfa       ; previous word LFA or 0 (lfa links points here)
 137 ;;   dd namehash  ; it is always here, and always calculated, even if hashtable is turned off
 138 ;; nfa:
 139 ;;   dd flags-and-name-len   ; see below
 140 ;;   db name      ; no terminating zero or other "termination flag" here
 141 ;;  here could be some 0 bytes to align everything to 4 bytes
 142 ;;   db namelen   ; yes, name length again, so CFA->NFA can avoid guessing
 143 ;;                ; full length, including padding, but not including this byte
 144 ;; cfa:
 145 ;;   dd cfaidx    ; our internal CFA index, or image address for DOES>
 146 ;; pfa:
 147 ;;   word data follows
 148 ;;
 149 ;; first word cell contains combined name length (low byte), argtype and flags (other bytes)
 150 ;; layout:
 151 ;;   db namelen
 152 ;;   db argtype
 153 ;;   dw flags
 154 ;; i.e. we have 16 bits for flags, and 256 possible argument types. why not.
 155 ;;
 156 ;; flags:
 157 ;;  bit 0: immediate
 158 ;;  bit 1: smudge
 159 ;;  bit 2: noreturn
 160 ;;  bit 3: hidden
 161 ;;  bit 4: codeblock
 162 ;;  bit 5: vocabulary
 163 ;;  bit 6: main scattered colon word (with "...")
 164 ;;  bit 7: protected
 165 ;;
 166 ;;  argtype is the type of the argument that this word reads from the threaded code.
 167 ;;  possible argument types:
 168 ;;    0: none
 169 ;;    1: branch address
 170 ;;    2: cell-size numeric literal
 171 ;;    3: cell-counted string with terminating zero (not counted)
 172 ;;    4: cfa of another word
 173 ;;    5: cblock
 174 ;;    6: vocid
 175 ;;    7: *UNUSED* byte-counted string with terminating zero (not counted)
 176 ;;    8: unsigned byte
 177 ;;    9: signed byte
 178 ;;   10: unsigned word
 179 ;;   11: signed word
 180
 181
 182 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 183 ;; wordlist structure (at PFA)
 184 ;;   dd latest
 185 ;;   dd voclink (voclink always points here)
 186 ;;   dd parent (if not zero, all parent words are visible)
 187 ;;   dd header-nfa (can be 0 for anonymous wordlists)
 188 ;;   hashtable (if enabled), or ~0U if no hash table
 189 */
 190
 191
 192 // ////////////////////////////////////////////////////////////////////////// //
 193 #define UFO_BFA_TO_LFA(bfa_)    ((bfa_) + 1u * 4u)
 194 #define UFO_LFA_TO_DFA(lfa_)    ((lfa_) - 3u * 4u)
 195 #define UFO_LFA_TO_SFA(lfa_)    ((lfa_) - 2u * 4u)
 196 #define UFO_LFA_TO_BFA(lfa_)    ((lfa_) - 1u * 4u)
 197 #define UFO_LFA_TO_NFA(lfa_)    ((lfa_) + 2u * 4u)
 198 #define UFO_LFA_TO_CFA(lfa_)    UFO_ALIGN4((lfa_) + 3u * 4u + 1u + ufoImgGetU8((lfa_) + 2u * 4u))
 199 #define UFO_LFA_TO_NHASH(lfa_)  ((lfa_) + 1u * 4u)
 200 #define UFO_CFA_TO_NFA(cfa_)    ((cfa_) - 1u - 4u - ufoImgGetU8((cfa_) - 1u))
 201 #define UFO_CFA_TO_LFA(cfa_)    ((cfa_) - 1u - 4u * 3u - ufoImgGetU8((cfa_) - 1u))
 202 #define UFO_CFA_TO_PFA(cfa_)    ((cfa_) + 1u * 4u)
 203 #define UFO_PFA_TO_CFA(pfa_)    ((pfa_) - 1u * 4u)
 204 #define UFO_NFA_TO_CFA(nfa_)    UFO_ALIGN4((nfa_) + 4u + 1u + ufoImgGetU8((nfa_)))
 205 #define UFO_NFA_TO_LFA(nfa_)    ((nfa_) - 2u * 4u)
 206
 207
 208 // ////////////////////////////////////////////////////////////////////////// //
 209 #define UFW_FLAG_IMMEDIATE  (1u<<16)
 210 #define UFW_FLAG_SMUDGE     (1u<<17)
 211 #define UFW_FLAG_NORETURN   (1u<<18)
 212 #define UFW_FLAG_HIDDEN     (1u<<19)
 213 #define UFW_FLAG_CBLOCK     (1u<<20)
 214 #define UFW_FLAG_VOCAB      (1u<<21)
 215 #define UFW_FLAG_SCOLON     (1u<<22)
 216 #define UFW_FLAG_PROTECTED  (1u<<23)
 217
 218 #define UFW_WARG_MASK    ((uint32_t)0xff00U)
 219
 220 #define UFW_WARG_NONE    (0u<<8)
 221 #define UFW_WARG_BRANCH  (1u<<8)
 222 #define UFW_WARG_LIT     (2u<<8)
 223 #define UFW_WARG_C4STRZ  (3u<<8)
 224 #define UFW_WARG_CFA     (4u<<8)
 225 #define UFW_WARG_CBLOCK  (5u<<8)
 226 #define UFW_WARG_VOCID   (6u<<8)
 227 #define UFW_WARG_C1STRZ  (7u<<8)
 228 //#define UFW_WARG_U8      (8u<<8)
 229 //#define UFW_WARG_S8      (9u<<8)
 230 //#define UFW_WARG_U16     (10u<<8)
 231 //#define UFW_WARG_S16     (11u<<8)
 232
 233 #define UFW_VOCAB_OFS_LATEST   (0u * 4u)
 234 #define UFW_VOCAB_OFS_VOCLINK  (1u * 4u)
 235 #define UFW_VOCAB_OFS_PARENT   (2u * 4u)
 236 #define UFW_VOCAB_OFS_HEADER   (3u * 4u)
 237 #define UFW_VOCAB_OFS_HTABLE   (4u * 4u)
 238
 239 #define UFO_HASHTABLE_SIZE  (256)
 240
 241 #define UFO_NO_HTABLE_FLAG  (~(uint32_t)0)
 242
 243 static jmp_buf ufoInlineQuitJP;
 244
 245 typedef void (*ufoNativeCFA) (uint32_t pfa);
 246 #define UFO_MAX_NATIVE_CFAS  (1024u)
 247 static ufoNativeCFA *ufoForthCFAs = NULL;
 248 static uint32_t ufoCFAsUsed = 0;
 249
 250 static uint32_t ufoDoForthCFA;
 251 static uint32_t ufoDoVarCFA;
 252 static uint32_t ufoDoValueCFA;
 253 static uint32_t ufoDoConstCFA;
 254 static uint32_t ufoDoDeferCFA;
 255 static uint32_t ufoDoVocCFA;
 256 static uint32_t ufoMaxDoCFA;
 257
 258 static uint32_t ufoStrLit8CFA;
 259
 260 // special address types:
 261 #define UFO_ADDR_CFA_BIT   ((uint32_t)1<<31)
 262 #define UFO_ADDR_CFA_MASK  (UFO_ADDR_CFA_BIT-1u)
 263
 264 #define UFO_ADDR_HANDLE_BIT   ((uint32_t)1<<30)
 265 #define UFO_ADDR_HANDLE_MASK  (UFO_ADDR_HANDLE_BIT-1u)
 266
 267 // temporary area is 1MB buffer out of the main image
 268 #define UFO_ADDR_TEMP_BIT   ((uint32_t)1<<29)
 269 #define UFO_ADDR_TEMP_MASK  (UFO_ADDR_TEMP_BIT-1u)
 270
 271 #define UFO_ADDR_SPECIAL_BITS_MASK  (UFO_ADDR_CFA_BIT|UFO_ADDR_HANDLE_BIT|UFO_ADDR_TEMP_BIT)
 272
 273
 274 static uint32_t *ufoImage = NULL;
 275 static uint32_t ufoImageSize = 0;
 276
 277 static uint32_t *ufoImageTemp = NULL;
 278 static uint32_t ufoImageTempSize = 0;
 279
 280 static uint32_t ufoIP = 0; // in image
 281 static uint32_t ufoSP = 0; // points AFTER the last value pushed
 282 static uint32_t ufoRP = 0; // points AFTER the last value pushed
 283 static uint32_t ufoRPTop = 0; // stop when RP is this, and we're doing EXIT
 284
 285 static uint32_t ufoTrueValue = ~0u;
 286
 287 static uint32_t ufoStopVM = 0;
 288
 289 enum {
 290   UFO_MODE_NONE = -1,
 291   UFO_MODE_NATIVE = 0, // executing forth code
 292   UFO_MODE_MACRO = 1, // executing forth asm macro
 293 };
 294 static uint32_t ufoMode = UFO_MODE_NONE;
 295
 296 #define UFO_DSTACK_SIZE  (8192)
 297 #define UFO_RSTACK_SIZE  (8192)
 298 #define UFO_LSTACK_SIZE  (8192)
 299 static uint32_t *ufoDStack;
 300 static uint32_t *ufoRStack;
 301 static uint32_t *ufoLStack;
 302 static uint32_t ufoLP = 0;
 303 static uint32_t ufoLBP = 0;
 304
 305 // dynamically allocated text input buffer
 306 // always ends with zero (this is word name too)
 307 // first 512 bytes of image is TIB
 308 #define ufoTIBAreaSize  (512)
 309 #define ufoNUMAreaSize  (128)
 310 static uint32_t ufoAddrTIB = 0; // TIB; 0 means "in TIB area", otherwise in the dictionary
 311 static uint32_t ufoAddrIN = 0; // >IN
 312
 313 static uint32_t ufoAddrContext; // CONTEXT
 314 static uint32_t ufoAddrCurrent; // CURRENT (definitions will go there)
 315 static uint32_t ufoAddrVocLink;
 316 static uint32_t ufoAddrHERE;
 317 static uint32_t ufoAddrSTATE;
 318 static uint32_t ufoAddrBASE;
 319 static uint32_t ufoAddrNewWordFlags;
 320
 321 #define UFO_GET_DP()      ufoImgGetU32(ufoAddrHERE)
 322 #define UFO_SET_DP(val_)  ufoImgPutU32(ufoAddrHERE, (val_))
 323
 324 #define UFO_MAX_NESTED_INCLUDES  (32)
 325 typedef struct {
 326   FILE *fl;
 327   char *fname;
 328   char *incpath;
 329   int fline;
 330   uint8_t *savedTIB;
 331   uint32_t savedTIBSize;
 332 } UFOFileStackEntry;
 333
 334 static UFOFileStackEntry ufoFileStack[UFO_MAX_NESTED_INCLUDES];
 335 static uint32_t ufoFileStackPos; // after the last used item
 336
 337 static FILE *ufoInFile = NULL;
 338 static char *ufoInFileName = NULL;
 339 static char *ufoLastIncPath = NULL;
 340 static int ufoInFileLine = 0;
 341 static int ufoCondStLine = -1;
 342
 343 static int ufoLastEmitWasCR = 1;
 344 static uint32_t ufoCSP = 0;
 345 static int ufoInCondIf = 0;
 346
 347 #define UFO_VOCSTACK_SIZE  (16u)
 348 static uint32_t ufoVocStack[UFO_VOCSTACK_SIZE]; // cfas
 349 static uint32_t ufoVSP;
 350 static uint32_t ufoForthVocId;
 351 static uint32_t ufoCompilerVocId;
 352 static uint32_t ufoMacroVocId;
 353
 354 // dynamic handles
 355 typedef struct UHandleInfo_t {
 356   uint32_t ufoHandle;
 357   uint32_t typecfa;
 358   uint32_t *mem;
 359   uint32_t size; // in `uint32_t`
 360   uint32_t used; // in `uint32_t`; for dynamic arrays
 361   // in free list
 362   struct UHandleInfo_t *next;
 363 } UHandleInfo;
 364
 365 static UHandleInfo *ufoHandleFreeList = NULL;
 366 static UHandleInfo **ufoHandles = NULL;
 367 static uint32_t ufoHandlesUsed = 0;
 368 static uint32_t ufoHandlesAlloted = 0;
 369
 370 #define UFO_HANDLE_FREE  (0)
 371
 372 #define UFO_GET_NATIVE_HANDLE(adr_)  ({ \
 373   uint32_t aa = (uint32_t)(adr_); \
 374   if ((aa & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("expected handle"); \
 375   aa &= UFO_HANDLE_MASK; \
 376   if (aa >= ufoHandlesUsed || ufoHandles[aa] == NULL || ufoHandles[aa]->typecfa == UFO_HANDLE_FREE) ufoFatal("invalid handle"); \
 377   ufoHandles[aa]; \
 378 })
 379
 380
 381 static char ufoCurrFileLine[520];
 382 // used to extract strings from the image
 383 static char ufoTempCharBuf[1024];
 384
 385 // for `ufoFatal()`
 386 static uint32_t ufoInBacktrace = 0;
 387
 388
 389 // ////////////////////////////////////////////////////////////////////////// //
 390 #ifndef WIN32
 391 static void ufoDbgDeinit (void);
 392 #endif
 393 static void ufoClearCondDefines (void);
 394
 395 // "force VM" always run a VM, even if we're already in VM.
 396 // "normal" runs VM only if we are not in VM yet, otherwise calls CFA and returns.
 397 // "tailcall" tries to perform a tail call. we should be in VM, otherwise it fails.
 398 #define UFO_EXEC_FORCE_VM  (-1)
 399 #define UFO_EXEC_NORMAL    (0)
 400 #define UFO_EXEC_TAILCALL  (1)
 401 static void ufoExecuteCFA (uint32_t cfa, int exectype);
 402 static void ufoRunVM (void);
 403
 404 static void ufoBacktrace (void);
 405
 406 static void ufoFixLatestSFA (void);
 407 static void ufoClearCondDefines (void);
 408
 409 __attribute__((unused)) static void ufoDumpWordHeader (const uint32_t lfa);
 410
 411
 412 //==========================================================================
 413 //
 414 //  ufoAllocHandle
 415 //
 416 //==========================================================================
 417 static UHandleInfo *ufoAllocHandle (uint32_t typecfa) {
 418   ufo_assert(typecfa != UFO_HANDLE_FREE);
 419   UHandleInfo *newh = ufoHandleFreeList;
 420   if (newh == NULL) {
 421     if (ufoHandlesUsed == ufoHandlesAlloted) {
 422       uint32_t newsz = ufoHandlesAlloted + 16384;
 423       if (newsz > 0x1000000U) {
 424         if (ufoHandlesAlloted >= 0x1000000U) ufoFatal("too many dynamic handles");
 425       }
 426       UHandleInfo **nh = realloc(ufoHandles, sizeof(ufoHandles[0]) * newsz);
 427       if (nh == NULL) ufoFatal("out of memory for handle table");
 428       ufoHandles = nh;
 429       ufoHandlesAlloted = newsz;
 430     }
 431     newh = calloc(1, sizeof(UHandleInfo));
 432     if (newh == NULL) ufoFatal("out of memory for handle info");
 433     ufoHandles[ufoHandlesUsed] = newh;
 434     // setup new handle info
 435     newh->ufoHandle = ufoHandlesUsed | UFO_ADDR_HANDLE_BIT;
 436     ufoHandlesUsed += 1;
 437   } else {
 438     ufoHandleFreeList = newh->next;
 439   }
 440   // setup new handle info
 441   newh->typecfa = typecfa;
 442   newh->mem = NULL;
 443   newh->size = 0;
 444   newh->next = NULL;
 445   return newh;
 446 }
 447
 448
 449 //==========================================================================
 450 //
 451 //  ufoFreeHandle
 452 //
 453 //==========================================================================
 454 static void ufoFreeHandle (UHandleInfo *hh) {
 455   if (hh != NULL) {
 456     ufo_assert(hh->typecfa != UFO_HANDLE_FREE);
 457     if (hh->mem) free(hh->mem);
 458     hh->typecfa = UFO_HANDLE_FREE;
 459     hh->mem = NULL;
 460     hh->size = 0;
 461     hh->next = ufoHandleFreeList;
 462     ufoHandleFreeList = hh;
 463   }
 464 }
 465
 466
 467 //==========================================================================
 468 //
 469 //  ufoGetHandle
 470 //
 471 //==========================================================================
 472 static UHandleInfo *ufoGetHandle (uint32_t hh) {
 473   UHandleInfo *res;
 474   if (hh != 0 && (hh & UFO_ADDR_HANDLE_BIT) != 0) {
 475     hh &= UFO_ADDR_HANDLE_MASK;
 476     if (hh < ufoHandlesUsed) {
 477       res = ufoHandles[hh];
 478       if (res->typecfa == UFO_HANDLE_FREE) res = NULL;
 479     } else {
 480       res = NULL;
 481     }
 482   } else {
 483     res = NULL;
 484   }
 485   return res;
 486 }
 487
 488
 489 //==========================================================================
 490 //
 491 //  setLastIncPath
 492 //
 493 //==========================================================================
 494 static void setLastIncPath (const char *fname) {
 495   if (fname == NULL || fname[0] == 0) {
 496     if (ufoLastIncPath) free(ufoLastIncPath);
 497     ufoLastIncPath = strdup(".");
 498   } else {
 499     if (ufoLastIncPath) free(ufoLastIncPath);
 500     ufoLastIncPath = strdup(fname);
 501     char *lslash = ufoLastIncPath;
 502     char *cpos = ufoLastIncPath;
 503     while (*cpos) {
 504       #ifdef WIN32
 505       if (*cpos == '/' || *cpos == '\\') lslash = cpos;
 506       #else
 507       if (*cpos == '/') lslash = cpos;
 508       #endif
 509       cpos += 1;
 510     }
 511     *lslash = 0;
 512   }
 513 }
 514
 515
 516 //==========================================================================
 517 //
 518 //  ufoErrorPrintFile
 519 //
 520 //==========================================================================
 521 static void ufoErrorPrintFile (FILE *fo) {
 522   if (ufoInFileName) {
 523     fprintf(fo, "UFO ERROR at file %s, line %d: ", ufoInFileName, ufoInFileLine);
 524   } else {
 525     fprintf(fo, "UFO ERROR somewhere in time: ");
 526   }
 527 }
 528
 529
 530 //==========================================================================
 531 //
 532 //  ufoErrorMsgV
 533 //
 534 //==========================================================================
 535 static void ufoErrorMsgV (const char *fmt, va_list ap) {
 536   if (!ufoLastEmitWasCR) { printf("\n"); ufoLastEmitWasCR = 1; }
 537   fflush(stdout);
 538   ufoErrorPrintFile(stderr);
 539   vfprintf(stderr, fmt, ap);
 540   va_end(ap);
 541   fputc('\n', stderr);
 542   fflush(NULL);
 543 }
 544
 545
 546 //==========================================================================
 547 //
 548 //  ufoWarning
 549 //
 550 //==========================================================================
 551 __attribute__((format(printf, 1, 2)))
 552 void ufoWarning (const char *fmt, ...) {
 553   va_list ap;
 554   va_start(ap, fmt);
 555   ufoErrorMsgV(fmt, ap);
 556 }
 557
 558
 559 //==========================================================================
 560 //
 561 //  ufoFatal
 562 //
 563 //==========================================================================
 564 __attribute__((noreturn)) __attribute__((format(printf, 1, 2)))
 565 void ufoFatal (const char *fmt, ...) {
 566   va_list ap;
 567   va_start(ap, fmt);
 568   ufoErrorMsgV(fmt, ap);
 569   if (!ufoInBacktrace) {
 570     ufoInBacktrace = 1;
 571     ufoBacktrace();
 572     ufoInBacktrace = 0;
 573   } else {
 574     fprintf(stderr, "DOUBLE FATAL: error in backtrace!\n");
 575   }
 576   #ifdef UFO_DEBUG_FATAL_ABORT
 577   abort();
 578   #endif
 579   ufoFatalError();
 580 }
 581
 582
 583 // ////////////////////////////////////////////////////////////////////////// //
 584 // working with the stacks
 585 UFO_FORCE_INLINE void ufoPush (uint32_t v) { if (ufoSP >= UFO_DSTACK_SIZE) ufoFatal("UFO data stack overflow"); ufoDStack[ufoSP++] = v; }
 586 UFO_FORCE_INLINE void ufoDrop (void) { if (ufoSP == 0) ufoFatal("UFO data stack underflow"); --ufoSP; }
 587 UFO_FORCE_INLINE uint32_t ufoPop (void) { if (ufoSP == 0) { ufoFatal("UFO data stack underflow"); } return ufoDStack[--ufoSP]; }
 588 UFO_FORCE_INLINE uint32_t ufoPeek (void) { if (ufoSP == 0) ufoFatal("UFO data stack underflow"); return ufoDStack[ufoSP-1u]; }
 589 UFO_FORCE_INLINE void ufoDup (void) { if (ufoSP == 0) ufoFatal("UFO data stack underflow"); ufoPush(ufoDStack[ufoSP-1u]); }
 590 UFO_FORCE_INLINE void ufoOver (void) { if (ufoSP < 2u) ufoFatal("UFO data stack underflow"); ufoPush(ufoDStack[ufoSP-2u]); }
 591 UFO_FORCE_INLINE void ufoSwap (void) { if (ufoSP < 2u) ufoFatal("UFO data stack underflow"); const uint32_t t = ufoDStack[ufoSP-1u]; ufoDStack[ufoSP-1u] = ufoDStack[ufoSP-2u]; ufoDStack[ufoSP-2u] = t; }
 592 UFO_FORCE_INLINE void ufoRot (void) { if (ufoSP < 3u) ufoFatal("UFO 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; }
 593 UFO_FORCE_INLINE void ufoNRot (void) { if (ufoSP < 3u) ufoFatal("UFO 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; }
 594
 595 UFO_FORCE_INLINE void ufo2Dup (void) { ufoOver(); ufoOver(); }
 596 UFO_FORCE_INLINE void ufo2Drop (void) { ufoDrop(); ufoDrop(); }
 597 UFO_FORCE_INLINE void ufo2Over (void) { if (ufoSP < 4u) ufoFatal("UFO data stack underflow"); const uint32_t n0 = ufoDStack[ufoSP-4u]; const uint32_t n1 = ufoDStack[ufoSP-3u]; ufoPush(n0); ufoPush(n1); }
 598 UFO_FORCE_INLINE void ufo2Swap (void) { if (ufoSP < 4u) ufoFatal("UFO 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; }
 599
 600 UFO_FORCE_INLINE void ufoRPush (uint32_t v) { if (ufoRP >= UFO_RSTACK_SIZE) ufoFatal("UFO return stack overflow"); ufoRStack[ufoRP++] = v; }
 601 UFO_FORCE_INLINE void ufoRDrop (void) { if (ufoRP == 0 || ufoRP == ufoRPTop) ufoFatal("UFO return stack underflow"); --ufoRP; }
 602 UFO_FORCE_INLINE uint32_t ufoRPop (void) { if (ufoRP == 0 || ufoRP == ufoRPTop) ufoFatal("UFO return stack underflow"); return ufoRStack[--ufoRP]; }
 603 UFO_FORCE_INLINE uint32_t ufoRPeek (void) { if (ufoRP == 0 || ufoRP == ufoRPTop) ufoFatal("UFO return stack underflow"); return ufoRStack[ufoRP-1u]; }
 604 UFO_FORCE_INLINE void ufoRDup (void) { if (ufoRP == 0 || ufoRP == ufoRPTop) ufoFatal("UFO return stack underflow"); ufoPush(ufoRStack[ufoRP-1u]); }
 605
 606 UFO_FORCE_INLINE void ufoPushBool (int v) { ufoPush(v ? ufoTrueValue : 0u); }
 607
 608
 609 //==========================================================================
 610 //
 611 //  ufoImgEnsureSize
 612 //
 613 //==========================================================================
 614 static void ufoImgEnsureSize (uint32_t addr) {
 615   if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) != 0) ufoFatal("ufoImgEnsureSize: internal error");
 616   if (addr >= ufoImageSize) {
 617     // 64MB should be enough for everyone!
 618     if (addr >= 0x04000000U) {
 619       ufoFatal("UFO image grown too big (addr=0%08XH)", addr);
 620     }
 621     const uint32_t osz = ufoImageSize;
 622     // grow by 1MB steps
 623     uint32_t nsz = (addr|0x000fffffU) + 1U;
 624     ufo_assert(nsz > addr);
 625     uint32_t *nimg = realloc(ufoImage, nsz);
 626     if (nimg == NULL) {
 627       ufoFatal("out of memory for UFO image (%u -> %u MBs)",
 628                ufoImageSize / 1024u / 1024u,
 629                nsz / 1024u / 1024u);
 630     }
 631     ufoImage = nimg;
 632     ufoImageSize = nsz;
 633     memset((char *)ufoImage + osz, 0, (nsz - osz));
 634   }
 635 }
 636
 637
 638 //==========================================================================
 639 //
 640 //  ufoImgEnsureTemp
 641 //
 642 //==========================================================================
 643 static void ufoImgEnsureTemp (uint32_t addr) {
 644   if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) != 0) ufoFatal("ufoImgEnsureTemp: internal error");
 645   if (addr >= ufoImageTempSize) {
 646     if (addr >= 1024u * 1024u) {
 647       ufoFatal("Forth segmentation fault at address 0x%08X", addr|UFO_ADDR_TEMP_BIT);
 648     }
 649     const uint32_t osz = ufoImageTempSize;
 650     // grow by 256KB steps
 651     uint32_t nsz = (addr|0x0003ffffU) + 1U;
 652     uint32_t *nimg = realloc(ufoImageTemp, nsz);
 653     if (nimg == NULL) {
 654       ufoFatal("out of memory for temp UFO image (%u -> %u KBs)",
 655                ufoImageTempSize / 1024u,
 656                nsz / 1024u);
 657     }
 658     ufoImageTemp = nimg;
 659     ufoImageTempSize = nsz;
 660     memset(ufoImageTemp + osz, 0, (nsz - osz));
 661   }
 662 }
 663
 664
 665 //==========================================================================
 666 //
 667 //  ufoImgPutU8
 668 //
 669 //==========================================================================
 670 static void ufoImgPutU8 (uint32_t addr, uint32_t value) {
 671   uint32_t *imgptr;
 672   if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
 673     if (addr >= ufoImageSize) ufoImgEnsureSize(addr);
 674     imgptr = &ufoImage[addr/4u];
 675   } else if (addr & UFO_ADDR_TEMP_BIT) {
 676     addr &= UFO_ADDR_TEMP_MASK;
 677     if (addr >= ufoImageTempSize) ufoImgEnsureTemp(addr);
 678     imgptr = &ufoImageTemp[addr/4u];
 679   } else {
 680     ufoFatal("Forth segmentation fault at address 0x%08X", addr);
 681   }
 682   const uint8_t val = (uint8_t)value;
 683   memcpy((uint8_t *)imgptr + (addr&3), &val, 1);
 684 }
 685
 686
 687 //==========================================================================
 688 //
 689 //  ufoImgPutU16
 690 //
 691 //==========================================================================
 692 static void ufoImgPutU16 (uint32_t addr, uint32_t value) {
 693   ufoImgPutU8(addr, value&0xffU);
 694   ufoImgPutU8(addr + 1u, (value>>8)&0xffU);
 695 }
 696
 697
 698 //==========================================================================
 699 //
 700 //  ufoImgPutU32
 701 //
 702 //==========================================================================
 703 static void ufoImgPutU32 (uint32_t addr, uint32_t value) {
 704   ufoImgPutU16(addr, value&0xffffU);
 705   ufoImgPutU16(addr + 2u, (value>>16)&0xffffU);
 706 }
 707
 708
 709 //==========================================================================
 710 //
 711 //  ufoImgGetU8
 712 //
 713 //==========================================================================
 714 static uint32_t ufoImgGetU8 (uint32_t addr) {
 715   uint32_t *imgptr;
 716   if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
 717     if (addr >= ufoImageSize) return 0;
 718     imgptr = &ufoImage[addr/4u];
 719   } else if (addr & UFO_ADDR_TEMP_BIT) {
 720     addr &= UFO_ADDR_TEMP_MASK;
 721     if (addr >= ufoImageTempSize) return 0;
 722     imgptr = &ufoImageTemp[addr/4u];
 723   } else {
 724     ufoFatal("Forth segmentation fault at address 0x%08X", addr);
 725   }
 726   uint8_t val;
 727   memcpy(&val, (uint8_t *)imgptr + (addr&3), 1);
 728   return (uint32_t)val;
 729 }
 730
 731
 732 //==========================================================================
 733 //
 734 //  ufoImgGetU16
 735 //
 736 //==========================================================================
 737 static uint32_t ufoImgGetU16 (uint32_t addr) {
 738   return ufoImgGetU8(addr) | (ufoImgGetU8(addr + 1u) << 8);
 739 }
 740
 741
 742 //==========================================================================
 743 //
 744 //  ufoImgGetU32
 745 //
 746 //==========================================================================
 747 static uint32_t ufoImgGetU32 (uint32_t addr) {
 748   return ufoImgGetU16(addr) | (ufoImgGetU16(addr + 2u) << 16);
 749 }
 750
 751
 752 //==========================================================================
 753 //
 754 //  ufoImgEmitU8
 755 //
 756 //==========================================================================
 757 static void ufoImgEmitU8 (uint32_t value) {
 758   uint32_t here = UFO_GET_DP();
 759   ufoImgPutU8(here, value); here += 1u;
 760   UFO_SET_DP(here);
 761 }
 762
 763
 764 //==========================================================================
 765 //
 766 //  ufoImgEmitU32
 767 //
 768 //==========================================================================
 769 static void ufoImgEmitU32 (uint32_t value) {
 770   uint32_t here = UFO_GET_DP();
 771   ufoImgPutU32(here, value); here += 4u;
 772   UFO_SET_DP(here);
 773 }
 774
 775
 776 //==========================================================================
 777 //
 778 //  ufoImgEmitAlign
 779 //
 780 //==========================================================================
 781 static void ufoImgEmitAlign (void) {
 782   while ((UFO_GET_DP() & 3) != 0) ufoImgEmitU8(0);
 783 }
 784
 785
 786 //==========================================================================
 787 //
 788 //  ufoDoForth
 789 //
 790 //==========================================================================
 791 static void ufoDoForth (uint32_t pfa) {
 792   ufoRPush(ufoIP);
 793   ufoIP = pfa;
 794 }
 795
 796
 797 //==========================================================================
 798 //
 799 //  ufoDoVariable
 800 //
 801 //==========================================================================
 802 static void ufoDoVariable (uint32_t pfa) {
 803   ufoPush(pfa);
 804 }
 805
 806
 807 //==========================================================================
 808 //
 809 //  ufoDoValue
 810 //
 811 //==========================================================================
 812 static void ufoDoValue (uint32_t pfa) {
 813   ufoPush(ufoImgGetU32(pfa));
 814 }
 815
 816
 817 //==========================================================================
 818 //
 819 //  ufoDoConst
 820 //
 821 //==========================================================================
 822 static void ufoDoConst (uint32_t pfa) {
 823   ufoPush(ufoImgGetU32(pfa));
 824 }
 825
 826
 827 //==========================================================================
 828 //
 829 //  ufoDoDefer
 830 //
 831 //==========================================================================
 832 static void ufoDoDefer (uint32_t pfa) {
 833   const uint32_t cfa = ufoImgGetU32(pfa);
 834   if (cfa == 0) ufoFatal("cannot execute empty defer");
 835   uint32_t cfaidx = ufoImgGetU32(cfa);
 836   #if 0
 837   fprintf(stderr, "**DEFER**: IP=0x%08x; cfa=0x%08x; cfaidx=0x%08x\n", ufoIP, cfa, cfaidx);
 838   ufoDumpWordHeader(UFO_CFA_TO_LFA(cfa));
 839   #endif
 840   if (cfaidx & UFO_ADDR_CFA_BIT) {
 841     cfaidx &= UFO_ADDR_CFA_MASK;
 842     if (cfaidx >= ufoCFAsUsed) {
 843       ufoFatal("UFO tried to execute an unknown word: 0x%08x (max is 0x%08x); IP=0x%08x",
 844                cfaidx, ufoCFAsUsed, ufoIP);
 845     }
 846     if (ufoForthCFAs[cfaidx] == NULL) ufoFatal("VM internal error: empty CFA");
 847     ufoForthCFAs[cfaidx](UFO_CFA_TO_PFA(cfa));
 848   } else {
 849     // if CFA points somewhere inside a dict, this is "DOES>" word
 850     if (cfaidx < UFO_GET_DP() || (cfaidx & UFO_ADDR_TEMP_MASK) != 0) {
 851       ufoRPush(ufoIP);
 852       ufoIP = cfa;
 853     } else {
 854       ufoFatal("VM tried to execute something that is not a word at 0x%08x: cfa=0x%08x; cfaidx=0x%08x",
 855                ufoIP, cfa, cfaidx);
 856     }
 857   }
 858 }
 859
 860
 861 //==========================================================================
 862 //
 863 //  ufoDoVoc
 864 //
 865 //==========================================================================
 866 static void ufoDoVoc (uint32_t pfa) {
 867   ufoImgPutU32(ufoAddrContext, ufoImgGetU32(pfa));
 868 }
 869
 870
 871 //==========================================================================
 872 //
 873 //  ufoOpenFileOrDir
 874 //
 875 //==========================================================================
 876 static FILE *ufoOpenFileOrDir (char **fnameptr) {
 877   struct stat st;
 878   char *tmp;
 879   char *fname;
 880
 881   if (fnameptr == NULL) return NULL;
 882   fname = *fnameptr;
 883   #if 0
 884   fprintf(stderr, "***:fname=<%s>\n", fname);
 885   #endif
 886
 887   if (fname == NULL || fname[0] == 0 || stat(fname, &st) != 0) return NULL;
 888
 889   if (S_ISDIR(st.st_mode)) {
 890     tmp = calloc(1, strlen(fname) + 128);
 891     ufo_assert(tmp != NULL);
 892     sprintf(tmp, "%s/%s", fname, "zzmain.f");
 893     free(fname); fname = tmp; *fnameptr = tmp;
 894     #if 0
 895     fprintf(stderr, "***:  <%s>\n", fname);
 896     #endif
 897   }
 898
 899   return fopen(fname, "rb");
 900 }
 901
 902
 903 //==========================================================================
 904 //
 905 //  ufoPushInFile
 906 //
 907 //==========================================================================
 908 static void ufoPushInFile (void) {
 909   if (ufoFileStackPos >= UFO_MAX_NESTED_INCLUDES) ufoFatal("too many includes");
 910   UFOFileStackEntry *stk = &ufoFileStack[ufoFileStackPos];
 911   stk->fl = ufoInFile;
 912   stk->fname = ufoInFileName;
 913   stk->fline = ufoInFileLine;
 914   stk->incpath = ufoLastIncPath;
 915   // save TIB (if it is the default)
 916   uint32_t tib = ufoImgGetU32(ufoAddrTIB);
 917   uint32_t in = ufoImgGetU32(ufoAddrIN);
 918   stk->savedTIBSize = 0;
 919   stk->savedTIB = NULL;
 920   if (tib == 0 && in < ufoTIBAreaSize) {
 921     while (ufoImgGetU8(tib + in + stk->savedTIBSize) != 0) stk->savedTIBSize += 1;
 922     if (stk->savedTIBSize != 0) {
 923       stk->savedTIB = malloc(stk->savedTIBSize);
 924       if (stk->savedTIB == NULL) ufoFatal("out of memory for include stack");
 925       for (uint32_t f = 0; f < stk->savedTIBSize; f += 1) {
 926         stk->savedTIB[f] = ufoImgGetU8(tib + in + f);
 927       }
 928     }
 929   }
 930   ufoFileStackPos += 1;
 931   ufoInFile = NULL;
 932   ufoInFileName = NULL;
 933   ufoInFileLine = 0;
 934   ufoLastIncPath = NULL;
 935 }
 936
 937
 938 //==========================================================================
 939 //
 940 //  ufoPopInFile
 941 //
 942 //==========================================================================
 943 static void ufoPopInFile (void) {
 944   if (ufoFileStackPos == 0) ufoFatal("trying to pop include from empty stack");
 945   if (ufoInFileName) free(ufoInFileName);
 946   if (ufoInFile) fclose(ufoInFile);
 947   if (ufoLastIncPath) free(ufoLastIncPath);
 948   ufoFileStackPos -= 1;
 949   UFOFileStackEntry *stk = &ufoFileStack[ufoFileStackPos];
 950   ufoInFile = stk->fl;
 951   ufoInFileName = stk->fname;
 952   ufoInFileLine = stk->fline;
 953   ufoLastIncPath = stk->incpath;
 954   // restore TIB
 955   // also, restore current line, because some code may need it
 956   if (stk->savedTIBSize >= ufoTIBAreaSize) ufoFatal("restored TIB too big");
 957   ufoImgPutU32(ufoAddrTIB, 0);
 958   ufoImgPutU32(ufoAddrIN, 0);
 959   if (stk->savedTIBSize != 0) {
 960     for (uint32_t f = 0; f < stk->savedTIBSize; f += 1) {
 961       ufoImgPutU8(f, stk->savedTIB[f]);
 962     }
 963     free(stk->savedTIB);
 964   }
 965   ufoImgPutU8(stk->savedTIBSize, 0);
 966   #ifdef UFO_DEBUG_INCLUDE
 967   fprintf(stderr, "INC-POP: <%s>\n", ufoCurrFileLine);
 968   #endif
 969 }
 970
 971
 972 //==========================================================================
 973 //
 974 //  ufoDeinit
 975 //
 976 //==========================================================================
 977 void ufoDeinit (void) {
 978   ufoInBacktrace = 0;
 979   ufoClearCondDefines();
 980
 981   // free all handles
 982   for (uint32_t f = 0; f < ufoHandlesUsed; f += 1) {
 983     UHandleInfo *hh = ufoHandles[f];
 984     if (hh != NULL) {
 985       if (hh->mem != NULL) free(hh->mem);
 986       free(hh);
 987     }
 988   }
 989   if (ufoHandles != NULL) free(ufoHandles);
 990   ufoHandles = NULL; ufoHandlesUsed = 0; ufoHandlesAlloted = 0;
 991   ufoHandleFreeList = NULL;
 992
 993   // release all includes
 994   ufoInFile = NULL;
 995   if (ufoInFileName) free(ufoInFileName);
 996   if (ufoLastIncPath) free(ufoLastIncPath);
 997   ufoInFileName = NULL; ufoLastIncPath = NULL;
 998   ufoInFileLine = 0;
 999
1000   free(ufoForthCFAs);
1001   ufoForthCFAs = NULL;
1002   ufoCFAsUsed = 0;
1003
1004   free(ufoImage);
1005   ufoImage = NULL;
1006   ufoImageSize = 0;
1007
1008   free(ufoImageTemp);
1009   ufoImageTemp = NULL;
1010   ufoImageTempSize = 0;
1011
1012   ufoIP = 0;
1013   ufoSP = 0; ufoRP = 0; ufoRPTop = 0;
1014   ufoLP = 0; ufoLBP = 0;
1015   ufoMode = UFO_MODE_NATIVE;
1016   ufoVSP = 0;
1017   ufoForthVocId = 0; ufoCompilerVocId = 0; ufoMacroVocId = 0;
1018
1019   free(ufoDStack);
1020   ufoDStack = NULL;
1021   free(ufoRStack);
1022   ufoRStack = NULL;
1023   free(ufoLStack);
1024   ufoLStack = NULL;
1025
1026   ufoAddrTIB = 0; ufoAddrIN = 0;
1027
1028   ufoLastEmitWasCR = 1;
1029   ufoCSP = 0;
1030   ufoInCondIf = 0;
1031
1032   ufoClearCondDefines();
1033
1034   #ifndef WIN32
1035   ufoDbgDeinit();
1036   #endif
1037 }
1038
1039
1040 //==========================================================================
1041 //
1042 //  ufoDumpWordHeader
1043 //
1044 //==========================================================================
1045 __attribute__((unused)) static void ufoDumpWordHeader (const uint32_t lfa) {
1046   fprintf(stderr, "=== WORD: LFA: 0x%08x ===\n", lfa);
1047   if (lfa != 0) {
1048     fprintf(stderr, "  (DFA): 0x%08x\n", ufoImgGetU32(UFO_LFA_TO_DFA(lfa)));
1049     fprintf(stderr, "  (SFA): 0x%08x\n", ufoImgGetU32(UFO_LFA_TO_SFA(lfa)));
1050     fprintf(stderr, "  (BFA): 0x%08x\n", ufoImgGetU32(UFO_LFA_TO_BFA(lfa)));
1051     fprintf(stderr, "  (LFA): 0x%08x\n", ufoImgGetU32(lfa));
1052     fprintf(stderr, "  (NHH): 0x%08x\n", ufoImgGetU32(UFO_LFA_TO_NHASH(lfa)));
1053     const uint32_t cfa = UFO_LFA_TO_CFA(lfa);
1054     fprintf(stderr, "    CFA: 0x%08x\n", cfa);
1055     fprintf(stderr, "    PFA: 0x%08x\n", UFO_CFA_TO_PFA(cfa));
1056     fprintf(stderr, "  (CFA): 0x%08x\n", ufoImgGetU32(cfa));
1057     const uint32_t nfa = UFO_LFA_TO_NFA(lfa);
1058     const uint32_t nlen = ufoImgGetU8(nfa);
1059     fprintf(stderr, "    NFA: 0x%08x  (nlen: %u)\n", nfa, nlen);
1060     const uint32_t flags = ufoImgGetU32(nfa);
1061     fprintf(stderr, "  FLAGS: 0x%08x\n", flags);
1062     if ((flags & 0xffff0000U) != 0) {
1063       fprintf(stderr, "  FLAGS:");
1064       if (flags & UFW_FLAG_IMMEDIATE) fprintf(stderr, " IMM");
1065       if (flags & UFW_FLAG_SMUDGE) fprintf(stderr, " SMUDGE");
1066       if (flags & UFW_FLAG_NORETURN) fprintf(stderr, " NORET");
1067       if (flags & UFW_FLAG_HIDDEN) fprintf(stderr, " HIDDEN");
1068       if (flags & UFW_FLAG_CBLOCK) fprintf(stderr, " CBLOCK");
1069       if (flags & UFW_FLAG_VOCAB) fprintf(stderr, " VOCAB");
1070       if (flags & UFW_FLAG_SCOLON) fprintf(stderr, " SCOLON");
1071       if (flags & UFW_FLAG_PROTECTED) fprintf(stderr, " PROTECTED");
1072       fputc('\n', stderr);
1073     }
1074     if ((flags & 0xff00U) != 0) {
1075       fprintf(stderr, "   ARGS: ");
1076       switch (flags & UFW_WARG_MASK) {
1077         case UFW_WARG_NONE: fprintf(stderr, "NONE"); break;
1078         case UFW_WARG_BRANCH: fprintf(stderr, "BRANCH"); break;
1079         case UFW_WARG_LIT: fprintf(stderr, "LIT"); break;
1080         case UFW_WARG_C4STRZ: fprintf(stderr, "C4STRZ"); break;
1081         case UFW_WARG_CFA: fprintf(stderr, "CFA"); break;
1082         case UFW_WARG_CBLOCK: fprintf(stderr, "CBLOCK"); break;
1083         case UFW_WARG_VOCID: fprintf(stderr, "VOCID"); break;
1084         case UFW_WARG_C1STRZ: fprintf(stderr, "C1STRZ"); break;
1085         default: fprintf(stderr, "wtf?!"); break;
1086       }
1087       fputc('\n', stderr);
1088     }
1089     fprintf(stderr, "  BACKLEN: %u (nfa at 0x%08x)\n", ufoImgGetU8(cfa - 1u), UFO_CFA_TO_NFA(cfa));
1090     fprintf(stderr, "  NAME(%u): ", nlen);
1091     for (uint32_t f = 0; f < nlen; f += 1) {
1092       const uint8_t ch = ufoImgGetU8(nfa + 4u + f);
1093       if (ch <= 32 || ch >= 127) {
1094         fprintf(stderr, "\\x%02x", ch);
1095       } else {
1096         fprintf(stderr, "%c", (char)ch);
1097       }
1098     }
1099     fprintf(stderr, "\n");
1100     ufo_assert(UFO_CFA_TO_LFA(cfa) == lfa);
1101   }
1102 }
1103
1104
1105 //==========================================================================
1106 //
1107 //  ufoVocCheckName
1108 //
1109 //  return 0 or CFA
1110 //
1111 //==========================================================================
1112 static uint32_t ufoVocCheckName (uint32_t lfa, const void *wname, uint32_t wnlen, uint32_t hash,
1113                                  int allowvochid)
1114 {
1115   uint32_t res = 0;
1116   #ifdef UFO_DEBUG_FIND_WORD
1117   fprintf(stderr, "CHECK-NAME: %.*s; LFA: 0x%08x; hash: 0x%08x (wname: 0x%08x)\n",
1118           (unsigned) wnlen, (const char *)wname,
1119           lfa, (lfa != 0 ? ufoImgGetU32(UFO_LFA_TO_NHASH(lfa)) : 0), hash);
1120   ufoDumpWordHeader(lfa);
1121   #endif
1122   if (lfa != 0 && ufoImgGetU32(UFO_LFA_TO_NHASH(lfa)) == hash) {
1123     const uint32_t lenflags = ufoImgGetU32(UFO_LFA_TO_NFA(lfa));
1124     if ((lenflags & UFW_FLAG_SMUDGE) == 0 &&
1125         (allowvochid || (lenflags & UFW_FLAG_HIDDEN) == 0))
1126     {
1127       const uint32_t nlen = lenflags&0xffU;
1128       if (nlen == wnlen) {
1129         uint32_t naddr = UFO_LFA_TO_NFA(lfa) + 4u;
1130         uint32_t pos = 0;
1131         while (pos < nlen) {
1132           uint8_t c0 = ((const unsigned char *)wname)[pos];
1133           if (c0 >= 'a' && c0 <= 'z') c0 = c0 - 'a' + 'A';
1134           uint8_t c1 = ufoImgGetU8(naddr + pos);
1135           if (c1 >= 'a' && c1 <= 'z') c1 = c1 - 'a' + 'A';
1136           if (c0 != c1) break;
1137           pos += 1u;
1138         }
1139         if (pos == nlen) {
1140           // i found her!
1141           naddr += pos + 1u;
1142           res = UFO_ALIGN4(naddr);
1143         }
1144       }
1145     }
1146   }
1147   return res;
1148 }
1149
1150
1151 //==========================================================================
1152 //
1153 //  ufoFindWordInVoc
1154 //
1155 //  return 0 or CFA
1156 //
1157 //==========================================================================
1158 static uint32_t ufoFindWordInVoc (const void *wname, uint32_t wnlen, uint32_t hash,
1159                                   uint32_t vocid, int allowvochid)
1160 {
1161   uint32_t res = 0;
1162   if (wname == NULL) ufo_assert(wnlen == 0);
1163   if (wnlen != 0) {
1164     #if defined(UFO_DEBUG_FIND_WORD) || defined(UFO_DEBUG_FIND_WORD_IN_VOC)
1165     fprintf(stderr, "IN-VOC: %.*s; VOCID: 0x%08x; whash: 0x%08x; htbl[0]: 0x%08x\n",
1166             (unsigned) wnlen, (const char *)wname,
1167             vocid, hash, ufoImgGetU32(vocid + UFW_VOCAB_OFS_HTABLE));
1168     #endif
1169     const uint32_t htbl = vocid + UFW_VOCAB_OFS_HTABLE;
1170     if (ufoImgGetU32(htbl) != UFO_NO_HTABLE_FLAG) {
1171       // hash table present, use it
1172       uint32_t bfa = htbl + (hash % (uint32_t)UFO_HASHTABLE_SIZE) * 4u;
1173       bfa = ufoImgGetU32(bfa);
1174       while (res == 0 && bfa != 0) {
1175         #if defined(UFO_DEBUG_FIND_WORD) || defined(UFO_DEBUG_FIND_WORD_IN_VOC)
1176         fprintf(stderr, "IN-VOC:   bfa: 0x%08x\n", bfa);
1177         #endif
1178         res = ufoVocCheckName(UFO_BFA_TO_LFA(bfa), wname, wnlen, hash, allowvochid);
1179         bfa = ufoImgGetU32(bfa);
1180       }
1181     } else {
1182       // no hash table, use linear search
1183       uint32_t lfa = vocid + UFW_VOCAB_OFS_LATEST;
1184       lfa = ufoImgGetU32(lfa);
1185       while (res != 0 && lfa != 0) {
1186         res = ufoVocCheckName(lfa, wname, wnlen, hash, allowvochid);
1187         lfa = ufoImgGetU32(lfa);
1188       }
1189     }
1190   }
1191   return res;
1192 }
1193
1194
1195 //==========================================================================
1196 //
1197 //  ufoFindColon
1198 //
1199 //  return part after the colon, or `NULL`
1200 //
1201 //==========================================================================
1202 static const void *ufoFindColon (const void *wname, uint32_t wnlen) {
1203   const void *res = NULL;
1204   if (wnlen != 0) {
1205     ufo_assert(wname != NULL);
1206     const char *str = (const char *)wname;
1207     while (wnlen != 0 && str[0] != ':') {
1208       str += 1; wnlen -= 1;
1209     }
1210     if (wnlen != 0) {
1211       res = (const void *)(str + 1); // skip colon
1212     }
1213   }
1214   return res;
1215 }
1216
1217
1218 //==========================================================================
1219 //
1220 //  ufoFindWordNameRes
1221 //
1222 //  find with name resolution
1223 //
1224 //  return 0 or CFA
1225 //
1226 //==========================================================================
1227 static uint32_t ufoFindWordNameRes (const void *wname, uint32_t wnlen) {
1228   uint32_t res = 0;
1229   if (wnlen != 0 && *(const char *)wname != ':') {
1230     ufo_assert(wname != NULL);
1231
1232     const void *stx = wname;
1233     wname = ufoFindColon(wname, wnlen);
1234     if (wname != NULL) {
1235       // look in all vocabs (excluding hidden ones)
1236       uint32_t xlen = (uint32_t)(ptrdiff_t)(wname - stx) - 1u;
1237       ufo_assert(xlen > 0 && xlen < 255);
1238       uint32_t xhash = joaatHashBufCI(stx, xlen);
1239       uint32_t voclink = ufoImgGetU32(ufoAddrVocLink);
1240       #ifdef UFO_DEBUG_FIND_WORD_COLON
1241       fprintf(stderr, "COLON-FIND: first voc: {%.*s}; xhash=0x%08x; voc-link: 0x%08x\n",
1242               (unsigned)xlen, (const char *)stx, xhash, voclink);
1243       #endif
1244       while (res == 0 && voclink != 0) {
1245         const uint32_t vhdraddr = voclink - UFW_VOCAB_OFS_VOCLINK + UFW_VOCAB_OFS_HEADER;
1246         const uint32_t vhdr = ufoImgGetU32(vhdraddr);
1247         if (vhdr != 0) {
1248           res = ufoVocCheckName(UFO_NFA_TO_LFA(vhdr), stx, xlen, xhash, 0);
1249           if (res == 0) voclink = ufoImgGetU32(voclink);
1250         }
1251       }
1252       if (res != 0) {
1253         uint32_t vocid = voclink - UFW_VOCAB_OFS_VOCLINK;
1254         ufo_assert(voclink != 0);
1255         wnlen -= xlen + 1;
1256         #ifdef UFO_DEBUG_FIND_WORD_COLON
1257         fprintf(stderr, "searching {%.*s}(%u) in {%.*s}\n",
1258                 (unsigned)wnlen, wname, wnlen, (unsigned)xlen, stx);
1259         #endif
1260         while (res != 0 && wname != NULL) {
1261           stx = wname;
1262           wname = ufoFindColon(wname, wnlen);
1263           if (wname == NULL) xlen = wnlen; else xlen = (uint32_t)(ptrdiff_t)(wname - stx) - 1u;
1264           ufo_assert(xlen > 0 && xlen < 255);
1265           xhash = joaatHashBufCI(stx, xlen);
1266           res = ufoFindWordInVoc(stx, xlen, xhash, vocid, 1);
1267           if (res != 0) {
1268             wnlen -= xlen + 1;
1269             if (wname != NULL) {
1270               // it should be a vocabulary
1271               const uint32_t nfa = UFO_CFA_TO_NFA(res);
1272               if ((ufoImgGetU32(nfa) & UFW_FLAG_VOCAB) != 0) {
1273                 vocid = ufoImgGetU32(UFO_CFA_TO_PFA(res)); // pfa points to vocabulary
1274               } else {
1275                 res = 0;
1276               }
1277             }
1278           }
1279         }
1280       }
1281     }
1282   }
1283
1284   return res;
1285 }
1286
1287
1288 //==========================================================================
1289 //
1290 //  ufoFindWord
1291 //
1292 //  doesn't look in CURRENT, does name resolution ("a:b" is word "b" in "a")
1293 //
1294 //  return 0 or CFA
1295 //
1296 //==========================================================================
1297 static uint32_t ufoFindWord (const char *wname) {
1298   uint32_t res = 0;
1299   if (wname && wname[0] != 0) {
1300     const size_t wnlen = strlen(wname);
1301     ufo_assert(wnlen < 8192);
1302     uint32_t ctx = ufoImgGetU32(ufoAddrContext);
1303     const uint32_t hash = joaatHashBufCI(wname, (uint32_t)wnlen);
1304
1305     //fprintf(stderr, "FIND-WORD: whash: 0x%08x; name:{%s}\n", hash, wname);
1306
1307     // first search in context
1308     res = ufoFindWordInVoc(wname, (uint32_t)wnlen, hash, ctx, (ctx == ufoImgGetU32(ufoAddrCurrent)));
1309
1310     // try linked vocs
1311     if (res == 0 && ctx != 0) {
1312       ctx = ufoImgGetU32(ctx + UFW_VOCAB_OFS_PARENT);
1313       while (res != 0 && ctx != 0) {
1314         res = ufoFindWordInVoc(wname, (uint32_t)wnlen, hash, ctx, (ctx == ufoImgGetU32(ufoAddrCurrent)));
1315         ctx = ufoImgGetU32(ctx + UFW_VOCAB_OFS_PARENT);
1316       }
1317     }
1318
1319     // now try vocabulary stack
1320     uint32_t vstp = ufoVSP;
1321     while (res == 0 && vstp != 0) {
1322       vstp -= 1;
1323       ctx = ufoVocStack[vstp];
1324       res = ufoFindWordInVoc(wname, (uint32_t)wnlen, hash, ctx, (ctx == ufoImgGetU32(ufoAddrCurrent)));
1325     }
1326
1327     // if not found, try name resolution
1328     if (res == 0) res = ufoFindWordNameRes(wname, (uint32_t)wnlen);
1329   }
1330
1331   return res;
1332 }
1333
1334
1335 //==========================================================================
1336 //
1337 //  ufoFindWordMacro
1338 //
1339 //==========================================================================
1340 static uint32_t ufoFindWordMacro (const char *wname) {
1341   if (!wname || wname[0] == 0) return 0;
1342   const size_t wnlen = strlen(wname);
1343   ufo_assert(wnlen < 8192);
1344   return ufoFindWordInVoc(wname, (uint32_t)wnlen, joaatHashBufCI(wname, (uint32_t)wnlen),
1345                           ufoMacroVocId, 0);
1346 }
1347
1348
1349 //==========================================================================
1350 //
1351 //  ufoCreateWordHeader
1352 //
1353 //  create word header up to CFA, link to the current dictionary
1354 //
1355 //==========================================================================
1356 static void ufoCreateWordHeader (const char *wname, uint32_t flags) {
1357   if (wname == NULL) wname = "";
1358   const size_t wnlen = strlen(wname);
1359   ufo_assert(wnlen < UFO_MAX_WORD_LENGTH);
1360   const uint32_t hash = joaatHashBufCI(wname, (uint32_t)wnlen);
1361   const uint32_t curr = ufoImgGetU32(ufoAddrCurrent);
1362   ufo_assert(curr != 0);
1363   {
1364     const uint32_t cfa = ufoFindWordInVoc(wname, wnlen, hash, curr, 1);
1365     if (cfa) {
1366       const uint32_t nfa = UFO_CFA_TO_NFA(cfa);
1367       const uint32_t flags = ufoImgGetU32(nfa);
1368       if ((flags & UFW_FLAG_PROTECTED) != 0) {
1369         ufoFatal("trying to redefine protected word '%s'", wname);
1370       } else {
1371         ufoWarning("redefining word '%s'", wname);
1372       }
1373     }
1374   }
1375   //fprintf(stderr, "000: HERE: 0x%08x\n", UFO_GET_DP());
1376   const uint32_t bkt = (hash % (uint32_t)UFO_HASHTABLE_SIZE) * 4u;
1377   const uint32_t htbl = curr + UFW_VOCAB_OFS_HTABLE;
1378   ufoImgEmitAlign();
1379   ufoImgEmitU32(0); // dfa
1380   ufoImgEmitU32(0); // sfa
1381   // bucket link (bfa)
1382   if (wnlen == 0 || ufoImgGetU32(htbl) == UFO_NO_HTABLE_FLAG) {
1383     ufoImgEmitU32(0);
1384   } else {
1385     #ifdef UFO_DEBUG_DUMP_NEW_HEADERS
1386     fprintf(stderr, "NEW HEADER: %s; curr: 0x%08x; htbl: 0x%08x; bkt: 0x%08x\n",
1387             wname, curr, htbl, bkt);
1388     fprintf(stderr, "  [bkt]: 0x%08x; nbk: 0x%08x\n", ufoImgGetU32(htbl + bkt), UFO_GET_DP());
1389     #endif
1390     // bfa points to bfa
1391     const uint32_t bfa = UFO_GET_DP();
1392     ufoImgEmitU32(ufoImgGetU32(htbl + bkt));
1393     ufoImgPutU32(htbl + bkt, bfa);
1394   }
1395   // lfa
1396   const uint32_t lfa = UFO_GET_DP();
1397   ufoImgEmitU32(ufoImgGetU32(curr + UFW_VOCAB_OFS_LATEST));
1398   // fix voc latest
1399   ufoImgPutU32(curr + UFW_VOCAB_OFS_LATEST, lfa);
1400   // name hash
1401   ufoImgEmitU32(hash);
1402   // name length
1403   const uint32_t nfa = UFO_GET_DP();
1404   ufoImgEmitU32(((uint32_t)wnlen&0xffU) | (flags & 0xffffff00U));
1405   const uint32_t nstart = UFO_GET_DP();
1406   // put name
1407   for (size_t f = 0; f < wnlen; f += 1) {
1408     ufoImgEmitU8(((const unsigned char *)wname)[f]);
1409   }
1410   while ((UFO_GET_DP() & 3) != 3) ufoImgEmitU8(0);
1411   const uint32_t nend = UFO_GET_DP(); // length byte itself is not included
1412   // name length, again
1413   ufo_assert(nend - nstart <= 255);
1414   ufoImgEmitU8((uint8_t)(nend - nstart));
1415   ufo_assert((UFO_GET_DP() & 3) == 0);
1416   ufo_assert(UFO_CFA_TO_NFA(UFO_GET_DP()) == nfa);
1417   #ifdef UFO_DEBUG_DUMP_NEW_HEADERS
1418   fprintf(stderr, "*** NEW HEADER ***\n");
1419   fprintf(stderr, "CFA: 0x%08x\n", UFO_GET_DP());
1420   fprintf(stderr, "NSTART: 0x%08x\n", nstart);
1421   fprintf(stderr, "NEND: 0x%08x\n", nend);
1422   fprintf(stderr, "NLEN: %u (%u)\n", nend - nstart, ufoImgGetU8(UFO_GET_DP() - 1u));
1423   ufoDumpWordHeader(lfa);
1424   #endif
1425   #if 0
1426   fprintf(stderr, "NEW WORD CFA 0x%08x: %s\n", UFO_GET_DP(), wname);
1427   #endif
1428 }
1429
1430
1431 //==========================================================================
1432 //
1433 //  ufoDecompilePart
1434 //
1435 //==========================================================================
1436 static void ufoDecompilePart (uint32_t addr, uint32_t eaddr, int indent) {
1437   uint32_t count;
1438   FILE *fo = stdout;
1439   while (addr < eaddr) {
1440     uint32_t cfa = ufoImgGetU32(addr);
1441     for (int n = 0; n < indent; n += 1) fputc(' ', fo);
1442     fprintf(fo, "%6u: 0x%08x: ", addr, cfa);
1443     uint32_t nfa = UFO_CFA_TO_NFA(cfa);
1444     uint32_t flags = ufoImgGetU32(nfa);
1445     //fprintf(fo, "[0x%08x] ", flags & UFW_WARG_MASK);
1446     uint32_t nlen = flags & 0xffU;
1447     for (uint32_t f = 0; f < nlen; f += 1) {
1448       const uint8_t ch = ufoImgGetU8(nfa + 4u + f);
1449       if (ch <= 32 || ch >= 127) {
1450         fprintf(fo, "\\x%02x", ch);
1451       } else {
1452         fprintf(fo, "%c", (char)ch);
1453       }
1454     }
1455     addr += 4u;
1456     switch (flags & UFW_WARG_MASK) {
1457       case UFW_WARG_NONE:
1458         break;
1459       case UFW_WARG_BRANCH:
1460         fprintf(fo, "  @%u", ufoImgGetU32(addr)); addr += 4u;
1461         break;
1462       case UFW_WARG_LIT:
1463         fprintf(fo, "  %u : %d : 0x%08x", ufoImgGetU32(addr),
1464                 (int32_t)ufoImgGetU32(addr), ufoImgGetU32(addr)); addr += 4u;
1465         break;
1466       case UFW_WARG_C4STRZ:
1467         count = ufoImgGetU32(addr); addr += 4;
1468        print_str:
1469         fprintf(fo, "  str:");
1470         for (int f = 0; f < count; f += 1) {
1471           const uint8_t ch = ufoImgGetU8(addr); addr += 1u;
1472           if (ch <= 32 || ch >= 127) {
1473             fprintf(fo, "\\x%02x", ch);
1474           } else {
1475             fprintf(fo, "%c", (char)ch);
1476           }
1477         }
1478         addr += 1u; // skip zero byte
1479         addr = UFO_ALIGN4(addr);
1480         break;
1481       case UFW_WARG_CFA:
1482         cfa = ufoImgGetU32(addr); addr += 4u;
1483         fprintf(fo, "  CFA:%u: ", cfa);
1484         nfa = UFO_CFA_TO_NFA(cfa);
1485         nlen = ufoImgGetU8(nfa);
1486         for (uint32_t f = 0; f < nlen; f += 1) {
1487           const uint8_t ch = ufoImgGetU8(nfa + 4u + f);
1488           if (ch <= 32 || ch >= 127) {
1489             fprintf(fo, "\\x%02x", ch);
1490           } else {
1491             fprintf(fo, "%c", (char)ch);
1492           }
1493         }
1494         break;
1495       case UFW_WARG_CBLOCK:
1496         fprintf(fo, "  CBLOCK:%u", ufoImgGetU32(addr)); addr += 4u;
1497         break;
1498       case UFW_WARG_VOCID:
1499         fprintf(fo, "  VOCID:%u", ufoImgGetU32(addr)); addr += 4u;
1500         break;
1501       case UFW_WARG_C1STRZ:
1502         count = ufoImgGetU8(addr); addr += 1;
1503         goto print_str;
1504       /*
1505       case UFW_WARG_U8:
1506         fprintf(fo, "  ubyte:%u", ufoImgGetU8(addr)); addr += 1u;
1507         break;
1508       case UFW_WARG_S8:
1509         fprintf(fo, "  sbyte:%u", ufoImgGetU8(addr)); addr += 1u;
1510         break;
1511       case UFW_WARG_U16:
1512         fprintf(fo, "  uword:%u", ufoImgGetU16(addr)); addr += 2u;
1513         break;
1514       case UFW_WARG_S16:
1515         fprintf(fo, "  sword:%u", ufoImgGetU16(addr)); addr += 2u;
1516         break;
1517       */
1518       default:
1519         fprintf(fo, " -- WTF?!\n");
1520         abort();
1521     }
1522     fputc('\n', fo);
1523   }
1524 }
1525
1526
1527 //==========================================================================
1528 //
1529 //  ufoDecompileWord
1530 //
1531 //==========================================================================
1532 static void ufoDecompileWord (const uint32_t cfa) {
1533   if (cfa != 0) {
1534     const uint32_t lfa = UFO_CFA_TO_LFA(cfa);
1535     fprintf(stdout, "#### DECOMPILING CFA 0x%08x ###\n", cfa);
1536     ufoDumpWordHeader(lfa);
1537     const uint32_t sfa = ufoImgGetU32(UFO_LFA_TO_SFA(lfa));
1538     if (ufoImgGetU32(cfa) == ufoDoForthCFA) {
1539       fprintf(stdout, "--- DECOMPILED CODE ---\n");
1540       ufoDecompilePart(UFO_CFA_TO_PFA(cfa), sfa, 0);
1541       fprintf(stdout, "=======================\n");
1542     }
1543   }
1544 }
1545
1546
1547 //==========================================================================
1548 //
1549 //  ufoFindWordForIP
1550 //
1551 //  return NFA or 0
1552 //
1553 //  WARNING: this is SLOW!
1554 //
1555 //==========================================================================
1556 static uint32_t ufoFindWordForIP (uint32_t ip) {
1557   uint32_t res = 0;
1558   if (ip != 0) {
1559     // iterate over all vocabs
1560     uint32_t voclink = ufoImgGetU32(ufoAddrVocLink);
1561     while (voclink != 0) {
1562       // iterate over all words
1563       const uint32_t vocid = voclink - UFW_VOCAB_OFS_VOCLINK;
1564       uint32_t lfa = ufoImgGetU32(vocid + UFW_VOCAB_OFS_LATEST);
1565       while (lfa != 0) {
1566         const uint32_t cfa = UFO_LFA_TO_CFA(lfa);
1567         const uint32_t pfa = UFO_CFA_TO_PFA(cfa);
1568         const uint32_t sfa = ufoImgGetU32(UFO_LFA_TO_SFA(lfa));
1569         if (ip >= pfa && ip < sfa) return UFO_LFA_TO_NFA(lfa);
1570         lfa = ufoImgGetU32(lfa);
1571       }
1572       voclink = ufoImgGetU32(vocid + UFW_VOCAB_OFS_VOCLINK);
1573     }
1574   }
1575   return res;
1576 }
1577
1578
1579 //==========================================================================
1580 //
1581 //  ufoBacktrace
1582 //
1583 //==========================================================================
1584 static void ufoBacktrace (void) {
1585   // dump data stack (top 16)
1586   if (!ufoLastEmitWasCR) { printf("\n"); ufoLastEmitWasCR = 1; }
1587   fflush(NULL);
1588
1589   fprintf(stderr, "***UFO STACK DEPTH: %u\n", ufoSP);
1590   uint32_t xsp = ufoSP;
1591   if (xsp > 16) xsp = 16;
1592   for (uint32_t sp = 0; sp < xsp; ++sp) {
1593     fprintf(stderr, "  %2u: 0x%08x  %d\n", sp,
1594             ufoDStack[xsp - sp - 1], (int32_t)ufoDStack[xsp - sp - 1]);
1595   }
1596   if (ufoSP > 16) fprintf(stderr, "    ...more...\n");
1597
1598   // dump return stack (top 32)
1599   fprintf(stderr, "***UFO RETURN STACK DEPTH: %u\n", ufoRP);
1600   uint32_t rp = ufoRP;
1601   uint32_t rscount = 0;
1602   if (rp > UFO_RSTACK_SIZE) rp = UFO_RSTACK_SIZE;
1603   while (rscount != 32 && rp != 0) {
1604     rp -= 1;
1605     const uint32_t val = ufoRStack[rp];
1606     uint32_t nfa = ufoFindWordForIP(val);
1607     if (nfa != 0) {
1608       // print word name
1609       fprintf(stderr, "  %2u: 0x%08x -- ", ufoRP - rp - 1u, val);
1610       uint32_t len = ufoImgGetU8(nfa); nfa += 4u;
1611       while (len != 0) {
1612         uint8_t ch = ufoImgGetU8(nfa); nfa += 1u; len -= 1u;
1613         if (ch <= 32 || ch >= 127) {
1614           fprintf(stderr, "\\x%02x", ch);
1615         } else {
1616           fprintf(stderr, "%c", (char)ch);
1617         }
1618       }
1619       fputc('\n', stderr);
1620     } else {
1621       fprintf(stderr, "  %2u: 0x%08x  %d\n", ufoRP - rp - 1u,
1622               val, (int32_t)val);
1623     }
1624     rscount += 1;
1625   }
1626   if (ufoRP > 32) fprintf(stderr, "    ...more...\n");
1627
1628   fflush(NULL);
1629 }
1630
1631
1632 //==========================================================================
1633 //
1634 //  ufoDumpVocab
1635 //
1636 //==========================================================================
1637 /*
1638 static void ufoDumpVocab (uint32_t vocid) {
1639   if (vocid != 0) {
1640     fprintf(stderr, "*** VOCID: 0x%08x ***\n", vocid);
1641     uint32_t vochdr = vocid + UFW_VOCAB_OFS_HEADER;
1642     vochdr = ufoImgGetU32(vochdr);
1643     if (vochdr != 0) {
1644       fprintf(stderr, "--- HEADER ---\n");
1645       ufoDumpWordHeader(UFO_NFA_TO_LFA(vochdr));
1646       fprintf(stderr, "========\n");
1647       uint32_t htbl = vocid + UFW_VOCAB_OFS_HTABLE;
1648       if (ufoImgGetU32(htbl) != UFO_NO_HTABLE_FLAG) {
1649         fprintf(stderr, "--- HASH TABLE ---\n");
1650         for (int f = 0; f < UFO_HASHTABLE_SIZE; f += 1) {
1651           uint32_t bfa = ufoImgGetU32(htbl);
1652           if (bfa != 0) {
1653             fprintf(stderr, "**** %2d: 0x%08x\n", f, bfa);
1654             do {
1655               ufoDumpWordHeader(UFO_BFA_TO_LFA(bfa));
1656               bfa = ufoImgGetU32(bfa);
1657             } while (bfa != 0);
1658           }
1659           htbl += 4u;
1660         }
1661       }
1662     }
1663   }
1664 }
1665 */
1666
1667
1668 //==========================================================================
1669 //
1670 //  ufoSetNextLine
1671 //
1672 //==========================================================================
1673 static void ufoSetNextLine (const char *text) {
1674   if (text == NULL) text = "";
1675
1676   ufoImgPutU32(ufoAddrTIB, 0);
1677   ufoImgPutU32(ufoAddrIN, 0);
1678   ufoImgPutU32(0, 0);
1679
1680   size_t sslen = strlen(text);
1681   while (sslen != 0 && (text[sslen - 1u] == 13 || text[sslen - 1u] == 10)) sslen -= 1;
1682   if (sslen > 510) ufoFatal("input line too long");
1683   if (sslen >= ufoTIBAreaSize) ufoFatal("input line too long");
1684
1685   #ifdef UFO_DEBUG_INCLUDE
1686   fprintf(stderr, "NEXT-LINE: <%.*s>\n", (unsigned)sslen, (const char *)text);
1687   #endif
1688
1689   uint32_t dpos = 0;
1690   while (dpos != (uint32_t)sslen) {
1691     uint8_t ch = ((const unsigned char *)text)[dpos];
1692     // replace bad chars, because why not
1693     if (ch == 0 || ch == 13 || ch == 10) ch = 32;
1694     ufoImgPutU8(dpos, ch); dpos += 1;
1695   }
1696   ufoImgPutU8(dpos, 0);
1697 }
1698
1699
1700 //==========================================================================
1701 //
1702 //  ufoLoadNextLine_NativeMode
1703 //
1704 //  load next file line into TIB
1705 //  always strips final '\n'
1706 //
1707 //==========================================================================
1708 static void ufoLoadNextLine_NativeMode (int crossInclude) {
1709   const char *text = NULL;
1710
1711   int done = 0;
1712
1713   while (ufoInFile && done == 0) {
1714     if (fgets(ufoCurrFileLine, 510, ufoInFile) != NULL) {
1715       // check for a newline
1716       // if there is no newline char at the end, the string was truncated
1717       ufoCurrFileLine[510] = 0;
1718       uint32_t slen = (uint32_t)strlen(ufoCurrFileLine);
1719       if (slen == 0 || (ufoCurrFileLine[slen - 1u] != 13 && ufoCurrFileLine[slen - 1u] != 10)) {
1720         ufoFatal("input line too long");
1721       }
1722       ++ufoInFileLine;
1723       text = ufoCurrFileLine;
1724       done = 1;
1725       #if defined(UFO_DEBUG_INCLUDE) && 0
1726       fprintf(stderr, "READ LINE: %s", text);
1727       #endif
1728     } else {
1729       if (!crossInclude) {
1730         if (ufoCondStLine >= 0) {
1731           ufoFatal("unfinished conditional from line %d", ufoCondStLine);
1732         }
1733         ufoFatal("unexpected end of text");
1734       }
1735       ufoPopInFile();
1736     }
1737   }
1738
1739   if (done == 0) {
1740     int lnum;
1741     const char *fname;
1742     text = ufoGetSrcLine(&fname, &lnum);
1743     if (text == NULL) {
1744       if (ufoCondStLine >= 0) {
1745         ufoFatal("unfinished conditional from line %d", ufoCondStLine);
1746       }
1747       ufoFatal("unexpected end of text");
1748     }
1749     ufoInFileLine = lnum;
1750     if (ufoInFileName == NULL || strcmp(ufoInFileName, fname) != 0) {
1751       if (ufoInFileName != NULL) free(ufoInFileName);
1752       ufoInFileName = strdup(fname);
1753       setLastIncPath(ufoInFileName);
1754     }
1755   }
1756
1757   ufoSetNextLine(text);
1758 }
1759
1760
1761 //==========================================================================
1762 //
1763 //  ufoLoadMacroLine
1764 //
1765 //==========================================================================
1766 static void ufoLoadMacroLine (const char *line, const char *fname, int lnum) {
1767   const char *text = line;
1768   if (text == NULL) text = "";
1769   if (fname == NULL) fname = "";
1770
1771   ufoInFileLine = lnum;
1772   if (ufoInFileName == NULL || strcmp(ufoInFileName, fname) != 0) {
1773     if (ufoInFileName != NULL) free(ufoInFileName);
1774     ufoInFileName = strdup(fname);
1775     setLastIncPath(ufoInFileName);
1776   }
1777
1778   ufoSetNextLine(text);
1779 }
1780
1781
1782 //==========================================================================
1783 //
1784 //  ufoLoadNextLine
1785 //
1786 //  load next file line into TIB
1787 //  return zero on success, -1 on EOF, -2 on error
1788 //
1789 //==========================================================================
1790 static void ufoLoadNextLine (int crossInclude) {
1791   switch (ufoMode) {
1792     case UFO_MODE_NATIVE:
1793       ufoLoadNextLine_NativeMode(crossInclude);
1794       break;
1795     case UFO_MODE_MACRO:
1796       if (ufoCondStLine >= 0) {
1797         ufoFatal("unfinished conditional from line %d", ufoCondStLine);
1798       }
1799       ufoFatal("unexpected end of input for FORTH asm macro");
1800       break;
1801     default: ufoFatal("wtf?! not properly inited!");
1802   }
1803 }
1804
1805
1806 // ////////////////////////////////////////////////////////////////////////// //
1807 #define UFWORD(name_) \
1808 static void ufoWord_##name_ (uint32_t mypfa)
1809
1810 #define UFCALL(name_)  ufoWord_##name_(0)
1811 #define UFCFA(name_)   (&ufoWord_##name_)
1812
1813
1814 // ////////////////////////////////////////////////////////////////////////// //
1815 // debug
1816
1817 // DUMP-STACK
1818 // ( -- )
1819 UFWORD(DUMP_STACK) {
1820   if (!ufoLastEmitWasCR) { printf("\n"); ufoLastEmitWasCR = 1; }
1821   printf("***UFO STACK DEPTH: %u\n", ufoSP);
1822   uint32_t left = 32;
1823   uint32_t sp = ufoSP;
1824   while (sp != 0 && left != 0) {
1825     sp -= 1; left -= 1;
1826     printf("  %4u: 0x%08x  %d\n", sp, ufoDStack[sp], (int32_t)ufoDStack[sp]);
1827   }
1828   if (sp != 0) printf("...more...\n");
1829   ufoLastEmitWasCR = 1;
1830 }
1831
1832 // BACKTRACE
1833 UFWORD(UFO_BACKTRACE) {
1834   ufoBacktrace();
1835 }
1836
1837 #include "urforth_dbg.c"
1838
1839 // (UFO-BP)
1840 // debug breakpoint
1841 UFWORD(UFO_BP) {
1842   if (!ufoLastEmitWasCR) { printf("\n"); ufoLastEmitWasCR = 1; }
1843   #ifdef WIN32
1844   ufoFatal("there is no UFO debug breakpoint support in windoze");
1845   #else
1846   if (isatty(STDIN_FILENO) && isatty(STDOUT_FILENO)) {
1847     ufoDebugSession();
1848   } else {
1849     fprintf(stderr, "WARNING: cannot start UFO debug session, because standard streams are not on TTY!\n");
1850   }
1851   #endif
1852 }
1853
1854
1855 // ////////////////////////////////////////////////////////////////////////// //
1856 // SP0!
1857 // ( -- )
1858 UFWORD(SP0_STORE) { ufoSP = 0; }
1859
1860 // RP0!
1861 // ( -- )
1862 UFWORD(RP0_STORE) { ufoRP = ufoRPTop; }
1863
1864 // DP!
1865 // ( newhere -- )
1866 UFWORD(DP_STORE) { UFO_SET_DP(ufoPop()); }
1867
1868 // HERE
1869 // ( -- n )
1870 UFWORD(HERE) { ufoPush(UFO_GET_DP()); }
1871
1872 // PAD
1873 // ( -- )
1874 // PAD is at the beginning of temp area
1875 UFWORD(PAD) {
1876   ufoPush(UFO_ADDR_TEMP_BIT);
1877 }
1878
1879 // @
1880 // ( addr -- value32 )
1881 UFWORD(PEEK) { const uint32_t addr = ufoPop(); ufoPush(ufoImgGetU32(addr)); }
1882
1883 // C@
1884 // ( addr -- value8 )
1885 UFWORD(CPEEK) { const uint32_t addr = ufoPop(); ufoPush(ufoImgGetU8(addr)); }
1886
1887 // W@
1888 // ( addr -- value32 )
1889 UFWORD(WPEEK) { const uint32_t addr = ufoPop(); ufoPush(ufoImgGetU16(addr)); }
1890
1891 // !
1892 // ( val32 addr -- )
1893 UFWORD(POKE) { const uint32_t addr = ufoPop(); const uint32_t val = ufoPop(); ufoImgPutU32(addr, val); }
1894
1895 // C!
1896 // ( val8 addr -- )
1897 UFWORD(CPOKE) { const uint32_t addr = ufoPop(); const uint32_t val = ufoPop(); ufoImgPutU8(addr, val&0xffU); }
1898
1899 // W!
1900 // ( val32 addr -- )
1901 UFWORD(WPOKE) { const uint32_t addr = ufoPop(); const uint32_t val = ufoPop(); ufoImgPutU16(addr, val&0xffffU); }
1902
1903 // C,
1904 // ( val8 -- )
1905 UFWORD(CCOMMA) { const uint32_t val = ufoPop(); ufoImgEmitU8(val); }
1906
1907 // W,
1908 // ( val16 -- )
1909 UFWORD(WCOMMA) { const uint32_t val = ufoPop(); ufoImgEmitU8(val&0xffU); ufoImgEmitU8((val >> 8)&0xffU); }
1910
1911 // ,
1912 // ( val -- )
1913 UFWORD(COMMA) { const uint32_t val = ufoPop(); ufoImgEmitU32(val); }
1914
1915
1916 // ZX-C,
1917 // ( val8 -- )
1918 // puts byte to zx dictionary
1919 UFWORD(ZX_CCOMMA) {
1920   const uint32_t val = ufoPop()&0xffU;
1921   ufoZXEmitU8(val);
1922 }
1923
1924 // ZX-W,
1925 // ( val -- )
1926 // puts word to zx dictionary
1927 UFWORD(ZX_WCOMMA) {
1928   const uint32_t val = ufoPop();
1929   ufoZXEmitU16(val&0xffffU);
1930 }
1931
1932 // ZX-C@
1933 // ( addr -- value8 )
1934 UFWORD(ZX_CPEEK) { const uint32_t addr = ufoPop(); ufoPush(ufoZXGetU8(addr)); }
1935
1936 // ZX-C!
1937 // ( val8 addr -- )
1938 UFWORD(ZX_CPOKE) { const uint32_t addr = ufoPop(); const uint32_t val = ufoPop(); ufoZXPutU8(addr, val); }
1939
1940 // ZX-W@
1941 // ( addr -- value16 )
1942 UFWORD(ZX_WPEEK) { const uint32_t addr = ufoPop(); ufoPush(ufoZXGetU16(addr)); }
1943
1944 // ZX-W!
1945 // ( val16 addr -- )
1946 UFWORD(ZX_WPOKE) { const uint32_t addr = ufoPop(); const uint32_t val = ufoPop(); ufoZXPutU16(addr, val); }
1947
1948 // ZX-RESERVED?
1949 // ( addr -- bool )
1950 UFWORD(ZX_RESERVEDQ) {
1951   const uint32_t addr = ufoPop();
1952   ufoPushBool(ufoZXGetReserved(addr));
1953 }
1954
1955 // ZX-RESERVED!
1956 // ( bool addr -- )
1957 UFWORD(ZX_RESERVEDS) {
1958   const uint32_t addr = ufoPop();
1959   const uint32_t flag = ufoPop();
1960   ufoZXSetReserved(addr, (flag ? 1 : 0));
1961 }
1962
1963
1964 // (LIT) ( -- n )
1965 UFWORD(PAR_LIT) {
1966   const uint32_t v = ufoImgGetU32(ufoIP); ufoIP += 4;
1967   ufoPush(v);
1968 }
1969
1970 // (LITCFA) ( -- n )
1971 UFWORD(PAR_LITCFA) {
1972   const uint32_t v = ufoImgGetU32(ufoIP); ufoIP += 4;
1973   ufoPush(v);
1974 }
1975
1976 // (LITVOCID) ( -- n )
1977 UFWORD(PAR_LITVOCID) {
1978   const uint32_t v = ufoImgGetU32(ufoIP); ufoIP += 4;
1979   ufoPush(v);
1980 }
1981
1982 // (STRLIT8)
1983 UFWORD(PAR_STRLIT8) {
1984   const uint32_t count = ufoImgGetU8(ufoIP); ufoIP += 1;
1985   ufoPush(ufoIP);
1986   ufoPush(count);
1987   ufoIP += count + 1; // 1 for terminating 0
1988   // align
1989   ufoIP = UFO_ALIGN4(ufoIP);
1990 }
1991
1992 // (BRANCH) ( -- )
1993 UFWORD(PAR_BRANCH) {
1994   ufoIP = ufoImgGetU32(ufoIP);
1995 }
1996
1997 // (TBRANCH) ( flag )
1998 UFWORD(PAR_TBRANCH) {
1999   if (ufoPop()) {
2000     ufoIP = ufoImgGetU32(ufoIP);
2001   } else {
2002     ufoIP += 4;
2003   }
2004 }
2005
2006 // (0BRANCH) ( flag )
2007 UFWORD(PAR_0BRANCH) {
2008   if (!ufoPop()) {
2009     ufoIP = ufoImgGetU32(ufoIP);
2010   } else {
2011     ufoIP += 4;
2012   }
2013 }
2014
2015 // EXECUTE ( cfa )
2016 UFWORD(EXECUTE) {
2017   ufoExecuteCFA(ufoPop(), UFO_EXEC_NORMAL);
2018 }
2019
2020 // EXECUTE-TAIL ( cfa )
2021 UFWORD(EXECUTE_TAIL) {
2022   ufoExecuteCFA(ufoPop(), UFO_EXEC_TAILCALL);
2023 }
2024
2025 // (EXIT)
2026 UFWORD(PAR_EXIT) {
2027   if (ufoRP == 0 || ufoRP == ufoRPTop) {
2028     ufoStopVM = 1;
2029   } else {
2030     ufoIP = ufoRPop();
2031     if ((ufoIP & 3) != 0) ufoFatal("invalid IP");
2032   }
2033 }
2034
2035 // (L-ENTER)
2036 // ( loccount -- )
2037 UFWORD(PAR_LENTER) {
2038   // low byte of loccount is total number of locals
2039   // high byte is the number of args
2040   uint32_t lcount = ufoImgGetU32(ufoIP); ufoIP += 1;
2041   uint32_t acount = (lcount >> 8)&0xff;
2042   lcount &= 0xff;
2043   if (lcount == 0 || lcount < acount) ufoFatal("invalid call to (L-ENTER)");
2044   if ((ufoLBP != 0 && ufoLBP >= ufoLP) || UFO_LSTACK_SIZE - ufoLP <= lcount + 2) {
2045     ufoFatal("out of locals stack");
2046   }
2047   uint32_t newbp;
2048   if (ufoLP == 0) { ufoLP = 1; newbp = 1; } else newbp = ufoLP;
2049   //fprintf(stderr, "LP: %u; LBP: %u; locs: %u; word: %s\n", ufoLP, ufoLBP, fw->locs, fw->name);
2050   ufoLStack[ufoLP] = ufoLBP; ufoLP += 1;
2051   ufoLBP = newbp; ufoLP += lcount;
2052   // and copy args
2053   newbp += acount;
2054   while (newbp != ufoLBP) {
2055     ufoLStack[newbp] = ufoPop();
2056     newbp -= 1;
2057   }
2058 }
2059
2060 // (L-LEAVE)
2061 UFWORD(PAR_LLEAVE) {
2062   if (ufoLBP == 0) ufoFatal("(L-LEAVE) with empty locals stack");
2063   if (ufoLBP >= ufoLP) ufoFatal("(L-LEAVE) broken locals stack");
2064   ufoLP = ufoLBP;
2065   ufoLBP = ufoLStack[ufoLBP];
2066 }
2067
2068
2069 //==========================================================================
2070 //
2071 //  ufoLoadLocal
2072 //
2073 //==========================================================================
2074 static void ufoLoadLocal (uint32_t lidx) {
2075   if (lidx == 0 || lidx >= UFO_LSTACK_SIZE) ufoFatal("invalid local index1");
2076   if (ufoLBP == 0 || ufoLBP >= ufoLP || ufoLP - ufoLBP <= lidx) ufoFatal("invalid local index");
2077   ufoPush(ufoLStack[ufoLBP + lidx]);
2078 }
2079
2080
2081 //==========================================================================
2082 //
2083 //  ufoStoreLocal
2084 //
2085 //==========================================================================
2086 static void ufoStoreLocal (uint32_t lidx) {
2087   uint32_t value = ufoPop();
2088   if (lidx == 0 || lidx >= UFO_LSTACK_SIZE) ufoFatal("invalid local index1");
2089   if (ufoLBP == 0 || ufoLBP >= ufoLP || ufoLP - ufoLBP <= lidx) ufoFatal("invalid local index");
2090   ufoLStack[ufoLBP + lidx] = value;
2091 }
2092
2093
2094 // (LOCAL@)
2095 // ( idx -- value )
2096 UFWORD(PAR_LOCAL_LOAD) { ufoLoadLocal(ufoPop()); }
2097
2098 // (LOCAL!)
2099 // ( value idx -- )
2100 UFWORD(PAR_LOCAL_STORE) { ufoStoreLocal(ufoPop()); }
2101
2102 // (LOCAL!-1) .. (LOCAL!-7)
2103
2104 // DUP ( n -- n n )
2105 UFWORD(DUP) { ufoDup(); }
2106 // ?DUP ( n -- n n ) | ( 0 -- 0 )
2107 UFWORD(QDUP) { if (ufoPeek()) ufoDup(); }
2108 // 2DUP ( n0 n1 -- n0 n1 n0 n1 ) | ( 0 -- 0 )
2109 UFWORD(DDUP) { ufo2Dup(); }
2110 // DROP ( n -- )
2111 UFWORD(DROP) { ufoDrop(); }
2112 // 2DROP ( n -- )
2113 UFWORD(DDROP) { ufo2Drop(); }
2114 // SWAP ( n0 n1 -- n1 n0 )
2115 UFWORD(SWAP) { ufoSwap(); }
2116 // 2SWAP ( n0 n1 -- n1 n0 )
2117 UFWORD(DSWAP) { ufo2Swap(); }
2118 // OVER ( n0 n1 -- n0 n1 n0 )
2119 UFWORD(OVER) { ufoOver(); }
2120 // 2OVER ( n0 n1 -- n0 n1 n0 )
2121 UFWORD(DOVER) { ufo2Over(); }
2122 // ROT ( n0 n1 n2 -- n1 n2 n0 )
2123 UFWORD(ROT) { ufoRot(); }
2124 // NROT ( n0 n1 n2 -- n2 n0 n1 )
2125 UFWORD(NROT) { ufoNRot(); }
2126
2127 // RDUP ( n -- n n )
2128 UFWORD(RDUP) { ufoRDup(); }
2129 // RDROP ( n -- )
2130 UFWORD(RDROP) { ufoRDrop(); }
2131
2132 // >R ( n -- | n)
2133 UFWORD(DTOR) { ufoRPush(ufoPop()); }
2134 // R> ( -- n | n-removed )
2135 UFWORD(RTOD) { ufoPush(ufoRPop()); }
2136 // R@ ( -- n | n-removed )
2137 UFWORD(RPEEK) { ufoPush(ufoRPeek()); }
2138
2139
2140 // PICK ( idx -- n )
2141 UFWORD(PICK) {
2142   const uint32_t n = ufoPop();
2143   if (n >= ufoSP) ufoFatal("invalid PICK index %u", n);
2144   ufoPush(ufoDStack[ufoSP - n - 1u]);
2145 }
2146
2147 // RPICK ( idx -- n )
2148 UFWORD(RPICK) {
2149   const uint32_t n = ufoPop();
2150   if (n >= ufoRP) ufoFatal("invalid RPICK index %u", n);
2151   const uint32_t rp = ufoRP - n - 1u;
2152   if (rp <= ufoRPTop) ufoFatal("invalid RPICK index %u", n);
2153   ufoPush(ufoRStack[rp]);
2154 }
2155
2156 // ROLL ( idx -- n )
2157 UFWORD(ROLL) {
2158   const uint32_t n = ufoPop();
2159   if (n >= ufoSP) ufoFatal("invalid ROLL index %u", n);
2160   switch (n) {
2161     case 0: break; // do nothing
2162     case 1: ufoSwap(); break;
2163     case 2: ufoRot(); break;
2164     default:
2165       {
2166         const uint32_t val = ufoDStack[ufoSP - n - 1u];
2167         for (uint32_t f = ufoSP - n; f < ufoSP; f += 1) ufoDStack[f - 1] = ufoDStack[f];
2168         ufoDStack[ufoSP - 1u] = val;
2169       }
2170       break;
2171   }
2172 }
2173
2174 // RROLL ( idx -- n )
2175 UFWORD(RROLL) {
2176   const uint32_t n = ufoPop();
2177   if (n >= ufoRP) ufoFatal("invalid RROLL index %u", n);
2178   if (n != 0) {
2179     const uint32_t rp = ufoRP - n - 1u;
2180     if (rp <= ufoRPTop) ufoFatal("invalid RROLL index %u", n);
2181     const uint32_t val = ufoRStack[rp];
2182     for (uint32_t f = rp + 1u; f < ufoRP; f += 1u) ufoRStack[f - 1u] = ufoRStack[f];
2183     ufoRStack[ufoRP - 1u] = val;
2184   }
2185 }
2186
2187
2188 // REFILL
2189 // ( -- eofflag )
2190 UFWORD(REFILL) {
2191   ufoLoadNextLine(1);
2192   ufoPushBool(1);
2193 }
2194
2195
2196 //==========================================================================
2197 //
2198 //  ufoIsDelim
2199 //
2200 //==========================================================================
2201 static int ufoIsDelim (uint8_t ch, uint8_t delim) {
2202   return (delim == 32 ? (ch <= 32) : (ch == delim));
2203 }
2204
2205
2206 // (PARSE)
2207 // ( delim skip-leading-delim? -- addr count TRUE / FALSE )
2208 // does base TIB parsing; never copies anything.
2209 // as our reader is line-based, returns FALSE on EOL.
2210 // EOL is detected after skipping leading delimiters.
2211 // passing -1 as delimiter skips the whole line, and always returns FALSE.
2212 // trailing delimiter is always skipped.
2213 UFWORD(PAR_PARSE) {
2214   const uint32_t skipDelim = ufoPop();
2215   const uint32_t delim = ufoPop();
2216   const uint32_t tib = ufoImgGetU32(ufoAddrTIB);
2217   uint32_t in = ufoImgGetU32(ufoAddrIN);
2218
2219   #if 0
2220   fprintf(stderr, "PARSE-IN: in=%u; delim=%u; skip=%u\n",
2221           in, delim, skipDelim);
2222   #endif
2223
2224   if (delim == 0 || delim > 0xffU) {
2225     // skip everything
2226     while (ufoImgGetU8(tib + in) != 0) in += 1;
2227     ufoImgPutU32(ufoAddrIN, in);
2228     ufoPushBool(0);
2229   } else {
2230     uint8_t ch;
2231     ch = ufoImgGetU8(tib + in);
2232     // skip initial delimiters
2233     if (skipDelim) {
2234       while (ch != 0 && ufoIsDelim(ch, delim)) {
2235         in += 1;
2236         ch = ufoImgGetU8(tib + in);
2237       }
2238     }
2239     // parse
2240     if (ch == 0) {
2241       ufoImgPutU32(ufoAddrIN, in);
2242       ufoPushBool(0);
2243     } else {
2244       const uint32_t stin = in;
2245       while (ch != 0 && !ufoIsDelim(ch, delim)) {
2246         in += 1;
2247         ch = ufoImgGetU8(tib + in);
2248       }
2249       ufoPush(tib + stin);
2250       ufoPush(in - stin);
2251       if (ch != 0) {
2252         // skip delimiter
2253         ufo_assert(ufoIsDelim(ch, delim));
2254         in += 1;
2255       }
2256       ufoImgPutU32(ufoAddrIN, in);
2257       ufoPushBool(1);
2258       #if 0
2259       fprintf(stderr, "PARSE-OUT: len=%u\n", in - stin);
2260       #endif
2261     }
2262   }
2263 }
2264
2265 // PARSE-SKIP-BLANKS
2266 // ( -- )
2267 UFWORD(PARSE_SKIP_BLANKS) {
2268   const uint32_t tib = ufoImgGetU32(ufoAddrTIB);
2269   uint32_t in = ufoImgGetU32(ufoAddrIN);
2270   uint8_t ch;
2271   ch = ufoImgGetU8(tib + in);
2272   while (ch != 0 && ch <= 32) {
2273     in += 1;
2274     ch = ufoImgGetU8(tib + in);
2275   }
2276   ufoImgPutU32(ufoAddrIN, in);
2277 }
2278
2279 // PARSE-SKIP-COMMENTS
2280 // skip all blanks and comments
2281 UFWORD(PARSE_SKIP_COMMENTS) {
2282   const uint32_t tib = ufoImgGetU32(ufoAddrTIB);
2283   uint32_t in = ufoImgGetU32(ufoAddrIN);
2284   uint32_t done = 0;
2285   uint8_t ch;
2286   ch = ufoImgGetU8(tib + in);
2287   while (ch != 0 && !done) {
2288     if (ch <= 32) {
2289       in += 1;
2290       ch = ufoImgGetU8(tib + in);
2291     } else if ((ch == '(' || ch == '\\') && ufoImgGetU8(tib + in + 1u) <= 32) {
2292       // single-line comment
2293       uint8_t ech = (ch == '(' ? ')' : 0);
2294       while (ch != 0 && ch != ech) {
2295         in += 1;
2296         ch = ufoImgGetU8(tib + in);
2297       }
2298       if (ch != 0) {
2299         in += 1;
2300         ch = ufoImgGetU8(tib + in);
2301       }
2302     } else if (ch == ';' && ufoImgGetU8(tib + in + 1u) == ';') {
2303       while (ch != 0) {
2304         in += 1;
2305         ch = ufoImgGetU8(tib + in);
2306       }
2307     } else {
2308       done = 1;
2309     }
2310   }
2311   ufoImgPutU32(ufoAddrIN, in);
2312 }
2313
2314 // PARSE-SKIP-LINE
2315 // ( -- )
2316 UFWORD(PARSE_SKIP_LINE) {
2317   ufoPush(0); ufoPushBool(0); UFCALL(PAR_PARSE);
2318   if (ufoPop() != 0) {
2319     ufo2Drop();
2320   }
2321 }
2322
2323 // PARSE-NAME
2324 // ( -- addr count )
2325 // parse with leading blanks skipping. doesn't copy anything.
2326 // return empty string on EOL.
2327 UFWORD(PARSE_NAME) {
2328   ufoPush(32); ufoPushBool(1); UFCALL(PAR_PARSE);
2329   if (ufoPop() == 0) {
2330     const uint32_t tib = ufoImgGetU32(ufoAddrTIB);
2331     const uint32_t in = ufoImgGetU32(ufoAddrIN);
2332     ufoPush(tib + in);
2333     ufoPush(0);
2334   }
2335 }
2336
2337 // PARSE
2338 // ( delim -- addr count TRUE / FALSE )
2339 // parse without skipping delimiters; never copies anything.
2340 // as our reader is line-based, returns FALSE on EOL.
2341 // passing 0 as delimiter skips the whole line, and always returns FALSE.
2342 // trailing delimiter is always skipped.
2343 UFWORD(PARSE) {
2344   ufoPushBool(0); UFCALL(PAR_PARSE);
2345 }
2346
2347 // (WORD-OR-PARSE)
2348 // ( delim skip-leading-delim? -- here TRUE / FALSE )
2349 // parse word, copy it to HERE as counted string.
2350 // adds trailing zero after the string, but doesn't include it in count.
2351 // doesn't advance line.
2352
2353 // WORD
2354 // ( delim -- here )
2355 // parse word, copy it to HERE as counted string.
2356 // adds trailing zero after the string, but doesn't include it in count.
2357 // doesn't advance line.
2358 // return empty string on EOL.
2359
2360 // PARSE-TO-HERE
2361 // ( delim -- addr count TRUE / FALSE )
2362 // parse word w/o skipping delimiters, copy it to HERE as counted string.
2363 // adds trailing zero after the string, but doesn't include it in count.
2364 // doesn't advance line.
2365
2366
2367 // ////////////////////////////////////////////////////////////////////////// //
2368 // char output
2369
2370 // EMIT
2371 // ( n -- )
2372 UFWORD(EMIT) {
2373   uint32_t ch = ufoPop()&0xffU;
2374   if (ch < 32 || ch == 127) {
2375     if (ch != 9 && ch != 10 && ch != 13) ch = '?';
2376   }
2377   ufoLastEmitWasCR = (ch == 10);
2378   putchar((char)ch);
2379 }
2380
2381 // XEMIT
2382 // ( n -- )
2383 UFWORD(XEMIT) {
2384   uint32_t ch = ufoPop()&0xffU;
2385   putchar(ch < 32 || ch == 127 ? '?' : (char)ch);
2386   ufoLastEmitWasCR = 0;
2387 }
2388
2389 // LASTCR?
2390 // ( -- bool )
2391 UFWORD(LASTCRQ) {
2392   ufoPushBool(ufoLastEmitWasCR);
2393 }
2394
2395 // LASTCR!
2396 // ( bool -- )
2397 UFWORD(LASTCRSET) {
2398   ufoLastEmitWasCR = !!ufoPop();
2399 }
2400
2401 // CR
2402 // ( -- )
2403 UFWORD(CR) {
2404   putchar('\n');
2405   ufoLastEmitWasCR = 1;
2406 }
2407
2408 // SPACE
2409 // ( -- )
2410 UFWORD(SPACE) {
2411   putchar(' ');
2412   ufoLastEmitWasCR = 0;
2413 }
2414
2415 // SPACES
2416 // ( n -- )
2417 UFWORD(SPACES) {
2418   char tmpbuf[64];
2419   int32_t n = (int32_t)ufoPop();
2420   if (n > 0) {
2421     memset(tmpbuf, 32, sizeof(tmpbuf));
2422     while (n > 0) {
2423       int32_t xwr = n;
2424       if (xwr > (int32_t)sizeof(tmpbuf) - 1) xwr = (int32_t)sizeof(tmpbuf) - 1;
2425       tmpbuf[xwr] = 0;
2426       printf("%s", tmpbuf);
2427       n -= xwr;
2428     }
2429     ufoLastEmitWasCR = 0;
2430   }
2431 }
2432
2433 // ENDCR
2434 // ( -- )
2435 UFWORD(ENDCR) {
2436   if (ufoLastEmitWasCR == 0) {
2437     putchar('\n');
2438     ufoLastEmitWasCR = 1;
2439   }
2440 }
2441
2442 // TYPE
2443 // ( addr count -- )
2444 UFWORD(TYPE) {
2445   int32_t count = (int32_t)ufoPop();
2446   uint32_t addr = ufoPop();
2447   while (count > 0) {
2448     const uint8_t ch = ufoImgGetU8(addr);
2449     ufoPush(ch);
2450     UFCALL(EMIT);
2451     addr += 1; count -= 1;
2452   }
2453 }
2454
2455 // XTYPE
2456 // ( addr count -- )
2457 UFWORD(XTYPE) {
2458   int32_t count = (int32_t)ufoPop();
2459   uint32_t addr = ufoPop();
2460   while (count > 0) {
2461     const uint8_t ch = ufoImgGetU8(addr);
2462     ufoPush(ch);
2463     UFCALL(XEMIT);
2464     addr += 1; count -= 1;
2465   }
2466 }
2467
2468
2469 // ////////////////////////////////////////////////////////////////////////// //
2470 // simple math
2471
2472 #define UF_UMATH(name_,op_)  \
2473 UFWORD(name_) { \
2474   const uint32_t a = ufoPop(); \
2475   ufoPush(op_); \
2476 }
2477
2478 #define UF_BMATH(name_,op_)  \
2479 UFWORD(name_) { \
2480   const uint32_t b = ufoPop(); \
2481   const uint32_t a = ufoPop(); \
2482   ufoPush(op_); \
2483 }
2484
2485 #define UF_BDIV(name_,op_)  \
2486 UFWORD(name_) { \
2487   const uint32_t b = ufoPop(); \
2488   const uint32_t a = ufoPop(); \
2489   if (b == 0) ufoFatal("UFO division by zero"); \
2490   ufoPush(op_); \
2491 }
2492
2493
2494 // +
2495 // ( a b -- a+b )
2496 UF_BMATH(PLUS, a + b);
2497
2498 // -
2499 // ( a b -- a-b )
2500 UF_BMATH(MINUS, a - b);
2501
2502 // *
2503 // ( a b -- a*b )
2504 UF_BMATH(MUL, (uint32_t)((int32_t)a * (int32_t)b));
2505
2506 // U*
2507 // ( a b -- a*b )
2508 UF_BMATH(UMUL, a * b);
2509
2510 // /
2511 // ( a b -- a/b )
2512 UF_BDIV(DIV, (uint32_t)((int32_t)a / (int32_t)b));
2513
2514 // U/
2515 // ( a b -- a/b )
2516 UF_BDIV(UDIV, a / b);
2517
2518 // MOD
2519 // ( a b -- a%b )
2520 UF_BDIV(MOD, (uint32_t)((int32_t)a % (int32_t)b));
2521
2522 // UMOD
2523 // ( a b -- a%b )
2524 UF_BDIV(UMOD, a % b);
2525
2526 // /MOD
2527 // ( a b -- a/b, a%b )
2528 UFWORD(DIVMOD) {
2529   const int32_t b = (int32_t)ufoPop();
2530   const int32_t a = (int32_t)ufoPop();
2531   if (b == 0) ufoFatal("UFO division by zero");
2532   ufoPush((uint32_t)(a/b));
2533   ufoPush((uint32_t)(a%b));
2534 }
2535
2536 // U/MOD
2537 // ( a b -- a/b, a%b )
2538 UFWORD(UDIVMOD) {
2539   const uint32_t b = ufoPop();
2540   const uint32_t a = ufoPop();
2541   if (b == 0) ufoFatal("UFO division by zero");
2542   ufoPush((uint32_t)(a/b));
2543   ufoPush((uint32_t)(a%b));
2544 }
2545
2546
2547 // ////////////////////////////////////////////////////////////////////////// //
2548 // simple logic
2549
2550 #define UF_CMP(name_,op_)  \
2551 UFWORD(name_) { \
2552   const uint32_t b = ufoPop(); \
2553   const uint32_t a = ufoPop(); \
2554   ufoPushBool(op_); \
2555 }
2556
2557 // <
2558 // ( a b -- a<b )
2559 UF_CMP(LESS, (int32_t)a < (int32_t)b);
2560
2561 // U<
2562 // ( a b -- a<b )
2563 UF_CMP(ULESS, a < b);
2564
2565 // >
2566 // ( a b -- a>b )
2567 UF_CMP(GREAT, (int32_t)a > (int32_t)b);
2568
2569 // U>
2570 // ( a b -- a>b )
2571 UF_CMP(UGREAT, a > b);
2572
2573 // <=
2574 // ( a b -- a<=b )
2575 UF_CMP(LESSEQU, (int32_t)a <= (int32_t)b);
2576
2577 // U<=
2578 // ( a b -- a<=b )
2579 UF_CMP(ULESSEQU, a <= b);
2580
2581 // >=
2582 // ( a b -- a>=b )
2583 UF_CMP(GREATEQU, (int32_t)a >= (int32_t)b);
2584
2585 // U>=
2586 // ( a b -- a>=b )
2587 UF_CMP(UGREATEQU, a >= b);
2588
2589 // =
2590 // ( a b -- a=b )
2591 UF_CMP(EQU, a == b);
2592
2593 // <>
2594 // ( a b -- a<>b )
2595 UF_CMP(NOTEQU, a != b);
2596
2597 // WITHIN
2598 // ( value a b -- value>=a&&value<b )
2599 UFWORD(WITHIN) {
2600   const int32_t b = (int32_t)ufoPop();
2601   const int32_t a = (int32_t)ufoPop();
2602   const int32_t value = (int32_t)ufoPop();
2603   ufoPushBool(value >= a && value < b);
2604 }
2605
2606 // UWITHIN
2607 // ( value a b -- value>=a&&value<b )
2608 UFWORD(UWITHIN) {
2609   const uint32_t b = ufoPop();
2610   const uint32_t a = ufoPop();
2611   const uint32_t value = ufoPop();
2612   ufoPushBool(value >= a && value < b);
2613 }
2614
2615 // BOUNDS?
2616 // ( value a b -- value>=a&&value<=b )
2617 // unsigned compare
2618 UFWORD(BOUNDSQ) {
2619   const uint32_t b = ufoPop();
2620   const uint32_t a = ufoPop();
2621   const uint32_t value = ufoPop();
2622   ufoPushBool(value >= a && value <= b);
2623 }
2624
2625 // NOT
2626 // ( a -- !a )
2627 UFWORD(NOT) {
2628   const uint32_t a = ufoPop();
2629   ufoPushBool(!a);
2630 }
2631
2632 // LAND
2633 // ( a b -- a&&b )
2634 UF_CMP(LOGAND, a && b);
2635
2636 // LOR
2637 // ( a b -- a||b )
2638 UF_CMP(LOGOR, a || b);
2639
2640 // AND
2641 // ( a b -- a&b )
2642 UFWORD(AND) {
2643   const uint32_t b = ufoPop();
2644   const uint32_t a = ufoPop();
2645   ufoPush(a&b);
2646 }
2647
2648 // OR
2649 // ( a b -- a|b )
2650 UFWORD(OR) {
2651   const uint32_t b = ufoPop();
2652   const uint32_t a = ufoPop();
2653   ufoPush(a|b);
2654 }
2655
2656 // XOR
2657 // ( a b -- a^b )
2658 UFWORD(XOR) {
2659   const uint32_t b = ufoPop();
2660   const uint32_t a = ufoPop();
2661   ufoPush(a^b);
2662 }
2663
2664 // BITNOT
2665 // ( a -- ~a )
2666 UFWORD(BITNOT) {
2667   const uint32_t a = ufoPop();
2668   ufoPush(~a);
2669 }
2670
2671 UFWORD(ONESHL) { uint32_t n = ufoPop(); ufoPush(n << 1); }
2672 UFWORD(ONESHR) { uint32_t n = ufoPop(); ufoPush(n >> 1); }
2673 UFWORD(TWOSHL) { uint32_t n = ufoPop(); ufoPush(n << 2); }
2674 UFWORD(TWOSHR) { uint32_t n = ufoPop(); ufoPush(n >> 2); }
2675
2676 // ASH
2677 // ( n count -- )
2678 // arithmetic shift; positive `n` shifts to the left
2679 UFWORD(ASH) {
2680   int32_t c = (int32_t)ufoPop();
2681   if (c < 0) {
2682     // right
2683     int32_t n = (int32_t)ufoPop();
2684     if (c < -30) {
2685       if (n < 0) n = -1; else n = 0;
2686     } else {
2687       n >>= (uint8_t)(-c);
2688     }
2689     ufoPush((uint32_t)n);
2690   } else if (c > 0) {
2691     // left
2692     uint32_t u = ufoPop();
2693     if (c > 31) {
2694       u = 0;
2695     } else {
2696       u <<= (uint8_t)c;
2697     }
2698     ufoPush(u);
2699   }
2700 }
2701
2702 // LSH
2703 // ( n count -- )
2704 // logical shift; positive `n` shifts to the left
2705 UFWORD(LSH) {
2706   int32_t c = (int32_t) ufoPop();
2707   uint32_t u = ufoPop();
2708   if (c < 0) {
2709     // right
2710     if (c < -31) {
2711       u = 0;
2712     } else {
2713       u >>= (uint8_t)(-c);
2714     }
2715   } else if (c > 0) {
2716     // left
2717     if (c > 31) {
2718       u = 0;
2719     } else {
2720       u <<= (uint8_t)c;
2721     }
2722   }
2723   ufoPush(u);
2724 }
2725
2726
2727 // (UNESCAPE)
2728 // ( addr count -- addr count )
2729 UFWORD(PAR_UNESCAPE) {
2730   const uint32_t count = ufoPop();
2731   const uint32_t addr = ufoPeek();
2732   if ((count & ((uint32_t)1<<31)) == 0) {
2733     const uint32_t eaddr = addr + count;
2734     uint32_t caddr = addr;
2735     uint32_t daddr = addr;
2736     while (caddr != eaddr) {
2737       uint8_t ch = ufoImgGetU8(caddr); caddr += 1u;
2738       if (ch == '\\' && caddr != eaddr) {
2739         ch = ufoImgGetU8(caddr); caddr += 1u;
2740         switch (ch) {
2741           case 'r': ch = '\r'; break;
2742           case 'n': ch = '\n'; break;
2743           case 't': ch = '\t'; break;
2744           case 'e': ch = '\x1b'; break;
2745           case '`': ch = '"'; break; // special escape to insert double-quote
2746           case '"': ch = '"'; break;
2747           case '\\': ch = '\\'; break;
2748           case 'x': case 'X':
2749             if (eaddr - daddr >= 1) {
2750               const int dg0 = digitInBase((char)(ufoImgGetU8(caddr + 1)), 16);
2751               if (dg0 < 0) ufoFatal("invalid hex string escape");
2752               if (eaddr - daddr >= 2) {
2753                 const int dg1 = digitInBase((char)(ufoImgGetU8(caddr + 2)), 16);
2754                 if (dg1 < 0) ufoFatal("invalid hex string escape");
2755                 ch = (uint8_t)(dg0 * 16 + dg1);
2756                 caddr += 2;
2757               } else {
2758                 ch = (uint8_t)dg0;
2759                 caddr += 1;
2760               }
2761             } else {
2762               ufoFatal("invalid hex string escape");
2763             }
2764             break;
2765           default: ufoFatal("invalid string escape");
2766         }
2767       }
2768       ufoImgPutU8(daddr, ch); daddr += 1u;
2769     }
2770     ufoPush(daddr - addr);
2771   } else {
2772     ufoPush(count);
2773   }
2774 }
2775
2776
2777 // convert number from addrl+1
2778 // returns address of the first inconvertible char
2779 // (XNUMBER) ( addr count allowsign? -- num TRUE / FALSE )
2780 UFWORD(PAR_XNUMBER) {
2781   const uint32_t allowSign = ufoPop();
2782   int32_t count = (int32_t)ufoPop();
2783   uint32_t addr = ufoPop();
2784   uint32_t n = 0;
2785   int base = 0;
2786   int xbase = (int32_t)ufoImgGetU32(ufoAddrBASE);
2787   int neg = 0;
2788   uint8_t ch;
2789
2790   if (allowSign && count > 1) {
2791     ch = ufoImgGetU8(addr);
2792     if (ch == '-') { neg = 1; addr += 1u; count -= 1; }
2793     else if (ch == '+') { neg = 0; addr += 1u; count -= 1; }
2794   }
2795
2796   // special-based numbers
2797   if (count >= 3 && ufoImgGetU8(addr) == '0') {
2798     switch (ufoImgGetU8(addr + 1)) {
2799       case 'x': case 'X': base = 16; break;
2800       case 'o': case 'O': base = 8; break;
2801       case 'b': case 'B': base = 2; break;
2802       case 'd': case 'D': base = 10; break;
2803       default: break;
2804     }
2805     if (base) { addr += 2; count -= 2; }
2806   } else if (count >= 2 && ufoImgGetU8(addr) == '$') {
2807     base = 16;
2808     addr += 1; count -= 1;
2809   } else if (count >= 2 && ufoImgGetU8(addr) == '#') {
2810     base = 16;
2811     addr += 1; count -= 1;
2812   } else if (count >= 2 && ufoImgGetU8(addr) == '%') {
2813     base = 2;
2814     addr += 1; count -= 1;
2815   } else if (count >= 3 && ufoImgGetU8(addr) == '&') {
2816     switch (ufoImgGetU8(addr + 1)) {
2817       case 'h': case 'H': base = 16; break;
2818       case 'o': case 'O': base = 8; break;
2819       case 'b': case 'B': base = 2; break;
2820       case 'd': case 'D': base = 10; break;
2821       default: break;
2822     }
2823     if (base) { addr += 2; count -= 2; }
2824   } else if (xbase < 12 && count > 2 && toUpperU8(ufoImgGetU8(addr + count - 1)) == 'B') {
2825     base = 2;
2826     count -= 1;
2827   } else if (xbase < 18 && count > 2 && toUpperU8(ufoImgGetU8(addr + count - 1)) == 'H') {
2828     base = 16;
2829     count -= 1;
2830   } else if (xbase < 25 && count > 2 && toUpperU8(ufoImgGetU8(addr + count - 1)) == 'O') {
2831     base = 8;
2832     count -= 1;
2833   }
2834
2835   // in current base?
2836   if (!base) base = xbase;
2837
2838   if (count <= 0 || base < 1 || base > 36) {
2839     ufoPushBool(0);
2840   } else {
2841     uint32_t nc;
2842     int wasDig = 0, wasUnder = 1, error = 0, dig;
2843     while (!error && count != 0) {
2844       ch = ufoImgGetU8(addr); addr += 1; count -= 1;
2845       if (ch != '_') {
2846         error = 1; wasUnder = 0; wasDig = 1;
2847         dig = digitInBase((char)ch, (int)base);
2848         if (dig >= 0) {
2849           nc = n * (uint32_t)base;
2850           if (nc >= n) {
2851             nc += (uint32_t)dig;
2852             if (nc >= n) {
2853               n = nc;
2854               error = 0;
2855             }
2856           }
2857         }
2858       } else {
2859         error = wasUnder;
2860         wasUnder = 1;
2861       }
2862     }
2863
2864     if (!error && wasDig && !wasUnder) {
2865       if (allowSign && neg) n = ~n + 1u;
2866       ufoPush(n);
2867       ufoPushBool(1);
2868     } else {
2869       ufoPushBool(0);
2870     }
2871   }
2872 }
2873
2874
2875 // ////////////////////////////////////////////////////////////////////////// //
2876 // compiler-related, dictionary-related
2877
2878 static char ufoWNameBuf[256];
2879
2880
2881 // [
2882 UFWORD(LBRACKET_IMM) {
2883   if (ufoImgGetU32(ufoAddrSTATE) == 0) ufoFatal("expects compiling mode");
2884   ufoImgPutU32(ufoAddrSTATE, 0);
2885 }
2886
2887 // ]
2888 UFWORD(RBRACKET) {
2889   if (ufoImgGetU32(ufoAddrSTATE) != 0) ufoFatal("expects interpreting mode");
2890   ufoImgPutU32(ufoAddrSTATE, 1);
2891 }
2892
2893 // (CREATE-WORD-HEADER)
2894 // ( addr count word-flags -- )
2895 UFWORD(PAR_CREATE_WORD_HEADER) {
2896   const uint32_t flags = ufoPop();
2897   const uint32_t wlen = ufoPop();
2898   const uint32_t waddr = ufoPop();
2899   if (wlen == 0) ufoFatal("word name expected");
2900   if (wlen >= UFO_MAX_WORD_LENGTH) ufoFatal("word name too long");
2901   // copy to separate buffer
2902   for (uint32_t f = 0; f < wlen; f += 1) {
2903     ufoWNameBuf[f] = (char)ufoImgGetU8(waddr + f);
2904   }
2905   ufoWNameBuf[wlen] = 0;
2906   ufoCreateWordHeader(ufoWNameBuf, flags);
2907 }
2908
2909 // FIND-WORD
2910 // ( addr count -- cfa TRUE / FALSE)
2911 UFWORD(FIND_WORD) {
2912   const uint32_t wlen = ufoPop();
2913   const uint32_t waddr = ufoPop();
2914   if (wlen > 0 && wlen < UFO_MAX_WORD_LENGTH) {
2915     // copy to separate buffer
2916     for (uint32_t f = 0; f < wlen; f += 1) {
2917       ufoWNameBuf[f] = (char)ufoImgGetU8(waddr + f);
2918     }
2919     ufoWNameBuf[wlen] = 0;
2920     const uint32_t cfa = ufoFindWord(ufoWNameBuf);
2921     if (cfa != 0) {
2922       ufoPush(cfa);
2923       ufoPushBool(1);
2924     } else {
2925       ufoPushBool(0);
2926     }
2927   } else {
2928     ufoPushBool(0);
2929   }
2930 }
2931
2932 // FIND-WORD-IN-VOC
2933 // ( addr count vocid allowhidden -- cfa TRUE / FALSE)
2934 // find only in the given voc; no name resolution
2935 UFWORD(FIND_WORD_IN_VOC) {
2936   const uint32_t allowHidden = ufoPop();
2937   const uint32_t vocid = ufoPop();
2938   const uint32_t wlen = ufoPop();
2939   const uint32_t waddr = ufoPop();
2940   if (wlen > 0 && wlen < UFO_MAX_WORD_LENGTH) {
2941     // copy to separate buffer
2942     for (uint32_t f = 0; f < wlen; f += 1) {
2943       ufoWNameBuf[f] = (char)ufoImgGetU8(waddr + f);
2944     }
2945     ufoWNameBuf[wlen] = 0;
2946     const uint32_t cfa = ufoFindWordInVoc(ufoWNameBuf, wlen,
2947                                           joaatHashBufCI(ufoWNameBuf, wlen),
2948                                           vocid, (allowHidden ? 1 : 0));
2949     if (cfa != 0) {
2950       ufoPush(cfa);
2951       ufoPushBool(1);
2952     } else {
2953       ufoPushBool(0);
2954     }
2955   } else {
2956     ufoPushBool(0);
2957   }
2958 }
2959
2960
2961 // ////////////////////////////////////////////////////////////////////////// //
2962 // more compiler words
2963
2964 // ?EXEC
2965 UFWORD(QEXEC) {
2966   if (ufoImgGetU32(ufoAddrSTATE) != 0) ufoFatal("expecting execution mode");
2967 }
2968
2969 // ?COMP
2970 UFWORD(QCOMP) {
2971   if (ufoImgGetU32(ufoAddrSTATE) == 0) ufoFatal("expecting compilation mode");
2972 }
2973
2974 // "
2975 // string literal
2976 UFWORD(QUOTE_IMM) {
2977   ufoPush(34); UFCALL(PARSE);
2978   if (ufoPop() == 0) ufoFatal("string literal expected");
2979   UFCALL(PAR_UNESCAPE);
2980   if (ufoImgGetU32(ufoAddrSTATE) != 0) {
2981     // compiling
2982     const uint32_t wlen = ufoPop();
2983     const uint32_t waddr = ufoPop();
2984     if (wlen > 255) ufoFatal("string literal too long");
2985     ufoImgEmitU32(ufoStrLit8CFA);
2986     ufoImgEmitU8(wlen);
2987     for (uint32_t f = 0; f < wlen; f += 1) {
2988       ufoImgEmitU8(ufoImgGetU8(waddr + f));
2989     }
2990     ufoImgEmitU8(0);
2991     ufoImgEmitAlign();
2992   }
2993 }
2994
2995
2996 // ////////////////////////////////////////////////////////////////////////// //
2997 // vocabulary utilities
2998
2999 // (VSP@)
3000 // ( -- vsp )
3001 UFWORD(PAR_GET_VSP) {
3002   ufoPush(ufoVSP);
3003 }
3004
3005 // (VSP!)
3006 // ( vsp -- )
3007 UFWORD(PAR_SET_VSP) {
3008   const uint32_t vsp = ufoPop();
3009   if (vsp >= UFO_VOCSTACK_SIZE) ufoFatal("VSP %u out of range (%u)", vsp, UFO_VOCSTACK_SIZE);
3010   ufoVSP = vsp;
3011 }
3012
3013 // (VSP-AT@)
3014 // ( idx -- value )
3015 UFWORD(PAR_VSP_LOAD) {
3016   const uint32_t vsp = ufoPop();
3017   if (vsp >= UFO_VOCSTACK_SIZE) ufoFatal("VSP %u out of range (%u)", vsp, UFO_VOCSTACK_SIZE);
3018   ufoPush(ufoVocStack[vsp]);
3019 }
3020
3021 // (VSP-AT!)
3022 // ( value idx -- )
3023 UFWORD(PAR_VSP_STORE) {
3024   const uint32_t vsp = ufoPop();
3025   const uint32_t value = ufoPop();
3026   if (vsp > UFO_VOCSTACK_SIZE) ufoFatal("VSP %u out of range (%u)", vsp, UFO_VOCSTACK_SIZE);
3027   ufoVocStack[vsp] = value;
3028 }
3029
3030 // (HIDDEN)
3031 UFWORD(PAR_HIDDEN) {
3032   uint32_t curr = ufoImgGetU32(ufoAddrCurrent);
3033   uint32_t latest = ufoImgGetU32(curr);
3034   if (latest == 0) ufoFatal("wtf in `IMMEDIATE`");
3035   uint32_t nfa = latest + 8u;
3036   uint32_t flags = ufoImgGetU32(nfa);
3037   flags |= UFW_FLAG_HIDDEN;
3038   ufoImgPutU32(nfa, flags);
3039 }
3040
3041
3042 // ////////////////////////////////////////////////////////////////////////// //
3043 // word field address conversion
3044
3045 // CFA->PFA
3046 // ( cfa -- pfa )
3047 UFWORD(CFA2PFA) {
3048   const uint32_t cfa = ufoPop();
3049   ufoPush(UFO_CFA_TO_PFA(cfa));
3050 }
3051
3052 // PFA->CFA
3053 // ( pfa -- cfa )
3054 UFWORD(PFA2CFA) {
3055   const uint32_t pfa = ufoPop();
3056   ufoPush(UFO_PFA_TO_CFA(pfa));
3057 }
3058
3059 // CFA->NFA
3060 // ( cfa -- nfa )
3061 UFWORD(CFA2NFA) {
3062   const uint32_t cfa = ufoPop();
3063   ufoPush(UFO_CFA_TO_NFA(cfa));
3064 }
3065
3066 // NFA->CFA
3067 // ( nfa -- cfa )
3068 UFWORD(NFA2CFA) {
3069   const uint32_t nfa = ufoPop();
3070   ufoPush(UFO_NFA_TO_CFA(nfa));
3071 }
3072
3073 // CFA->LFA
3074 // ( cfa -- lfa )
3075 UFWORD(CFA2LFA) {
3076   const uint32_t cfa = ufoPop();
3077   ufoPush(UFO_CFA_TO_LFA(cfa));
3078 }
3079
3080 // LFA->CFA
3081 // ( lfa -- cfa )
3082 UFWORD(LFA2CFA) {
3083   const uint32_t lfa = ufoPop();
3084   ufoPush(UFO_LFA_TO_CFA(lfa));
3085 }
3086
3087 // LFA->BFA
3088 // ( lfa -- bfa )
3089 UFWORD(LFA2BFA) {
3090   const uint32_t lfa = ufoPop();
3091   ufoPush(UFO_LFA_TO_BFA(lfa));
3092 }
3093
3094 // LFA->SFA
3095 // ( lfa -- sfa )
3096 UFWORD(LFA2SFA) {
3097   const uint32_t lfa = ufoPop();
3098   ufoPush(UFO_LFA_TO_SFA(lfa));
3099 }
3100
3101 // LFA->NFA
3102 // ( lfa -- nfa )
3103 UFWORD(LFA2NFA) {
3104   const uint32_t lfa = ufoPop();
3105   ufoPush(UFO_LFA_TO_NFA(lfa));
3106 }
3107
3108 // NFA->LFA
3109 // ( nfa -- lfa )
3110 UFWORD(NFA2LFA) {
3111   const uint32_t nfa = ufoPop();
3112   ufoPush(UFO_NFA_TO_LFA(nfa));
3113 }
3114
3115
3116 // ////////////////////////////////////////////////////////////////////////// //
3117 // UrAsm API
3118
3119
3120 //==========================================================================
3121 //
3122 //  ufoPopStrLitToTempBuf
3123 //
3124 //==========================================================================
3125 static void ufoPopStrLitToTempBuf (void) {
3126   uint32_t count = ufoPop();
3127   uint32_t addr = ufoPop();
3128   if ((count & (1u<<31)) != 0) ufoFatal("invalid string length");
3129   if ((size_t)count >= sizeof(ufoTempCharBuf)) ufoFatal("string too long");
3130   for (uint32_t f = 0; f < count; f += 1) {
3131     ufoTempCharBuf[f] = (char)ufoImgGetU8(addr + f);
3132   }
3133   ufoTempCharBuf[count] = 0;
3134 }
3135
3136
3137 // UR-HAS-LABEL?
3138 // ( addr count -- flag )
3139 UFWORD(UR_HAS_LABELQ) {
3140   ufoPopStrLitToTempBuf();
3141   ufoPushBool(ufoZXGetLabelType(ufoTempCharBuf) > UFO_ZX_LABEL_UNKNOWN);
3142 }
3143
3144 // UR-LABEL-TYPE?
3145 // ( addr count -- type )
3146 // 0: unknown
3147 UFWORD(UR_GET_LABELQ_TYPE) {
3148   ufoPopStrLitToTempBuf();
3149   ufoPush(ufoZXGetLabelType(ufoTempCharBuf));
3150 }
3151
3152 // UR-GET-LABEL
3153 // ( addr count -- value )
3154 // fatals when the label is not found
3155 UFWORD(UR_GET_LABEL) {
3156   ufoPopStrLitToTempBuf();
3157   ufoPush((uint32_t)ufoZXGetLabelValue(ufoTempCharBuf));
3158 }
3159
3160 // UR-NEW-LABEL-ITER
3161 // ( -- iterid | 0 )
3162 UFWORD(UR_NEW_LABEL_ITER) {
3163   ufoPush(ufoZXNewLabelIter());
3164 }
3165
3166 // UR-CLOSE-LABEL-ITER
3167 // ( iterid -- )
3168 UFWORD(UR_CLOSE_LABEL_ITER) {
3169   uint32_t id = ufoPop();
3170   ufoZXLabelIterClose(id);
3171 }
3172
3173 // UR-LABEL-ITER-NEXT
3174 // ( iterid -- not-done? )
3175 UFWORD(UR_LABEL_ITER_NEXT) {
3176   uint32_t id = ufoPop();
3177   ufoPushBool(ufoZXLabelIterNext(id));
3178 }
3179
3180 // UR-LABEL-ITER-GET-NAME
3181 // ( iterid -- addr count )
3182 // to PAD
3183 UFWORD(UR_LABEL_ITER_GET_NAME) {
3184   uint32_t id = ufoPop();
3185   const char *name = ufoZXLabelIterGetName(id);
3186   if (name == NULL) name = "";
3187   uint32_t count = 0;
3188   UFCALL(PAD);
3189   uint32_t pad = ufoPop() + 4u;
3190   while (count != 1024 && *name != 0) {
3191     ufoImgPutU8(pad + count, ((const unsigned char *)name)[count]);
3192     count += 1u; name += 1u;
3193   }
3194   if (count == 1024) ufoFatal("label name too long");
3195   ufoImgPutU8(pad + count, 0); // just in case
3196   ufoPush(pad); ufoPush(count);
3197 }
3198
3199 // UR-LABEL-ITER-GET-VALUE
3200 // ( iterid -- value )
3201 UFWORD(UR_LABEL_ITER_GET_VALUE) {
3202   uint32_t id = ufoPop();
3203   ufoPush((uint32_t)ufoZXIterGetValue(id));
3204 }
3205
3206 // UR-LABEL-ITER-GET-TYPE
3207 // ( iterid -- type )
3208 UFWORD(UR_LABEL_ITER_GET_TYPE) {
3209   uint32_t id = ufoPop();
3210   ufoPush((uint32_t)ufoZXIterGetType(id));
3211 }
3212
3213
3214 //==========================================================================
3215 //
3216 //  urw_set_typed_label
3217 //
3218 // ( value addr count -- )
3219 //
3220 //==========================================================================
3221 static void urw_set_typed_label (int type) {
3222   ufoPopStrLitToTempBuf();
3223   const char *name = ufoTempCharBuf;
3224   int32_t val = (int32_t)ufoPop();
3225   ufoZXSetLabelValue(name, type, val);
3226 }
3227
3228
3229 // UR-SET-LABEL-VAR
3230 // ( value addr count -- )
3231 // create/overwrite an "assign" label
3232 UFWORD(UR_SET_LABEL_VAR) { urw_set_typed_label(UFO_ZX_LABEL_VAR); }
3233
3234 // UR-SET-LABEL-EQU
3235 // ( value addr count -- )
3236 UFWORD(UR_SET_LABEL_EQU) { urw_set_typed_label(UFO_ZX_LABEL_EQU); }
3237
3238 // UR-SET-LABEL-CODE
3239 // ( value addr count -- )
3240 UFWORD(UR_SET_LABEL_CODE) { urw_set_typed_label(UFO_ZX_LABEL_CODE); }
3241
3242 // UR-SET-LABEL-STOFS
3243 // ( value addr count -- )
3244 UFWORD(UR_SET_LABEL_STOFS) { urw_set_typed_label(UFO_ZX_LABEL_STOFS); }
3245
3246 // UR-SET-LABEL-DATA
3247 // ( value addr count -- )
3248 UFWORD(UR_SET_LABEL_DATA) { urw_set_typed_label(UFO_ZX_LABEL_DATA); }
3249
3250
3251 //==========================================================================
3252 //
3253 //  urw_declare_typed_label
3254 //
3255 //==========================================================================
3256 static void urw_declare_typed_label (int type) {
3257   UFCALL(QEXEC);
3258   UFCALL(PARSE_NAME);
3259   ufoPopStrLitToTempBuf();
3260   if (ufoTempCharBuf[0] == 0) ufoFatal("label name expected");
3261   const char *name = ufoTempCharBuf;
3262   ufoZXSetLabelValue(name, type, ufoZXGetOrg());
3263 }
3264
3265 // $LABEL-DATA: name
3266 UFWORD(DLR_LABEL_DATA_IMM) { urw_declare_typed_label(UFO_ZX_LABEL_DATA); }
3267 // $LABEL-CODE: name
3268 UFWORD(DLR_LABEL_CODE_IMM) { urw_declare_typed_label(UFO_ZX_LABEL_CODE); }
3269
3270
3271 // UR-PASS@
3272 // ( -- pass )
3273 UFWORD(UR_PASSQ) {
3274   ufoPush(ufoZXGetPass());
3275 }
3276
3277 // UR-ORG@
3278 // ( -- org )
3279 UFWORD(UR_GETORG) {
3280   ufoPush(ufoZXGetOrg());
3281 }
3282
3283 // UR-DISP@
3284 // ( -- disp )
3285 UFWORD(UR_GETDISP) {
3286   ufoPush(ufoZXGetDisp());
3287 }
3288
3289 // UR-ENT@
3290 // ( -- ent )
3291 UFWORD(UR_GETENT) {
3292   ufoPush(ufoZXGetEnt());
3293 }
3294
3295 // UR-ORG!
3296 // ( org -- )
3297 // also sets disp
3298 UFWORD(UR_SETORG) {
3299   const uint32_t addr = ufoPop();
3300   ufoZXSetOrg(addr);
3301 }
3302
3303 // UR-DISP!
3304 // ( disp -- )
3305 // doesn't change ORG
3306 UFWORD(UR_SETDISP) {
3307   const uint32_t addr = ufoPop();
3308   ufoZXSetDisp(addr);
3309 }
3310
3311 // UR-ENT!
3312 // ( ent -- )
3313 UFWORD(UR_SETENT) {
3314   const uint32_t addr = ufoPop();
3315   ufoZXSetEnt(addr);
3316 }
3317
3318
3319 // ////////////////////////////////////////////////////////////////////////// //
3320 // string
3321
3322 static uint32_t ufoHashBuf (uint32_t addr, uint32_t size, uint8_t orbyte) {
3323   uint32_t hash = 0x29a;
3324   if ((size & ((uint32_t)1<<31)) == 0) {
3325     while (size != 0) {
3326       hash += ufoImgGetU8(addr) | orbyte;
3327       hash += hash<<10;
3328       hash ^= hash>>6;
3329       addr += 1u; size -= 1u;
3330     }
3331   }
3332   // finalize
3333   hash += hash<<3;
3334   hash ^= hash>>11;
3335   hash += hash<<15;
3336   return hash;
3337 }
3338
3339 // STRING:=
3340 // ( a0 c0 a1 c1 -- bool )
3341 UFWORD(STREQU) {
3342   int32_t c1 = (int32_t)ufoPop();
3343   uint32_t a1 = ufoPop();
3344   int32_t c0 = (int32_t)ufoPop();
3345   uint32_t a0 = ufoPop();
3346   if (c0 < 0) c0 = 0;
3347   if (c1 < 0) c1 = 0;
3348   if (c0 == c1) {
3349     int res = 1;
3350     while (res != 0 && c0 != 0) {
3351       res = (ufoImgGetU8(a0) == ufoImgGetU8(a1));
3352       a0 += 1; a1 += 1; c0 -= 1;
3353     }
3354     ufoPushBool(res);
3355   } else {
3356     ufoPushBool(0);
3357   }
3358 }
3359
3360 // STRING:=CI
3361 // ( a0 c0 a1 c1 -- bool )
3362 UFWORD(STREQUCI) {
3363   int32_t c1 = (int32_t)ufoPop();
3364   uint32_t a1 = ufoPop();
3365   int32_t c0 = (int32_t)ufoPop();
3366   uint32_t a0 = ufoPop();
3367   if (c0 < 0) c0 = 0;
3368   if (c1 < 0) c1 = 0;
3369   if (c0 == c1) {
3370     int res = 1;
3371     while (res != 0 && c0 != 0) {
3372       res = (toUpperU8(ufoImgGetU8(a0)) == toUpperU8(ufoImgGetU8(a1)));
3373       a0 += 1; a1 += 1; c0 -= 1;
3374     }
3375     ufoPushBool(res);
3376   } else {
3377     ufoPushBool(0);
3378   }
3379 }
3380
3381 // STRING:HASH
3382 // ( addr count -- hash )
3383 UFWORD(STRHASH) {
3384   uint32_t count = ufoPop();
3385   uint32_t addr = ufoPop();
3386   ufoPush(ufoHashBuf(addr, count, 0));
3387 }
3388
3389 // STRING:HASH-CI
3390 // ( addr count -- hash )
3391 UFWORD(STRHASHCI) {
3392   uint32_t count = ufoPop();
3393   uint32_t addr = ufoPop();
3394   ufoPush(ufoHashBuf(addr, count, 0x20));
3395 }
3396
3397
3398 // ////////////////////////////////////////////////////////////////////////// //
3399 // conditional defines
3400 typedef struct UForthCondDefine_t UForthCondDefine;
3401 struct UForthCondDefine_t {
3402   char *name;
3403   uint32_t namelen;
3404   uint32_t hash;
3405   UForthCondDefine *next;
3406 };
3407
3408 static UForthCondDefine *ufoCondDefines = NULL;
3409 static char ufoErrMsgBuf[4096];
3410
3411
3412 //==========================================================================
3413 //
3414 //  ufoBufEquCI
3415 //
3416 //==========================================================================
3417 static int ufoBufEquCI (uint32_t addr, uint32_t count, const void *buf) {
3418   int res;
3419   if ((count & ((uint32_t)1<<31)) == 0) {
3420     const unsigned char *src = (const unsigned char *)buf;
3421     res = 1;
3422     while (res != 0 && count != 0) {
3423       res = (toUpperU8(*src) == toUpperU8(ufoImgGetU8(addr)));
3424       src += 1; addr += 1u; count -= 1u;
3425     }
3426   } else {
3427     res = 0;
3428   }
3429   return res;
3430 }
3431
3432
3433 //==========================================================================
3434 //
3435 //  ufoClearCondDefines
3436 //
3437 //==========================================================================
3438 static void ufoClearCondDefines (void) {
3439   while (ufoCondDefines) {
3440     UForthCondDefine *df = ufoCondDefines;
3441     ufoCondDefines = df->next;
3442     if (df->name) free(df->name);
3443     free(df);
3444   }
3445 }
3446
3447
3448 // ($DEFINE)
3449 // ( addr count -- )
3450 UFWORD(PAR_DLR_DEFINE) {
3451   uint32_t count = ufoPop();
3452   uint32_t addr = ufoPop();
3453   if (count == 0) ufoFatal("empty define");
3454   if (count >= UFO_MAX_WORD_LENGTH) ufoFatal("define too long");
3455   const uint32_t hash = ufoHashBuf(addr, count, 0x20);
3456   UForthCondDefine *dd;
3457   for (dd = ufoCondDefines; dd != NULL; dd = dd->next) {
3458     if (dd->hash == hash && dd->namelen == count) {
3459       if (ufoBufEquCI(addr, count, dd->name)) return;
3460     }
3461   }
3462   // new define
3463   dd = calloc(1, sizeof(UForthCondDefine));
3464   if (dd == NULL) ufoFatal("out of memory for defines");
3465   dd->name = calloc(1, count + 1u);
3466   if (dd->name == NULL) { free(dd); ufoFatal("out of memory for defines"); }
3467   for (uint32_t f = 0; f < count; f += 1) {
3468     ((unsigned char *)dd->name)[f] = ufoImgGetU8(addr + f);
3469   }
3470   dd->namelen = count;
3471   dd->hash = hash;
3472   dd->next = ufoCondDefines;
3473   ufoCondDefines = dd;
3474 }
3475
3476 // ($UNDEF)
3477 // ( addr count -- )
3478 UFWORD(PAR_DLR_UNDEF) {
3479   uint32_t count = ufoPop();
3480   uint32_t addr = ufoPop();
3481   if (count == 0) ufoFatal("empty define");
3482   if (count >= UFO_MAX_WORD_LENGTH) ufoFatal("define too long");
3483   const uint32_t hash = ufoHashBuf(addr, count, 0x20);
3484   UForthCondDefine *prev = NULL;
3485   UForthCondDefine *dd;
3486   for (dd = ufoCondDefines; dd != NULL; prev = dd, dd = dd->next) {
3487     if (dd->hash == hash && dd->namelen == count) {
3488       if (ufoBufEquCI(addr, count, dd->name)) {
3489         if (prev == NULL) ufoCondDefines = dd->next; else prev->next = dd->next;
3490         free(dd->name);
3491         free(dd);
3492         return;
3493       }
3494     }
3495   }
3496 }
3497
3498 // ($DEFINED?)
3499 // ( addr count -- bool )
3500 UFWORD(PAR_DLR_DEFINEDQ) {
3501   uint32_t count = ufoPop();
3502   uint32_t addr = ufoPop();
3503   if (count == 0) ufoFatal("empty define");
3504   if (count >= UFO_MAX_WORD_LENGTH) ufoFatal("define too long");
3505   const uint32_t hash = ufoHashBuf(addr, count, 0x20);
3506   int found = 0;
3507   UForthCondDefine *dd;
3508   for (dd = ufoCondDefines; !found && dd != NULL; dd = dd->next) {
3509     if (dd->hash == hash && dd->namelen == count) {
3510       found = ufoBufEquCI(addr, count, dd->name);
3511     }
3512   }
3513   ufoPushBool(found);
3514 }
3515
3516 // $DEFINE defname
3517 UFWORD(DLR_DEFINE_IMM) {
3518   UFCALL(PARSE_NAME);
3519   if (ufoPeek() == 0) ufoFatal("guard name expected");
3520   UFCALL(PARSE_SKIP_COMMENTS);
3521   if (ufoImgGetU8(ufoImgGetU32(ufoAddrTIB) + ufoImgGetU32(ufoAddrIN)) != 0) {
3522     ufoFatal("$DEFINE doesn't accept extra args yet");
3523   }
3524   UFCALL(PAR_DLR_DEFINE);
3525 }
3526
3527 // $UNDEF defname
3528 UFWORD(DLR_UNDEF_IMM) {
3529   UFCALL(PARSE_NAME);
3530   if (ufoPeek() == 0) ufoFatal("guard name expected");
3531   UFCALL(PARSE_SKIP_COMMENTS);
3532   if (ufoImgGetU8(ufoImgGetU32(ufoAddrTIB) + ufoImgGetU32(ufoAddrIN)) != 0) {
3533     ufoFatal("$UNDEF doesn't accept extra args yet");
3534   }
3535   UFCALL(PAR_DLR_UNDEF);
3536 }
3537
3538 // (TYPE-CURR-FILE)
3539 // ( -- )
3540 UFWORD(PAR_TYPE_CURR_FILE) {
3541   if (ufoInFile != NULL) {
3542     fprintf(stdout, "at file %s, line %d: ", ufoInFileName, ufoInFileLine);
3543   } else {
3544     fprintf(stdout, "somewhere in time: ");
3545   }
3546 }
3547
3548 // ERROR
3549 // ( addr count -- )
3550 UFWORD(ERROR) {
3551   uint32_t count = ufoPop();
3552   uint32_t addr = ufoPop();
3553   if (count & (1u<<31)) ufoFatal("invalid error message");
3554   if (count == 0) ufoFatal("some error");
3555   if (count > (uint32_t)sizeof(ufoErrMsgBuf) - 1u) count = (uint32_t)sizeof(ufoErrMsgBuf) - 1u;
3556   for (uint32_t f = 0; f < count; f += 1) {
3557     ufoErrMsgBuf[f] = (char)ufoImgGetU8(addr + f);
3558   }
3559   ufoErrMsgBuf[count] = 0;
3560   ufoFatal("%s", ufoErrMsgBuf);
3561 }
3562
3563 // ?ERROR
3564 // ( errflag addr count -- )
3565 UFWORD(QERROR) {
3566   const uint32_t count = ufoPop();
3567   const uint32_t addr = ufoPop();
3568   if (ufoPop()) {
3569     ufoPush(addr);
3570     ufoPush(count);
3571     UFCALL(ERROR);
3572   }
3573 }
3574
3575
3576 // ////////////////////////////////////////////////////////////////////////// //
3577 // includes
3578
3579 static char ufoFNameBuf[4096];
3580
3581 // (INCLUDE)
3582 // ( addr count -- )
3583 UFWORD(PAR_INCLUDE) {
3584   uint32_t count = ufoPop();
3585   uint32_t addr = ufoPop();
3586
3587   if ((count & ((uint32_t)1<<31)) != 0) ufoFatal("invalid include name");
3588   //if (count == 0) ufoFatal("empty define");
3589   //if (count > (uint32_t)sizeof(ufoErrMsgBuf) - 1u) ufoFatal("define too long");
3590
3591   uint32_t dpos;
3592   int system = 0, softinclude = 0;
3593   uint8_t ch;
3594
3595   while (count != 0) {
3596     ch = ufoImgGetU8(addr);
3597     if (ch == '!') {
3598       if (system) ufoFatal("invalid file name (duplicate system mark)");
3599       system = 1;
3600     } else if (ch == '?') {
3601       if (softinclude) ufoFatal("invalid file name (duplicate soft mark)");
3602       softinclude = 1;
3603     } else {
3604       break;
3605     }
3606     do {
3607       addr += 1; count -= 1;
3608       ch = ufoImgGetU8(addr);
3609     } while (ch <= 32 && count != 0);
3610   }
3611
3612   if (count == 0) {
3613     if (!softinclude) ufoFatal("empty include file name");
3614     return;
3615   }
3616   if (count > (uint32_t)sizeof(ufoFNameBuf) - 1u) ufoFatal("include file name too long");
3617
3618   // get filename
3619   if ((size_t)count >= sizeof(ufoFNameBuf)) ufoFatal("include file name too long");
3620   dpos = 0;
3621   while (count != 0) {
3622     ufoFNameBuf[dpos] = (char)ufoImgGetU8(addr); dpos += 1;
3623     addr += 1; count -= 1;
3624   }
3625   ufoFNameBuf[dpos] = 0;
3626
3627   char *ffn = ufoCreateIncludeName(ufoFNameBuf, system, ufoLastIncPath);
3628   FILE *fl = ufoOpenFileOrDir(&ffn);
3629   if (!fl) {
3630     if (softinclude) { free(ffn); return; }
3631     ufoFatal("include file '%s' not found", ffn);
3632   }
3633   ufoPushInFile();
3634   ufoInFile = fl;
3635   ufoInFileLine = 0;
3636   ufoInFileName = ffn;
3637   setLastIncPath(ufoInFileName);
3638
3639   // trigger next line loading
3640   UFCALL(REFILL);
3641   if (!ufoPop()) ufoFatal("(INCLUDE) internal error");
3642 }
3643
3644 // $INCLUDE "str"
3645 UFWORD(DLR_INCLUDE_IMM) {
3646   // parse include filename
3647   UFCALL(PARSE_SKIP_BLANKS);
3648   if (ufoImgGetU8(ufoImgGetU32(ufoAddrTIB) + ufoImgGetU32(ufoAddrIN)) != 34) {
3649     ufoFatal("expected quoted string");
3650   }
3651   ufoImgPutU32(ufoAddrIN, ufoImgGetU32(ufoAddrIN) + 1u); // skip quote
3652   ufoPush(34); UFCALL(PARSE);
3653   if (!ufoPop()) ufoFatal("file name expected");
3654   UFCALL(PARSE_SKIP_COMMENTS);
3655   if (ufoImgGetU8(ufoImgGetU32(ufoAddrTIB) + ufoImgGetU32(ufoAddrIN)) != 0) {
3656     ufoFatal("$INCLUDE doesn't accept extra args yet");
3657   }
3658   UFCALL(PAR_INCLUDE);
3659 }
3660
3661 // $INCLUDE-ONCE defname "str"
3662 UFWORD(DLR_INCLUDE_ONCE_IMM) {
3663   UFCALL(PARSE_NAME);
3664   if (ufoPeek() == 0) ufoFatal("guard name expected");
3665   ufo2Dup(); UFCALL(PAR_DLR_DEFINEDQ);
3666   if (ufoPop() == 0) {
3667     // define guard
3668     UFCALL(PAR_DLR_DEFINE);
3669     // parse include filename
3670     UFCALL(DLR_INCLUDE_IMM);
3671   } else {
3672     // already included
3673     ufo2Drop();
3674     //UFCALL(PARSE_SKIP_LINE);
3675     if (ufoImgGetU8(ufoImgGetU32(ufoAddrTIB) + ufoImgGetU32(ufoAddrIN)) != 34) {
3676       ufoFatal("expected quoted string");
3677     }
3678     ufoImgPutU32(ufoAddrIN, ufoImgGetU32(ufoAddrIN) + 1u); // skip quote
3679     ufoPush(34); UFCALL(PARSE);
3680     UFCALL(PARSE_SKIP_COMMENTS);
3681     if (ufoImgGetU8(ufoImgGetU32(ufoAddrTIB) + ufoImgGetU32(ufoAddrIN)) != 0) {
3682       ufoFatal("$INCLUDE doesn't accept extra args yet");
3683     }
3684   }
3685 }
3686
3687
3688 // ////////////////////////////////////////////////////////////////////////// //
3689 // handles
3690
3691 // HANDLE:NEW
3692 // ( typecfa -- hx )
3693 UFWORD(PAR_NEW_HANDLE) {
3694   const uint32_t typecfa = ufoPop();
3695   if (typecfa == UFO_HANDLE_FREE) ufoFatal("invalid handle typecfa");
3696   UHandleInfo *hh = ufoAllocHandle(typecfa);
3697   ufoPush(hh->ufoHandle);
3698 }
3699
3700 // HANDLE:FREE
3701 // ( hx -- )
3702 UFWORD(PAR_FREE_HANDLE) {
3703   const uint32_t hx = ufoPop();
3704   if (hx != 0) {
3705     if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("trying to free something that is not a handle");
3706     UHandleInfo *hh = ufoGetHandle(hx);
3707     if (hh == NULL) ufoFatal("trying to free invalid handle");
3708     ufoFreeHandle(hh);
3709   }
3710 }
3711
3712 // HANDLE:GET-SIZE
3713 // ( hx -- size )
3714 UFWORD(PAR_HANDLE_GET_SIZE) {
3715   const uint32_t hx = ufoPop();
3716   if (hx != 0) {
3717     if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle");
3718     UHandleInfo *hh = ufoGetHandle(hx);
3719     if (hh == NULL) ufoFatal("invalid handle");
3720     ufoPush(hh->size);
3721   } else {
3722     ufoPush(0);
3723   }
3724 }
3725
3726 // HANDLE:SET-SIZE
3727 // ( size hx -- )
3728 UFWORD(PAR_HANDLE_SET_SIZE) {
3729   const uint32_t hx = ufoPop();
3730   const uint32_t size = ufoPop();
3731   if (size > 0x04000000) ufoFatal("invalid handle size");
3732   if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle");
3733   UHandleInfo *hh = ufoGetHandle(hx);
3734   if (hh == NULL) ufoFatal("invalid handle");
3735   if (hh->size != size) {
3736     if (size == 0) {
3737       free(hh->mem);
3738       hh->mem = NULL;
3739     } else {
3740       uint32_t *nx = realloc(hh->mem, size * sizeof(hh->mem[0]));
3741       if (nx == NULL) ufoFatal("out of memory for handle of size %u", size);
3742       hh->mem = nx;
3743     }
3744     hh->size = size;
3745     if (hh->used > size) hh->used = size;
3746   }
3747 }
3748
3749 // HANDLE:GET-USED
3750 // ( hx -- used )
3751 UFWORD(PAR_HANDLE_GET_USED) {
3752   const uint32_t hx = ufoPop();
3753   if (hx != 0) {
3754     if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle");
3755     UHandleInfo *hh = ufoGetHandle(hx);
3756     if (hh == NULL) ufoFatal("invalid handle");
3757     ufoPush(hh->used);
3758   } else {
3759     ufoPush(0);
3760   }
3761 }
3762
3763 // HANDLE:SET-USED
3764 // ( size hx -- )
3765 UFWORD(PAR_HANDLE_SET_USED) {
3766   const uint32_t hx = ufoPop();
3767   const uint32_t used = ufoPop();
3768   if (used > 0x04000000) ufoFatal("invalid handle used");
3769   if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle");
3770   UHandleInfo *hh = ufoGetHandle(hx);
3771   if (hh == NULL) ufoFatal("invalid handle");
3772   if (used > hh->size) ufoFatal("handle used %u out of range (%u)", used, hh->size);
3773   hh->used = used;
3774 }
3775
3776 // HANDLE:@
3777 // ( idx hx -- value )
3778 UFWORD(PAR_HANDLE_LOAD) {
3779   const uint32_t hx = ufoPop();
3780   const uint32_t idx = ufoPop();
3781   if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle");
3782   UHandleInfo *hh = ufoGetHandle(hx);
3783   if (hh == NULL) ufoFatal("invalid handle");
3784   if (idx >= hh->size) ufoFatal("handle index %u out of range (%u)", idx, hh->size);
3785   ufoPush(hh->mem[idx]);
3786 }
3787
3788 // HANDLE:!
3789 // ( value idx hx -- value )
3790 UFWORD(PAR_HANDLE_STORE) {
3791   const uint32_t hx = ufoPop();
3792   const uint32_t idx = ufoPop();
3793   const uint32_t value = ufoPop();
3794   if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle");
3795   UHandleInfo *hh = ufoGetHandle(hx);
3796   if (hh == NULL) ufoFatal("invalid handle");
3797   if (idx >= hh->size) ufoFatal("handle index %u out of range (%u)", idx, hh->size);
3798   hh->mem[idx] = value;
3799 }
3800
3801 // DEBUG:(DECOMPILE-CFA)
3802 // ( cfa -- )
3803 UFWORD(DEBUG_DECOMPILE_CFA) {
3804   const uint32_t cfa = ufoPop();
3805   ufoDecompileWord(cfa);
3806 }
3807
3808
3809 // ////////////////////////////////////////////////////////////////////////// //
3810 // inline stop
3811
3812 // $END_FORTH
3813 UFWORD(DLR_END_FORTH_IMM) {
3814   if (ufoMode != UFO_MODE_NATIVE) ufoFatal("$END_FORTH in non-native mode");
3815   if (ufoImgGetU32(ufoAddrSTATE) != 0) ufoFatal("$END_FORTH: still compiling something");
3816   longjmp(ufoInlineQuitJP, 1);
3817 }
3818
3819
3820 // ////////////////////////////////////////////////////////////////////////// //
3821 #undef UFWORD
3822
3823 #define UFWORD(name_)  do { \
3824   const uint32_t xcfa_ = ufoCFAsUsed; \
3825   ufo_assert(xcfa_ < UFO_MAX_NATIVE_CFAS); \
3826   ufoForthCFAs[xcfa_] = &ufoWord_##name_; \
3827   ufoCFAsUsed += 1; \
3828   ufoDefineNative(""#name_, xcfa_, 0); \
3829 } while (0)
3830
3831 #define UFWORDX(strname_,name_)  do { \
3832   const uint32_t xcfa_ = ufoCFAsUsed; \
3833   ufo_assert(xcfa_ < UFO_MAX_NATIVE_CFAS); \
3834   ufoForthCFAs[xcfa_] = &ufoWord_##name_; \
3835   ufoCFAsUsed += 1; \
3836   ufoDefineNative(strname_, xcfa_, 0); \
3837 } while (0)
3838
3839 #define UFWORD_IMM(name_)  do { \
3840   const uint32_t xcfa_ = ufoCFAsUsed; \
3841   ufo_assert(xcfa_ < UFO_MAX_NATIVE_CFAS); \
3842   ufoForthCFAs[xcfa_] = &ufoWord_##name_; \
3843   ufoCFAsUsed += 1; \
3844   ufoDefineNative(""#name_, xcfa_, 1); \
3845 } while (0)
3846
3847 #define UFWORDX_IMM(strname_,name_)  do { \
3848   const uint32_t xcfa_ = ufoCFAsUsed; \
3849   ufo_assert(xcfa_ < UFO_MAX_NATIVE_CFAS); \
3850   ufoForthCFAs[xcfa_] = &ufoWord_##name_; \
3851   ufoCFAsUsed += 1; \
3852   ufoDefineNative(strname_, xcfa_, 1); \
3853 } while (0)
3854
3855
3856 //==========================================================================
3857 //
3858 //  ufoVocSetOnlyDefs
3859 //
3860 //==========================================================================
3861 static void ufoVocSetOnlyDefs (uint32_t vocid) {
3862   ufoImgPutU32(ufoAddrCurrent, vocid);
3863   ufoImgPutU32(ufoAddrContext, vocid);
3864 }
3865
3866
3867 //==========================================================================
3868 //
3869 //  ufoCreateVoc
3870 //
3871 //  return voc PFA (vocid)
3872 //
3873 //==========================================================================
3874 static uint32_t ufoCreateVoc (const char *wname, uint32_t parentvocid) {
3875   // create wordlist struct
3876   const uint32_t vocid = UFO_GET_DP();
3877   //fprintf(stderr, "NEW VOCID (%s): 0x%08x\n", wname, vocid);
3878   ufoImgEmitU32(0); // latest
3879   const uint32_t vlink = UFO_GET_DP();
3880   if ((vocid & UFO_ADDR_TEMP_BIT) == 0) {
3881     ufoImgEmitU32(ufoImgGetU32(ufoAddrVocLink)); // voclink
3882     ufoImgPutU32(ufoAddrVocLink, vlink); // update voclink
3883   } else {
3884     abort();
3885     ufoImgEmitU32(0);
3886   }
3887   ufoImgEmitU32(parentvocid); // parent
3888   const uint32_t hdraddr = UFO_GET_DP();
3889   ufoImgEmitU32(0); // word header
3890   // create empty hash table
3891   for (int f = 0; f < UFO_HASHTABLE_SIZE; f += 1) ufoImgEmitU32(0);
3892   // update CONTEXT and CURRENT if this is the first wordlist ever
3893   if (ufoImgGetU32(ufoAddrContext) == 0) {
3894     ufoImgPutU32(ufoAddrContext, vocid);
3895   }
3896   if (ufoImgGetU32(ufoAddrCurrent) == 0) {
3897     ufoImgPutU32(ufoAddrCurrent, vocid);
3898   }
3899   // create word header
3900   if (wname != NULL && wname[0] != 0) {
3901     uint32_t flags = ufoImgGetU32(ufoAddrNewWordFlags);
3902     flags &=
3903       //UFW_FLAG_IMMEDIATE|
3904       //UFW_FLAG_SMUDGE|
3905       //UFW_FLAG_NORETURN|
3906       UFW_FLAG_HIDDEN|
3907       //UFW_FLAG_CBLOCK|
3908       //UFW_FLAG_VOCAB|
3909       //UFW_FLAG_SCOLON|
3910       UFW_FLAG_PROTECTED;
3911     flags |= UFW_FLAG_VOCAB;
3912     ufoCreateWordHeader(wname, flags);
3913     const uint32_t cfa = UFO_GET_DP();
3914     ufoImgEmitU32(ufoDoVocCFA); // cfa
3915     ufoImgEmitU32(vocid); // pfa
3916     // update sfa
3917     const uint32_t lfa = UFO_CFA_TO_LFA(cfa);
3918     const uint32_t sfa = UFO_LFA_TO_SFA(lfa);
3919     ufoImgPutU32(sfa, UFO_GET_DP());
3920     // update vocab header pointer
3921     ufoImgPutU32(hdraddr, UFO_LFA_TO_NFA(lfa));
3922     #ifdef UFO_DEBUG_DUMP_NEW_HEADERS
3923     ufoDumpWordHeader(lfa);
3924     #endif
3925   }
3926   return vocid;
3927 }
3928
3929
3930 //==========================================================================
3931 //
3932 //  ufoFixLatestSFA
3933 //
3934 //==========================================================================
3935 static void ufoFixLatestSFA (void) {
3936   const uint32_t curr = ufoImgGetU32(ufoAddrCurrent);
3937   const uint32_t lfa = ufoImgGetU32(curr);
3938   const uint32_t sfa = UFO_LFA_TO_SFA(lfa);
3939   ufoImgPutU32(sfa, UFO_GET_DP()); // update sfa
3940   #ifdef UFO_DEBUG_DUMP_NEW_HEADERS
3941   ufoDumpWordHeader(lfa);
3942   #endif
3943 }
3944
3945
3946 //==========================================================================
3947 //
3948 //  ufoSetLatestArgs
3949 //
3950 //==========================================================================
3951 static void ufoSetLatestArgs (uint32_t warg) {
3952   const uint32_t curr = ufoImgGetU32(ufoAddrCurrent);
3953   const uint32_t lfa = ufoImgGetU32(curr);
3954   const uint32_t nfa = UFO_LFA_TO_NFA(lfa);
3955   uint32_t flags = ufoImgGetU32(nfa);
3956   //fprintf(stderr, "OLD FLAGS: 0x%08x\n", flags);
3957   flags &= ~UFW_WARG_MASK;
3958   flags |= warg & UFW_WARG_MASK;
3959   //fprintf(stderr, "NEW FLAGS: 0x%08x\n", flags);
3960   ufoImgPutU32(nfa, flags);
3961   #ifdef UFO_DEBUG_DUMP_NEW_HEADERS
3962   ufoDumpWordHeader(lfa);
3963   #endif
3964 }
3965
3966
3967 //==========================================================================
3968 //
3969 //  ufoDefine
3970 //
3971 //==========================================================================
3972 static void ufoDefineNative (const char *wname, uint32_t cfaidx, int immed) {
3973   cfaidx |= UFO_ADDR_CFA_BIT;
3974   uint32_t flags = ufoImgGetU32(ufoAddrNewWordFlags);
3975   flags &=
3976       //UFW_FLAG_IMMEDIATE|
3977       //UFW_FLAG_SMUDGE|
3978       //UFW_FLAG_NORETURN|
3979       UFW_FLAG_HIDDEN|
3980       //UFW_FLAG_CBLOCK|
3981       //UFW_FLAG_VOCAB|
3982       //UFW_FLAG_SCOLON|
3983       UFW_FLAG_PROTECTED;
3984   if (immed) flags |= UFW_FLAG_IMMEDIATE;
3985   ufoCreateWordHeader(wname, flags);
3986   ufoImgEmitU32(cfaidx);
3987   ufoFixLatestSFA();
3988 }
3989
3990
3991 //==========================================================================
3992 //
3993 //  ufoDefineConstant
3994 //
3995 //==========================================================================
3996 static void ufoDefineConstant (const char *name, uint32_t value) {
3997   ufoDefineNative(name, ufoDoConstCFA, 0);
3998   ufoImgEmitU32(value);
3999   ufoFixLatestSFA();
4000 }
4001
4002
4003 //==========================================================================
4004 //
4005 //  ufoDefineVar
4006 //
4007 //==========================================================================
4008 /*
4009 static void ufoDefineVar (const char *name, uint32_t value) {
4010   ufoDefineNative(name, ufoDoVarCFA, 0);
4011   ufoImgEmitU32(value);
4012   ufoFixLatestSFA();
4013 }
4014 */
4015
4016
4017 //==========================================================================
4018 //
4019 //  ufoDefineDefer
4020 //
4021 //==========================================================================
4022 /*
4023 static void ufoDefineDefer (const char *name, uint32_t value) {
4024   ufoDefineNative(name, ufoDoDeferCFA, 0);
4025   ufoImgEmitU32(value);
4026   ufoFixLatestSFA();
4027 }
4028 */
4029
4030
4031 //==========================================================================
4032 //
4033 //  ufoDefineForth
4034 //
4035 //==========================================================================
4036 static void ufoDefineForth (const char *name) {
4037   ufoDefineNative(name, ufoDoForthCFA, 0);
4038 }
4039
4040
4041 //==========================================================================
4042 //
4043 //  ufoDoneForth
4044 //
4045 //==========================================================================
4046 static void ufoDoneForth (void) {
4047   ufoFixLatestSFA();
4048 }
4049
4050
4051 //==========================================================================
4052 //
4053 //  ufoReset
4054 //
4055 //==========================================================================
4056 static void ufoReset (void) {
4057   ufoSP = 0; ufoRP = 0;
4058   ufoLP = 0; ufoLBP = 0;
4059
4060   ufoStopVM = 0;
4061   ufoInBacktrace = 0;
4062
4063   ufoImgPutU32(ufoAddrSTATE, 0);
4064   ufoImgPutU32(ufoAddrBASE, 10);
4065   ufoImgPutU32(ufoAddrTIB, 0);
4066   ufoImgPutU32(ufoAddrIN, 0);
4067   ufoImgPutU32(0, 0);
4068
4069   ufoImgPutU32(ufoAddrNewWordFlags, 0);
4070   ufoVocSetOnlyDefs(ufoForthVocId);
4071 }
4072
4073
4074 //==========================================================================
4075 //
4076 //  ufoFindWordChecked
4077 //
4078 //==========================================================================
4079 static uint32_t ufoFindWordChecked (const char *wname) {
4080   const uint32_t cfa = ufoFindWord(wname);
4081   if (cfa == 0) ufoFatal("word '%s' not found", wname);
4082   return cfa;
4083 }
4084
4085
4086 #define UFC(name_)  ufoImgEmitU32(ufoFindWordChecked(name_))
4087
4088
4089 //==========================================================================
4090 //
4091 //  ufoCompileStrLit
4092 //
4093 //  compile string literal, the same as QUOTE_IMM
4094 //
4095 //==========================================================================
4096 static void ufoCompileStrLit (const char *str) {
4097   if (str == NULL) str = "";
4098   const size_t slen = strlen(str);
4099   if (slen > 255) ufoFatal("string literal too long");
4100   UFC("FORTH:(STRLIT8)");
4101   ufoImgEmitU8((uint8_t)slen);
4102   for (size_t f = 0; f < slen; f += 1) {
4103     ufoImgEmitU8(((const unsigned char *)str)[f]);
4104   }
4105   ufoImgEmitU8(0);
4106   ufoImgEmitAlign();
4107 }
4108
4109
4110 //==========================================================================
4111 //
4112 //  ufoCompileLit
4113 //
4114 //==========================================================================
4115 static __attribute__((unused)) void ufoCompileLit (uint32_t value) {
4116   UFC("FORTH:(LIT)");
4117   ufoImgEmitU32(value);
4118 }
4119
4120
4121 //==========================================================================
4122 //
4123 //  ufoDefineInterpret
4124 //
4125 //  define "INTERPRET" in Forth
4126 //
4127 //==========================================================================
4128 static void ufoDefineInterpret (void) {
4129   // skip comments, parse name, refilling lines if necessary
4130   ufoDefineForth("(INTERPRET-PARSE-NAME)");
4131     const uint32_t label_ipn_again = UFO_GET_DP();
4132     UFC("PARSE-SKIP-COMMENTS");
4133     UFC("PARSE-NAME");
4134     UFC("DUP");
4135     UFC("FORTH:(TBRANCH)");
4136     const uint32_t label_ipn_exit_fwd = UFO_GET_DP();
4137     ufoImgEmitU32(0);
4138     UFC("2DROP");
4139     UFC("REFILL"); UFC("NOT");
4140     ufoCompileStrLit("unexpected end of file");
4141     UFC("?ERROR");
4142     UFC("FORTH:(BRANCH)");
4143     ufoImgEmitU32(label_ipn_again);
4144     // patch the jump above
4145     ufoImgPutU32(label_ipn_exit_fwd, UFO_GET_DP());
4146     UFC("FORTH:(EXIT)");
4147   ufoDoneForth(); UFCALL(PAR_HIDDEN);
4148   //ufoDecompileWord(ufoFindWordChecked("(INTERPRET-PARSE-NAME)"));
4149
4150   ufoDefineForth("INTERPRET");
4151     const uint32_t label_it_again = UFO_GET_DP();
4152     UFC("FORTH:(INTERPRET-PARSE-NAME)");
4153     UFC("2DUP"); UFC("FIND-WORD");  // ( addr count cfa TRUE / addr count FALSE )
4154     UFC("FORTH:(0BRANCH)");
4155     const uint32_t label_it_try_num = UFO_GET_DP();
4156     ufoImgEmitU32(0);
4157       UFC("NROT"); UFC("2DROP"); // drop word string
4158       UFC("STATE"); UFC("@");
4159       UFC("FORTH:(0BRANCH)");
4160       const uint32_t label_it_exec_fwd = UFO_GET_DP();
4161       ufoImgEmitU32(0);
4162         // compiling; check immediate bit
4163         UFC("DUP"); UFC("CFA->NFA"); UFC("@");
4164         UFC("COMPILER:(WFLAG-IMMEDIATE)"); UFC("AND");
4165         UFC("FORTH:(TBRANCH)");
4166         const uint32_t label_it_exec_imm = UFO_GET_DP();
4167         ufoImgEmitU32(0);
4168           // compile it
4169           UFC("FORTH:COMPILE,");
4170           UFC("FORTH:(BRANCH)");
4171           ufoImgEmitU32(label_it_again);
4172         // execute it
4173         ufoImgPutU32(label_it_exec_imm, UFO_GET_DP());
4174         ufoImgPutU32(label_it_exec_fwd, UFO_GET_DP());
4175           UFC("EXECUTE");
4176           UFC("FORTH:(BRANCH)");
4177           ufoImgEmitU32(label_it_again);
4178     // not a word, try a number
4179     ufoImgPutU32(label_it_try_num, UFO_GET_DP());
4180     UFC("2DUP"); UFC("TRUE"); UFC("FORTH:(XNUMBER)");
4181     // (XNUMBER) ( addr count allowsign? -- num TRUE / FALSE )
4182     UFC("FORTH:(0BRANCH)");
4183     const uint32_t label_it_num_error = UFO_GET_DP();
4184     ufoImgEmitU32(0);
4185       // number
4186       UFC("NROT"); UFC("2DROP"); // drop word string
4187       // do we need to compile it?
4188       UFC("STATE"); UFC("@");
4189       UFC("FORTH:(0BRANCH)");
4190       ufoImgEmitU32(label_it_again);
4191       // compile "(LITERAL)" (do it properly, with "LITCFA")
4192       UFC("FORTH:(LITCFA)"); UFC("FORTH:(LIT)");
4193       UFC("FORTH:COMPILE,"); // compile "(LIT)" CFA
4194       UFC("FORTH:,"); // compile number
4195       UFC("FORTH:(BRANCH)");
4196       ufoImgEmitU32(label_it_again);
4197     // error
4198     ufoImgPutU32(label_it_num_error, UFO_GET_DP());
4199       UFC("ENDCR"); UFC("SPACE"); UFC("XTYPE");
4200       ufoCompileStrLit(" -- wut?\n"); UFC("TYPE");
4201       ufoCompileStrLit("unknown word");
4202       UFC("ERROR");
4203   ufoDoneForth();
4204   //ufoDecompileWord(ufoFindWordChecked("INTERPRET"));
4205 }
4206
4207
4208 //==========================================================================
4209 //
4210 //  ufoInitCommon
4211 //
4212 //==========================================================================
4213 static void ufoInitCommon (void) {
4214   ufoVSP = 0;
4215   ufoForthVocId = 0; ufoCompilerVocId = 0; ufoMacroVocId = 0;
4216
4217   ufoDStack = calloc(UFO_DSTACK_SIZE, sizeof(ufoDStack[0]));
4218   ufoRStack = calloc(UFO_RSTACK_SIZE, sizeof(ufoRStack[0]));
4219   ufoLStack = calloc(UFO_LSTACK_SIZE, sizeof(ufoLStack[0]));
4220   ufoForthCFAs = calloc(UFO_MAX_NATIVE_CFAS, sizeof(ufoForthCFAs[0]));
4221
4222   ufoForthCFAs[0] = NULL;
4223   ufoDoForthCFA = 1u | UFO_ADDR_CFA_BIT; ufoForthCFAs[ufoDoForthCFA & UFO_ADDR_CFA_MASK] = &ufoDoForth;
4224   ufoDoVarCFA = 2u | UFO_ADDR_CFA_BIT; ufoForthCFAs[ufoDoVarCFA & UFO_ADDR_CFA_MASK] = &ufoDoVariable;
4225   ufoDoValueCFA = 3u | UFO_ADDR_CFA_BIT; ufoForthCFAs[ufoDoValueCFA & UFO_ADDR_CFA_MASK] = &ufoDoValue;
4226   ufoDoConstCFA = 4u | UFO_ADDR_CFA_BIT; ufoForthCFAs[ufoDoConstCFA & UFO_ADDR_CFA_MASK] = &ufoDoConst;
4227   ufoDoDeferCFA = 5u | UFO_ADDR_CFA_BIT; ufoForthCFAs[ufoDoDeferCFA & UFO_ADDR_CFA_MASK] = &ufoDoDefer;
4228   ufoDoVocCFA = 6u | UFO_ADDR_CFA_BIT; ufoForthCFAs[ufoDoVocCFA & UFO_ADDR_CFA_MASK] = &ufoDoVoc;
4229   ufoCFAsUsed = 7;
4230   ufoMaxDoCFA = ufoCFAsUsed;
4231
4232   //fprintf(stderr, "DO-FORTH-CFA: 0x%08x\n", ufoDoForthCFA);
4233
4234   uint32_t imgAddr = 0;
4235
4236   // reserve TIB
4237   for (uint32_t f = 0; f < ufoTIBAreaSize; f += 1) {
4238     ufoImgPutU8(imgAddr, 0);
4239     imgAddr += 1;
4240   }
4241   // align
4242   while ((imgAddr & 3) != 0) {
4243     ufoImgPutU8(imgAddr, 0);
4244     imgAddr += 1;
4245   }
4246
4247   // reserve numeric buffer
4248   for (uint32_t f = 0; f < ufoNUMAreaSize; f += 1) {
4249     ufoImgPutU8(imgAddr, 0);
4250     imgAddr += 1;
4251   }
4252   // align
4253   while ((imgAddr & 3) != 0) {
4254     ufoImgPutU8(imgAddr, 0);
4255     imgAddr += 1;
4256   }
4257
4258   // BASE
4259   ufoAddrBASE = imgAddr;
4260   ufoImgPutU32(imgAddr, 10); imgAddr += 4u;
4261
4262   // STATE
4263   ufoAddrSTATE = imgAddr;
4264   ufoImgPutU32(imgAddr, 0); imgAddr += 4u;
4265
4266   // HERE
4267   ufoAddrHERE = imgAddr;
4268   ufoImgPutU32(imgAddr, 0); imgAddr += 4u;
4269
4270   // TIB
4271   ufoAddrTIB = imgAddr;
4272   ufoImgPutU32(imgAddr, 0); imgAddr += 4u;
4273
4274   // >IN
4275   ufoAddrIN = imgAddr;
4276   ufoImgPutU32(imgAddr, 0); imgAddr += 4u;
4277
4278   // CONTEXT
4279   ufoAddrContext = imgAddr;
4280   ufoImgPutU32(imgAddr, 0); imgAddr += 4u;
4281
4282   // CURRENT
4283   ufoAddrCurrent = imgAddr;
4284   ufoImgPutU32(imgAddr, 0); imgAddr += 4u;
4285
4286   // (VOC-LINK)
4287   ufoAddrVocLink = imgAddr;
4288   ufoImgPutU32(imgAddr, 0); imgAddr += 4u;
4289
4290   // (NEW-WORD-FLAGS)
4291   ufoAddrNewWordFlags = imgAddr;
4292   ufoImgPutU32(imgAddr, UFW_FLAG_PROTECTED); imgAddr += 4u;
4293
4294   UFO_SET_DP(imgAddr);
4295   #if 0
4296   fprintf(stderr, "INITIAL HERE: 0x%08x (0x%08x)\n", imgAddr, UFO_GET_DP());
4297   #endif
4298
4299   // create "FORTH" vocabulary
4300   ufoForthVocId = ufoCreateVoc("FORTH", 0);
4301   ufoVocSetOnlyDefs(ufoForthVocId);
4302
4303   // create "COMPILER" vocabulary
4304   ufoCompilerVocId = ufoCreateVoc("COMPILER", 0);
4305
4306   // create "STRING" vocabulary
4307   uint32_t stringVocId = ufoCreateVoc("STRING", 0);
4308
4309   // create "HANDLE" vocabulary
4310   uint32_t handleVocId = ufoCreateVoc("HANDLE", 0);
4311
4312   // create "URASM-MACROS" vocabulary
4313   ufoMacroVocId = ufoCreateVoc("URASM-MACROS", 0);
4314
4315   // create "URASM" vocabulary
4316   uint32_t urasmVocId = ufoCreateVoc("URASM", 0);
4317
4318   // create "DEBUG" vocabulary
4319   uint32_t debugVocId = ufoCreateVoc("DEBUG", 0);
4320
4321   // base low-level interpreter words
4322   ufoDefineConstant("FALSE", 0);
4323   ufoDefineConstant("TRUE", ufoTrueValue);
4324
4325   ufoDefineConstant("BL", 32);
4326   ufoDefineConstant("NL", 10);
4327
4328   // basic vars
4329   ufoDefineConstant("BASE", ufoAddrBASE);
4330   ufoDefineConstant("STATE", ufoAddrSTATE);
4331   ufoDefineConstant("TIB", ufoAddrTIB);
4332   ufoDefineConstant(">IN", ufoAddrIN);
4333   ufoDefineConstant("STD-TIB-ADDR", 0);
4334   ufoDefineConstant("STD-TIB-SIZE", ufoTIBAreaSize);
4335   ufoDefineConstant("(#BUF-START)", ufoTIBAreaSize + 4u); UFCALL(PAR_HIDDEN);
4336   ufoDefineConstant("(#BUF-END)", ufoTIBAreaSize + ufoNUMAreaSize); UFCALL(PAR_HIDDEN);
4337   ufoDefineConstant("(#BUF-SIZE)", ufoNUMAreaSize - 4u); UFCALL(PAR_HIDDEN);
4338   ufoDefineConstant("(#BUF-OFS)", ufoTIBAreaSize); UFCALL(PAR_HIDDEN);
4339   ufoDefineConstant("CONTEXT", ufoAddrContext);
4340   ufoDefineConstant("CURRENT", ufoAddrCurrent);
4341   ufoDefineConstant("(VOC-LINK)", ufoAddrVocLink); UFCALL(PAR_HIDDEN);
4342   ufoDefineConstant("(NEW-WORD-FLAGS)", ufoAddrNewWordFlags); UFCALL(PAR_HIDDEN);
4343   ufoDefineConstant("(ADDR-TEMP-BIT)", UFO_ADDR_TEMP_BIT); UFCALL(PAR_HIDDEN);
4344   ufoDefineConstant("(ADDR-CFA-BIT)", UFO_ADDR_CFA_BIT); UFCALL(PAR_HIDDEN);
4345   ufoDefineConstant("(ADDR-HANDLE-BIT)", UFO_ADDR_HANDLE_BIT); UFCALL(PAR_HIDDEN);
4346
4347   //UFWORDX("(UFO-BUCKET-STATS)", PAR_UFO_BUCKET_STATS);
4348   UFWORDX("SP0!", SP0_STORE);
4349   UFWORDX("RP0!", RP0_STORE);
4350
4351   UFWORDX("PAD", PAD);
4352   UFWORDX("HERE", HERE);
4353
4354   UFWORDX("@", PEEK);
4355   UFWORDX("C@", CPEEK);
4356   UFWORDX("W@", WPEEK);
4357
4358   UFWORDX("!", POKE);
4359   UFWORDX("C!", CPOKE);
4360   UFWORDX("W!", WPOKE);
4361
4362   UFWORDX(",", COMMA);
4363   UFWORDX("C,", CCOMMA);
4364   UFWORDX("W,", WCOMMA);
4365
4366   UFWORDX("(LIT)", PAR_LIT); ufoSetLatestArgs(UFW_WARG_LIT); UFCALL(PAR_HIDDEN);
4367   UFWORDX("(LITCFA)", PAR_LITCFA); ufoSetLatestArgs(UFW_WARG_CFA); UFCALL(PAR_HIDDEN);
4368   UFWORDX("(LITVOCID)", PAR_LITVOCID); ufoSetLatestArgs(UFW_WARG_VOCID); UFCALL(PAR_HIDDEN);
4369   UFWORDX("(STRLIT8)", PAR_STRLIT8); ufoSetLatestArgs(UFW_WARG_C1STRZ); UFCALL(PAR_HIDDEN);
4370   UFWORDX("(EXIT)", PAR_EXIT); UFCALL(PAR_HIDDEN);
4371
4372   ufoStrLit8CFA = ufoFindWordChecked("FORTH:(STRLIT8)");
4373
4374   UFWORDX("(L-ENTER)", PAR_LENTER); UFCALL(PAR_HIDDEN);
4375   UFWORDX("(L-LEAVE)", PAR_LLEAVE); UFCALL(PAR_HIDDEN);
4376   UFWORDX("(LOCAL@)", PAR_LOCAL_LOAD); UFCALL(PAR_HIDDEN);
4377   UFWORDX("(LOCAL!)", PAR_LOCAL_STORE); UFCALL(PAR_HIDDEN);
4378
4379   UFWORDX("(BRANCH)", PAR_BRANCH); ufoSetLatestArgs(UFW_WARG_BRANCH); UFCALL(PAR_HIDDEN);
4380   UFWORDX("(TBRANCH)", PAR_TBRANCH); ufoSetLatestArgs(UFW_WARG_BRANCH); UFCALL(PAR_HIDDEN);
4381   UFWORDX("(0BRANCH)", PAR_0BRANCH); ufoSetLatestArgs(UFW_WARG_BRANCH); UFCALL(PAR_HIDDEN);
4382
4383   UFWORDX("(HIDDEN)", PAR_HIDDEN);
4384
4385
4386   // some COMPILER words
4387   ufoVocSetOnlyDefs(ufoCompilerVocId);
4388
4389   ufoDefineConstant("(CFAIDX-DO-FORTH)", ufoDoForthCFA);
4390   ufoDefineConstant("(CFAIDX-DO-VAR)", ufoDoVarCFA);
4391   ufoDefineConstant("(CFAIDX-DO-VALUE)", ufoDoValueCFA);
4392   ufoDefineConstant("(CFAIDX-DO-CONST)", ufoDoConstCFA);
4393   ufoDefineConstant("(CFAIDX-DO-DEFER)", ufoDoDeferCFA);
4394   ufoDefineConstant("(CFAIDX-DO-VOC)", ufoDoVocCFA);
4395
4396   ufoDefineConstant("(WFLAG-IMMEDIATE)", UFW_FLAG_IMMEDIATE);
4397   ufoDefineConstant("(WFLAG-SMUDGE)", UFW_FLAG_SMUDGE);
4398   ufoDefineConstant("(WFLAG-NORETURN)", UFW_FLAG_NORETURN);
4399   ufoDefineConstant("(WFLAG-HIDDEN)", UFW_FLAG_HIDDEN);
4400   ufoDefineConstant("(WFLAG-CBLOCK)", UFW_FLAG_CBLOCK);
4401   ufoDefineConstant("(WFLAG-VOCAB)", UFW_FLAG_VOCAB);
4402   ufoDefineConstant("(WFLAG-SCOLON)", UFW_FLAG_SCOLON);
4403   ufoDefineConstant("(WFLAG-PROTECTED)", UFW_FLAG_PROTECTED);
4404
4405   ufoDefineConstant("(WARG-MASK)", UFW_WARG_MASK);
4406   ufoDefineConstant("(WARG-NONE)", UFW_WARG_NONE);
4407   ufoDefineConstant("(WARG-BRANCH)", UFW_WARG_BRANCH);
4408   ufoDefineConstant("(WARG-LIT)", UFW_WARG_LIT);
4409   ufoDefineConstant("(WARG-C4STRZ)", UFW_WARG_C4STRZ);
4410   ufoDefineConstant("(WARG-CFA)", UFW_WARG_CFA);
4411   ufoDefineConstant("(WARG-CBLOCK)", UFW_WARG_CBLOCK);
4412   ufoDefineConstant("(WARG-VOCID)", UFW_WARG_VOCID);
4413   ufoDefineConstant("(WARG-C1STRZ)", UFW_WARG_C1STRZ);
4414
4415   ufoDefineConstant("(VOCOFS-LATEST)", UFW_VOCAB_OFS_LATEST);
4416   ufoDefineConstant("(VOCOFS-VOCLINK)", UFW_VOCAB_OFS_VOCLINK);
4417   ufoDefineConstant("(VOCOFS-PARENT)", UFW_VOCAB_OFS_PARENT);
4418   ufoDefineConstant("(VOCOFS-HEADER)", UFW_VOCAB_OFS_HEADER);
4419   ufoDefineConstant("(VOCOFS-HTABLE)", UFW_VOCAB_OFS_HTABLE);
4420   ufoDefineConstant("(VOC-HTABLE-SIZE)", UFO_HASHTABLE_SIZE);
4421   ufoDefineConstant("(VOC-HTABLE-NOFLAG)", UFO_NO_HTABLE_FLAG);
4422
4423   UFWORDX("(UNESCAPE)", PAR_UNESCAPE);
4424
4425   UFWORDX("DP!", DP_STORE);
4426
4427   UFWORDX("?EXEC", QEXEC);
4428   UFWORDX("?COMP", QCOMP);
4429
4430   // interpreter
4431   /*
4432   UFWORDX("(INTERPRET-DUMB)", PAR_INTERPRET_DUMB); UFCALL(PAR_HIDDEN);
4433   const uint32_t idumbCFA = UFO_LFA_TO_CFA(ufoImgGetU32(ufoImgGetU32(ufoAddrCurrent)));
4434   ufo_assert(idumbCFA == UFO_PFA_TO_CFA(UFO_GET_DP()));
4435   */
4436
4437   UFWORDX("(CREATE-WORD-HEADER)", PAR_CREATE_WORD_HEADER);
4438
4439
4440   // more FORTH words
4441   ufoVocSetOnlyDefs(ufoForthVocId);
4442
4443   UFWORDX("COMPILE,", COMMA); // just an alias, for clarity
4444
4445   UFWORDX("CFA->PFA", CFA2PFA);
4446   UFWORDX("PFA->CFA", PFA2CFA);
4447   UFWORDX("CFA->NFA", CFA2NFA);
4448   UFWORDX("NFA->CFA", NFA2CFA);
4449   UFWORDX("CFA->LFA", CFA2LFA);
4450   UFWORDX("LFA->CFA", LFA2CFA);
4451   UFWORDX("LFA->BFA", LFA2BFA);
4452   UFWORDX("LFA->SFA", LFA2SFA);
4453   UFWORDX("LFA->NFA", LFA2NFA);
4454   UFWORDX("NFA->LFA", NFA2LFA);
4455
4456   UFWORDX("ERROR", ERROR);
4457   UFWORDX("?ERROR", QERROR);
4458
4459   UFWORDX("(XNUMBER)", PAR_XNUMBER);
4460   UFWORDX("FIND-WORD", FIND_WORD);
4461   UFWORDX("FIND-WORD-IN-VOC", FIND_WORD_IN_VOC);
4462
4463   UFWORDX_IMM("\"", QUOTE_IMM);
4464
4465   UFWORD(EXECUTE);
4466   UFWORDX("EXECUTE-TAIL", EXECUTE_TAIL);
4467
4468   UFWORD(DUP);
4469   UFWORDX("?DUP", QDUP);
4470   UFWORDX("2DUP", DDUP);
4471   UFWORD(DROP);
4472   UFWORDX("2DROP", DDROP);
4473   UFWORD(SWAP);
4474   UFWORDX("2SWAP", DSWAP);
4475   UFWORD(OVER);
4476   UFWORDX("2OVER", DOVER);
4477   UFWORD(ROT);
4478   UFWORD(NROT);
4479   UFWORDX("PICK", PICK);
4480   UFWORDX("ROLL", ROLL);
4481
4482   UFWORD(RDUP);
4483   UFWORD(RDROP);
4484   UFWORDX(">R", DTOR);
4485   UFWORDX("R>", RTOD);
4486   UFWORDX("R@", RPEEK);
4487   UFWORDX("RPICK", RPICK);
4488   UFWORDX("RROLL", RROLL);
4489
4490   UFWORD(EMIT);
4491   UFWORD(XEMIT);
4492   UFWORD(TYPE);
4493   UFWORD(XTYPE);
4494   UFWORD(SPACE);
4495   UFWORD(SPACES);
4496   UFWORD(CR);
4497   UFWORD(ENDCR);
4498   UFWORDX("LASTCR?", LASTCRQ);
4499   UFWORDX("LASTCR!", LASTCRSET);
4500
4501   // simple math
4502   UFWORDX("+", PLUS);
4503   UFWORDX("-", MINUS);
4504   UFWORDX("*", MUL);
4505   UFWORDX("U*", UMUL);
4506   UFWORDX("/", DIV);
4507   UFWORDX("U/", UDIV);
4508   UFWORDX("MOD", MOD);
4509   UFWORDX("UMOD", UMOD);
4510   UFWORDX("/MOD", DIVMOD);
4511   UFWORDX("U/MOD", UDIVMOD);
4512
4513   UFWORDX("2U*", ONESHL);
4514   UFWORDX("2U/", ONESHR);
4515   UFWORDX("4U*", TWOSHL);
4516   UFWORDX("4U/", TWOSHR);
4517
4518   UFWORD(ASH);
4519   UFWORD(LSH);
4520
4521   // logic
4522   UFWORDX("<", LESS);
4523   UFWORDX(">", GREAT);
4524   UFWORDX("<=", LESSEQU);
4525   UFWORDX(">=", GREATEQU);
4526   UFWORDX("U<", ULESS);
4527   UFWORDX("U>", UGREAT);
4528   UFWORDX("U<=", ULESSEQU);
4529   UFWORDX("U>=", UGREATEQU);
4530   UFWORDX("=", EQU);
4531   UFWORDX("<>", NOTEQU);
4532   UFWORD(WITHIN);
4533   UFWORD(UWITHIN);
4534   UFWORDX("BOUNDS?", BOUNDSQ);
4535
4536   UFWORD(NOT);
4537   UFWORD(BITNOT);
4538   UFWORD(AND);
4539   UFWORD(OR);
4540   UFWORD(XOR);
4541   UFWORDX("LOGAND", LOGAND);
4542   UFWORDX("LOGOR", LOGOR);
4543
4544   // TIB parser
4545   UFWORDX("(PARSE)", PAR_PARSE); UFCALL(PAR_HIDDEN);
4546   UFWORDX("PARSE-SKIP-BLANKS", PARSE_SKIP_BLANKS);
4547   UFWORDX("PARSE-NAME", PARSE_NAME);
4548   UFWORDX("PARSE-SKIP-LINE", PARSE_SKIP_LINE);
4549   UFWORDX("PARSE-SKIP-COMMENTS", PARSE_SKIP_COMMENTS);
4550   UFWORDX("PARSE", PARSE);
4551   UFWORDX("REFILL", REFILL);
4552
4553   UFWORDX_IMM("[", LBRACKET_IMM);
4554   UFWORDX("]", RBRACKET);
4555
4556   UFWORDX("(VSP@)", PAR_GET_VSP); UFCALL(PAR_HIDDEN);
4557   UFWORDX("(VSP!)", PAR_SET_VSP); UFCALL(PAR_HIDDEN);
4558   UFWORDX("(VSP-AT@)", PAR_VSP_LOAD); UFCALL(PAR_HIDDEN);
4559   UFWORDX("(VSP-AT!)", PAR_VSP_STORE); UFCALL(PAR_HIDDEN);
4560   ufoDefineConstant("(VSP-SIZE)", UFO_VOCSTACK_SIZE); UFCALL(PAR_HIDDEN);
4561
4562   ufoDefineConstant("(SP-SIZE)", UFO_DSTACK_SIZE); UFCALL(PAR_HIDDEN);
4563   ufoDefineConstant("(RP-SIZE)", UFO_RSTACK_SIZE); UFCALL(PAR_HIDDEN);
4564   ufoDefineConstant("(LP-SIZE)", UFO_LSTACK_SIZE); UFCALL(PAR_HIDDEN);
4565
4566
4567   // HANDLE vocabulary
4568   ufoVocSetOnlyDefs(handleVocId);
4569
4570   UFWORDX("NEW", PAR_NEW_HANDLE);
4571   UFWORDX("FREE", PAR_FREE_HANDLE);
4572   UFWORDX("GET-SIZE", PAR_HANDLE_GET_SIZE);
4573   UFWORDX("SET-SIZE", PAR_HANDLE_SET_SIZE);
4574   UFWORDX("GET-USED", PAR_HANDLE_GET_USED);
4575   UFWORDX("SET-USED", PAR_HANDLE_SET_USED);
4576   UFWORDX("@", PAR_HANDLE_LOAD);
4577   UFWORDX("!", PAR_HANDLE_STORE);
4578
4579
4580   // some higher-level FORTH words (includes, etc.)
4581   ufoVocSetOnlyDefs(ufoForthVocId);
4582
4583   UFWORDX("(INCLUDE)", PAR_INCLUDE); UFCALL(PAR_HIDDEN);
4584
4585   UFWORDX_IMM("$DEFINE", DLR_DEFINE_IMM);
4586   UFWORDX_IMM("$UNDEF", DLR_UNDEF_IMM);
4587   UFWORDX_IMM("$INCLUDE", DLR_INCLUDE_IMM);
4588   UFWORDX_IMM("$INCLUDE-ONCE", DLR_INCLUDE_ONCE_IMM);
4589
4590   UFWORDX("($DEFINED?)", PAR_DLR_DEFINEDQ); UFCALL(PAR_HIDDEN);
4591   UFWORDX("($DEFINE)", PAR_DLR_DEFINE); UFCALL(PAR_HIDDEN);
4592   UFWORDX("($UNDEF)", PAR_DLR_UNDEF); UFCALL(PAR_HIDDEN);
4593   UFWORDX("(TYPE-CURR-FILE)", PAR_TYPE_CURR_FILE); UFCALL(PAR_HIDDEN);
4594
4595
4596   // STRING vocabulary
4597   ufoVocSetOnlyDefs(stringVocId);
4598   UFWORDX("=", STREQU);
4599   UFWORDX("=CI", STREQUCI);
4600   UFWORDX("HASH", STRHASH);
4601   UFWORDX("HASH-CI", STRHASHCI);
4602
4603
4604   // very high-level FORTH words
4605   ufoVocSetOnlyDefs(ufoForthVocId);
4606
4607   UFWORDX("$LABEL-CODE:", DLR_LABEL_CODE_IMM);
4608   UFWORDX("$LABEL-DATA:", DLR_LABEL_DATA_IMM);
4609
4610   UFWORDX_IMM("$END_FORTH", DLR_END_FORTH_IMM);
4611   UFWORDX_IMM("$END-FORTH", DLR_END_FORTH_IMM);
4612
4613
4614   // DEBUG vocabulary
4615   ufoVocSetOnlyDefs(debugVocId);
4616   UFWORDX("BP", UFO_BP);
4617   UFWORDX("(DECOMPILE-CFA)", DEBUG_DECOMPILE_CFA);
4618   UFWORDX("BACKTRACE", UFO_BACKTRACE);
4619   UFWORDX("DUMP-STACK", DUMP_STACK);
4620
4621
4622   // UrAsm API
4623   ufoVocSetOnlyDefs(urasmVocId);
4624   // UrAsm label types
4625   // WARNING! keep in sync with C source!
4626   ufoDefineConstant("LBL-TYPE-UNKNOWN", UFO_ZX_LABEL_UNKNOWN);
4627   ufoDefineConstant("LBL-TYPE-VAR", UFO_ZX_LABEL_VAR);
4628   ufoDefineConstant("LBL-TYPE-EQU", UFO_ZX_LABEL_EQU);
4629   ufoDefineConstant("LBL-TYPE-CODE", UFO_ZX_LABEL_CODE);
4630   ufoDefineConstant("LBL-TYPE-STOFS", UFO_ZX_LABEL_STOFS);
4631   ufoDefineConstant("LBL-TYPE-DATA", UFO_ZX_LABEL_DATA);
4632
4633   UFWORDX("C,", ZX_CCOMMA);
4634   UFWORDX("W,", ZX_WCOMMA);
4635   UFWORDX("C@", ZX_CPEEK);
4636   UFWORDX("C!", ZX_CPOKE);
4637   UFWORDX("W@", ZX_WPEEK);
4638   UFWORDX("W!", ZX_WPOKE);
4639
4640   UFWORDX("RESERVED?", ZX_RESERVEDQ);
4641   UFWORDX("RESERVED!", ZX_RESERVEDS);
4642
4643   UFWORDX("HAS-LABEL?", UR_HAS_LABELQ);
4644   UFWORDX("LABEL-TYPE?", UR_GET_LABELQ_TYPE);
4645   UFWORDX("GET-LABEL", UR_GET_LABEL);
4646   UFWORDX("SET-LABEL-VAR", UR_SET_LABEL_VAR);
4647   UFWORDX("SET-LABEL-EQU", UR_SET_LABEL_EQU);
4648   UFWORDX("SET-LABEL-CODE", UR_SET_LABEL_CODE);
4649   UFWORDX("SET-LABEL-STOFS", UR_SET_LABEL_STOFS);
4650   UFWORDX("SET-LABEL-DATA", UR_SET_LABEL_DATA);
4651   UFWORDX("NEW-LABEL-ITER", UR_NEW_LABEL_ITER);
4652   UFWORDX("CLOSE-LABEL-ITER", UR_CLOSE_LABEL_ITER);
4653   UFWORDX("LABEL-ITER-NEXT", UR_LABEL_ITER_NEXT);
4654   UFWORDX("LABEL-ITER-GET-NAME", UR_LABEL_ITER_GET_NAME);
4655   UFWORDX("LABEL-ITER-GET-VALUE", UR_LABEL_ITER_GET_VALUE);
4656   UFWORDX("LABEL-ITER-GET-TYPE", UR_LABEL_ITER_GET_TYPE);
4657
4658   UFWORDX("PASS@", UR_PASSQ);
4659
4660   //UFWORDX("LOAD-DATA-FILE", ZX_LOAD_DATA_FILE);
4661
4662   UFWORDX("ORG@", UR_GETORG);
4663   UFWORDX("DISP@", UR_GETDISP);
4664   UFWORDX("ENT@", UR_GETENT);
4665   UFWORDX("ORG!", UR_SETORG);
4666   UFWORDX("DISP!", UR_SETDISP);
4667   UFWORDX("ENT!", UR_SETENT);
4668
4669
4670   // very-very high-level FORTH words
4671   ufoVocSetOnlyDefs(ufoForthVocId);
4672
4673   // interpret defer
4674   //ufoDefineDefer("INTERPRET", idumbCFA);
4675
4676
4677   // create "FORTH:EXIT"
4678   // : EXIT  ?COMP COMPILE FORTH:(EXIT) ;
4679   ufoDefineForth("EXIT");
4680     UFC("COMPILER:?COMP");
4681     UFC("FORTH:(LITCFA)"); UFC("FORTH:(EXIT)");
4682     UFC("FORTH:COMPILE,");
4683     UFC("FORTH:(EXIT)");
4684   ufoDoneForth();
4685
4686   ufoDefineInterpret();
4687
4688   //ufoDumpVocab(ufoCompilerVocId);
4689
4690   ufoDefineForth("RUN-INTERPRET-LOOP");
4691     const uint32_t addrAgain = UFO_GET_DP();
4692     UFC("RP0!");
4693     UFC("INTERPRET");
4694     UFC("FORTH:(BRANCH)");
4695     ufoImgEmitU32(addrAgain);
4696   ufoDoneForth();
4697
4698   #if 0
4699   ufoDecompileWord(ufoFindWordChecked("RUN-INTERPRET-LOOP"));
4700   #endif
4701
4702   ufoReset();
4703 }
4704
4705 #undef UFC
4706
4707
4708 //==========================================================================
4709 //
4710 //  ufoExecuteCFA
4711 //
4712 //  this executes either directly, or in VM.
4713 //  do not use tailcalls if you're not inside a VM yet!
4714 //
4715 //  "in VM" state is detected by checking `ufoIP`: it should not be 0 for VM
4716 //
4717 //==========================================================================
4718 static void ufoExecuteCFA (uint32_t cfa, int exectype) {
4719   ufo_assert(exectype >= -1 && exectype <= 1);
4720   if (cfa == 0) ufoFatal("EXECUTE: NULL CFA");
4721   const int inVM = (ufoIP != 0);
4722   if (exectype == UFO_EXEC_TAILCALL && !inVM) ufoFatal("EXEC: tail call outside of VM");
4723   uint32_t cfaidx = ufoImgGetU32(cfa);
4724   if (cfaidx & UFO_ADDR_CFA_BIT) {
4725     cfaidx &= UFO_ADDR_CFA_MASK;
4726     if (cfaidx < ufoCFAsUsed && ufoForthCFAs[cfaidx] != NULL) {
4727       // HACK! trying to detect forth-like words
4728       const uint32_t oldRP = ufoRP;
4729       ufoForthCFAs[cfaidx](UFO_CFA_TO_PFA(cfa));
4730       // if we are not in VM yet, execute it
4731       // otherwise we can simply return
4732       if (!inVM) {
4733         // we're not in VM, drop useless return address
4734         if (oldRP != ufoRP) {
4735           ufoRDrop();
4736           ufo_assert(ufoRP == oldRP);
4737         }
4738         ufoRunVM();
4739       } else if (exectype == UFO_EXEC_FORCE_VM) {
4740         // we are in VM, will need to restore return address; do it without using RSTACK
4741         uint32_t retIP;
4742         // we're not in VM, drop useless return address
4743         if (oldRP != ufoRP) {
4744           retIP = ufoRPop();
4745           ufo_assert(ufoRP == oldRP);
4746         } else {
4747           retIP = ufoIP;
4748         }
4749         ufoRunVM();
4750         ufoIP = retIP;
4751       } else if (exectype == UFO_EXEC_TAILCALL) {
4752         // forth-like word?
4753         if (oldRP != ufoRP) {
4754           ufoRDrop();
4755           ufo_assert(ufoRP == oldRP);
4756         } else {
4757           // something that doesn't change the IP
4758           if (ufoRP == 0 || ufoRP == ufoRPTop) {
4759             ufoStopVM = 1;
4760           } else {
4761             // return to the previous word
4762             // WARNING! this will not work for words with locals!
4763             ufoIP = ufoRPop();
4764           }
4765         }
4766       }
4767     } else {
4768       if (inVM) {
4769         ufoFatal("UFO tried to execute an unknown word: 0x%08x (max is 0x%08x); IP=0x%08x",
4770                  cfaidx, ufoCFAsUsed, ufoIP - 4u);
4771       } else {
4772         ufoFatal("UFO tried to execute an unknown word: 0x%08x (max is 0x%08x)",
4773                  cfaidx, ufoCFAsUsed);
4774       }
4775     }
4776   } else {
4777     // if CFA points somewhere inside a dict, this is "DOES>" word
4778     if (cfaidx < UFO_GET_DP() || (cfaidx & UFO_ADDR_TEMP_MASK) != 0) {
4779       if (!inVM) {
4780         // not in VM
4781         ufoIP = cfa;
4782         ufoRunVM();
4783       } else if (exectype == UFO_EXEC_FORCE_VM) {
4784         // force VM execution
4785         const uint32_t retIP = ufoIP;
4786         ufoIP = cfa;
4787         ufoRunVM();
4788         ufoIP = retIP;
4789       } else if (exectype == UFO_EXEC_TAILCALL) {
4790         // tail call
4791         ufoIP = cfa; // it's that easy
4792       } else {
4793         // normal "in VM" call
4794         ufoRPush(ufoIP);
4795         ufoIP = cfa;
4796       }
4797     } else {
4798       ufoFatal("VM tried to execute something that is not a word");
4799     }
4800   }
4801 }
4802
4803
4804 //==========================================================================
4805 //
4806 //  ufoRunVM
4807 //
4808 //  address interpreter
4809 //
4810 //==========================================================================
4811 static void ufoRunVM (void) {
4812   const uint32_t oldRPTop = ufoRPTop;
4813   ufoStopVM = 0; ufoRPTop = ufoRP;
4814   while (!ufoStopVM) {
4815     if (ufoIP == 0) ufoFatal("IP is NULL");
4816     const uint32_t cfa = ufoImgGetU32(ufoIP); ufoIP += 4u;
4817     uint32_t cfaidx = ufoImgGetU32(cfa);
4818     #ifdef UFO_TRACE_VM_RUN
4819     fprintf(stderr, "**VM**: IP=0x%08x; cfa=0x%08x; cfaidx=0x%08x\n", ufoIP - 4u, cfa, cfaidx);
4820     UFCALL(DUMP_STACK);
4821     ufoDumpWordHeader(UFO_CFA_TO_LFA(cfa));
4822     fprintf(stderr, "######################################\n");
4823     #endif
4824     if (cfaidx & UFO_ADDR_CFA_BIT) {
4825       cfaidx &= UFO_ADDR_CFA_MASK;
4826       if (cfaidx >= ufoCFAsUsed) {
4827         ufoFatal("UFO tried to execute an unknown word: 0x%08x (max is 0x%08x); IP=0x%08x",
4828                  cfaidx, ufoCFAsUsed, ufoIP - 4u);
4829       }
4830       if (ufoForthCFAs[cfaidx] == NULL) ufoFatal("VM internal error: empty CFA");
4831       ufoForthCFAs[cfaidx](UFO_CFA_TO_PFA(cfa));
4832     } else {
4833       // if CFA points somewhere inside a dict, this is "DOES>" word
4834       if (cfaidx < UFO_GET_DP() || (cfaidx & UFO_ADDR_TEMP_MASK) != 0) {
4835         ufoPush(ufoIP);
4836         ufoIP = cfa;
4837       } else {
4838         ufoFatal("VM tried to execute something that is not a word at 0x%08x: cfa=0x%08x; cfaidx=0x%08x",
4839                  ufoIP - 4u, cfa, cfaidx);
4840       }
4841     }
4842   }
4843   ufoStopVM = 0;
4844   if (ufoRP != ufoRPTop) ufoFatal("VM: unbalanced RP!");
4845   ufoRPTop = oldRPTop;
4846 }
4847
4848
4849 //==========================================================================
4850 //
4851 //  ufoRunIt
4852 //
4853 //==========================================================================
4854 static void ufoRunIt (const char *wname) {
4855   uint32_t cfa = ufoFindWord(wname);
4856   if (cfa == 0) {
4857     ufoFatal("UFO '%s' word not found", wname);
4858   }
4859   ufoExecuteCFA(cfa, UFO_EXEC_FORCE_VM);
4860 }
4861
4862
4863 //==========================================================================
4864 //
4865 //  ufoInlineInit
4866 //
4867 //==========================================================================
4868 void ufoInlineInit (void) {
4869   ufoMode = UFO_MODE_NATIVE;
4870   ufoTrueValue = ~0u; // -1 is better!
4871
4872   ufoInFileLine = 0; ufoCondStLine = -1;
4873   ufoInFileName = NULL;
4874   ufoInFile = NULL;
4875   ufoLastIncPath = NULL;
4876
4877   ufoInitCommon();
4878
4879   ufoZXPostInit();
4880
4881   ufoReset();
4882
4883   // load ufo modules
4884   char *ufmname = ufoCreateIncludeName("init", 1, NULL);
4885   FILE *ufl = ufoOpenFileOrDir(&ufmname);
4886   if (ufl) {
4887     ufoPushInFile();
4888     ufoInFileName = ufmname;
4889     ufoInFile = ufl;
4890     setLastIncPath(ufoInFileName);
4891   } else {
4892     free(ufmname);
4893   }
4894 }
4895
4896
4897 //==========================================================================
4898 //
4899 //  ufoInlineRun
4900 //
4901 //==========================================================================
4902 void ufoInlineRun (void) {
4903   if (ufoMode == UFO_MODE_NONE) {
4904     ufoInlineInit();
4905   }
4906   ufoMode = UFO_MODE_NATIVE;
4907
4908   if (setjmp(ufoInlineQuitJP) == 0) {
4909     ufoReset();
4910     ufoRunIt("RUN-INTERPRET-LOOP");
4911     ufo_assert(0); // the thing that should not be
4912   } else {
4913     while (ufoFileStackPos != 0) ufoPopInFile();
4914   }
4915 }
4916
4917
4918 //==========================================================================
4919 //
4920 //  ufoIsMacro
4921 //
4922 //==========================================================================
4923 uint32_t ufoIsMacro (const char *wname) {
4924   if (ufoMode != UFO_MODE_NONE && wname != NULL && wname[0] != 0) {
4925     return ufoFindWordMacro(wname);
4926   } else {
4927     return 0;
4928   }
4929 }
4930
4931
4932 //==========================================================================
4933 //
4934 //  ufoMacroRun
4935 //
4936 //==========================================================================
4937 void ufoMacroRun (uint32_t cfa, const char *line, const char *fname, int lnum) {
4938   ufo_assert(ufoMode != UFO_MODE_NONE);
4939   if (cfa != 0) {
4940     if (setjmp(ufoInlineQuitJP) == 0) {
4941       ufoReset();
4942       ufoLoadMacroLine(line, fname, lnum);
4943       ufoExecuteCFA(cfa, UFO_EXEC_FORCE_VM);
4944       while (ufoFileStackPos != 0) ufoPopInFile();
4945     } else {
4946       while (ufoFileStackPos != 0) ufoPopInFile();
4947       ufoFatal("wtf with UFO macro?!");
4948     }
4949   } else {
4950     ufoFatal("wtf with UFO macro?!");
4951   }
4952 }