src/urforth.c

   1 // and now for something completely different...
   2 // UrAsm built-in Forth Engine!
   3 // GPLv3 ONLY
   4
   5 //#define UFE_DSFORTH_CONFORMANT_LOOPS
   6
   7 static uint32_t ufeAfterTrace = 0;
   8
   9 typedef struct UForthWord_t UForthWord;
  10 struct UForthWord_t {
  11   char *name;
  12   UForthWord *prev;
  13   void (*cfa) (UForthWord *self); // `self` may be NULL if called from the internal code
  14   uint32_t cfaidx; // in `ufeForthCFAs`
  15   uint32_t pfa; // pointer to image
  16   uint32_t immediate;
  17 };
  18
  19 static UForthWord *ufeForthDict = NULL;
  20
  21 #define UFE_MAX_WORDS  (65536u)
  22 static UForthWord **ufeForthCFAs = NULL;
  23 static unsigned ufeCFAsUsed = 0;
  24
  25 #define UFE_ZX_ADDR_BIT   (1u<<30)
  26 #define UFE_ZX_ADDR_MASK  (0xffffU)
  27
  28 static uint32_t *ufeImage = NULL;
  29 static uint32_t ufeImageSize = 0;
  30 static uint32_t ufeImageUsed = 0;
  31
  32 static uint32_t ufeIP = 0; // in image
  33 static uint32_t ufeSP = 0;
  34 static uint32_t ufeRP = 0;
  35
  36 // the compiler works in two modes
  37 // first mode is "native"
  38 //   only forth variables are allowed, and they're leaving ZX addresses
  39 // second mode is "zx"
  40 //   in this mode, various creation words will create things in ZX memory.
  41 //   note that in interpret mode it is still possible to perform various
  42 //   native calculations, and call native words.
  43 //   but calling native word while compiling ZX code is possible only if it
  44 //   is an immediate one.
  45 enum {
  46   UFE_MODE_NATIVE = 0,
  47   UFE_MODE_ZX = 1, // if STATE is not zero, we're compiling
  48 };
  49 static uint32_t ufeMode = UFE_MODE_NATIVE;
  50
  51 // hack for `NFIND`
  52 static ForthWord *ufeNFindZXWordResult = NULL;
  53 static UForthWord *ufeNFindNativeWordResult = NULL;
  54
  55 // hack for `IMMEDIATE`
  56 // set by `;`
  57 // only one of those can be set! (invariant)
  58 static ForthWord *ufeLastDefinedZXWord = NULL;
  59 static UForthWord *ufeLastDefinedNativeWord = NULL;
  60
  61 #define UFE_DSTACK_SIZE  (8192)
  62 #define UFE_RSTACK_SIZE  (8192)
  63 static uint32_t *ufeDStack = NULL;
  64 static uint32_t *ufeRStack = NULL;
  65
  66 // dynamically allocated text input buffer
  67 // always ends with zero (this is word name too)
  68 // first 512 cells of image is TIB
  69 static uint32_t ufeTIBAreaSize = 512;
  70
  71 static uint32_t ufeTIB = 0; // TIB; 0 means "in TIB area", otherwise in the dictionary
  72 static uint32_t ufeIN = 0; // >IN
  73
  74 static uint32_t ufeBASEaddr; // address of "BASE" variable
  75 static uint32_t ufeSTATEaddr; // address of "STATE" variable
  76 static uint32_t ufeStopVM;
  77
  78 #define UFE_PAD_OFFSET   (2048u)
  79 #define UFE_PAD1_OFFSET  (4096u)
  80
  81 typedef struct UFEInFileStack_t {
  82   FILE *fl;
  83   char *fname;
  84   int fline;
  85   struct UFEInFileStack_t *prev;
  86 } UFEInFileStack;
  87
  88 static UFEInFileStack *ufeFileStack = NULL;
  89
  90 static FILE *ufeInFile = NULL;
  91 static char *ufeInFileName = NULL;
  92 static int ufeInFileLine = 0;
  93 static jmp_buf ufeEOFJP;
  94
  95 static UrLabelInfo *zxlblLastByte = NULL;
  96
  97 static int ufeLastEmitWasCR = 1;
  98 static uint32_t ufeCSP = 0;
  99 static int ufeInCondIf = 0;
 100
 101
 102 // ////////////////////////////////////////////////////////////////////////// //
 103 static void ufeDbgDeinit (void);
 104 static void ufeRunVM (void);
 105
 106 static char *ufeZXWORD (char delim);
 107 // returns dynalloced string
 108 static char *ufePopStrLit (void);
 109
 110 static void ufeDoConditional (unsigned type, int skipword);
 111 static void ufeCompileNativeWord (const char *wname);
 112
 113
 114 // ////////////////////////////////////////////////////////////////////////// //
 115 /* returns malloced string */
 116 static char *ufeCreateIncludeName (const char *fname, int assystem) {
 117   if (!fname || !fname[0]) return strdup("");
 118   //char *incdir = extractFileDir(ufeInFileName);
 119   struct stat st;
 120
 121   if (!assystem && stat(fname, &st) == 0) return strdup(fname);
 122
 123   if (fname[0] == '/') return strdup(fname);
 124
 125   char *incdir = NULL;
 126   if (assystem) {
 127     incdir = (sysIncludeDir && sysIncludeDir[0] ? strprintf("%s/ufe", sysIncludeDir) : strdup("."));
 128   } else {
 129     incdir = extractFileDir(ufeInFileName);
 130   }
 131   char *res = strprintf("%s/%s", incdir, fname);
 132   free(incdir);
 133   //fprintf(stderr, "000: **** <%s> : <%s> : <%s>\n", fname, incdir, res);
 134   if (stat(res, &st) == 0) return res;
 135   free(res);
 136   return strdup(fname);
 137 }
 138
 139
 140 static void ufePushInFile (void) {
 141   UFEInFileStack *stk = malloc(sizeof(UFEInFileStack));
 142   stk->fl = ufeInFile;
 143   stk->fname = ufeInFileName;
 144   stk->fline = ufeInFileLine;
 145   stk->prev = ufeFileStack;
 146   ufeFileStack = stk;
 147   ufeInFile = NULL;
 148   ufeInFileName = NULL;
 149   ufeInFileLine = 0;
 150 }
 151
 152
 153 static void ufePopInFile (void) {
 154   if (ufeInFileName) free(ufeInFileName);
 155   if (ufeInFile) fclose(ufeInFile);
 156   UFEInFileStack *stk = ufeFileStack;
 157   ufeFileStack = stk->prev;
 158   ufeInFile = stk->fl;
 159   ufeInFileName = stk->fname;
 160   ufeInFileLine = stk->fline;
 161   free(stk);
 162 }
 163
 164
 165 // ////////////////////////////////////////////////////////////////////////// //
 166 static void ufeErrorWriteFile (FILE *fo) {
 167   if (ufeInFileName) {
 168     fprintf(fo, "UFE ERROR at file %s, line %d: ", ufeInFileName, ufeInFileLine);
 169   } else {
 170     fprintf(fo, "UFE ERROR somewhere in time: ");
 171   }
 172 }
 173
 174 static void ufeErrorMsgV (const char *fmt, va_list ap) {
 175   ufeErrorWriteFile(stderr);
 176   vfprintf(stderr, fmt, ap);
 177   va_end(ap);
 178   fputc('\n', stderr);
 179   fflush(stderr);
 180 }
 181
 182 static void __attribute__((noreturn)) __attribute__((format(printf, 1, 2))) ufeFatal (const char *fmt, ...) {
 183   va_list ap;
 184   va_start(ap, fmt);
 185   ufeErrorMsgV(fmt, ap);
 186   longjmp(errJP, 666);
 187 }
 188
 189
 190 // ////////////////////////////////////////////////////////////////////////// //
 191 static void ufeDeinit (void) {
 192   ufeInFile = NULL;
 193   if (ufeInFileName) free(ufeInFileName);
 194   ufeInFileName = NULL;
 195   ufeInFileLine = 0;
 196
 197   while (ufeForthDict) {
 198     UForthWord *fw = ufeForthDict;
 199     ufeForthDict = fw->prev;
 200     free(fw->name);
 201     free(fw);
 202   }
 203
 204   free(ufeForthCFAs);
 205   ufeForthCFAs = NULL;
 206   ufeCFAsUsed = 0;
 207
 208   free(ufeImage);
 209   ufeImage = NULL;
 210   ufeImageSize = 0;
 211   ufeImageUsed = 0;
 212
 213   ufeIP = 0;
 214   ufeSP = 0;
 215   ufeRP = 0;
 216   ufeMode = UFE_MODE_NATIVE;
 217
 218   free(ufeDStack);
 219   ufeDStack = NULL;
 220   free(ufeRStack);
 221   ufeRStack = NULL;
 222
 223   ufeTIB = 0;
 224   ufeIN = 0;
 225
 226   zxlblLastByte = NULL;
 227
 228   ufeNFindZXWordResult = NULL;
 229   ufeNFindNativeWordResult = NULL;
 230
 231   ufeLastDefinedZXWord = NULL;
 232   ufeLastDefinedNativeWord = NULL;
 233
 234   ufeLastEmitWasCR = 1;
 235   ufeCSP = 0;
 236   ufeInCondIf = 0;
 237
 238   ufeDbgDeinit();
 239 }
 240
 241
 242 // ////////////////////////////////////////////////////////////////////////// //
 243 // working with the zx image
 244
 245 static __attribute__((unused)) inline uint32_t ufeZXGetU16 (uint32_t addr) {
 246   addr &= 0xffffU;
 247   return getWord(addr);
 248 }
 249
 250 static __attribute__((unused)) inline void ufeZXPutU16 (uint32_t addr, uint32_t v) {
 251   addr &= 0xffffU;
 252   v &= 0xffffU;
 253   putWord(addr, v);
 254 }
 255
 256 static __attribute__((unused)) inline void ufeZXEmitU8 (uint32_t v) {
 257   //if (!zxlblLastByte) ufeFatal("label 'latest_byte' not found");
 258   emitByte(v&0xffU);
 259   if (zxlblLastByte) zxlblLastByte->value = disp;
 260 }
 261
 262 static __attribute__((unused)) inline void ufeZXEmitU16 (uint32_t v) {
 263   //if (!zxlblLastByte) ufeFatal("label 'latest_byte' not found");
 264   emitWord(v&0xffffU);
 265   if (zxlblLastByte) zxlblLastByte->value = disp;
 266 }
 267
 268
 269 // ////////////////////////////////////////////////////////////////////////// //
 270 // working with the image
 271
 272 static __attribute__((unused)) inline void ufeImgEnsure (uint32_t addr) {
 273   if ((addr&UFE_ZX_ADDR_BIT) == 0) {
 274     if (addr+8192u > ufeImageSize) {
 275       const uint32_t osz = ufeImageSize;
 276       while (addr+8192u > ufeImageSize) {
 277         if (ufeImageSize >= 1024u*1024u*8u) ufeFatal("UFE image grown too big");
 278         ufeImageSize += 1024u*1024u;
 279       }
 280       ufeImage = realloc(ufeImage, ufeImageSize*sizeof(ufeImage[0]));
 281       memset(ufeImage+osz, 0, (ufeImageSize-osz)*sizeof(ufeImage[0]));
 282     }
 283   }
 284 }
 285
 286 static __attribute__((unused)) inline void ufeImgPutU8 (uint32_t addr, uint32_t value) {
 287   if (addr&UFE_ZX_ADDR_BIT) {
 288     addr &= UFE_ZX_ADDR_MASK;
 289     putByte(addr, value&0xffU);
 290   } else {
 291     if (addr >= ufeImageSize) ufeFatal("UFE write violation (%u)", addr);
 292     ufeImage[addr] = value;
 293   }
 294 }
 295
 296 static __attribute__((unused)) inline void ufeImgPutU32 (uint32_t addr, uint32_t value) {
 297   if (addr&UFE_ZX_ADDR_BIT) {
 298     addr &= UFE_ZX_ADDR_MASK;
 299     putWord(addr, value&0xffffU);
 300   } else {
 301     if (addr >= ufeImageSize) ufeFatal("UFE write violation (%u)", addr);
 302     ufeImage[addr] = value;
 303   }
 304 }
 305
 306 static __attribute__((unused)) inline void ufeImgEmitU32 (uint32_t value) {
 307   ufeImgEnsure(ufeImageUsed);
 308   ufeImgPutU32(ufeImageUsed, value);
 309   ++ufeImageUsed;
 310 }
 311
 312
 313 static __attribute__((unused)) inline uint32_t ufeImgGetU8 (uint32_t addr) {
 314   if (addr&UFE_ZX_ADDR_BIT) {
 315     addr &= UFE_ZX_ADDR_MASK;
 316     return getByte(addr);
 317   } else {
 318     if (addr >= ufeImageSize) ufeFatal("UFE read violation (%u)", addr);
 319     return ufeImage[addr];
 320   }
 321 }
 322
 323
 324 static __attribute__((unused)) inline uint32_t ufeImgGetU32 (uint32_t addr) {
 325   if (addr&UFE_ZX_ADDR_BIT) {
 326     addr &= UFE_ZX_ADDR_MASK;
 327     return getWord(addr);
 328   } else {
 329     if (addr >= ufeImageSize) ufeFatal("UFE read violation (%u)", addr);
 330     return ufeImage[addr];
 331   }
 332 }
 333
 334
 335 // 32 for native address, 8 for zx address
 336 static __attribute__((unused)) inline uint32_t ufeImgGetCounter (uint32_t addr) {
 337   if (addr&UFE_ZX_ADDR_BIT) {
 338     return ufeImgGetU8(addr);
 339   } else {
 340     return ufeImgGetU32(addr);
 341   }
 342 }
 343
 344
 345 // ////////////////////////////////////////////////////////////////////////// //
 346 static inline int ufeGetState (void) { return (int)ufeImgGetU32(ufeSTATEaddr); }
 347 static inline void ufeSetState (int v) { ufeImgPutU32(ufeSTATEaddr, (uint32_t)v); }
 348
 349
 350 // ////////////////////////////////////////////////////////////////////////// //
 351 static UForthWord *ufeFindWord (const char *wname) {
 352   if (!wname) wname = "";
 353   for (UForthWord *fw = ufeForthDict; fw; fw = fw->prev) {
 354     if (strcasecmp(fw->name, wname) == 0) return fw;
 355   }
 356   return NULL;
 357 }
 358
 359
 360 static inline UForthWord *ufeAlwaysWord (const char *wname) {
 361   UForthWord *fw = ufeFindWord(wname);
 362   if (!fw) ufeFatal("UFE word `%s` not found", (wname[0] ? wname : "~"));
 363   return fw;
 364 }
 365
 366
 367 static UForthWord *ufeNFind (uint32_t addr, uint32_t count) {
 368   char wbuf[128];
 369   if (count > 0) {
 370     if (count > 127) return NULL; // too long
 371     // copy
 372     for (uint32_t n = 0; n < count; ++n) {
 373       const uint8_t ch = ufeImgGetU8(addr+n)&0xffU;
 374       if (!ch) return NULL; // word name cannot contain 0 byte
 375       wbuf[n] = toUpper((char)(ch));
 376     }
 377   }
 378   wbuf[count] = 0;
 379   // ignore words with no CFA: those are not finished yet
 380   for (UForthWord *fw = ufeForthDict; fw; fw = fw->prev) {
 381     if (fw->cfa && strcasecmp(fw->name, wbuf) == 0) return fw;
 382   }
 383   return NULL;
 384 }
 385
 386
 387 static ForthWord *ufeNFindZX (uint32_t addr, uint32_t count) {
 388   char wbuf[32];
 389   if (count > 0) {
 390     if (count > 31) return NULL; // too long
 391     // copy
 392     for (uint32_t n = 0; n < count; ++n) {
 393       const uint8_t ch = ufeImgGetU8(addr+n)&0xffU;
 394       if (!ch) return NULL; // word name cannot contain 0 byte
 395       wbuf[n] = toUpper((char)(ch));
 396     }
 397   }
 398   wbuf[count] = 0;
 399   // ignore last word if we're in compiling mode (it is not finished yet)
 400   return findForthWordEx(wbuf, (ufeMode == UFE_MODE_ZX && ufeGetState()));
 401 }
 402
 403
 404 // ////////////////////////////////////////////////////////////////////////// //
 405 // load next file line into TIV
 406 // return zero on success, -1 on EOF, -2 on error
 407 static char ufeCurrFileLine[520];
 408
 409 static int ufeLoadNextLine (void) {
 410   ufeTIB = 0;
 411   ufeIN = 0;
 412   if (!ufeInFile) return -2;
 413   if (!fgets(ufeCurrFileLine, 510, ufeInFile)) {
 414     if (!ufeFileStack) return -1;
 415     ufePopInFile();
 416     return ufeLoadNextLine();
 417   }
 418   ++ufeInFileLine;
 419   unsigned f = 0;
 420   do {
 421     ufeImgEnsure(f);
 422     ufeImgPutU32(f, (uint8_t)(ufeCurrFileLine[f]&0xff));
 423   } while (ufeCurrFileLine[f++]);
 424   //fprintf(stderr, "---\n%s", ufeCurrFileLine);
 425   return 0;
 426 }
 427
 428
 429 // ////////////////////////////////////////////////////////////////////////// //
 430 // working with the stacks
 431 static __attribute__((unused)) inline void ufePush (uint32_t v) { if (ufeSP >= UFE_DSTACK_SIZE) ufeFatal("UFE data stack overflow"); ufeDStack[ufeSP++] = v; }
 432 static __attribute__((unused)) inline void ufeDrop (void) { if (ufeSP == 0) ufeFatal("UFE data stack underflow"); --ufeSP; }
 433 static __attribute__((unused)) inline uint32_t ufePop (void) { if (ufeSP == 0) ufeFatal("UFE data stack underflow"); return ufeDStack[--ufeSP]; }
 434 static __attribute__((unused)) inline uint32_t ufePeek (void) { if (ufeSP == 0) ufeFatal("UFE data stack underflow"); return ufeDStack[ufeSP-1u]; }
 435 static __attribute__((unused)) inline void ufeDup (void) { if (ufeSP == 0) ufeFatal("UFE data stack underflow"); ufePush(ufeDStack[ufeSP-1u]); }
 436 static __attribute__((unused)) inline void ufeOver (void) { if (ufeSP < 2u) ufeFatal("UFE data stack underflow"); ufePush(ufeDStack[ufeSP-2u]); }
 437 static __attribute__((unused)) inline void ufeSwap (void) { if (ufeSP < 2u) ufeFatal("UFE data stack underflow"); const uint32_t t = ufeDStack[ufeSP-1u]; ufeDStack[ufeSP-1u] = ufeDStack[ufeSP-2u]; ufeDStack[ufeSP-2u] = t; }
 438 static __attribute__((unused)) inline void ufeRot (void) { if (ufeSP < 3u) ufeFatal("UFE data stack underflow"); const uint32_t t = ufeDStack[ufeSP-3u]; ufeDStack[ufeSP-3u] = ufeDStack[ufeSP-2u]; ufeDStack[ufeSP-2u] = ufeDStack[ufeSP-1u]; ufeDStack[ufeSP-1u] = t; }
 439 static __attribute__((unused)) inline void ufeNRot (void) { if (ufeSP < 3u) ufeFatal("UFE data stack underflow"); const uint32_t t = ufeDStack[ufeSP-1u]; ufeDStack[ufeSP-1u] = ufeDStack[ufeSP-2u]; ufeDStack[ufeSP-2u] = ufeDStack[ufeSP-3u]; ufeDStack[ufeSP-3u] = t; }
 440
 441 static __attribute__((unused)) inline void ufe2Dup (void) { ufeOver(); ufeOver(); }
 442 static __attribute__((unused)) inline void ufe2Drop (void) { ufeDrop(); ufeDrop(); }
 443 static __attribute__((unused)) inline void ufe2Over (void) { if (ufeSP < 4u) ufeFatal("UFE data stack underflow"); const uint32_t n0 = ufeDStack[ufeSP-4u]; const uint32_t n1 = ufeDStack[ufeSP-3u]; ufePush(n0); ufePush(n1); }
 444 static __attribute__((unused)) inline void ufe2Swap (void) { if (ufeSP < 4u) ufeFatal("UFE data stack underflow"); const uint32_t n0 = ufeDStack[ufeSP-4u]; const uint32_t n1 = ufeDStack[ufeSP-3u]; ufeDStack[ufeSP-4u] = ufeDStack[ufeSP-2u]; ufeDStack[ufeSP-3u] = ufeDStack[ufeSP-1u]; ufeDStack[ufeSP-2u] = n0; ufeDStack[ufeSP-1u] = n1; }
 445
 446 static __attribute__((unused)) inline void ufeRPush (uint32_t v) { if (ufeRP >= UFE_RSTACK_SIZE) ufeFatal("UFE return stack overflow"); ufeRStack[ufeRP++] = v; }
 447 static __attribute__((unused)) inline void ufeRDrop (void) { if (ufeRP == 0) ufeFatal("UFE return stack underflow"); --ufeRP; }
 448 static __attribute__((unused)) inline uint32_t ufeRPop (void) { if (ufeRP == 0) ufeFatal("UFE return stack underflow"); return ufeRStack[--ufeRP]; }
 449 static __attribute__((unused)) inline uint32_t ufeRPeek (void) { if (ufeRP == 0) ufeFatal("UFE return stack underflow"); return ufeRStack[ufeRP-1u]; }
 450 static __attribute__((unused)) inline void ufeRDup (void) { if (ufeRP == 0) ufeFatal("UFE return stack underflow"); ufePush(ufeRStack[ufeRP-1u]); }
 451 static __attribute__((unused)) inline void ufeROver (void) { if (ufeRP < 2u) ufeFatal("UFE return stack underflow"); ufePush(ufeRStack[ufeRP-2u]); }
 452 static __attribute__((unused)) inline void ufeRSwap (void) { if (ufeRP < 2u) ufeFatal("UFE return stack underflow"); const uint32_t t = ufeRStack[ufeRP-1u]; ufeRStack[ufeRP-1u] = ufeRStack[ufeRP-2u]; ufeRStack[ufeRP-2u] = t; }
 453 static __attribute__((unused)) inline void ufeRRot (void) { if (ufeRP < 3u) ufeFatal("UFE return stack underflow"); const uint32_t t = ufeRStack[ufeRP-3u]; ufeRStack[ufeRP-3u] = ufeRStack[ufeRP-2u]; ufeRStack[ufeRP-2u] = ufeRStack[ufeRP-1u]; ufeRStack[ufeRP-1u] = t; }
 454 static __attribute__((unused)) inline void ufeRNRot (void) { if (ufeRP < 3u) ufeFatal("UFE return stack underflow"); const uint32_t t = ufeRStack[ufeRP-1u]; ufeRStack[ufeRP-1u] = ufeRStack[ufeRP-2u]; ufeRStack[ufeRP-2u] = ufeRStack[ufeRP-3u]; ufeRStack[ufeRP-3u] = t; }
 455
 456
 457 // ////////////////////////////////////////////////////////////////////////// //
 458 #define UFWORD(name_) \
 459 static void ufeWord_##name_ (UForthWord *self)
 460
 461 #define UFCALL(name_) ufeWord_##name_(NULL)
 462
 463
 464 static void ufeDoForth (UForthWord *self) {
 465     //fprintf(stderr, "ufeDoForth: <%s>; ip=%u; pfa=%u; HERE=%u\n", self->name, ufeIP, self->pfa, ufeImageUsed);
 466   ufeRPush(ufeIP);
 467   ufeIP = self->pfa;
 468 }
 469
 470
 471 // ////////////////////////////////////////////////////////////////////////// //
 472 // SP0!
 473 UFWORD(SP0_PUT) {
 474   ufeSP = 0;
 475 }
 476
 477 // RP0!
 478 UFWORD(RP0_PUT) {
 479   ufeRP = 0;
 480 }
 481
 482 // BASE
 483 UFWORD(BASE) {
 484   ufePush(ufeBASEaddr);
 485 }
 486
 487 // STATE
 488 UFWORD(STATE) {
 489   ufePush(ufeSTATEaddr);
 490 }
 491
 492 // @
 493 UFWORD(PEEK) {
 494   const uint32_t addr = ufePop();
 495   ufePush(ufeImgGetU32(addr));
 496 }
 497
 498 // C@
 499 UFWORD(CPEEK) {
 500   const uint32_t addr = ufePop();
 501   ufePush(ufeImgGetU8(addr)&0xffU);
 502 }
 503
 504 // W@
 505 UFWORD(WPEEK) {
 506   const uint32_t addr = ufePop();
 507   ufePush(ufeImgGetU32(addr)&0xffffU);
 508 }
 509
 510 // !
 511 // ( val addr -- )
 512 UFWORD(POKE) {
 513   const uint32_t addr = ufePop();
 514   const uint32_t val = ufePop();
 515   ufeImgPutU32(addr, val);
 516 }
 517
 518 // C!
 519 // ( val addr -- )
 520 UFWORD(CPOKE) {
 521   const uint32_t addr = ufePop();
 522   const uint32_t val = ufePop();
 523   ufeImgPutU8(addr, val&0xffU);
 524 }
 525
 526 // W!
 527 // ( val addr -- )
 528 UFWORD(WPOKE) {
 529   const uint32_t addr = ufePop();
 530   const uint32_t val = ufePop();
 531   ufeImgPutU32(addr, val&0xffffU);
 532 }
 533
 534 // C,
 535 // ( val -- )
 536 // puts byte to native/zx dictionary, according to the current mode
 537 UFWORD(CCOMMA) {
 538   const uint32_t val = ufePop()&0xffU;
 539   if (ufeMode == UFE_MODE_ZX) {
 540     ufeZXEmitU8(val);
 541   } else {
 542     ufeImgEmitU32(val);
 543   }
 544 }
 545
 546 // ,
 547 // ( val -- )
 548 // puts uint/word to native/zx dictionary, according to the current mode
 549 UFWORD(COMMA) {
 550   const uint32_t val = ufePop();
 551   if (ufeMode == UFE_MODE_ZX) {
 552     ufeZXEmitU16(val&0xffffU);
 553   } else {
 554     ufeImgEmitU32(val);
 555   }
 556 }
 557
 558 // ZXADDR?
 559 // ( addr -- flag )
 560 // is address a ZX Spectrum mmaped address?
 561 UFWORD(ZXADDRQ) {
 562   const uint32_t addr = ufePop();
 563   ufePush(addr&UFE_ZX_ADDR_BIT ? 1u : 0u);
 564 }
 565
 566 // (TOZX)
 567 // ( addr -- addr )
 568 // convert address to ZX Spectrum mmaped address
 569 UFWORD(TOZX) {
 570   const uint32_t addr = ufePop();
 571   ufePush((addr&UFE_ZX_ADDR_MASK)|UFE_ZX_ADDR_BIT);
 572 }
 573
 574 // TOZX
 575 // ( addr -- addr )
 576 // convert address to ZX Spectrum mmaped address
 577 UFWORD(TOZX_IMM) {
 578   if (ufeMode == UFE_MODE_NATIVE) {
 579     if (ufeGetState()) {
 580       ufeCompileNativeWord("(TOZX)");
 581     } else {
 582       UFCALL(TOZX);
 583     }
 584   }
 585 }
 586
 587 // (FROMZX)
 588 // ( addr -- addr )
 589 // convert address from ZX Spectrum mmaped address
 590 UFWORD(FROMZX) {
 591   const uint32_t addr = ufePop();
 592   ufePush(addr&UFE_ZX_ADDR_MASK);
 593 }
 594
 595 // FROMZX
 596 // ( addr -- addr )
 597 // convert address from ZX Spectrum mmaped address
 598 UFWORD(FROMZX_IMM) {
 599   if (ufeMode == UFE_MODE_NATIVE) {
 600     if (ufeGetState()) {
 601       ufeCompileNativeWord("(FROMZX)");
 602     } else {
 603       UFCALL(FROMZX);
 604     }
 605   }
 606 }
 607
 608 // LIT ( -- n )
 609 UFWORD(LIT) {
 610   const uint32_t v = ufeImgGetU32(ufeIP++);
 611   ufePush(v);
 612 }
 613
 614 // BRANCH ( -- )
 615 UFWORD(BRANCH) {
 616   ufeIP = ufeImgGetU32(ufeIP);
 617 }
 618
 619 // TBRANCH ( flag )
 620 UFWORD(TBRANCH) {
 621   if (ufePop()) {
 622     ufeIP = ufeImgGetU32(ufeIP);
 623   } else {
 624     ++ufeIP;
 625   }
 626 }
 627
 628 // FBRANCH ( flag )
 629 UFWORD(FBRANCH) {
 630   if (!ufePop()) {
 631     ufeIP = ufeImgGetU32(ufeIP);
 632   } else {
 633     ++ufeIP;
 634   }
 635 }
 636
 637 // (DO)
 638 // ( limit start -- | limit counter )
 639 // loops from start to limit-1
 640 UFWORD(DO_PAREN) {
 641   ufeSwap();
 642   ufeRPush(ufePop());
 643   ufeRPush(ufePop());
 644 }
 645
 646 // ( -- | limit counter )
 647 static void ufePLoopCommon (int32_t add) {
 648   const int32_t n = (int32_t)ufeRPop();
 649   const int32_t lim = (int32_t)ufeRPeek();
 650   const int32_t newn = n+add;
 651   // this is how dsForth does it
 652   if ((newn < 0 ? lim-newn : newn-lim) < 0) {
 653     ufeRPush(newn);
 654     ufeIP = ufeImgGetU32(ufeIP);
 655   } else {
 656     ufeRDrop();
 657     ++ufeIP;
 658   }
 659 }
 660
 661 // (LOOP)
 662 // ( -- | limit counter )
 663 // loops from start to limit-1
 664 UFWORD(LOOP_PAREN) {
 665   ufePLoopCommon(1);
 666 }
 667
 668 // (+LOOP)
 669 // ( n -- | limit counter )
 670 // loops from start to limit-1
 671 UFWORD(PLOOP_PAREN) {
 672   const int32_t add = (int32_t)ufePop();
 673   ufePLoopCommon(add);
 674 }
 675
 676 /*
 677 UFWORD(LEAVE) {
 678   ufeRDrop();
 679   ufeRDrop();
 680   const int32_t add = (int32_t)ufePop();
 681   int32_t n = (int32_t)ufeRPop();
 682   const int32_t lim = (int32_t)ufeRPeek();
 683   if ((n < lim && n+add >= lim) || (n > lim && n+add <= lim)) {
 684     ufeRDrop();
 685     ++ufeIP;
 686   } else {
 687     ufeRPush(n+add);
 688     ufeIP = ufeImgGetU32(ufeIP);
 689   }
 690 }
 691 */
 692
 693 // I
 694 // ( counter -- | limit counter )
 695 UFWORD(I) {
 696   ufePush(ufeRPeek());
 697 }
 698
 699 // I'
 700 // ( limit -- | limit counter )
 701 UFWORD(ITICK) {
 702   const uint32_t c = ufeRPop();
 703   ufePush(ufeRPeek());
 704   ufeRPush(c);
 705 }
 706
 707 // J
 708 UFWORD(J) {
 709   const uint32_t c0 = ufeRPop();
 710   const uint32_t c1 = ufeRPop();
 711   ufePush(ufeRPeek());
 712   ufeRPush(c1);
 713   ufeRPush(c0);
 714 }
 715
 716 // J'
 717 UFWORD(JTICK) {
 718   const uint32_t c0 = ufeRPop();
 719   const uint32_t c1 = ufeRPop();
 720   const uint32_t c2 = ufeRPop();
 721   ufePush(ufeRPeek());
 722   ufeRPush(c2);
 723   ufeRPush(c1);
 724   ufeRPush(c0);
 725 }
 726
 727 // EXECUTE ( cfa )
 728 UFWORD(EXECUTE) {
 729   const uint32_t cfa = ufePop();
 730   if (cfa >= ufeCFAsUsed) ufeFatal("calling invalid UFE word with EXECUTE (%u)", cfa);
 731   //ufeForthCFAs[cfa]->cfa(ufeForthCFAs[cfa]);
 732   UForthWord *fw = ufeForthCFAs[cfa];
 733   //fprintf(stderr, "[E:%s] ", fw->name);
 734   if (fw->cfa == &ufeDoForth) {
 735     ufeRPush(ufeIP);
 736     ufeRPush(0xbec0ffeeU);
 737     ufeIP = fw->pfa;
 738     ufeRunVM();
 739   } else {
 740     fw->cfa(fw);
 741   }
 742 }
 743
 744 // DUP ( n -- n n )
 745 UFWORD(DUP) { ufeDup(); }
 746 // ?DUP ( n -- n n ) | ( 0 -- 0 )
 747 UFWORD(QDUP) { if (ufePeek()) ufeDup(); }
 748 // 2DUP ( n0 n1 -- n0 n1 n0 n1 ) | ( 0 -- 0 )
 749 UFWORD(DDUP) { ufe2Dup(); }
 750 // DROP ( n -- )
 751 UFWORD(DROP) { ufeDrop(); }
 752 // 2DROP ( n -- )
 753 UFWORD(DDROP) { ufe2Drop(); }
 754 // SWAP ( n0 n1 -- n1 n0 )
 755 UFWORD(SWAP) { ufeSwap(); }
 756 // 2SWAP ( n0 n1 -- n1 n0 )
 757 UFWORD(DSWAP) { ufe2Swap(); }
 758 // OVER ( n0 n1 -- n0 n1 n0 )
 759 UFWORD(OVER) { ufeOver(); }
 760 // 2OVER ( n0 n1 -- n0 n1 n0 )
 761 UFWORD(DOVER) { ufe2Over(); }
 762 // ROT ( n0 n1 n2 -- n1 n2 n0 )
 763 UFWORD(ROT) { ufeRot(); }
 764 // NROT ( n0 n1 n2 -- n2 n0 n1 )
 765 UFWORD(NROT) { ufeNRot(); }
 766
 767 // RDUP ( n -- n n )
 768 UFWORD(RDUP) { ufeRDup(); }
 769 // RDROP ( n -- )
 770 UFWORD(RDROP) { ufeRDrop(); }
 771 // RSWAP ( n0 n1 -- n1 n0 )
 772 UFWORD(RSWAP) { ufeRSwap(); }
 773 // ROVER ( n0 n1 -- n0 n1 n0 )
 774 UFWORD(ROVER) { ufeROver(); }
 775 // RROT ( n0 n1 n2 -- n1 n2 n0 )
 776 UFWORD(RROT) { ufeRRot(); }
 777 // RNROT ( n0 n1 n2 -- n2 n0 n1 )
 778 UFWORD(RNROT) { ufeRNRot(); }
 779
 780 // >R ( n -- | n)
 781 UFWORD(DTOR) { ufeRPush(ufePop()); }
 782 // R> ( -- n | n-removed )
 783 UFWORD(RTOD) { ufePush(ufeRPop()); }
 784 // R@ ( -- n | n-removed )
 785 UFWORD(RPEEK) { ufePush(ufeRPeek()); }
 786
 787
 788 // CMOVE>
 789 // ( src dest count -- )
 790 UFWORD(CMOVE_FWD) {
 791   uint32_t count = ufePop();
 792   uint32_t dest = ufePop();
 793   uint32_t src = ufePop();
 794   if (count == 0 || count > 0x1fffffffU || dest == src) return;
 795   dest += count;
 796   src += count;
 797   while (count--) {
 798     --dest;
 799     --src;
 800     const uint32_t v = (src&UFE_ZX_ADDR_BIT ? getByte(src&UFE_ZX_ADDR_MASK) : ufeImgGetU32(src));
 801     if (dest&UFE_ZX_ADDR_BIT) putByte(dest&UFE_ZX_ADDR_MASK, (uint8_t)v&0xffU); else ufeImgPutU32(dest, v);
 802   }
 803 }
 804
 805 // CMOVE
 806 // ( src dest count -- )
 807 UFWORD(CMOVE_BACK) {
 808   uint32_t count = ufePop();
 809   uint32_t dest = ufePop();
 810   uint32_t src = ufePop();
 811   if (count == 0 || count > 0x1fffffffU || dest == src) return;
 812   while (count--) {
 813     const uint32_t v = (src&UFE_ZX_ADDR_BIT ? getByte(src&UFE_ZX_ADDR_MASK) : ufeImgGetU32(src));
 814     if (dest&UFE_ZX_ADDR_BIT) putByte(dest&UFE_ZX_ADDR_MASK, (uint8_t)v&0xffU); else ufeImgPutU32(dest, v);
 815     ++dest;
 816     ++src;
 817   }
 818 }
 819
 820 // MOVE
 821 // ( src dest count -- )
 822 UFWORD(MOVE) {
 823   uint32_t count = ufePop();
 824   uint32_t dest = ufePop();
 825   uint32_t src = ufePop();
 826   ufePush(src);
 827   ufePush(dest);
 828   ufePush(count);
 829   if (dest < src) UFCALL(CMOVE_BACK); else UFCALL(CMOVE_FWD);
 830 }
 831
 832
 833 // STR=
 834 // ( addr1 count1 addr2 count2 -- flag )
 835 UFWORD(STREQU) {
 836   uint32_t count2 = ufePop();
 837   uint32_t addr2 = ufePop();
 838   uint32_t count1 = ufePop();
 839   uint32_t addr1 = ufePop();
 840   if (count2 != count1) { ufePush(0); return; }
 841   while (count1--) {
 842     uint8_t c0 = ufeImgGetU8(addr1++);
 843     uint8_t c1 = ufeImgGetU8(addr2++);
 844     if (c0 != c1) { ufePush(0); return; }
 845   }
 846   ufePush(1);
 847 }
 848
 849 // STR=CI
 850 // ( addr1 count1 addr2 count2 -- flag )
 851 UFWORD(STREQUCI) {
 852   uint32_t count2 = ufePop();
 853   uint32_t addr2 = ufePop();
 854   uint32_t count1 = ufePop();
 855   uint32_t addr1 = ufePop();
 856   if (count2 != count1) { ufePush(0); return; }
 857   while (count1--) {
 858     uint8_t c0 = (uint8_t)(toUpper((char)ufeImgGetU8(addr1++)));
 859     uint8_t c1 = (uint8_t)(toUpper((char)ufeImgGetU8(addr2++)));
 860     if (c0 != c1) { ufePush(0); return; }
 861   }
 862   ufePush(1);
 863 }
 864
 865
 866 // ////////////////////////////////////////////////////////////////////////// //
 867 // text input buffer parsing
 868
 869 static inline char ufePeekInChar (void) {
 870   uint32_t taddr = ufeTIB;
 871   if (taddr < ufeImageSize && taddr+ufeIN < ufeImageSize) {
 872     return ufeImgGetU32(taddr+ufeIN)&0xffU;
 873   }
 874   return 0;
 875 }
 876
 877
 878 static inline char ufeGetInChar (void) {
 879   const char ch = ufePeekInChar();
 880   if (ch) ++ufeIN;
 881   return ch;
 882 }
 883
 884
 885 // parse word from TIB, put it to HERE as counted string
 886 // always puts trailing zero to the buffer
 887 // WORD ( delim -- addr )
 888 UFWORD(WORD) {
 889   const uint8_t delim = ufePop()&0xffU;
 890   // put counter (to be fixed later)
 891   ufeImgEnsure(ufeImageUsed);
 892   ufeImgPutU32(ufeImageUsed, 0);
 893   // check TIB address
 894   uint32_t taddr = ufeTIB;
 895   if (taddr < ufeImageSize && taddr+ufeIN < ufeImageSize) {
 896     // parse
 897     uint32_t daddr = ufeImageUsed+1u;
 898     uint32_t count = 0;
 899     // skip leading blanks
 900     if (delim == 32) {
 901       for (;;) {
 902         uint8_t ch = ufeImgGetU32(taddr+ufeIN)&0xffU;
 903         if (!ch) break; // no more
 904         if (ch != delim) break;
 905         ++ufeIN;
 906       }
 907     }
 908     for (;;) {
 909       uint8_t ch = ufeImgGetU32(taddr+ufeIN)&0xffU;
 910       if (!ch) break; // no more
 911       //HACK!
 912       if (delim == 32 && ch <= 32) ch = 32;
 913       if ((delim == 13 || delim == 10) && (ch == 13 || ch == 10)) ch = delim;
 914       if (ch == delim) { ++ufeIN; break; } // skip delimiter
 915       ufeImgEnsure(daddr);
 916       ufeImgPutU32(daddr, ch);
 917       ++daddr;
 918       ++ufeIN;
 919       ++count;
 920     }
 921     // fix length
 922     ufeImgPutU32(ufeImageUsed, count);
 923     // put trailing zero
 924     ufeImgEnsure(ufeImageUsed+1u+count);
 925     ufeImgPutU32(ufeImageUsed+1u+count, 0);
 926   } else {
 927     // put trailing zero
 928     ufeImgEnsure(ufeImageUsed+1u);
 929     ufeImgPutU32(ufeImageUsed+1u, 0);
 930   }
 931   ufePush(ufeImageUsed);
 932 }
 933
 934
 935 // ////////////////////////////////////////////////////////////////////////// //
 936 // strings
 937
 938 // COUNT
 939 // ( n -- n+1 [n] )
 940 UFWORD(COUNT) {
 941   uint32_t addr = ufePop();
 942   uint32_t len = ufeImgGetCounter(addr);
 943   ufePush(addr+1);
 944   ufePush(len);
 945 }
 946
 947 // EMIT
 948 // ( n -- )
 949 UFWORD(EMIT) {
 950   uint32_t ch = ufePop()&0xffU;
 951   if (ch < 32 || ch == 127) {
 952     if (ch != 10 && ch != 13 && ch != 9) { printf("?"); return; }
 953   }
 954   ufeLastEmitWasCR = (ch == 10);
 955   if (ch == 10) printf("\n"); else printf("%c", (char)ch);
 956 }
 957
 958 // XEMIT
 959 // ( n -- )
 960 UFWORD(XEMIT) {
 961   uint32_t ch = ufePop()&0xffU;
 962   printf("%c", (ch < 32 || ch == 127 ? '?' : (char)ch));
 963   ufeLastEmitWasCR = 0;
 964 }
 965
 966 // CR
 967 // ( -- )
 968 UFWORD(CR) {
 969   printf("\n");
 970   ufeLastEmitWasCR = 1;
 971 }
 972
 973 // SPACE
 974 // ( -- )
 975 UFWORD(SPACE) {
 976   printf(" ");
 977   ufeLastEmitWasCR = 0;
 978 }
 979
 980 // SPACES
 981 // ( n -- )
 982 UFWORD(SPACES) {
 983   int32_t n = (int32_t)ufePop();
 984   while (n-- > 0) printf(" ");
 985   ufeLastEmitWasCR = 0;
 986 }
 987
 988 // ENDCR
 989 // ( -- )
 990 UFWORD(ENDCR) {
 991   if (!ufeLastEmitWasCR) {
 992     printf("\n");
 993     ufeLastEmitWasCR = 1;
 994   }
 995 }
 996
 997 // TYPE
 998 // ( addr count -- )
 999 UFWORD(TYPE) {
1000   int32_t count = (int32_t)ufePop();
1001   uint32_t addr = ufePop();
1002   while (count-- > 0) {
1003     const uint8_t ch = ufeImgGetU8(addr++)&0xffU;
1004     ufePush(ch);
1005     UFCALL(EMIT);
1006   }
1007 }
1008
1009 // XTYPE
1010 // ( addr count -- )
1011 UFWORD(XTYPE) {
1012   int32_t count = (int32_t)ufePop();
1013   uint32_t addr = ufePop();
1014   while (count-- > 0) {
1015     const uint8_t ch = ufeImgGetU8(addr++)&0xffU;
1016     ufePush(ch);
1017     UFCALL(XEMIT);
1018   }
1019 }
1020
1021 // (")
1022 UFWORD(STRQ_PAREN) {
1023   const uint32_t count = ufeImgGetU32(ufeIP++);
1024   ufePush(ufeIP);
1025   if (count > 0x7fffffffU) ufePush(0); else ufePush(count);
1026   ufeIP += count;
1027 }
1028
1029 // (.")
1030 UFWORD(STRDOTQ_PAREN) {
1031   const uint32_t count = ufeImgGetU32(ufeIP++);
1032   ufePush(ufeIP);
1033   ufePush(count);
1034   ufeIP += count;
1035   UFCALL(TYPE);
1036 }
1037
1038
1039 // ////////////////////////////////////////////////////////////////////////// //
1040 // number printing
1041
1042 static char *ufePrintNumber (uint32_t v, int sign) {
1043   static char buf[64];
1044   size_t bufpos = sizeof(buf);
1045   buf[--bufpos] = 0;
1046   int64_t n = (sign ? (int64_t)(int32_t)v : (int64_t)(uint32_t)v);
1047   const char sch = (n < 0 ? '-' : 0);
1048   if (n < 0) n = -n;
1049   int base = ufeImgGetU32(ufeBASEaddr);
1050   if (base < 2 || base > 36) { snprintf(buf, sizeof(buf), "%s", "invalid-base"); return buf; }
1051   do {
1052     if (bufpos == 0) ufeFatal("number too long");
1053     char ch = '0'+(char)(n%base);
1054     if (ch > '9') ch += 7;
1055     buf[--bufpos] = ch;
1056   } while ((n /= base) != 0);
1057   if (bufpos != 0 && sch) buf[--bufpos] = sch;
1058   return buf+bufpos;
1059 }
1060
1061
1062 // .
1063 // ( n -- )
1064 UFWORD(DOT) {
1065   int32_t v = (int32_t)ufePop();
1066   printf("%s ", ufePrintNumber(v, 1));
1067 }
1068
1069 // U.
1070 // ( n -- )
1071 UFWORD(UDOT) {
1072   uint32_t v = ufePop();
1073   printf("%s ", ufePrintNumber(v, 0));
1074 }
1075
1076 // .R
1077 // ( n width -- )
1078 UFWORD(DOTR) {
1079   int32_t wdt = (int32_t)ufePop();
1080   int32_t v = (int32_t)ufePop();
1081   char *s = ufePrintNumber(v, 1);
1082   int32_t slen = (int32_t)strlen(s);
1083   while (slen < wdt) { printf(" "); ++slen; }
1084   printf("%s", s);
1085 }
1086
1087 // U.R
1088 // ( n width -- )
1089 UFWORD(UDOTR) {
1090   int32_t wdt = (int32_t)ufePop();
1091   int32_t v = (int32_t)ufePop();
1092   char *s = ufePrintNumber(v, 0);
1093   int32_t slen = (int32_t)strlen(s);
1094   while (slen < wdt) { printf(" "); ++slen; }
1095   printf("%s", s);
1096 }
1097
1098
1099 // ////////////////////////////////////////////////////////////////////////// //
1100 // simple math
1101
1102 // NEGATE
1103 // ( a -- -a )
1104 UFWORD(NEGATE) {
1105   const uint32_t a = ufePop();
1106   ufePush((~a)+1u);
1107 }
1108
1109 // +
1110 // ( a b -- a+b )
1111 UFWORD(PLUS) {
1112   const uint32_t b = ufePop();
1113   const uint32_t a = ufePop();
1114   ufePush(a+b);
1115 }
1116
1117 // -
1118 // ( a b -- a-b )
1119 UFWORD(MINUS) {
1120   const uint32_t b = ufePop();
1121   const uint32_t a = ufePop();
1122   ufePush(a-b);
1123 }
1124
1125 // *
1126 // ( a b -- a*b )
1127 UFWORD(MUL) {
1128   const int32_t b = (int32_t)ufePop();
1129   const int32_t a = (int32_t)ufePop();
1130   ufePush((uint32_t)(a*b));
1131 }
1132
1133 // U*
1134 // ( a b -- a*b )
1135 UFWORD(UMUL) {
1136   const uint32_t b = ufePop();
1137   const uint32_t a = ufePop();
1138   ufePush((uint32_t)(a*b));
1139 }
1140
1141 // /
1142 // ( a b -- a/b )
1143 UFWORD(DIV) {
1144   const int32_t b = (int32_t)ufePop();
1145   const int32_t a = (int32_t)ufePop();
1146   if (b == 0) ufeFatal("UFE division by zero");
1147   ufePush((uint32_t)(a/b));
1148 }
1149
1150 // U*
1151 // ( a b -- a/b )
1152 UFWORD(UDIV) {
1153   const uint32_t b = ufePop();
1154   const uint32_t a = ufePop();
1155   if (b == 0) ufeFatal("UFE division by zero");
1156   ufePush((uint32_t)(a/b));
1157 }
1158
1159 // MOD
1160 // ( a b -- a%b )
1161 UFWORD(MOD) {
1162   const int32_t b = (int32_t)ufePop();
1163   const int32_t a = (int32_t)ufePop();
1164   if (b == 0) ufeFatal("UFE division by zero");
1165   ufePush((uint32_t)(a%b));
1166 }
1167
1168 // UMOD
1169 // ( a b -- a%b )
1170 UFWORD(UMOD) {
1171   const uint32_t b = ufePop();
1172   const uint32_t a = ufePop();
1173   if (b == 0) ufeFatal("UFE division by zero");
1174   ufePush((uint32_t)(a%b));
1175 }
1176
1177 // /MOD
1178 // ( a b -- a/b, a%b )
1179 UFWORD(DIVMOD) {
1180   const int32_t b = (int32_t)ufePop();
1181   const int32_t a = (int32_t)ufePop();
1182   if (b == 0) ufeFatal("UFE division by zero");
1183   ufePush((uint32_t)(a/b));
1184   ufePush((uint32_t)(a%b));
1185 }
1186
1187 // U/MOD
1188 // ( a b -- a/b, a%b )
1189 UFWORD(UDIVMOD) {
1190   const uint32_t b = ufePop();
1191   const uint32_t a = ufePop();
1192   if (b == 0) ufeFatal("UFE division by zero");
1193   ufePush((uint32_t)(a/b));
1194   ufePush((uint32_t)(a%b));
1195 }
1196
1197
1198 // ////////////////////////////////////////////////////////////////////////// //
1199 // simple logic
1200
1201 // <
1202 // ( a b -- a<b )
1203 UFWORD(LESS) {
1204   const int32_t b = (int32_t)ufePop();
1205   const int32_t a = (int32_t)ufePop();
1206   ufePush(a < b ? 1u : 0u);
1207 }
1208
1209 // >
1210 // ( a b -- a>b )
1211 UFWORD(GREAT) {
1212   const int32_t b = (int32_t)ufePop();
1213   const int32_t a = (int32_t)ufePop();
1214   ufePush(a > b ? 1u : 0u);
1215 }
1216
1217 // <=
1218 // ( a b -- a<=b )
1219 UFWORD(LESSEQU) {
1220   const int32_t b = (int32_t)ufePop();
1221   const int32_t a = (int32_t)ufePop();
1222   ufePush(a <= b ? 1u : 0u);
1223 }
1224
1225 // >=
1226 // ( a b -- a>=b )
1227 UFWORD(GREATEQU) {
1228   const int32_t b = (int32_t)ufePop();
1229   const int32_t a = (int32_t)ufePop();
1230   ufePush(a >= b ? 1u : 0u);
1231 }
1232
1233 // U<
1234 // ( a b -- a<b )
1235 UFWORD(ULESS) {
1236   const uint32_t b = ufePop();
1237   const uint32_t a = ufePop();
1238   ufePush(a < b ? 1u : 0u);
1239 }
1240
1241 // U>
1242 // ( a b -- a>b )
1243 UFWORD(UGREAT) {
1244   const uint32_t b = ufePop();
1245   const uint32_t a = ufePop();
1246   ufePush(a > b ? 1u : 0u);
1247 }
1248
1249 // U<=
1250 // ( a b -- a<=b )
1251 UFWORD(ULESSEQU) {
1252   const uint32_t b = ufePop();
1253   const uint32_t a = ufePop();
1254   ufePush(a <= b ? 1u : 0u);
1255 }
1256
1257 // U>=
1258 // ( a b -- a>=b )
1259 UFWORD(UGREATEQU) {
1260   const uint32_t b = ufePop();
1261   const uint32_t a = ufePop();
1262   ufePush(a >= b ? 1u : 0u);
1263 }
1264
1265 // =
1266 // ( a b -- a=b )
1267 UFWORD(EQU) {
1268   const uint32_t b = ufePop();
1269   const uint32_t a = ufePop();
1270   ufePush(a == b ? 1u : 0u);
1271 }
1272
1273 // <>
1274 // ( a b -- a<>b )
1275 UFWORD(NOTEQU) {
1276   const uint32_t b = ufePop();
1277   const uint32_t a = ufePop();
1278   ufePush(a != b ? 1u : 0u);
1279 }
1280
1281 // NOT
1282 // ( a -- !a )
1283 UFWORD(NOT) {
1284   const uint32_t a = ufePop();
1285   ufePush(a ? 0u : 1u);
1286 }
1287
1288 // NOTNOT
1289 // ( a -- !!a )
1290 UFWORD(NOTNOT) {
1291   const uint32_t a = ufePop();
1292   ufePush(a ? 1u : 0u);
1293 }
1294
1295 // LAND
1296 // ( a b -- a&&b )
1297 UFWORD(LAND) {
1298   const uint32_t b = ufePop();
1299   const uint32_t a = ufePop();
1300   ufePush(a && b ? 1u : 0u);
1301 }
1302
1303 // LOR
1304 // ( a b -- a||b )
1305 UFWORD(LOR) {
1306   const uint32_t b = ufePop();
1307   const uint32_t a = ufePop();
1308   ufePush(a || b ? 1u : 0u);
1309 }
1310
1311 // AND
1312 // ( a b -- a&b )
1313 UFWORD(AND) {
1314   const uint32_t b = ufePop();
1315   const uint32_t a = ufePop();
1316   ufePush(a&b);
1317 }
1318
1319 // OR
1320 // ( a b -- a|b )
1321 UFWORD(OR) {
1322   const uint32_t b = ufePop();
1323   const uint32_t a = ufePop();
1324   ufePush(a|b);
1325 }
1326
1327 // XOR
1328 // ( a b -- a^b )
1329 UFWORD(XOR) {
1330   const uint32_t b = ufePop();
1331   const uint32_t a = ufePop();
1332   ufePush(a^b);
1333 }
1334
1335 // BITNOT
1336 // ( a -- ~a )
1337 UFWORD(BITNOT) {
1338   const uint32_t a = ufePop();
1339   ufePush(~a);
1340 }
1341
1342 UFWORD(ONEPLUS) { uint32_t n = ufePop(); ufePush(n+1u); }
1343 UFWORD(ONEMINUS) { uint32_t n = ufePop(); ufePush(n-1u); }
1344 UFWORD(TWOPLUS) { uint32_t n = ufePop(); ufePush(n+2u); }
1345 UFWORD(TWOMINUS) { uint32_t n = ufePop(); ufePush(n-2u); }
1346 UFWORD(THREEPLUS) { uint32_t n = ufePop(); ufePush(n+3u); }
1347 UFWORD(THREEMINUS) { uint32_t n = ufePop(); ufePush(n-3u); }
1348 UFWORD(FOURPLUS) { uint32_t n = ufePop(); ufePush(n+4u); }
1349 UFWORD(FOURMINUS) { uint32_t n = ufePop(); ufePush(n-4u); }
1350 UFWORD(ONESHL) { uint32_t n = ufePop(); ufePush(n*2u); }
1351 UFWORD(ONESHR) { uint32_t n = ufePop(); ufePush(n/2u); }
1352
1353 UFWORD(SHL) { uint32_t c = ufePop(); uint32_t n = ufePop(); n = (c > 31u ? 0u : n<<c); ufePush(n); }
1354 UFWORD(SHR) { uint32_t c = ufePop(); uint32_t n = ufePop(); n = (c > 31u ? 0u : n>>c); ufePush(n); }
1355
1356
1357
1358 // ////////////////////////////////////////////////////////////////////////// //
1359 // compiler
1360
1361 static void ufeCompileZXWord (const char *wname) {
1362   if (!wname) wname = "";
1363   ForthWord *fw = findForthWord(wname);
1364   if (!fw) ufeFatal("ZX Forth word `%s` not found", (wname[0] ? wname : "~"));
1365   ufeZXEmitU16(fw->cfa);
1366 }
1367
1368 static void ufeCompileNativeWord (const char *wname) {
1369   if (!wname) wname = "";
1370   UForthWord *fw = ufeAlwaysWord(wname);
1371   ufeImgEmitU32(fw->cfaidx);
1372 }
1373
1374 // either ZX or native
1375 static void ufeCompileWord (const char *wname) {
1376   //fprintf(stderr, "+++ <%s>\n", wname);
1377   if (ufeMode == UFE_MODE_ZX) {
1378     // zx-compile
1379     ufeCompileZXWord(wname);
1380   } else {
1381     ufeCompileNativeWord(wname);
1382   }
1383 }
1384
1385 static void ufeCompileZXLiteral (uint16_t value) {
1386   ufeCompileZXWord("LIT");
1387   ufeZXEmitU16(value);
1388 }
1389
1390 static void ufeCompileNativeLiteral (uint32_t value) {
1391   ufeCompileNativeWord("LIT");
1392   ufeImgEmitU32(value);
1393 }
1394
1395 static void ufeCompileLiteral (uint32_t value) {
1396   if (ufeMode == UFE_MODE_ZX) {
1397     // zx-compile
1398     ufeCompileZXLiteral(value);
1399   } else {
1400     ufeCompileNativeLiteral(value);
1401   }
1402 }
1403
1404
1405 // LITERAL
1406 // ( n -- n )
1407 UFWORD(LITERAL) {
1408   if (ufeGetState()) {
1409     if (ufeMode == UFE_MODE_ZX) {
1410       // zx-compile
1411       ufeCompileZXLiteral(ufePop()&0xffffU);
1412     } else {
1413       // native mode
1414       ufeCompileLiteral(ufePop());
1415     }
1416   }
1417 }
1418
1419 // (UNESCAPE)
1420 // ( addr count -- addr count )
1421 UFWORD(UNESCAPE_PAREN) {
1422   int32_t count = (int32_t)ufePop();
1423   uint32_t addr = ufePeek();
1424   if (count < 0) { ufePush(0); return; }
1425   uint32_t caddr = addr;
1426   while (count-- > 0) {
1427     uint8_t ch = ufeImgGetU8(caddr)&0xffU;
1428     if (count && ch == '\\') {
1429       ++count;
1430       ch = ufeImgGetU8(caddr+1)&0xffU;
1431       uint32_t xlen = 1;
1432       switch (ch) {
1433         case 'r': ufeImgPutU8(caddr, '\r'); break;
1434         case 'n': ufeImgPutU8(caddr, '\r'); ufeImgPutU8(caddr+1, '\n'); xlen = 2; break;
1435         case 't': ufeImgPutU8(caddr, '\t'); break;
1436         case '`': ufeImgPutU8(caddr, '"'); break;
1437         case '"': ufeImgPutU8(caddr, '"'); break;
1438         case '\'': ufeImgPutU8(caddr, '\''); break;
1439         case '\\': ufeImgPutU8(caddr, '\\'); break;
1440         case 'x': case 'X':
1441           if (count >= 3) {
1442             const int dg0 = digitInBase((char)(ufeImgGetU8(caddr+2)&0xff), 16);
1443             const int dg1 = (count > 3 ? digitInBase((char)(ufeImgGetU8(caddr+3)&0xff), 16) : -1);
1444             if (dg0 < 0) ufeFatal("invalid UFE hex string escape");
1445             ch = (dg1 < 0 ? (uint32_t)dg0 : ((uint32_t)dg0)*16u+(uint32_t)dg1);
1446           } else {
1447             ufeFatal("invalid UFE hex string escape");
1448           }
1449           break;
1450         default: xlen = 0; break;
1451       }
1452       if (xlen) {
1453         if (xlen > count) ufeFatal("invalid UFE string escape");
1454         for (uint32_t n = xlen; n < count; ++n) ufeImgPutU8(n-xlen, ufeImgGetU8(n));
1455         count -= xlen;
1456         caddr += xlen;
1457         continue;
1458       }
1459       ufeFatal("invalid UFE string escape");
1460     } else {
1461       ++caddr;
1462     }
1463   }
1464   ufePush(caddr-addr);
1465 }
1466
1467 // STRLITERAL
1468 // I:( addr -- addr count )
1469 // R:( -- addr count )
1470 // C:( addr -- )
1471 // addr *MUST* be HERE
1472 UFWORD(STRLITERAL) {
1473   UFCALL(COUNT); // ( addr+1 count )
1474   UFCALL(UNESCAPE_PAREN);
1475   if (ufeGetState()) {
1476     uint32_t count = ufePop();
1477     uint32_t addr = ufePop();
1478     if (ufeMode == UFE_MODE_ZX) {
1479       // zx-compile
1480       if (count > 255) ufeFatal("UFE ZX string too long");
1481       ufeZXEmitU8(count&0xffU);
1482       for (uint32_t n = 0; n < count; ++n) {
1483         uint8_t ch = ufeImgGetU8(addr+n);
1484         ufeZXEmitU8(ch&0xffU);
1485       }
1486     } else {
1487       // compile
1488       if (count > 0xffffU) ufeFatal("UFE string too long");
1489       if (addr-1 != ufeImageUsed) ufeFatal("invalid call to UFE word 'STRLITERAL'");
1490       ufeImgPutU32(addr-1, count);
1491       ufeImageUsed += count+1;
1492       ufeImgEnsure(ufeImageUsed);
1493     }
1494   }
1495 }
1496
1497 // NATIVE-HERE
1498 // ( -- n )
1499 UFWORD(NATIVE_HERE) {
1500   ufeImgEnsure(ufeImageUsed);
1501   ufePush(ufeImageUsed);
1502 }
1503
1504 // NATIVE-PAD
1505 // ( -- n+1024 )
1506 UFWORD(NATIVE_PAD) {
1507   ufeImgEnsure(ufeImageUsed+1024);
1508   ufePush(ufeImageUsed+1024);
1509 }
1510
1511 // "
1512 UFWORD(STRQ) {
1513   if (ufeGetState()) ufeCompileWord("(\")");
1514   ufePush(34); UFCALL(WORD);
1515   UFCALL(STRLITERAL);
1516   if (/*ufeMode == UFE_MODE_NATIVE &&*/ !ufeGetState()) {
1517     // copy to PAD
1518     UFCALL(NATIVE_PAD);
1519     uint32_t dest = ufePop();
1520     uint32_t count = ufePop();
1521     uint32_t src = ufePop();
1522     if (count > 0xffffU) ufeFatal("UFE string too long");
1523     ufeImgEnsure(dest+count+2);
1524     for (uint32_t n = 0; n < count; ++n) ufeImgPutU32(dest+n, ufeImgGetU32(src+n));
1525     UFCALL(NATIVE_PAD);
1526     ufePush(count);
1527   }
1528 }
1529
1530 // ."
1531 UFWORD(STRDOTQ) {
1532   if (ufeGetState()) ufeCompileWord("(.\")");
1533   ufePush(34); UFCALL(WORD);
1534   UFCALL(STRLITERAL);
1535   if (!ufeGetState()) {
1536     UFCALL(TYPE);
1537   }
1538 }
1539
1540
1541 // ////////////////////////////////////////////////////////////////////////// //
1542 // interpreter
1543
1544 // "( ...)" comment
1545 UFWORD(COMMENTPAREN) {
1546   ufePush(')'); UFCALL(WORD);
1547   ufeDrop();
1548 }
1549
1550 // "\" comment
1551 UFWORD(COMMENTEOL) {
1552   ufePush(10); UFCALL(WORD);
1553   ufeDrop();
1554 }
1555
1556 // NFIND ( addr count onlynativeimmflag -- cfa 1 | 0 )
1557 // find native/zx word
1558 //   onlynativeimmflag:
1559 //     0: look for ZX word only if native word not found
1560 //    !0: look for ZX word only if native word not found, or if it is not immediate
1561 //   666: prefer ZX words (used in `COMPILE`)
1562 // returned ZX CFA has `UFE_ZX_ADDR_BIT` set
1563 //
1564 // native mode:
1565 //   look for native word
1566 //   if there is none, look for zx word
1567 // zx mode:
1568 //   look for native word
1569 //   STATE == 0: (interpreting)
1570 //     if there is none, look for zx word
1571 //   STATE != 0: (compiling)
1572 //     if no native word, or native word is not immediate, look for zx word
1573 UFWORD(NFIND) {
1574   uint32_t onlynativeimmflag = ufePop();
1575   const uint32_t count = ufePop();
1576   const uint32_t addr = ufePop();
1577   ufeNFindZXWordResult = NULL;
1578   ufeNFindNativeWordResult = NULL;
1579   // prefer ZX words?
1580   if (onlynativeimmflag == 666) {
1581     // look for ZX word
1582     ForthWord *zxfw = ufeNFindZX(addr, count);
1583     if (zxfw) {
1584       ufeNFindZXWordResult = zxfw;
1585       ufePush(zxfw->cfa|UFE_ZX_ADDR_BIT);
1586       ufePush(1);
1587       return;
1588     }
1589     onlynativeimmflag = 0;
1590   }
1591   // look for native word
1592   UForthWord *fw = ufeNFind(addr, count);
1593   /*
1594   if (!fw) {
1595     fprintf(stderr, "::%u:", count); for (uint32_t n = 0; n < count; ++n) fprintf(stderr, "%c", ufeImgGetU8(addr+n)); fprintf(stderr, "\n");
1596   } else {
1597     fprintf(stderr, "::FOUND::%u:(%u:%u:%u)", count, onlynativeimmflag, fw->immediate, ufeMode); for (uint32_t n = 0; n < count; ++n) fprintf(stderr, "%c", ufeImgGetU8(addr+n)); fprintf(stderr, "\n");
1598   }
1599   */
1600   if (fw && (!onlynativeimmflag || fw->immediate)) {
1601     // native words allowed, or immediate native words allowed and it is immediate
1602     //fprintf(stderr, "  !!\n");
1603     ufeNFindNativeWordResult = fw;
1604     ufePush(fw->cfaidx);
1605     ufePush(1);
1606     return;
1607   }
1608   // look for ZX word
1609   ForthWord *zxfw = ufeNFindZX(addr, count);
1610   if (zxfw) {
1611     ufeNFindZXWordResult = zxfw;
1612     ufePush(zxfw->cfa|UFE_ZX_ADDR_BIT);
1613     ufePush(1);
1614     return;
1615   }
1616   // nothing
1617   ufePush(0);
1618 }
1619
1620 // convert number from addrl+1
1621 // returns address of the first inconvertable char
1622 // (XNUMBER) ( n1 addrl -- n2 addr2 )
1623 UFWORD(XNUMBER) {
1624   uint32_t addr = ufePop()+1;
1625   uint32_t n = ufePop();
1626   int base = 0;
1627   // special-based numbers
1628   if (ufeImgGetU8(addr) == '0') {
1629     switch (ufeImgGetU8(addr+1)) {
1630       case 'x': case 'X': base = 16; break;
1631       case 'o': case 'O': base = 8; break;
1632       case 'b': case 'B': base = 2; break;
1633       case 'd': case 'D': base = 10; break;
1634       default: break;
1635     }
1636     if (base && digitInBase(ufeImgGetU8(addr+2), base) >= 0) {
1637       addr += 2;
1638     }
1639   }
1640   // in current base
1641   if (!base) base = (int)ufeImgGetU8(ufeBASEaddr);
1642   if (base > 0 && base <= 36) {
1643     while (addr < ufeImageSize) {
1644       const uint32_t ch = ufeImgGetU8(addr)&0xffU;
1645       if (ch != '_') {
1646         const int dig = digitInBase((char)ch, (int)base);
1647         if (dig < 0) break;
1648         n = n*(unsigned)base+(unsigned)dig;
1649       }
1650       ++addr;
1651     }
1652   }
1653   ufePush(n);
1654   ufePush(addr);
1655 }
1656
1657 // INTERPRET
1658 UFWORD(INTERPRET) {
1659   for (;;) {
1660     ufePush(32); UFCALL(WORD);  // ( addr )
1661     UFCALL(COUNT);
1662       //ufe2Dup(); printf("WORD: %u %u [", ufePop(), ufePop()); ufe2Dup(); UFCALL(XTYPE); printf("]"); UFCALL(CR);
1663     uint32_t len = ufePop();
1664     uint32_t addr = ufePop();
1665     if (!len) {
1666       // end of input buffer; read next line
1667       const int rd = ufeLoadNextLine();
1668       //printf("rd=%d\n", rd);
1669       if (rd < -1) ufeFatal("error reading UFE input buffer");
1670       if (rd == -1) longjmp(ufeEOFJP, 666); // EOF
1671       continue;
1672     }
1673     // stack: empty
1674     ufePush(addr); ufePush(len);
1675     ufePush(ufeMode == UFE_MODE_ZX && ufeGetState()); // if compiling for ZX, allow only immediate native words
1676     UFCALL(NFIND); // ( cfa 1 ) | ( 0 )
1677     if (ufePop()) {
1678       // word found, compile/execute
1679       uint32_t cfa = ufePop();
1680         //printf("FOUND; cfa=0x%08x: ", cfa); ufePush(addr); ufePush(len); UFCALL(XTYPE); UFCALL(CR);
1681       // is it ZX word?
1682       if (cfa&UFE_ZX_ADDR_BIT) {
1683         // ZX word
1684         cfa &= UFE_ZX_ADDR_MASK; // convert to real ZX address
1685         // if we're not compiling for ZX, only variables are allowed
1686         if (ufeMode == UFE_MODE_ZX) {
1687           // zx mode
1688           if (ufeGetState()) {
1689             // any ZX word is allowed, compile it
1690             ufeZXEmitU16(cfa);
1691             continue;
1692           } else {
1693             // only ZX variables are allowed
1694             if (ufeNFindZXWordResult->wtype == FWT_VAR) {
1695               // push ZX address
1696               ufePush((cfa+3)|UFE_ZX_ADDR_BIT);
1697               continue;
1698             }
1699             // fallback to number parsing
1700           }
1701         } else {
1702           // not in ZX mode
1703           // only ZX variables are allowed
1704           if (ufeNFindZXWordResult->wtype == FWT_VAR) {
1705             ufePush((cfa+3)|UFE_ZX_ADDR_BIT);
1706             UFCALL(LITERAL);
1707             continue;
1708           }
1709          // fallback to number parsing
1710         }
1711       } else {
1712         // native word
1713         if (cfa >= ufeCFAsUsed) abort(); // assertion, the thing that should not be
1714         UForthWord *fw = ufeForthCFAs[cfa];
1715         //fprintf(stderr, "  W:<%s>; cfa=0x%08x; state=%d\n", fw->name, cfa, ufeGetState());
1716         if (!fw->immediate && ufeGetState()) {
1717           //fprintf(stderr, " [C:%s:%u:%s]\n", fw->name, fw->cfaidx, ufeForthCFAs[fw->cfaidx]->name);
1718           // compile
1719           ufeImgEmitU32(fw->cfaidx);
1720         } else {
1721           // execute
1722           ufePush(fw->cfaidx);
1723           UFCALL(EXECUTE);
1724         }
1725         continue;
1726       }
1727     }
1728
1729     // word not found, try to parse a number
1730     unsigned neg = 0;
1731     if (ufeImgGetU8(addr) == '-') { neg = 1; ++addr; --len; }
1732     ufePush(0); // number
1733     ufePush(addr-1u); // address
1734     UFCALL(XNUMBER);
1735     // check if parsed successfully
1736     uint32_t eaddr = ufePop();
1737     uint32_t n = ufePop();
1738     //printf("addr=%u; n=%u; neg=%u\n", eaddr, n, neg); abort();
1739     if (eaddr == addr+len) {
1740       // valid number
1741       //printf("addr=%u; n=%u; neg=%u\n", eaddr, n, neg); abort();
1742       if (neg) n = (~n)+1u;
1743       //printf("addr=%u; n=%d; neg=%u\n", eaddr, (int32_t)n, neg); abort();
1744       ufePush(n);
1745       UFCALL(LITERAL);
1746       continue;
1747     }
1748     // something wicked this way comes
1749     if (neg) { --addr; ++len; }
1750     UFCALL(SPACE); ufePush(addr); ufePush(len); UFCALL(XTYPE);
1751     printf("?\n");
1752     ufeFatal("unknown %s word", (ufeMode == UFE_MODE_NATIVE ? "UFE" : "ZX"));
1753   }
1754 }
1755
1756
1757 // ////////////////////////////////////////////////////////////////////////// //
1758 // more compiler words
1759
1760 // ?EXEC
1761 UFWORD(QEXEC) {
1762   if (ufeGetState()) ufeFatal("UFE: expecting execution mode");
1763 }
1764
1765 // ?COMP
1766 UFWORD(QCOMP) {
1767   if (!ufeGetState()) ufeFatal("UFE: expecting compilation mode");
1768 }
1769
1770 // ?PAIRS
1771 // ( ocond cond -- )
1772 UFWORD(QPAIRS) {
1773   if (!ufeGetState()) ufeFatal("UFE: expecting compilation mode");
1774   const uint32_t cond = ufePop();
1775   const uint32_t ocond = ufePop();
1776   if (cond != ocond) ufeFatal("UFE: unbalanced structured code");
1777 }
1778
1779 // COMPILE
1780 UFWORD(COMPILE_IMM) {
1781   if (ufeGetState() == 0) ufeFatal("cannot call `COMPILE` from interpreter");
1782   ufePush(32); UFCALL(WORD);
1783   UFCALL(COUNT);
1784   ufePush(ufeMode == UFE_MODE_ZX ? 666u : 0u); // for ZX mode, prefer ZX words
1785   UFCALL(NFIND); // ( cfa 1 ) | ( 0 )
1786   if (ufePop()) {
1787     uint32_t cfa = ufePop();
1788     // for ZX mode, compile ZX code
1789     if (ufeMode == UFE_MODE_ZX) {
1790       if ((cfa&UFE_ZX_ADDR_BIT) == 0) ufeFatal("cannot `COMPILE` native word");
1791       cfa &= UFE_ZX_ADDR_MASK; // we need normal address here
1792     } else {
1793       if (cfa&UFE_ZX_ADDR_BIT) ufeFatal("cannot `COMPILE` ZX word");
1794     }
1795     ufeCompileLiteral(cfa);
1796     ufeCompileWord(",");
1797   } else {
1798     UFCALL(NATIVE_HERE); UFCALL(COUNT); UFCALL(SPACE); UFCALL(XTYPE);
1799     printf("?"); UFCALL(CR);
1800     ufeFatal("UFE: unknown word");
1801   }
1802 }
1803
1804 // [COMPILE]
1805 UFWORD(XCOMPILE_IMM) {
1806   if (ufeGetState() == 0) ufeFatal("cannot call `[COMPILE]` from interpreter");
1807   ufePush(32); UFCALL(WORD);
1808   UFCALL(COUNT);
1809   ufePush(ufeMode == UFE_MODE_ZX ? 666u : 0u); // for ZX mode, prefer ZX words
1810   UFCALL(NFIND); // ( cfa 1 ) | ( 0 )
1811   if (ufePop()) {
1812     uint32_t cfa = ufePop();
1813     // for ZX mode, compile ZX code
1814     if (ufeMode == UFE_MODE_ZX) {
1815       if ((cfa&UFE_ZX_ADDR_BIT) == 0) ufeFatal("cannot `[COMPILE]` native word");
1816       cfa &= UFE_ZX_ADDR_MASK; // we need normal address here
1817       ufeZXEmitU16(cfa);
1818     } else {
1819       if (cfa&UFE_ZX_ADDR_BIT) ufeFatal("cannot `[COMPILE]` ZX word");
1820       ufeImgEmitU32(cfa);
1821     }
1822   } else {
1823     UFCALL(NATIVE_HERE); UFCALL(COUNT); UFCALL(SPACE); UFCALL(XTYPE);
1824     printf("?"); UFCALL(CR);
1825     ufeFatal("UFE: unknown word");
1826   }
1827 }
1828
1829 // COMP-BACK
1830 // ( addr -- )
1831 UFWORD(COMP_BACK) {
1832   if (ufeMode == UFE_MODE_ZX) {
1833     ufeZXEmitU16(ufePop());
1834   } else {
1835     ufeImgEmitU32(ufePop());
1836   }
1837 }
1838
1839 // COMP-FWD
1840 // ( addr -- )
1841 // calculate the forward branch offset from addr to HERE and put it into the addr
1842 UFWORD(COMP_FWD) {
1843   if (ufeMode == UFE_MODE_ZX) {
1844     const uint32_t here = disp;
1845     const uint32_t addr = ufePop();
1846     ufeZXPutU16(addr, here);
1847   } else {
1848     UFCALL(NATIVE_HERE);
1849     const uint32_t here = ufePop();
1850     const uint32_t addr = ufePop();
1851     ufeImgPutU32(addr, here);
1852   }
1853 }
1854
1855 // EXIT
1856 UFWORD(EXIT) {
1857   ufeIP = ufeRPop();
1858   if (ufeIP == 0xbec0ffeeU) {
1859     if (ufeRP) ufeIP = ufeRPop();
1860     ufeStopVM = 1;
1861   }
1862 }
1863
1864 // BEGIN
1865 UFWORD(BEGIN) {
1866   UFCALL(QCOMP);
1867   if (ufeMode == UFE_MODE_ZX) {
1868     ufePush(disp);
1869   } else {
1870     UFCALL(NATIVE_HERE);
1871   }
1872   ufePush(1);
1873 }
1874
1875 // ENDIF
1876 UFWORD(ENDIF) {
1877   UFCALL(QCOMP);
1878   ufePush(2);
1879   UFCALL(QPAIRS);
1880   UFCALL(COMP_FWD);
1881 }
1882
1883 // DO
1884 UFWORD(DO) {
1885   if (ufeMode == UFE_MODE_ZX) {
1886     ufeCompileZXWord("(DO)");
1887     ufePush(disp);
1888   } else {
1889     UForthWord *fw = ufeAlwaysWord("(DO)");
1890     ufeImgEmitU32(fw->cfaidx);
1891     UFCALL(NATIVE_HERE);
1892   }
1893   ufePush(3);
1894 }
1895
1896 // LOOP
1897 UFWORD(LOOP) {
1898   UFCALL(QCOMP);
1899   ufePush(3);
1900   UFCALL(QPAIRS);
1901   if (ufeMode == UFE_MODE_ZX) {
1902     ufeCompileZXWord("(LOOP)");
1903   } else {
1904     UForthWord *fw = ufeAlwaysWord("(LOOP)");
1905     ufeImgEmitU32(fw->cfaidx);
1906   }
1907   UFCALL(COMP_BACK);
1908 }
1909
1910 // +LOOP
1911 UFWORD(PLOOP) {
1912   UFCALL(QCOMP);
1913   ufePush(3);
1914   UFCALL(QPAIRS);
1915   if (ufeMode == UFE_MODE_ZX) {
1916     ufeCompileZXWord("(+LOOP)");
1917   } else {
1918     UForthWord *fw = ufeAlwaysWord("(+LOOP)");
1919     ufeImgEmitU32(fw->cfaidx);
1920   }
1921   UFCALL(COMP_BACK);
1922 }
1923
1924 // UNTIL
1925 UFWORD(UNTIL) {
1926   UFCALL(QCOMP);
1927   ufePush(1);
1928   UFCALL(QPAIRS);
1929   if (ufeMode == UFE_MODE_ZX) {
1930     ufeCompileZXWord("0BRANCH");
1931   } else {
1932     UForthWord *fw = ufeAlwaysWord("0BRANCH");
1933     ufeImgEmitU32(fw->cfaidx);
1934   }
1935   UFCALL(COMP_BACK);
1936 }
1937
1938 // AGAIN
1939 UFWORD(AGAIN) {
1940   UFCALL(QCOMP);
1941   ufePush(1);
1942   UFCALL(QPAIRS);
1943   if (ufeMode == UFE_MODE_ZX) {
1944     ufeCompileZXWord("BRANCH");
1945   } else {
1946     UForthWord *fw = ufeAlwaysWord("BRANCH");
1947     ufeImgEmitU32(fw->cfaidx);
1948   }
1949   UFCALL(COMP_BACK);
1950 }
1951
1952 // REPEAT
1953 UFWORD(REPEAT) {
1954   const uint32_t n0 = ufePop();
1955   const uint32_t n1 = ufePop();
1956   UFCALL(AGAIN);
1957   ufePush(n1);
1958   ufePush(n0);
1959   ufePush(ufePop()-2u);
1960   UFCALL(ENDIF);
1961 }
1962
1963 // IF
1964 UFWORD(IF) {
1965   UFCALL(QCOMP);
1966   if (ufeMode == UFE_MODE_ZX) {
1967     ufeCompileZXWord("0BRANCH");
1968     ufePush(disp);
1969     ufeZXEmitU16(0);
1970   } else {
1971     UForthWord *fw = ufeAlwaysWord("0BRANCH");
1972     ufeImgEmitU32(fw->cfaidx);
1973     UFCALL(NATIVE_HERE);
1974     ufeImgEmitU32(0);
1975   }
1976   ufePush(2);
1977 }
1978
1979 // IFNOT
1980 UFWORD(IFNOT) {
1981   UFCALL(QCOMP);
1982   if (ufeMode == UFE_MODE_ZX) {
1983     ufeCompileZXWord("TBRANCH");
1984     ufePush(disp);
1985     ufeZXEmitU16(0);
1986   } else {
1987     UForthWord *fw = ufeAlwaysWord("TBRANCH");
1988     ufeImgEmitU32(fw->cfaidx);
1989     UFCALL(NATIVE_HERE);
1990     ufeImgEmitU32(0);
1991   }
1992   ufePush(2);
1993 }
1994
1995 // ELSE
1996 UFWORD(ELSE) {
1997   UFCALL(QCOMP);
1998   ufePush(2);
1999   UFCALL(QPAIRS);
2000   if (ufeMode == UFE_MODE_ZX) {
2001     ufeCompileZXWord("BRANCH");
2002     ufePush(disp);
2003     ufeZXEmitU16(0);
2004   } else {
2005     UForthWord *fw = ufeAlwaysWord("BRANCH");
2006     ufeImgEmitU32(fw->cfaidx);
2007     UFCALL(NATIVE_HERE);
2008     ufeImgEmitU32(0);
2009   }
2010   ufeSwap();
2011   ufePush(2);
2012   UFCALL(ENDIF);
2013   ufePush(2);
2014 }
2015
2016 // WHILE
2017 UFWORD(WHILE) {
2018   UFCALL(IF);
2019   ufePush(ufePop()+2u);
2020 }
2021
2022 // CASE
2023 UFWORD(CASE) {
2024   UFCALL(QCOMP);
2025   ufePush(ufeCSP); ufeCSP = ufeSP; //CSP @ !CSP
2026   ufePush(4);
2027 }
2028
2029 static void ufeXOF (const char *cmpwname, int doswap) {
2030   UFCALL(QCOMP);
2031   ufePush(4);
2032   UFCALL(QPAIRS);
2033   ufeCompileWord("OVER");
2034   if (doswap) ufeCompileWord("SWAP");
2035   ufeCompileWord(cmpwname);
2036   ufeCompileWord("0BRANCH");
2037   // HERE 0 ,
2038   if (ufeMode == UFE_MODE_ZX) {
2039     ufePush(disp);
2040     ufeZXEmitU16(0);
2041   } else {
2042     UFCALL(NATIVE_HERE);
2043     ufeImgEmitU32(0);
2044   }
2045   ufeCompileWord("DROP");
2046   ufePush(5);
2047 }
2048
2049 // OF
2050 UFWORD(OF) {
2051   ufeXOF("=", 0);
2052 }
2053
2054 // &OF
2055 UFWORD(AND_OF) {
2056   ufeXOF("AND", 1);
2057 }
2058
2059 // ENDOF
2060 UFWORD(ENDOF) {
2061   UFCALL(QCOMP);
2062   ufePush(5);
2063   UFCALL(QPAIRS);
2064   ufeCompileWord("BRANCH");
2065   // HERE 0 ,
2066   if (ufeMode == UFE_MODE_ZX) {
2067     ufePush(disp);
2068     ufeZXEmitU16(0);
2069   } else {
2070     UFCALL(NATIVE_HERE);
2071     ufeImgEmitU32(0);
2072   }
2073   ufeSwap();
2074   ufePush(2);
2075   UFCALL(ENDIF);
2076   ufePush(4);
2077 }
2078
2079 // OTHERWISE
2080 UFWORD(OTHERWISE) {
2081   UFCALL(QCOMP);
2082   ufePush(4);
2083   UFCALL(QPAIRS);
2084   ufePush(6);
2085 }
2086
2087 // ENDCASE
2088 UFWORD(ENDCASE) {
2089   UFCALL(QCOMP);
2090   if (ufePeek() != 6) {
2091     ufePush(4);
2092     UFCALL(QPAIRS);
2093     ufeCompileWord("DROP");
2094   } else {
2095     ufeDrop();
2096   }
2097   //fprintf(stderr, "SP=%u; csp=%u\n", ufeSP, ufeCSP);
2098   if (ufeSP < ufeCSP) ufeFatal("ENDCASE compiler error");
2099   while (ufeSP > ufeCSP) {
2100     ufePush(2);
2101     UFCALL(ENDIF);
2102   }
2103   ufeCSP = ufePop(); //CSP !
2104 }
2105
2106
2107 // ////////////////////////////////////////////////////////////////////////// //
2108 // define Forth words
2109 //
2110 // 32 for native address, 8 for zx address
2111 static char *ufeZXWORD (char delim) {
2112   static char buf[257];
2113   ufePush(delim);
2114   UFCALL(WORD);
2115   uint32_t addr = ufePop();
2116   uint32_t count = ufeImgGetCounter(addr++);
2117   if (count > 255) ufeFatal("zx forth line too long");
2118   for (uint32_t n = 0; n < count; ++n) buf[n] = ufeImgGetU8(addr+n);
2119   buf[count] = 0;
2120   if (delim == 32) for (char *s = buf; *s; ++s) *s = toUpper(*s);
2121   return buf;
2122 }
2123
2124
2125 // returns dynalloced string
2126 static char *ufePopStrLit (void) {
2127   uint32_t count = ufePop();
2128   uint32_t addr = ufePop();
2129   if (count > 4096) ufeFatal("UFE string literal too long");
2130   char *res = malloc(count+1);
2131   for (uint32_t n = 0; n < count; ++n) res[n] = ufeImgGetU8(addr+n);
2132   res[count] = 0;
2133   return res;
2134 }
2135
2136 // returns VM address of counted string
2137 static uint32_t ufePutTempStrLiteral (const char *s, uint32_t destofs) {
2138   if (!s) s = "";
2139   uint32_t staddr = ufeImageUsed+destofs;
2140   ufeImgEnsure(staddr);
2141   const size_t slen = strlen(s);
2142   if (slen > 1024*1024) ufeFatal("temp string too long");
2143   uint32_t addr = staddr;
2144   ufeImgPutU32(addr++, (uint32_t)slen);
2145   for (size_t f = 0; f < slen; ++f) {
2146     ufeImgPutU32(addr++, (uint8_t)(s[0]&0xffU));
2147     ++s;
2148   }
2149   return staddr;
2150 }
2151
2152
2153 static UForthWord *ufeRegisterWord (const char *wname, void (*cfa) (UForthWord *self), int imm) {
2154   if (!wname) wname = "";
2155   if (strlen(wname) > 127) ufeFatal("too long UFE builtin word name '%s'", wname);
2156   UForthWord *fw = ufeFindWord(wname);
2157   if (fw) ufeFatal("cannot redefine builtin UFE word '%s'", wname);
2158   fw = calloc(1, sizeof(UForthWord));
2159   fw->name = strdup(wname);
2160   for (char *s = fw->name; *s; ++s) *s = toUpper(*s);
2161   fw->cfa = cfa;
2162   fw->prev = ufeForthDict;
2163   fw->cfaidx = ufeCFAsUsed;
2164   fw->immediate = imm;
2165   fw->pfa = 0xffffffffu; //ufeImageUsed;
2166   ufeForthDict = fw;
2167   if (ufeCFAsUsed >= UFE_MAX_WORDS) ufeFatal("too many UFE words");
2168   ufeForthCFAs[ufeCFAsUsed++] = fw;
2169   //fprintf(stderr, "***NEW WORD #%u: <%s> at 0x%08x\n", ufeCFAsUsed-1u, ufeForthCFAs[ufeCFAsUsed-1u]->name, fw->pfa);
2170   return fw;
2171 };
2172
2173
2174 static UForthWord *ufeCreateNamelessForthWord (void) {
2175   UForthWord *fw = calloc(1, sizeof(UForthWord));
2176   fw->name = strdup("\x01 - - - \x01");
2177   fw->cfa = &ufeDoForth;
2178   fw->cfaidx = ufeCFAsUsed;
2179   fw->immediate = 0;
2180   fw->pfa = 0xffffffffu; //ufeImageUsed;
2181   //HACK: link it to the very bottom of the list
2182   UForthWord *ww = ufeForthDict;
2183   if (!ww) {
2184     fw->prev = NULL;
2185     ufeForthDict = fw;
2186   } else {
2187     while (ww->prev) ww = ww->prev;
2188     ww->prev = fw;
2189   }
2190   //
2191   if (ufeCFAsUsed >= UFE_MAX_WORDS) ufeFatal("too many UFE words");
2192   ufeForthCFAs[ufeCFAsUsed++] = fw;
2193   return fw;
2194 };
2195
2196
2197 static UForthWord *doNativeCreate (void) {
2198   ufePush(32); UFCALL(WORD);
2199   UFCALL(COUNT);
2200   uint32_t len = ufePop();
2201   uint32_t addr = ufePop();
2202   if (len < 1 || len > 31) ufeFatal("UFE new word name is too long");
2203   char wname[32];
2204   for (uint32_t n = 0; n < len; ++n) wname[n] = ufeImgGetU8(addr+n);
2205   wname[len] = 0;
2206   if (ufeFindWord(wname)) {
2207     printf("'%s' redefined\n", wname);
2208     ufeLastEmitWasCR = 1;
2209   }
2210   UForthWord *fw = ufeRegisterWord(wname, NULL, 0);
2211   fw->pfa = ufeImageUsed;
2212   return fw;
2213 }
2214
2215 static void doNativeColon (void) {
2216   UForthWord *fw = doNativeCreate();
2217   fw->cfa = NULL; // for now
2218   ufeSetState(1); // compiling
2219   //fprintf(stderr, "compiling native <%s>\n", wname);
2220   // always remember old mode
2221   ufePush(ufeMode);
2222   ufePush(0xdeadbeefU); // just a flag
2223   ufeMode = UFE_MODE_NATIVE;
2224 }
2225
2226 static void doZXColon (void) {
2227   const char *wname = ufeZXWORD(' ');
2228   if (!wname) ufeFatal("forth word name expected");
2229   //fprintf(stderr, "NFA OF <%s> = #%04X\n", wname, disp);
2230   /*ForthWord *nw =*/ forthWordHead(wname, 0, FWT_FORTH);
2231   // cfa
2232   forthEmitCallToLabel("_doforth");
2233   //fprintf(stderr, "compiling ZX <%s>\n", wname);
2234   ufeSetState(1); // compiling
2235   // always remember old mode
2236   ufePush(ufeMode);
2237   ufePush(0xdeadbeefU); // just a flag
2238   ufeMode = UFE_MODE_ZX;
2239 }
2240
2241 // :
2242 // either native, or ZX, depending of the current mode
2243 UFWORD(COLON) {
2244   if (ufeGetState()) ufeFatal("already compiling");
2245   if (ufeMode == UFE_MODE_ZX) doZXColon(); else doNativeColon();
2246 }
2247
2248 // ZX:
2249 UFWORD(ZX_COLON) {
2250   if (ufeGetState()) ufeFatal("already compiling");
2251   doZXColon(); // this forces ZX mode
2252 }
2253
2254
2255 static __attribute__((unused)) void ufeDecompileForth (UForthWord *fw) {
2256   // decompiler
2257   fprintf(stderr, "====: %s\n", fw->name);
2258   uint32_t addr = fw->pfa;
2259   while (addr < ufeImageUsed) {
2260     uint32_t cfaidx = ufeImgGetU32(addr);
2261     if (cfaidx >= ufeCFAsUsed) abort();
2262     UForthWord *fw = ufeForthCFAs[cfaidx];
2263     fprintf(stderr, "%8u: %s", addr, fw->name);
2264     ++addr;
2265     if (strcasecmp(fw->name, "BRANCH") == 0 ||
2266         strcasecmp(fw->name, "0BRANCH") == 0 ||
2267         strcasecmp(fw->name, "TBRANCH") == 0 ||
2268         strcasecmp(fw->name, "(LOOP)") == 0 ||
2269         strcasecmp(fw->name, "(+LOOP)") == 0)
2270     {
2271       uint32_t jaddr = ufeImgGetU32(addr++);
2272       fprintf(stderr, " %u", jaddr);
2273     } else if (strcasecmp(fw->name, "LIT") == 0) {
2274       uint32_t n = ufeImgGetU32(addr++);
2275       fprintf(stderr, " %u", n);
2276     } else if (strcasecmp(fw->name, "(\")") == 0 || strcasecmp(fw->name, "(.\")") == 0) {
2277       uint32_t count = ufeImgGetU32(addr++);
2278       fprintf(stderr, " cnt=%u; ~", count);
2279       while (count--) {
2280         uint8_t ch = ufeImgGetU32(addr++)&0xffU;
2281              if (ch == '\r') fprintf(stderr, "\\r");
2282         else if (ch == '\n') fprintf(stderr, "\\n");
2283         else if (ch == '\t') fprintf(stderr, "\\t");
2284         else if (ch == '\\') fprintf(stderr, "\\\\");
2285         else if (ch == '"') fprintf(stderr, "\\`");
2286         else if (ch < 32 || ch == 127) fprintf(stderr, "\\x%02x", ch);
2287         else fprintf(stderr, "%c", (char)ch);
2288       }
2289       fprintf(stderr, "~");
2290     }
2291     fprintf(stderr, "\n");
2292   }
2293   fprintf(stderr, "----\n");
2294 }
2295
2296
2297 // ;
2298 UFWORD(SEMI) {
2299   if (!ufeGetState()) ufeFatal("not compiling");
2300   ufeLastDefinedZXWord = NULL;
2301   ufeLastDefinedNativeWord = NULL;
2302   UFCALL(QCOMP);
2303   // check guard
2304   if (ufePop() != 0xdeadbeefU) ufeFatal("UFE finishing word primary magic imbalance!");
2305   // compile finishing word
2306   if (ufeMode == UFE_MODE_ZX) {
2307     ufeCompileZXWord(";S");
2308     ufeLastDefinedZXWord = forthWordListTail;
2309   } else {
2310     if (!ufeForthDict || ufeForthDict->cfa) ufeFatal("UFE ';' without ':'");
2311     if (ufeForthDict->pfa == 0xffffffffU) abort();
2312     ufeForthDict->cfa = &ufeDoForth;
2313     ufeCompileNativeWord("EXIT");
2314     //ufeDecompileForth(ufeForthDict);
2315     ufeLastDefinedNativeWord = ufeForthDict;
2316   }
2317   ufeSetState(0); // interpreting
2318   // restore mode
2319   ufeMode = ufePop();
2320   if (ufeMode != UFE_MODE_NATIVE && ufeMode != UFE_MODE_ZX) ufeFatal("UFE finishing word primary mode imbalance!");
2321   // stack must be empty
2322   //if (ufeSP) ufeFatal("UFE finishing word primary imbalance!");
2323   // call optimiser if there is any
2324   UForthWord *ofw = ufeFindWord(ufeLastDefinedZXWord ? "OPTIMISE-ZX-WORD" : "OPTIMISE-NATIVE-WORD");
2325   if (ofw && ofw != ufeLastDefinedNativeWord) {
2326     //if (ufeMode == UFE_MODE_ZX) fprintf(stderr, "**********000: #%04X\n", disp);
2327     uint32_t nnbuf = ufeImageUsed+8192;
2328     const char *wname = (ufeLastDefinedZXWord ? ufeLastDefinedZXWord->name : ufeLastDefinedNativeWord->name);
2329     size_t slen = strlen(wname);
2330     ufeImgEnsure(nnbuf+(uint32_t)slen+2);
2331     ufeImgPutU32(nnbuf, (uint32_t)slen); // counter
2332     for (size_t n = 0; n < slen; ++n) ufeImgPutU8(nnbuf+(uint32_t)n+1u, (uint8_t)(wname[n]&0xffU));
2333     ufeImgPutU8(nnbuf+(uint32_t)slen+1u, 0u);
2334     ufePush(nnbuf+1u);
2335     ufePush((uint32_t)slen);
2336     ufePush(ufeLastDefinedZXWord ? (ufeLastDefinedZXWord->cfa+3u)|UFE_ZX_ADDR_BIT : ufeLastDefinedNativeWord->pfa);
2337     ufePush(ofw->cfaidx);
2338     //if (ufeMode == UFE_MODE_ZX) fprintf(stderr, "**********001: #%04X\n", disp);
2339     // temporarily switch to native mode
2340     const uint32_t oldmode = ufeMode;
2341     ufeMode = UFE_MODE_NATIVE;
2342     UFCALL(EXECUTE);
2343     ufeMode = oldmode;
2344   }
2345   // stack must be empty
2346   //if (ufeSP) ufeFatal("UFE finishing word primary imbalance!");
2347 }
2348
2349 // IMMEDIATE
2350 UFWORD(IMMEDIATE) {
2351   if (ufeLastDefinedZXWord) {
2352     // toggle IMM bit (bit 6)
2353     uint8_t b = getByte(ufeLastDefinedZXWord->nfa);
2354     b ^= 0x40;
2355     putByte(ufeLastDefinedZXWord->nfa, b);
2356   } else if (ufeLastDefinedNativeWord) {
2357     ufeForthDict->immediate = !ufeForthDict->immediate;
2358   } else {
2359     ufeFatal("UFE: wtf in `IMMEDIATE`");
2360   }
2361 }
2362
2363 UFWORD(RECURSE_IMM) {
2364   UFCALL(QCOMP);
2365   //if (!ufeGetState()) ufeFatal("not compiling");
2366   if (ufeMode == UFE_MODE_ZX) {
2367     ufeZXEmitU16(forthWordListTail->cfa);
2368   } else {
2369     ufeImgEmitU32(ufeForthDict->cfaidx);
2370   }
2371 }
2372
2373
2374 // ////////////////////////////////////////////////////////////////////////// //
2375 // code blocks
2376
2377 // (CODEBLOCK) ( -- )
2378 UFWORD(CODEBLOCK) {
2379   // current IP is "jump over" destination
2380   // next IP is cfaidx
2381   ufePush(ufeImgGetU32(ufeIP+1u)); // push cfa
2382   ufeIP = ufeImgGetU32(ufeIP); // branch over the code block
2383 }
2384
2385 // [[ -- start code block
2386 UFWORD(CODEBLOCK_START_IMM) {
2387   UFCALL(QCOMP);
2388   if (ufeMode == UFE_MODE_ZX) {
2389     ufeCompileZXWord("(CODEBLOCK)");
2390     ufePush(disp);
2391     emitWord(0); // jump destination
2392     // emit forth word cfa
2393     UrLabelInfo *lbl = findLabel("_doforth");
2394     if (!lbl) ufeFatal("'_doforth' label not found");
2395     emitWord(lbl->value); // cfa
2396   } else {
2397     UForthWord *fw = ufeAlwaysWord("(CODEBLOCK)");
2398     ufeImgEmitU32(fw->cfaidx);
2399     UFCALL(NATIVE_HERE);
2400     ufeImgEmitU32(0); // jump over
2401     // create nameless word
2402     fw = ufeCreateNamelessForthWord();
2403     ufeImgEmitU32(fw->cfaidx); // cfaidx
2404     fw->pfa = ufeImageUsed;
2405   }
2406   ufePush(666);
2407 }
2408
2409 // ]] -- end code block
2410 UFWORD(CODEBLOCK_END_IMM) {
2411   UFCALL(QCOMP);
2412   ufePush(666);
2413   UFCALL(QPAIRS);
2414   ufeCompileWord("EXIT"); // finish code block
2415   UFCALL(COMP_FWD);
2416 }
2417
2418
2419 // ////////////////////////////////////////////////////////////////////////// //
2420 // some ZX words
2421
2422 // <ZX>
2423 UFWORD(ZX_MODE) {
2424   ufeMode = UFE_MODE_ZX;
2425 }
2426
2427 // <NATIVE>
2428 UFWORD(NATIVE_MODE) {
2429   ufeMode = UFE_MODE_NATIVE;
2430 }
2431
2432 // <UFE-MODE@>
2433 UFWORD(UFE_MODER) {
2434   ufePush(ufeMode);
2435 }
2436
2437 // <UFE-MODE!>
2438 UFWORD(UFE_MODEW) {
2439   const uint32_t m = ufePop();
2440   if (m != UFE_MODE_NATIVE && m != UFE_MODE_ZX) ufeFatal("invalid ufe mode %u", m);
2441   ufeMode = m;
2442 }
2443
2444 // ZX-START-WORD
2445 UFWORD(ZX_START_WORD) {
2446   const char *wname = ufeZXWORD(' ');
2447   if (!wname) ufeFatal("forth word name expected");
2448   ForthWord *fw = findForthWord(wname);
2449   if (!fw) ufeFatal("zx forth word '%s' not found", wname);
2450   UrLabelInfo *lb = urFindLabel("DSFORTH_START_WORD_CFA");
2451   if (!lb) ufeFatal("label 'DSFORTH_START_WORD_CFA' not found");
2452   lb->value = fw->cfa;
2453   lb = urFindLabel("dsforth_start_word_cfa_addr_plus_2");
2454   if (!lb) ufeFatal("label 'dsforth_start_word_cfa_addr_plus_2' not found");
2455   if (lb->known) putWord(lb->value-2, fw->cfa);
2456   //fprintf(stderr, "************ #%04X\n", fw->cfa);
2457 }
2458
2459
2460
2461 // ////////////////////////////////////////////////////////////////////////// //
2462 // ZX-VALUE
2463 UFWORD(ZX_VALUE) {
2464   const char *wname = ufeZXWORD(' ');
2465   if (!wname) ufeFatal("forth word name expected");
2466   /*ForthWord *nw =*/ forthWordHead(wname, 0, FWT_VALUE);
2467   // cfa
2468   forthEmitCallToLabel("_doconst");
2469   // constant value
2470   ufeZXEmitU16(ufePop()&0xffffU);
2471 }
2472
2473 // ZX-VAR-NOALLOT
2474 UFWORD(ZX_VAR_NOALLOT) {
2475   const char *wname = ufeZXWORD(' ');
2476   if (!wname) ufeFatal("forth word name expected");
2477   /*ForthWord *nw =*/ forthWordHead(wname, 0, FWT_VAR);
2478   // cfa
2479   forthEmitCallToLabel("_dovar");
2480   // no variable value yet
2481 }
2482
2483 // ZX-VARIABLE
2484 UFWORD(ZX_VARIABLE) {
2485   UFCALL(ZX_VAR_NOALLOT);
2486   // variable value
2487   ufeZXEmitU16(ufePop()&0xffffU);
2488 }
2489
2490 // ZX-CONSTANT
2491 UFWORD(ZX_CONSTANT) {
2492   const char *wname = ufeZXWORD(' ');
2493   if (!wname) ufeFatal("forth word name expected");
2494   /*ForthWord *nw =*/ forthWordHead(wname, 0, FWT_CONST);
2495   // cfa
2496   forthEmitCallToLabel("_doconst");
2497   // variable value
2498   ufeZXEmitU16(ufePop()&0xffffU);
2499 }
2500
2501 // ZX-DEFER
2502 UFWORD(ZX_DEFER) {
2503   const char *wname = ufeZXWORD(' ');
2504   if (!wname) ufeFatal("forth word name expected");
2505   /*ForthWord *nw =*/ forthWordHead(wname, 0, FWT_DEFER);
2506   // cfa
2507   forthEmitCallToLabel("_dodefer");
2508   // cfa value
2509   ufeZXEmitU16(ufePop()&0xffffU);
2510 }
2511
2512 // ZX-DP@
2513 UFWORD(ZX_DP_PEEK) {
2514   ufePush(disp|UFE_ZX_ADDR_BIT);
2515 }
2516
2517 // ZX-DP!
2518 UFWORD(ZX_DP_POKE) {
2519   uint32_t ndp = ufePop();
2520   if ((ndp&UFE_ZX_ADDR_BIT) == 0) ufeFatal("invalid new zx DP");
2521   disp = ndp&UFE_ZX_ADDR_MASK;
2522 }
2523
2524 // ZX-ALLOT
2525 UFWORD(ZX_ALLOT) {
2526   int32_t sz = (int32_t)ufePop();
2527   if (sz == 0) return;
2528   if (sz < 0) {
2529     if (sz < -65535) ufeFatal("cannot allot %d bytes", sz);
2530     sz = -sz;
2531     if (disp < sz) ufeFatal("cannot unallot %d bytes", sz);
2532     disp -= sz;
2533     pc -= sz;
2534   } else {
2535     if (sz > 65535) ufeFatal("cannot allot %d bytes", sz);
2536     if (disp+sz > 65535) ufeFatal("cannot allot %d bytes", sz);
2537     // fill unused bytes with zeroes to avoid holes
2538     while (sz--) {
2539       if (!memused[disp]) {
2540         emitByte(0);
2541       } else {
2542         ++disp;
2543       }
2544     }
2545   }
2546   if (zxlblLastByte) zxlblLastByte->value = disp;
2547 }
2548
2549 // ZX-HERE
2550 UFWORD(ZX_HERE) {
2551   ufePush(disp|UFE_ZX_ADDR_BIT);
2552 }
2553
2554 // ZX-PAD
2555 // WARNING! keep in sync with dsForth!
2556 UFWORD(ZX_PAD) {
2557   ufePush((disp+68)|UFE_ZX_ADDR_BIT);
2558 }
2559
2560 // ZX-VARBIN
2561 UFWORD(ZX_VARBIN) {
2562   char *fnx = ufePopStrLit();
2563   const char *wname = ufeZXWORD(' ');
2564   if (!wname) ufeFatal("forth word name expected");
2565   //fprintf(stderr, "<%s>\n", wname);
2566   /*ForthWord *nw =*/ forthWordHead(wname, 0, FWT_VAR);
2567   // cfa
2568   forthEmitCallToLabel("_dovar");
2569   // variable value
2570   char *fn = fnx;
2571   int system = 0;
2572   int softinclude = 0;
2573   if (fn[0] == '?') { softinclude = 1; ++fn; while (isSpace(*fn)) ++fn; }
2574   if (!fn[0]) ufeFatal("ZX-VARBIN: empty file name");
2575   // now fix the name
2576   char *fname = createIncludeName(fn, system, NULL);
2577   free(fnx);
2578   FILE *fl = fopen(fname, "rb");
2579   if (!fl) {
2580     if (!softinclude) ufeFatal("ZX-VARBIN: file not found: '%s'", fname);
2581   } else {
2582     for (;;) {
2583       uint8_t bt;
2584       int res = fread(&bt, 1, 1, fl);
2585       if (!res) break;
2586       if (res != 1) { fclose(fl); ufeFatal("ZX-VARBIN: error reading file: '%s'", fname); }
2587       ufeZXEmitU8(bt);
2588     }
2589     fclose(fl);
2590   }
2591   free(fname);
2592 }
2593
2594 // ZX-TO_IMM
2595 UFWORD(ZX_TO_IMM) {
2596   const char *wname = ufeZXWORD(' ');
2597   ForthWord *fwdr = findForthWord(wname);
2598   if (!fwdr) ufeFatal("forth word `%s` not found", wname);
2599   if (fwdr->wtype != FWT_DEFER && fwdr->wtype != FWT_VALUE) ufeFatal("forth word `%s` is not VALUE/DEFER", wname);
2600   if (ufeGetState()) {
2601     // compiling
2602     // LITTO!
2603     ufeCompileZXWord("LITTO!");
2604     // emit pfa literal
2605     ufeZXEmitU16(fwdr->cfa+3u);
2606   } else {
2607     // interpreting
2608     putWord(fwdr->cfa+3u, ufePop()&0xffffU);
2609   }
2610 }
2611
2612 // ZX-STRTO
2613 UFWORD(ZX_STRTO) {
2614   char *wname = ufePopStrLit();
2615   ForthWord *fwdr = findForthWord(wname);
2616   if (!fwdr) ufeFatal("forth word `%s` not found", wname);
2617   if (fwdr->wtype != FWT_DEFER && fwdr->wtype != FWT_VALUE) ufeFatal("forth word `%s` is not VALUE/DEFER", wname);
2618   free(wname);
2619   if (ufeGetState()) {
2620     // compiling
2621     // LITTO!
2622     ufeCompileZXWord("LITTO!");
2623     // emit pfa literal
2624     ufeZXEmitU16(fwdr->cfa+3u);
2625   } else {
2626     // interpreting
2627     putWord(fwdr->cfa+3u, ufePop()&0xffffU);
2628   }
2629 }
2630
2631 // ZX-'
2632 UFWORD(ZX_TICKCFA_IMM) {
2633   const char *wname = ufeZXWORD(' ');
2634   ForthWord *fwdr = findForthWord(wname);
2635   if (!fwdr) ufeFatal("forth word `%s` not found", wname);
2636   ufePush(fwdr->cfa|UFE_ZX_ADDR_BIT);
2637   if (ufeGetState()) {
2638     UFCALL(LITERAL);
2639     ufeCompileWord(",");
2640   }
2641 }
2642
2643 // ZX-'PFA
2644 UFWORD(ZX_TICKPFA_IMM) {
2645   const char *wname = ufeZXWORD(' ');
2646   ForthWord *fwdr = findForthWord(wname);
2647   if (!fwdr) ufeFatal("forth word `%s` not found", wname);
2648   ufePush((fwdr->cfa+3u)|UFE_ZX_ADDR_BIT);
2649   if (ufeGetState()) {
2650     UFCALL(LITERAL);
2651     ufeCompileWord(",");
2652   }
2653 }
2654
2655
2656 // ////////////////////////////////////////////////////////////////////////// //
2657 static void ufeXBasedLiteral (int base) {
2658   const char *num = ufeZXWORD(' ');
2659   uint32_t n = 0;
2660   for (const char *s = num; *s; ++s) {
2661     if (*s == '_') continue;
2662     const int dig = digitInBase(*s, base);
2663     if (dig < 0) ufeFatal("invalid hex number '%s'", num);
2664     n = n*16u+(unsigned)dig;
2665   }
2666   ufePush(n);
2667   UFCALL(LITERAL);
2668 }
2669
2670
2671 UFWORD(ZEROX_IMM) { ufeXBasedLiteral(16); }
2672 UFWORD(ZEROO_IMM) { ufeXBasedLiteral(8); }
2673 UFWORD(ZEROB_IMM) { ufeXBasedLiteral(2); }
2674 UFWORD(ZEROD_IMM) { ufeXBasedLiteral(10); }
2675
2676
2677 // ////////////////////////////////////////////////////////////////////////// //
2678 static void ufeDoVariable (UForthWord *self) { ufePush(self->pfa); }
2679 static void ufeDoValue (UForthWord *self) { ufePush(ufeImgGetU32(self->pfa)); }
2680 static void ufeDoConst (UForthWord *self) { ufePush(ufeImgGetU32(self->pfa)); }
2681 static void ufeDoDefer (UForthWord *self) {
2682   const uint32_t cfaidx = ufeImgGetU32(self->pfa);
2683   if (cfaidx >= ufeCFAsUsed) ufeFatal("defered word '%s' contains invalid address", self->name);
2684   ufePush(cfaidx);
2685   UFCALL(EXECUTE);
2686 }
2687
2688 // NATIVE-VALUE
2689 UFWORD(NATIVE_VALUE) {
2690   UForthWord *fvar = doNativeCreate();
2691   fvar->cfa = &ufeDoValue;
2692   // variable value
2693   ufeImgEmitU32(ufePop());
2694 }
2695
2696 // NATIVE-VAR-NOALLOT
2697 UFWORD(NATIVE_VAR_NOALLOT) {
2698   UForthWord *fvar = doNativeCreate();
2699   fvar->cfa = &ufeDoVariable;
2700   // no variable value yet
2701 }
2702
2703 // NATIVE-VARIABLE
2704 UFWORD(NATIVE_VARIABLE) {
2705   UFCALL(NATIVE_VAR_NOALLOT);
2706   // variable value
2707   ufeImgEmitU32(ufePop());
2708 }
2709
2710 // NATIVE-CONSTANT
2711 UFWORD(NATIVE_CONSTANT) {
2712   UForthWord *fvar = doNativeCreate();
2713   fvar->cfa = &ufeDoConst;
2714   // variable value
2715   ufeImgEmitU32(ufePop());
2716 }
2717
2718 // NATIVE-DEFER
2719 UFWORD(NATIVE_DEFER) {
2720   UForthWord *fvar = doNativeCreate();
2721   fvar->cfa = &ufeDoDefer;
2722   // variable value
2723   ufeImgEmitU32(ufePop());
2724 }
2725
2726 // NATIVE-ALLOT
2727 UFWORD(NATIVE_ALLOT) {
2728   int32_t sz = (int32_t)ufePop();
2729   if (sz == 0) return;
2730   if (sz < 0) {
2731     if (sz < -1024*1024*64) ufeFatal("cannot allot %d bytes", sz);
2732     sz = -sz;
2733     // arbitrary safeguard
2734     if (ufeImageUsed < sz || ufeImageUsed-sz < 1024) ufeFatal("cannot unallot %d bytes", sz);
2735     ufeImageUsed -= sz;
2736   } else {
2737     if (sz > 1024*1024*64) ufeFatal("cannot allot %d bytes", sz);
2738     ufeImgEnsure(ufeImageUsed+sz);
2739   }
2740 }
2741
2742 // NATIVE-DP@
2743 UFWORD(NATIVE_DP_PEEK) {
2744   ufePush(ufeImageUsed);
2745 }
2746
2747 // NATIVE-DP!
2748 UFWORD(NATIVE_DP_POKE) {
2749   uint32_t ndp = ufePop();
2750   if (ndp >= ufeImageSize) ufeFatal("invalid new native DP");
2751   ufeImageUsed = ndp;
2752 }
2753
2754 // NATIVE-VARBIN
2755 UFWORD(NATIVE_VARBIN) {
2756   char *fnx = ufePopStrLit();
2757   UForthWord *fvar = doNativeCreate();
2758   fvar->cfa = &ufeDoVariable;
2759   // variable value
2760   char *fn = fnx;
2761   int system = 0;
2762   int softinclude = 0;
2763   if (fn[0] == '?') { softinclude = 1; ++fn; while (isSpace(*fn)) ++fn; }
2764   if (!fn[0]) ufeFatal("VARBIN: empty file name");
2765   // now fix the name
2766   char *fname = createIncludeName(fn, system, NULL);
2767   free(fnx);
2768   FILE *fl = fopen(fname, "rb");
2769   if (!fl) {
2770     if (!softinclude) ufeFatal("VARBIN: file not found: '%s'", fname);
2771   } else {
2772     for (;;) {
2773       uint8_t bt;
2774       int res = fread(&bt, 1, 1, fl);
2775       if (!res) break;
2776       if (res != 1) { fclose(fl); ufeFatal("VARBIN: error reading file: '%s'", fname); }
2777       ufeZXEmitU8(bt);
2778     }
2779     fclose(fl);
2780   }
2781   free(fname);
2782 }
2783
2784 static UForthWord *ufeNTWordAddrCount (void) {
2785   uint32_t count = ufePop();
2786   uint32_t addr = ufePop();
2787   UForthWord *fw = ufeNFind(addr, count);
2788   if (!fw) {
2789     UFCALL(SPACE); ufePush(addr); ufePush(count); UFCALL(XTYPE);
2790     printf("?\n");
2791     ufeFatal("unknown UFE word");
2792   }
2793   return fw;
2794 }
2795
2796 static UForthWord *ufeNTWord (void) {
2797   ufePush(32); UFCALL(WORD);
2798   UFCALL(COUNT);
2799   return ufeNTWordAddrCount();
2800 }
2801
2802 // NATIVE-TO
2803 UFWORD(NATIVE_TO_IMM) {
2804   UForthWord *fw = ufeNTWord();
2805   if (fw->cfa != &ufeDoValue && fw->cfa != &ufeDoDefer) ufeFatal("UFE word `%s` is not VALUE/DEFER", fw->name);
2806   if (ufeGetState()) {
2807     // compiling
2808     // literal
2809     ufeCompileNativeLiteral(fw->pfa);
2810     ufeCompileNativeWord("!");
2811   } else {
2812     // interpreting
2813     ufeImgPutU32(fw->pfa, ufePop());
2814   }
2815 }
2816
2817 // NATIVE-STRTO
2818 // ( value addr count -- )
2819 UFWORD(NATIVE_STRTO) {
2820   UForthWord *fw = ufeNTWordAddrCount();
2821   if (fw->cfa != &ufeDoValue && fw->cfa != &ufeDoDefer) ufeFatal("UFE word `%s` is not VALUE/DEFER", fw->name);
2822   if (ufeGetState()) {
2823     // compiling
2824     // literal
2825     ufeCompileNativeLiteral(fw->pfa);
2826     ufeCompileNativeWord("!");
2827   } else {
2828     // interpreting
2829     ufeImgPutU32(fw->pfa, ufePop());
2830   }
2831 }
2832
2833 // NATIVE-'
2834 UFWORD(NATIVE_TICKCFA_IMM) {
2835   ufePush(32); UFCALL(WORD);
2836   UFCALL(COUNT);
2837   ufePush(0u);
2838   UFCALL(NFIND); // ( cfa 1 ) | ( 0 )
2839   if (ufePop()) {
2840     uint32_t cfa = ufePop();
2841     // reject ZX words
2842     if ((cfa&UFE_ZX_ADDR_BIT) != 0) ufeFatal("cannot ' ZX word");
2843     if (ufeGetState()) {
2844       ufeCompileNativeLiteral(cfa);
2845       ufeCompileNativeWord(",");
2846     } else {
2847       ufePush(cfa);
2848     }
2849   } else {
2850     UFCALL(NATIVE_HERE); UFCALL(COUNT); UFCALL(SPACE); UFCALL(XTYPE);
2851     printf("?"); UFCALL(CR);
2852     ufeFatal("UFE: unknown word");
2853   }
2854 }
2855
2856 // NATIVE-'PFA
2857 UFWORD(NATIVE_TICKPFA_IMM) {
2858   ufePush(32); UFCALL(WORD);
2859   UFCALL(COUNT);
2860   ufePush(0u);
2861   UFCALL(NFIND); // ( cfa 1 ) | ( 0 )
2862   if (ufePop()) {
2863     uint32_t cfa = ufePop();
2864     // reject ZX words
2865     if ((cfa&UFE_ZX_ADDR_BIT) != 0) ufeFatal("cannot ' ZX word");
2866     ufePush(ufeNFindNativeWordResult->pfa);
2867     if (ufeGetState()) {
2868       ufeCompileNativeLiteral(ufeNFindNativeWordResult->pfa);
2869       ufeCompileNativeWord(",");
2870     } else {
2871       ufePush(ufeNFindNativeWordResult->pfa);
2872     }
2873   } else {
2874     UFCALL(NATIVE_HERE); UFCALL(COUNT); UFCALL(SPACE); UFCALL(XTYPE);
2875     printf("?"); UFCALL(CR);
2876     ufeFatal("UFE: unknown word");
2877   }
2878 }
2879
2880
2881 // ////////////////////////////////////////////////////////////////////////// //
2882 #define UFWORD_2MODES(wname_) \
2883 UFWORD(wname_) { \
2884   if (ufeGetState()) { \
2885     /* compiling */ \
2886     /*FIXME: check for ZX turnkey! */ \
2887     if (ufeMode == UFE_MODE_ZX) ufeCompileZXWord(""#wname_); else ufeCompileNativeWord("NATIVE-"#wname_); \
2888   } else { \
2889     if (ufeMode == UFE_MODE_ZX) UFCALL(ZX_##wname_); else UFCALL(NATIVE_##wname_); \
2890   } \
2891 }
2892
2893 #define UFWORD_2MODES_X(wname_,fwname_) \
2894 UFWORD(wname_) { \
2895   if (ufeGetState()) { \
2896     /* compiling */ \
2897     /*FIXME: check for ZX turnkey! */ \
2898     if (ufeMode == UFE_MODE_ZX) ufeCompileZXWord(""#fwname_); else ufeCompileNativeWord("NATIVE-"#fwname_); \
2899   } else { \
2900     if (ufeMode == UFE_MODE_ZX) UFCALL(ZX_##wname_); else UFCALL(NATIVE_##wname_); \
2901   } \
2902 }
2903
2904 #define UFWORD_2MODES_IMM(wname_) \
2905 UFWORD(wname_) { \
2906   if (ufeMode == UFE_MODE_ZX) UFCALL(ZX_##wname_); else UFCALL(NATIVE_##wname_); \
2907 }
2908
2909 // VALUE
2910 UFWORD_2MODES(VALUE)
2911 // VARIABLE
2912 UFWORD_2MODES(VARIABLE)
2913 // VAR-NOALLOT
2914 UFWORD_2MODES(VAR_NOALLOT)
2915 // CONSTANT
2916 UFWORD_2MODES(CONSTANT)
2917 // DEFER
2918 UFWORD_2MODES(DEFER)
2919 // ALLOT
2920 UFWORD_2MODES(ALLOT)
2921 // HERE
2922 UFWORD_2MODES(HERE)
2923 // PAD
2924 UFWORD_2MODES(PAD)
2925 // DP@
2926 UFWORD_2MODES_X(DP_PEEK, DP@)
2927 // DP!
2928 UFWORD_2MODES_X(DP_POKE, DP!)
2929 // TO
2930 UFWORD_2MODES_IMM(TO_IMM)
2931 // STRTO
2932 UFWORD_2MODES(STRTO)
2933 // '
2934 UFWORD_2MODES_IMM(TICKCFA_IMM)
2935 // 'PFA
2936 UFWORD_2MODES_IMM(TICKPFA_IMM)
2937
2938 // VARBIN
2939 UFWORD(VARBIN) {
2940   if (ufeGetState()) {
2941     // compiling
2942     //FIXME: check for ZX turnkey!
2943     if (ufeMode == UFE_MODE_ZX) ufeFatal("dsForth has no `VARBIN`");
2944     ufeCompileNativeWord("NATIVE-VARBIN");
2945   } else {
2946     if (ufeMode == UFE_MODE_ZX) UFCALL(ZX_VARBIN); else UFCALL(NATIVE_VARBIN);
2947   }
2948 }
2949
2950
2951 // [
2952 UFWORD(LSQBRACKET_IMM) {
2953   ufeSetState(0);
2954 }
2955
2956 // ]
2957 UFWORD(RSQBRACKET) {
2958   ufeSetState(1);
2959 }
2960
2961
2962 // ////////////////////////////////////////////////////////////////////////// //
2963 // UrAsm API
2964
2965 // UR-HAS-LABEL?
2966 // ( addr count -- flag )
2967 UFWORD(UR_HAS_LABELQ) {
2968   char *name = ufePopStrLit();
2969   ufePush(urFindLabel(name) ? 1u : 0u);
2970   free(name);
2971 }
2972
2973 // UR-GET-LABEL
2974 // ( addr count -- value )
2975 // fatals when the label is not found
2976 UFWORD(UR_GET_LABELQ) {
2977   char *name = ufePopStrLit();
2978   UrLabelInfo *lbl = urFindLabel(name);
2979   if (!lbl) ufeFatal("label '%s' not found", name);
2980   free(name);
2981   int32_t v = lbl->value;
2982   ufePush((uint32_t)v);
2983 }
2984
2985 // UR-FOREACH-LABEL
2986 // ( cfa -- res )
2987 // EXECUTEs cfa, returns final res
2988 // cfa: ( addr count -- stopflag )
2989 // i.e. return non-zero from cfa to stop
2990 // res is the result of the last called cfa
2991 UFWORD(UR_FOREACH_LABEL) {
2992   uint32_t cfaidx = ufePop();
2993   uint32_t res = 0;
2994   for (UrLabelInfo *c = labels; c; c = c->next) {
2995     uint32_t addr = ufePutTempStrLiteral(c->name, UFE_PAD1_OFFSET);
2996     uint32_t count = ufeImgGetU32(addr++);
2997     ufePush(addr);
2998     ufePush(count);
2999     ufePush(cfaidx);
3000     UFCALL(EXECUTE);
3001     res = ufePop();
3002     if (res) break;
3003   }
3004   ufePush(res);
3005 }
3006
3007 // UR-PASS?
3008 // ( -- pass )
3009 UFWORD(UR_PASSQ) {
3010   ufePush(pass);
3011 }
3012
3013 // UR-AFTER-TRACE?
3014 // ( -- pass )
3015 UFWORD(UR_AFTER_TRACEQ) {
3016   ufePush(ufeAfterTrace);
3017 }
3018
3019 // UR-ZX-FIND-WORD
3020 // ( addr count -- cfa 1 // 0 )
3021 UFWORD(UR_ZX_FIND_WORD) {
3022   char *name = ufePopStrLit();
3023   for (char *s = name; *s; ++s) *s = toUpper(*s);
3024   ForthWord *fw = findForthWord(name);
3025   free(name);
3026   if (fw) {
3027     ufePush(fw->cfa|UFE_ZX_ADDR_BIT);
3028     ufePush(1);
3029   } else {
3030     ufePush(0);
3031   }
3032 }
3033
3034 // UR-ZX-WORD-NAME-BY-CFA
3035 // ( cfa -- addr count 1 // 0 )
3036 UFWORD(UR_ZX_WORD_NAME_BY_CFA) {
3037   uint32_t cfa = ufePop();
3038   // accept non-zx address too
3039   //if ((cfa&UFE_ZX_ADDR_BIT) == 0) { ufePush(0); return; }
3040   cfa &= UFE_ZX_ADDR_MASK;
3041   for (ForthWord *w = forthWordList; w; w = w->next) {
3042     if (w->cfa == cfa) {
3043       uint32_t addr = ufePutTempStrLiteral((w->name[0] ? w->name : "~"), UFE_PAD1_OFFSET);
3044       ufePush(addr+1);
3045       ufePush(ufeImgGetU32(addr));
3046       ufePush(1);
3047       return;
3048     }
3049   }
3050   ufePush(0);
3051 }
3052
3053 // UR-ZX-WORD-USED-BY-CFA?
3054 // ( cfa -- flag )
3055 UFWORD(UR_ZX_WORD_USED_BY_CFAQ) {
3056   uint32_t cfa = ufePop();
3057   // accept non-zx address too
3058   //if ((cfa&UFE_ZX_ADDR_BIT) == 0) { ufePush(0); return; }
3059   cfa &= UFE_ZX_ADDR_MASK;
3060   for (ForthWord *w = forthWordList; w; w = w->next) {
3061     if (w->cfa == cfa) {
3062       ufePush(w->usedmark ? 1u : 0u);
3063       return;
3064     }
3065   }
3066   ufePush(0);
3067 }
3068
3069 // UR-ZX-WORD-USED-BY-CFA-1!
3070 // ( cfa -- )
3071 UFWORD(UR_ZX_WORD_USED_BY_CFA_1POKE) {
3072   uint32_t cfa = ufePop();
3073   // accept non-zx address too
3074   //if ((cfa&UFE_ZX_ADDR_BIT) == 0) { ufePush(0); return; }
3075   cfa &= UFE_ZX_ADDR_MASK;
3076   for (ForthWord *w = forthWordList; w; w = w->next) {
3077     if (w->cfa == cfa) {
3078       w->usedmark = 1;
3079       return;
3080     }
3081   }
3082 }
3083
3084 // UR-ZX-WORD-FLAGS-BY-CFA
3085 // ( cfa -- flags )
3086 //   bit 0: branch
3087 //   bit 1: numlit
3088 //   bit 2: strlit
3089 //   bit 3: noreturn
3090 //   bit 4: noturnkey
3091 //   bit 5: immediate
3092 //   bit 6: unconditional branch
3093 //   bit 7: used mark
3094 //   bit 8: (codeblock)
3095 UFWORD(UR_ZX_WORD_FLAGS_BY_CFA) {
3096   uint32_t cfa = ufePop();
3097   // accept non-zx address too
3098   //if ((cfa&UFE_ZX_ADDR_BIT) == 0) { ufePush(0); return; }
3099   cfa &= UFE_ZX_ADDR_MASK;
3100   for (ForthWord *w = forthWordList; w; w = w->next) {
3101     if (w->cfa == cfa) {
3102       uint32_t flags = 0u;
3103       if (w->isbranch) flags |= (1u<<0);
3104       if (w->isnumlit) flags |= (1u<<1);
3105       if (w->isstrlit) flags |= (1u<<2);
3106       if (w->isnoreturn) flags |= (1u<<3);
3107       if (w->isnoturnkey) flags |= (1u<<4);
3108       if (w->immediate) flags |= (1u<<5);
3109       if (w->isuncondbranch) flags |= (1u<<6);
3110       if (w->usedmark) flags |= (1u<<7);
3111       if (w->codeblock) flags |= (1u<<8);
3112       //if (flags) fprintf(stderr, " <%s>: #%02X; %d;%d;%d;%d;%d;%d;%d\n", w->name, flags, w->isbranch, w->isnumlit, w->isstrlit, w->isnoreturn, w->isnoturnkey, w->immediate, w->isuncondbranch);
3113       ufePush(flags);
3114       return;
3115     }
3116   }
3117   ufePush(0);
3118 }
3119
3120 // UR-ZX-LAST-FORTH-WORD-NAME
3121 // ( -- addr count )
3122 UFWORD(UR_ZX_LAST_FORTH_WORD_NAME) {
3123   ForthWord *w = forthWordListTail;
3124   uint32_t addr = ufePutTempStrLiteral((w ? (w->name[0] ? w->name : "~") : ""), UFE_PAD1_OFFSET);
3125   ufePush(addr+1);
3126   ufePush(ufeImgGetU32(addr));
3127 }
3128
3129 // UR-ZX-LAST-FORTH-WORD-CFA
3130 UFWORD(UR_ZX_LAST_FORTH_WORD_CFA) {
3131   ForthWord *w = forthWordListTail;
3132   uint32_t addr = (w ? w->cfa|UFE_ZX_ADDR_BIT : 0);
3133   ufePush(addr);
3134 }
3135
3136 // UR-ZX-WORD-TYPE-BY-CFA
3137 // ( cfa -- wtype )
3138 UFWORD(UR_ZX_WORD_TYPE_BY_CFA) {
3139   uint32_t cfa = ufePop();
3140   // accept non-zx address too
3141   //if ((cfa&UFE_ZX_ADDR_BIT) == 0) { ufePush(0); return; }
3142   cfa &= UFE_ZX_ADDR_MASK;
3143   for (ForthWord *w = forthWordList; w; w = w->next) {
3144     if (w->cfa == cfa) {
3145       ufePush(w->wtype);
3146       return;
3147     }
3148   }
3149   ufePush(FWT_OTHER); //TODO: return -1?
3150 }
3151
3152
3153 // ////////////////////////////////////////////////////////////////////////// //
3154 // conditional compilation
3155 typedef struct UForthCondDefine_t UForthCondDefine;
3156 struct UForthCondDefine_t {
3157   char *name;
3158   uint32_t value;
3159   UForthCondDefine *prev;
3160 };
3161
3162 static UForthCondDefine *ufeCondDefines = NULL;
3163
3164
3165 static UForthCondDefine *ufeFindCondDefine (const char *name) {
3166   if (!name || !name[0]) return NULL;
3167   for (UForthCondDefine *dd = ufeCondDefines; dd; dd = dd->prev) {
3168     if (strcmp(dd->name, name) == 0) return dd;
3169   }
3170   return NULL;
3171 }
3172
3173
3174 static void ufeAddCondDefine (const char *name, uint32_t value) {
3175   if (!name || !name[0]) return;
3176   for (UForthCondDefine *dd = ufeCondDefines; dd; dd = dd->prev) {
3177     if (strcmp(dd->name, name) == 0) {
3178       dd->value = value;
3179       return;
3180     }
3181   }
3182   UForthCondDefine *dd = malloc(sizeof(UForthCondDefine));
3183   dd->name = strdup(name);
3184   dd->value = value;
3185   dd->prev = ufeCondDefines;
3186   ufeCondDefines = dd;
3187 }
3188
3189
3190 static void ufeRemoveCondDefine (const char *name) {
3191   if (!name || !name[0]) return;
3192   UForthCondDefine *pp = NULL;
3193   for (UForthCondDefine *dd = ufeCondDefines; dd; dd = dd->prev) {
3194     if (strcmp(dd->name, name) == 0) {
3195       if (pp) pp->prev = dd->prev; else ufeCondDefines = dd->prev;
3196       free(dd->name);
3197       free(dd);
3198       return;
3199     }
3200     pp = dd;
3201   }
3202 }
3203
3204
3205 enum {
3206   UFE_COND_IFDEF    = 0u,
3207   UFE_COND_IFNDEF   = 1u,
3208   UFE_COND_IF       = 2u,
3209   UFE_COND_IFNOT    = 3u,
3210   UFE_COND_IFZX     = 4u,
3211   UFE_COND_IFNATIVE = 5u,
3212   UFE_COND_NONE     = 666u,
3213 };
3214
3215
3216 static int strStartsWithCI (const char *s, const char *pat) {
3217   if (!pat[0]) return 0;
3218   while (*s && *pat) {
3219     if (toUpper(*s) != toUpper(*pat)) return 0;
3220     ++s;
3221     ++pat;
3222   }
3223   return (pat[0] == 0);
3224 }
3225
3226 static int strIsEmpty (const char *s) {
3227   while (*s && isSpace(*s)) ++s;
3228   if (!s[0]) return 1;
3229   // check for comments
3230   if (s[0] == '\\' && (!s[1] || isSpace(s[1]))) return 1;
3231   if (s[0] == ';' && s[1] == ';' && (!s[2] || isSpace(s[2]))) return 1;
3232   if (s[0] == '(' && isSpace(s[1])) {
3233     // skip comment
3234     s += 2;
3235     while (*s && *s != ')') ++s;
3236     if (*s == ')') ++s;
3237     return strIsEmpty(s);
3238   }
3239   return 0;
3240 }
3241
3242 static int strStartsWithWordCI (const char *s, const char *pat) {
3243   if (!strStartsWithCI(s, pat)) return 0;
3244   s += strlen(pat);
3245   return (!s[0] || isSpace(s[0]));
3246 }
3247
3248 static void ufeCondLoadNextLine (int stline) {
3249   const int rd = ufeLoadNextLine();
3250   if (rd < -1) ufeFatal("error reading UFE input buffer");
3251   if (rd == -1) ufeFatal("unfinished conditional from line %d", stline);
3252 }
3253
3254 static void ufeSkipConditionals (int toelse) {
3255   const int stline = ufeInFileLine;
3256   int iflevel = 0;
3257   for (;;) {
3258     ufeCondLoadNextLine(stline);
3259     char *s = ufeCurrFileLine;
3260     while (*s && isSpace(*s)) ++s;
3261     if (!s[0]) continue;
3262     //fprintf(stderr, "  skipcond(toelse=%d; nest=%d); line %d: %s", toelse, iflevel, ufeInFileLine, s);
3263     // nested conditionals
3264     if (strStartsWithWordCI(s, "$IF") ||
3265         strStartsWithWordCI(s, "$IFNOT") ||
3266         strStartsWithWordCI(s, "$IFDEF") ||
3267         strStartsWithWordCI(s, "$IFNDEF"))
3268     {
3269       ++iflevel;
3270       continue;
3271     }
3272     // in nested ifs, look only for $ENDIF
3273     if (iflevel) {
3274       if (!strStartsWithWordCI(s, "$ENDIF")) continue;
3275       if (!strIsEmpty(s+6)) ufeFatal("invalid $ENDIF");
3276       --iflevel;
3277       continue;
3278     }
3279     // else?
3280     // $ELSE
3281     if (strStartsWithWordCI(s, "$ELSE")) {
3282       if (!strIsEmpty(s+5)) ufeFatal("invalid $ELSE");
3283       // if we're skipping "true" part, go on
3284       if (toelse) {
3285         ufeCondLoadNextLine(stline);
3286         ++ufeInCondIf;
3287         return;
3288       }
3289       // we're skipping "false" part, there should be no else
3290       ufeFatal("unexpected $ELSE, skipping from line %d", stline);
3291     }
3292     if (strStartsWithWordCI(s, "$ENDIF")) {
3293       // it doesn't matter which part we're skipping, it ends here anyway
3294       if (!strIsEmpty(s+6)) ufeFatal("invalid $ENDIF");
3295       ufeCondLoadNextLine(stline);
3296       return;
3297     }
3298     // $ELIF/$ELIFNOT/$ELIFDEF/$ELIFNDEF
3299     unsigned cc = UFE_COND_NONE;
3300          if (strStartsWithWordCI(s, "$ELIF")) cc = UFE_COND_IF;
3301     else if (strStartsWithWordCI(s, "$ELIFNOT")) cc =UFE_COND_IFNOT;
3302     else if (strStartsWithWordCI(s, "$ELIFDEF")) cc = UFE_COND_IFDEF;
3303     else if (strStartsWithWordCI(s, "$ELIFNDEF")) cc = UFE_COND_IFNDEF;
3304     else if (strStartsWithWordCI(s, "$ELIFZX")) cc = UFE_COND_IFZX;
3305     else if (strStartsWithWordCI(s, "$ELIFNATIVE")) cc = UFE_COND_IFNATIVE;
3306     if (cc == UFE_COND_NONE) continue;
3307     // if we're skipping "true" part, go on
3308     if (toelse) return ufeDoConditional(UFE_COND_IFNOT, 1); // skip first word
3309     // we're skipping "false" part, there should be no else
3310     ufeFatal("unexpected $ELIFxx, skipping from line %d", stline);
3311   }
3312 }
3313
3314 static void ufeDoConditional (unsigned type, int skipword) {
3315   //if (ufeInCondIf) ufeFatal("conditional inside another conditional -- seems unbalanced");
3316   unsigned res;
3317   ufePush(32); UFCALL(WORD);
3318   if (skipword) { ufeDrop(); ufePush(32); UFCALL(WORD); }
3319   UFCALL(COUNT);
3320   char *name = ufePopStrLit();
3321   if (type == UFE_COND_IF && strcmp(name, "0") == 0) {
3322     res = 0;
3323   } else if (type == UFE_COND_IF && strcmp(name, "1") == 0) {
3324     res = 1;
3325   } else {
3326     UForthCondDefine *def = ufeFindCondDefine(name);
3327     //if (def) fprintf(stderr, "FOUNDDEF: <%s>=%u\n", def->name, def->value);
3328     UrLabelInfo *lbl = urFindLabel(name);
3329     switch (type) {
3330       case UFE_COND_IFDEF: res = !!lbl || !!def; break;
3331       case UFE_COND_IFNDEF: res = !lbl && !def; break;
3332       case UFE_COND_IF: res = (def ? !!def->value : lbl ? !!lbl->value : 0); break;
3333       case UFE_COND_IFNOT: res = (def ? !def->value : lbl ? !lbl->value : 0); break;
3334       case UFE_COND_IFZX: res = (ufeMode == UFE_MODE_ZX); break;
3335       case UFE_COND_IFNATIVE: res = (ufeMode == UFE_MODE_NATIVE); break;
3336       default: ufeFatal("what conditional?");
3337     }
3338   }
3339   free(name);
3340   //fprintf(stderr, "line %d: cond=%u; res=%u; lbl=%d (%d)\n", ufeInFileLine, type, res, (lbl ? lbl->value : 0), (lbl ? 1 : 0));
3341   if (!res) return ufeSkipConditionals(1);
3342   ++ufeInCondIf;
3343 }
3344
3345 // $DEFINE word
3346 UFWORD(DLR_DEFINE) {
3347   ufePush(32); UFCALL(WORD);
3348   UFCALL(COUNT);
3349   char *name = ufePopStrLit();
3350   ufeAddCondDefine(name, 1);
3351   free(name);
3352 }
3353
3354 // $UNDEF word
3355 UFWORD(DLR_UNDEF) {
3356   ufePush(32); UFCALL(WORD);
3357   UFCALL(COUNT);
3358   char *name = ufePopStrLit();
3359   ufeRemoveCondDefine(name);
3360   free(name);
3361 }
3362
3363 // these words can be encoundered only when we done with some $IF, so skip to $ENDIF
3364 // $ELSE
3365 UFWORD(DLR_ELSE_IMM) { if (!ufeInCondIf) ufeFatal("$ELSE without $IF"); ufeSkipConditionals(0); }
3366 // $ELIFDEF
3367 UFWORD(DLR_ELIFDEF_IMM) { if (!ufeInCondIf) ufeFatal("$ELIFDEF without $IF"); --ufeInCondIf; ufeSkipConditionals(0); }
3368 // $ELIFNDEF
3369 UFWORD(DLR_ELIFNDEF_IMM) { if (!ufeInCondIf) ufeFatal("$ELIFNDEF without $IF"); --ufeInCondIf; ufeSkipConditionals(0); }
3370 // $ELIF
3371 UFWORD(DLR_ELIF_IMM) { if (!ufeInCondIf) ufeFatal("$ELIF without $IF"); --ufeInCondIf; ufeSkipConditionals(0); }
3372 // $ELIFNOT
3373 UFWORD(DLR_ELIFNOT_IMM) { if (!ufeInCondIf) ufeFatal("$ELIFNOT without $IF"); --ufeInCondIf; ufeSkipConditionals(0); }
3374 // $ELIFZX
3375 UFWORD(DLR_ELIFZX_IMM) { if (!ufeInCondIf) ufeFatal("$ELIFZX without $IF"); --ufeInCondIf; ufeSkipConditionals(0); }
3376 // $ELIFNATIVE
3377 UFWORD(DLR_ELIFNATIVE_IMM) { if (!ufeInCondIf) ufeFatal("$ELIFNATIVE without $IF"); --ufeInCondIf; ufeSkipConditionals(0); }
3378 // $ENDIF
3379 UFWORD(DLR_ENDIF_IMM) { if (!ufeInCondIf) ufeFatal("$ENDIF without $IF"); --ufeInCondIf; }
3380
3381 // $IFDEF labelname
3382 UFWORD(DLR_IFDEF_IMM) { ufeDoConditional(UFE_COND_IFDEF, 0); }
3383 // $IFNDEF labelname
3384 UFWORD(DLR_IFNDEF_IMM) { ufeDoConditional(UFE_COND_IFNDEF, 0); }
3385 // $IF labelname
3386 // undefined label is false too
3387 UFWORD(DLR_IF_IMM) { ufeDoConditional(UFE_COND_IF, 0); }
3388 // $IFNOT labelname
3389 // undefined label is true too
3390 UFWORD(DLR_IFNOT_IMM) { ufeDoConditional(UFE_COND_IFNOT, 0); }
3391 // $IFZX
3392 UFWORD(DLR_IFZX_IMM) { ufeDoConditional(UFE_COND_IFZX, 0); }
3393 // $IFNATIVE
3394 UFWORD(DLR_IFNATIVE_IMM) { ufeDoConditional(UFE_COND_IFNATIVE, 0); }
3395
3396 // $INCLUDE fname
3397 UFWORD(DLR_INCLUDE_IMM) {
3398   uint8_t qCh;
3399   for (;;) {
3400     uint8_t ch = ufeGetInChar();
3401     if (!ch) ufeFatal("$INCLUDE wants filename");
3402     if (ch == '"' || ch == '<') {
3403       qCh = ch;
3404       break;
3405     }
3406     if (!isSpace((char)ch)) ufeFatal("$INCLUDE filename must be quoted");
3407   }
3408   int system = (qCh == '<');
3409   char fname[1024];
3410   size_t fnpos = 0;
3411   for (;;) {
3412     uint8_t ch = ufeGetInChar();
3413     if (!ch) ufeFatal("$INCLUDE wants properly quoted filename");
3414     if ((char)ch == qCh) break;
3415     if (fnpos >= sizeof(fname)-2)  ufeFatal("$INCLUDE filename too long");
3416     fname[fnpos++] = (char)ch;
3417   }
3418   fname[fnpos] = 0;
3419   char *fn = fname;
3420   int softinclude = 0;
3421   if (*fn == '?') {
3422     softinclude = 1;
3423     ++fn;
3424     while (isSpace(*fn)) ++fn;
3425     if (!fn[0]) ufeFatal("$INCLUDE: softinclude what?");
3426   }
3427   char *ffn = ufeCreateIncludeName(fn, system);
3428   FILE *fl = fopen(ffn, "rb");
3429   if (!fl) {
3430     if (softinclude) { free(ffn); return; }
3431     ufeFatal("$INCLUDE: file '%s' not found", ffn);
3432   }
3433   ufePushInFile();
3434   ufeInFile = fl;
3435   ufeInFileLine = 0;
3436   ufeInFileName = ffn;
3437   // trigger next line loading
3438   ufeTIB = 0;
3439   ufeIN = 0;
3440   ufeImgEnsure(0);
3441   ufeImgPutU32(0, 0);
3442 }
3443
3444
3445 // DUMP-STACK
3446 // ( -- )
3447 UFWORD(DUMP_STACK) {
3448   printf("***UFE STACK DEPTH: %u\n", ufeSP);
3449   for (uint32_t sp = 0; sp < ufeSP; ++sp) printf("  %4u: 0x%08x  %d\n", sp, ufeDStack[sp], (int32_t)ufeDStack[sp]);
3450 }
3451
3452
3453 // UFE-FATAL
3454 // ( addr count )
3455 UFWORD(UFE_FATAL) {
3456   //fprintf(stderr, "***UFE STACK DEPTH: %u\n", ufeSP); for (uint32_t sp = 0; sp < ufeSP; ++sp) fprintf(stderr, "  %4u: 0x%08x  %d\n", sp, ufeDStack[sp], (int32_t)ufeDStack[sp]);
3457   char *str = ufePopStrLit();
3458   ufeFatal(str);
3459 }
3460
3461
3462 // ////////////////////////////////////////////////////////////////////////// //
3463 // main loop
3464 //
3465
3466 static __attribute__((unused)) void ufeDefine (const char *wname) {
3467   if (ufeFindWord(wname)) {
3468     printf("'%s' redefined\n", wname);
3469     ufeLastEmitWasCR = 1;
3470   }
3471   UForthWord *fw = ufeRegisterWord(wname, &ufeDoForth, 0);
3472   fw->pfa = ufeImageUsed;
3473   //fprintf(stderr, "***DEFINING #%u: <%s> at 0x%08x\n", ufeCFAsUsed-1u, ufeForthCFAs[ufeCFAsUsed-1u]->name, fw->pfa);
3474   ufeSetState(1); // compiling
3475 }
3476
3477 static __attribute__((unused)) void ufeDefineDone (void) {
3478   ufeLastDefinedZXWord = NULL;
3479   ufeLastDefinedNativeWord = NULL;
3480   UFCALL(QCOMP);
3481   if (ufeSP) ufeFatal("UFE finishing word primary imbalance!");
3482   //if (!ufeForthDict || ufeForthDict->cfa) ufeFatal("UFE ';' without ':'");
3483   if (ufeForthDict->pfa == 0xffffffffU) abort();
3484   ufeForthDict->cfa = &ufeDoForth;
3485   ufeCompileNativeWord("EXIT");
3486   //ufeDecompileForth(ufeForthDict);
3487   ufeLastDefinedNativeWord = ufeForthDict;
3488   ufeSetState(0); // interpreting
3489 }
3490
3491 static __attribute__((unused)) void ufeNumber (uint32_t v) {
3492   UForthWord *fw = ufeAlwaysWord("LIT");
3493   ufeImgEmitU32(fw->cfaidx);
3494   ufeImgEmitU32(v);
3495 }
3496
3497 static __attribute__((unused)) void ufeCompile (const char *wname) {
3498   UForthWord *fw = ufeFindWord(wname);
3499   if (!fw) {
3500     // try a number
3501     char *end;
3502     long v = strtol(wname, &end, 0);
3503     if (end == wname || *end) ufeFatal("UFE word '%s' not found", wname);
3504     ufeNumber((uint32_t)v);
3505   } else {
3506     // compile/execute a word
3507     if (fw->immediate) {
3508       fw->cfa(fw);
3509     } else {
3510       ufeImgEmitU32(fw->cfaidx);
3511     }
3512   }
3513 }
3514
3515 static __attribute__((unused)) void ufeString (const char *str) {
3516   UForthWord *fw = ufeAlwaysWord("(\")");
3517   ufeImgEmitU32(fw->cfaidx);
3518   if (!str) str = "";
3519   size_t slen = strlen(str);
3520   if (slen > 65535) ufeFatal("UFE string too long");
3521   ufeImgEmitU32((uint32_t)slen);
3522   while (slen--) {
3523     ufeImgEmitU32((uint32_t)(str[0]&0xffU));
3524     ++str;
3525   }
3526 }
3527
3528 static __attribute__((unused)) void ufeDotString (const char *str) {
3529   UForthWord *fw = ufeAlwaysWord("(.\")");
3530   ufeImgEmitU32(fw->cfaidx);
3531   if (!str) str = "";
3532   size_t slen = strlen(str);
3533   if (slen > 65535) ufeFatal("UFE string too long");
3534   ufeImgEmitU32((uint32_t)slen);
3535   while (slen--) {
3536     ufeImgEmitU32((uint32_t)(str[0]&0xffU));
3537     ++str;
3538   }
3539 }
3540
3541
3542 #define UFC(wn_)   ufeCompile(""#wn_);
3543 #define UFS(wn_)   ufeString(""#wn_);
3544 #define UFDS(wn_)  ufeDotString(""#wn_);
3545 #define UFN(wn_)   ufeNumber(wn_);
3546
3547 #define UFBEGIN  UFCALL(BEGIN);
3548 #define UFAGAIN  UFCALL(AGAIN);
3549
3550
3551 static void ufeDefineQuit (void) {
3552   ufeDefine("UFE-RUN-LOOP");
3553   UFBEGIN
3554     UFC(RP0!)
3555     UFC(INTERPRET)
3556   UFAGAIN
3557   ufeDefineDone();
3558 }
3559
3560 static void ufeDefineMisc (void) {
3561   ufeDefine("HEX");
3562   ufeNumber(16); UFC(BASE); UFC(!);
3563   ufeDefineDone();
3564
3565   ufeDefine("DECIMAL");
3566   ufeNumber(10); UFC(BASE); UFC(!);
3567   ufeDefineDone();
3568
3569   ufeDefine("0!");
3570   UFC(0) UFC(SWAP) UFC(!)
3571   ufeDefineDone();
3572
3573   ufeDefine("1!");
3574   UFC(1) UFC(SWAP) UFC(!)
3575   ufeDefineDone();
3576
3577   ufeDefine("+!");
3578   UFC(DUP) UFC(@) UFC(ROT) UFC(+) UFC(SWAP) UFC(!)
3579   ufeDefineDone();
3580
3581   ufeDefine("-!");
3582   UFC(DUP) UFC(@) UFC(ROT) UFC(SWAP) UFC(-) UFC(SWAP) UFC(!)
3583   ufeDefineDone();
3584
3585   ufeDefine("1+!");
3586   UFC(DUP) UFC(@) UFC(1+) UFC(SWAP) UFC(!)
3587   ufeDefineDone();
3588
3589   ufeDefine("2+!");
3590   UFC(DUP) UFC(@) UFC(2+) UFC(SWAP) UFC(!)
3591   ufeDefineDone();
3592
3593   ufeDefine("3+!");
3594   UFC(DUP) UFC(@) UFC(3+) UFC(SWAP) UFC(!)
3595   ufeDefineDone();
3596
3597   ufeDefine("4+!");
3598   UFC(DUP) UFC(@) UFC(4+) UFC(SWAP) UFC(!)
3599   ufeDefineDone();
3600
3601   ufeDefine("1-!");
3602   UFC(DUP) UFC(@) UFC(1-) UFC(SWAP) UFC(!)
3603   ufeDefineDone();
3604
3605   ufeDefine("2-!");
3606   UFC(DUP) UFC(@) UFC(2-) UFC(SWAP) UFC(!)
3607   ufeDefineDone();
3608
3609   ufeDefine("3-!");
3610   UFC(DUP) UFC(@) UFC(3-) UFC(SWAP) UFC(!)
3611   ufeDefineDone();
3612
3613   ufeDefine("4-!");
3614   UFC(DUP) UFC(@) UFC(4-) UFC(SWAP) UFC(!)
3615   ufeDefineDone();
3616
3617   ufeDefine("0=");
3618   ufeNumber(0); UFC(=);
3619   ufeDefineDone();
3620
3621   ufeDefine("0<>");
3622   ufeNumber(0); UFC(<>);
3623   ufeDefineDone();
3624
3625   ufeDefine("0!=");
3626   ufeNumber(0); UFC(!=);
3627   ufeDefineDone();
3628
3629   ufeDefine("0<");
3630   ufeNumber(0); UFC(<);
3631   ufeDefineDone();
3632
3633   ufeDefine("0>");
3634   ufeNumber(0); UFC(>);
3635   ufeDefineDone();
3636
3637   ufeDefine("U0>");
3638   ufeNumber(0); UFC(U>);
3639   ufeDefineDone();
3640
3641   ufeDefine("NOOP");
3642   ufeDefineDone();
3643 }
3644
3645
3646 // ////////////////////////////////////////////////////////////////////////// //
3647 // debug breakpoint
3648 #include "urforth_dbg.c"
3649
3650 // (UFE-BP)
3651 UFWORD(UFE_BP) {
3652   #ifdef WIN32
3653   ufeFatal("there is no UFE debug breakpoint support in windoze");
3654   #else
3655   if (isatty(STDIN_FILENO) && isatty(STDOUT_FILENO)) {
3656     ufeDebugSession();
3657   } else {
3658     fprintf(stderr, "WARNING: cannot start UFE debug session, because standard streams are not on TTY!\n");
3659   }
3660   #endif
3661 }
3662
3663
3664 // ////////////////////////////////////////////////////////////////////////// //
3665 #undef UFWORD
3666
3667 #define UFWORD(name_) ufeRegisterWord(""#name_, ufeWord_##name_, 0)
3668 #define UFWORDX(strname_,name_) ufeRegisterWord(strname_, ufeWord_##name_, 0)
3669
3670 #define UFWORD_IMM(name_) ufeRegisterWord(""#name_, ufeWord_##name_, 1)
3671 #define UFWORDX_IMM(strname_,name_) ufeRegisterWord(strname_, ufeWord_##name_, 1)
3672
3673
3674 static void ufeInit (void) {
3675   ufeMode = UFE_MODE_NATIVE;
3676   ufeInCondIf = 0;
3677
3678   zxlblLastByte = urFindLabel("latest_byte");
3679   //if (!zxlblLastByte) ufeFatal("label 'latest_byte' not found");
3680
3681   ufeDStack = calloc(UFE_DSTACK_SIZE, sizeof(ufeDStack[0]));
3682   ufeRStack = calloc(UFE_RSTACK_SIZE, sizeof(ufeRStack[0]));
3683   ufeForthCFAs = calloc(UFE_MAX_WORDS, sizeof(ufeForthCFAs[0]));
3684
3685   // reserve TIB
3686   while (ufeImageUsed <= ufeTIBAreaSize) ufeImgEmitU32(0);
3687
3688   // BASE
3689   ufeBASEaddr = ufeImageUsed;
3690   ufeImgEmitU32(10);
3691
3692   // STATE
3693   ufeSTATEaddr = ufeImageUsed;
3694   ufeImgEmitU32(0);
3695
3696   ufeSetState(0); // ensure interpreting
3697
3698   // base low-level interpreter words
3699   UFWORDX("SP0!", SP0_PUT);
3700   UFWORDX("RP0!", RP0_PUT);
3701   UFWORD(BASE);
3702   UFWORD(STATE);
3703   UFWORDX("@", PEEK);
3704   UFWORDX("!", POKE);
3705   UFWORDX("C@", CPEEK);
3706   UFWORDX("C!", CPOKE);
3707   UFWORDX("W@", WPEEK);
3708   UFWORDX("W!", WPOKE);
3709   UFWORDX("C,", CCOMMA);
3710   UFWORDX(",", COMMA);
3711   UFWORDX("ZXADDR?", ZXADDRQ);
3712   UFWORDX("(TOZX)", TOZX);
3713   UFWORDX_IMM("TOZX", TOZX_IMM);
3714   UFWORDX("(FROMZX)", FROMZX);
3715   UFWORDX_IMM("FROMZX", FROMZX_IMM);
3716
3717   UFWORD(LIT);
3718   UFWORD(BRANCH);
3719   UFWORD(TBRANCH);
3720   UFWORDX("0BRANCH", FBRANCH);
3721   UFWORDX("(DO)", DO_PAREN);
3722   UFWORDX("(LOOP)", LOOP_PAREN);
3723   UFWORDX("(+LOOP)", PLOOP_PAREN);
3724
3725   UFWORDX_IMM("RECURSE", RECURSE_IMM);
3726   UFWORD(EXECUTE);
3727
3728   UFWORD(DUP);
3729   UFWORDX("?DUP", QDUP);
3730   UFWORDX("2DUP", DDUP);
3731   UFWORD(DROP);
3732   UFWORDX("2DROP", DDROP);
3733   UFWORD(SWAP);
3734   UFWORDX("2SWAP", DSWAP);
3735   UFWORD(OVER);
3736   UFWORDX("2OVER", DOVER);
3737   UFWORD(ROT);
3738   UFWORD(NROT);
3739
3740   UFWORD(RDUP);
3741   UFWORD(RDROP);
3742   UFWORD(RSWAP);
3743   UFWORD(ROVER);
3744   UFWORD(RROT);
3745   UFWORD(RNROT);
3746
3747   UFWORDX(">R", DTOR);
3748   UFWORDX("R>", RTOD);
3749   UFWORDX("R@", RPEEK);
3750
3751   UFWORDX("CMOVE>", CMOVE_FWD);
3752   UFWORDX("CMOVE", CMOVE_BACK);
3753   UFWORDX("MOVE", MOVE);
3754
3755   UFWORDX("STR=", STREQU);
3756   UFWORDX("STR=CI", STREQUCI);
3757
3758   // some useful words
3759   UFWORDX_IMM("(", COMMENTPAREN);
3760   UFWORDX_IMM("\\", COMMENTEOL);
3761   UFWORDX_IMM(";;", COMMENTEOL);
3762
3763   UFWORD(COUNT);
3764   UFWORD(EMIT);
3765   UFWORD(XEMIT);
3766   UFWORD(TYPE);
3767   UFWORD(XTYPE);
3768   UFWORD(SPACE);
3769   UFWORD(SPACES);
3770   UFWORD(CR);
3771   UFWORD(ENDCR);
3772
3773   // number printing
3774   UFWORDX(".", DOT);
3775   UFWORDX("U.", UDOT);
3776   UFWORDX(".R", DOTR);
3777   UFWORDX("U.R", UDOTR);
3778
3779   // simple math
3780   UFWORD(NEGATE);
3781   UFWORDX("+", PLUS);
3782   UFWORDX("-", MINUS);
3783   UFWORDX("*", MUL);
3784   UFWORDX("U*", UMUL);
3785   UFWORDX("/", DIV);
3786   UFWORDX("U/", UDIV);
3787   UFWORDX("MOD", MOD);
3788   UFWORDX("UMOD", UMOD);
3789   UFWORDX("/MOD", DIVMOD);
3790   UFWORDX("U/MOD", UDIVMOD);
3791
3792   // logic
3793   UFWORDX("<", LESS);
3794   UFWORDX(">", GREAT);
3795   UFWORDX("<=", LESSEQU);
3796   UFWORDX(">=", GREATEQU);
3797   UFWORDX("U<", ULESS);
3798   UFWORDX("U>", UGREAT);
3799   UFWORDX("U<=", ULESSEQU);
3800   UFWORDX("U>=", UGREATEQU);
3801   UFWORDX("=", EQU);
3802   UFWORDX("<>", NOTEQU);
3803   UFWORDX("!=", NOTEQU);
3804   UFWORD(NOT);
3805   UFWORD(NOTNOT);
3806   UFWORD(BITNOT);
3807   UFWORD(AND);
3808   UFWORD(LAND);
3809   UFWORD(OR);
3810   UFWORD(LOR);
3811   UFWORD(XOR);
3812
3813   UFWORDX("1+", ONEPLUS);
3814   UFWORDX("1-", ONEMINUS);
3815   UFWORDX("2+", TWOPLUS);
3816   UFWORDX("2-", TWOMINUS);
3817   UFWORDX("3+", THREEPLUS);
3818   UFWORDX("3-", THREEMINUS);
3819   UFWORDX("4+", FOURPLUS);
3820   UFWORDX("4-", FOURMINUS);
3821   UFWORDX("2U*", ONESHL);
3822   UFWORDX("2U/", ONESHR);
3823
3824   UFWORDX("SHL", SHL);
3825   UFWORDX("SHR", SHR);
3826
3827   // low-level compiler words
3828   UFWORDX("LITERAL", LITERAL);
3829   UFWORDX("STRLITERAL", STRLITERAL);
3830   UFWORDX("(UNESCAPE)", UNESCAPE_PAREN);
3831   UFWORDX("(\")", STRQ_PAREN);
3832   UFWORDX("(.\")", STRDOTQ_PAREN);
3833
3834   UFWORDX_IMM("\"", STRQ);
3835   UFWORDX_IMM(".\"", STRDOTQ);
3836
3837   UFWORDX("?EXEC", QEXEC);
3838   UFWORDX("?COMP", QCOMP);
3839   UFWORDX("?PAIRS", QPAIRS);
3840   UFWORDX_IMM("COMPILE", COMPILE_IMM);
3841   UFWORDX_IMM("[COMPILE]", XCOMPILE_IMM);
3842   UFWORDX("COMP-BACK", COMP_BACK);
3843   UFWORDX("COMP-FWD", COMP_FWD);
3844
3845   UFWORD(EXIT);
3846
3847   UFWORD_IMM(IF);
3848   UFWORD_IMM(IFNOT);
3849   UFWORD_IMM(ELSE);
3850   UFWORD_IMM(ENDIF);
3851   UFWORDX_IMM("THEN", ENDIF);
3852   UFWORD_IMM(BEGIN);
3853   UFWORD_IMM(AGAIN);
3854   UFWORD_IMM(WHILE);
3855   UFWORD_IMM(REPEAT);
3856   UFWORD_IMM(UNTIL);
3857   UFWORD_IMM(CASE);
3858   UFWORD_IMM(ENDCASE);
3859   UFWORD_IMM(OF);
3860   UFWORDX_IMM("&OF", AND_OF);
3861   UFWORD_IMM(ENDOF);
3862   UFWORD_IMM(OTHERWISE);
3863   UFWORD_IMM(DO);
3864   UFWORD_IMM(LOOP);
3865   UFWORDX_IMM("+LOOP", PLOOP);
3866   UFWORD(I);
3867   UFWORD(J);
3868   UFWORDX("I'", ITICK);
3869   UFWORDX("J'", JTICK);
3870
3871   UFWORDX(":", COLON);
3872   UFWORDX("ZX:", ZX_COLON);
3873   UFWORDX_IMM(";", SEMI);
3874   UFWORD(IMMEDIATE);
3875
3876   // TIB parser
3877   UFWORD(WORD);
3878
3879   // interpreter
3880   UFWORD(NFIND);
3881   UFWORDX("(NUMBER)", XNUMBER);
3882   UFWORD(INTERPRET);
3883
3884   // some ZX words
3885   UFWORDX_IMM("<ZX>", ZX_MODE);
3886   UFWORDX_IMM("<NATIVE>", NATIVE_MODE);
3887   UFWORDX("<UFE-MODE@>", UFE_MODER);
3888   UFWORDX("<UFE-MODE!>", UFE_MODEW);
3889
3890   UFWORDX("ZX-VALUE", ZX_VALUE);
3891   UFWORDX("ZX-VAR-NOALLOT", ZX_VAR_NOALLOT);
3892   UFWORDX("ZX-VARIABLE", ZX_VARIABLE);
3893   UFWORDX("ZX-CONSTANT", ZX_CONSTANT);
3894   UFWORDX("ZX-DEFER", ZX_DEFER);
3895   UFWORDX("ZX-VARBIN", ZX_VARBIN);
3896   UFWORDX("ZX-ALLOT", ZX_ALLOT);
3897   UFWORDX("ZX-HERE", ZX_HERE);
3898   UFWORDX("ZX-PAD", ZX_PAD);
3899   UFWORDX("ZX-DP@", ZX_DP_PEEK);
3900   UFWORDX("ZX-DP!", ZX_DP_POKE);
3901   UFWORDX_IMM("ZX-TO", ZX_TO_IMM);
3902   UFWORDX_IMM("ZX-STRTO", ZX_STRTO);
3903   UFWORDX_IMM("ZX-'", ZX_TICKCFA_IMM);
3904   UFWORDX_IMM("ZX-'PFA", ZX_TICKPFA_IMM);
3905
3906   UFWORDX("NATIVE-VALUE", NATIVE_VALUE);
3907   UFWORDX("NATIVE-VAR-NOALLOT", NATIVE_VAR_NOALLOT);
3908   UFWORDX("NATIVE-VARIABLE", NATIVE_VARIABLE);
3909   UFWORDX("NATIVE-CONSTANT", NATIVE_CONSTANT);
3910   UFWORDX("NATIVE-DEFER", NATIVE_DEFER);
3911   UFWORDX("NATIVE-VARBIN", NATIVE_VARBIN);
3912   UFWORDX("NATIVE-ALLOT", NATIVE_ALLOT);
3913   UFWORDX("NATIVE-HERE", NATIVE_HERE);
3914   UFWORDX("NATIVE-PAD", NATIVE_PAD);
3915   UFWORDX("NATIVE-DP@", NATIVE_DP_PEEK);
3916   UFWORDX("NATIVE-DP!", NATIVE_DP_POKE);
3917   UFWORDX_IMM("NATIVE-TO", NATIVE_TO_IMM);
3918   UFWORDX_IMM("NATIVE-STRTO", NATIVE_STRTO);
3919   UFWORDX_IMM("NATIVE-'", NATIVE_TICKCFA_IMM);
3920   UFWORDX_IMM("NATIVE-'PFA", NATIVE_TICKPFA_IMM);
3921
3922   UFWORDX_IMM("VALUE", VALUE);
3923   UFWORDX_IMM("VAR-NOALLOT", VAR_NOALLOT);
3924   UFWORDX_IMM("VARIABLE", VARIABLE);
3925   UFWORDX_IMM("CONSTANT", CONSTANT);
3926   UFWORDX_IMM("DEFER", DEFER);
3927   UFWORDX_IMM("VARBIN", VARBIN);
3928   UFWORDX_IMM("ALLOT", ALLOT);
3929   UFWORDX_IMM("HERE", HERE);
3930   UFWORDX_IMM("PAD", PAD);
3931   UFWORDX_IMM("DP@", DP_PEEK);
3932   UFWORDX_IMM("DP!", DP_POKE);
3933   UFWORDX_IMM("TO", TO_IMM);
3934   UFWORDX_IMM("STRTO", STRTO);
3935   UFWORDX_IMM("'", TICKCFA_IMM);
3936   UFWORDX_IMM("'PFA", TICKPFA_IMM);
3937
3938   UFWORDX_IMM("[0X]", ZEROX_IMM);
3939   UFWORDX_IMM("[0O]", ZEROO_IMM);
3940   UFWORDX_IMM("[0B]", ZEROB_IMM);
3941   UFWORDX_IMM("[0D]", ZEROD_IMM);
3942
3943   UFWORDX_IMM("[", LSQBRACKET_IMM);
3944   UFWORDX("]", RSQBRACKET);
3945
3946   UFWORDX("(CODEBLOCK)", CODEBLOCK);
3947   UFWORDX_IMM("[:", CODEBLOCK_START_IMM);
3948   UFWORDX_IMM(";]", CODEBLOCK_END_IMM);
3949     /* code blocks are used like this:
3950          : A  [[ ( addr count -- res ) TYPE 0 ]] UR-FOREACH-LABEL DROP ;
3951        i.e. it creates inlined code block, and returns its CFA.
3952      */
3953
3954   // UrAsm API
3955   UFWORDX("UR-HAS-LABEL?", UR_HAS_LABELQ);
3956   UFWORDX("UR-GET-LABEL", UR_GET_LABELQ);
3957   UFWORDX("UR-FOREACH-LABEL", UR_FOREACH_LABEL);
3958   UFWORDX("UR-PASS?", UR_PASSQ);
3959   UFWORDX("UR-AFTER-TRACE?", UR_AFTER_TRACEQ);
3960
3961   UFWORDX("UR-ZX-FIND-WORD", UR_ZX_FIND_WORD);
3962   UFWORDX("UR-ZX-WORD-NAME-BY-CFA", UR_ZX_WORD_NAME_BY_CFA);
3963   UFWORDX("UR-ZX-WORD-FLAGS-BY-CFA", UR_ZX_WORD_FLAGS_BY_CFA);
3964   UFWORDX("UR-ZX-WORD-USED-BY-CFA?", UR_ZX_WORD_USED_BY_CFAQ);
3965   UFWORDX("UR-ZX-WORD-USED-BY-CFA-1!", UR_ZX_WORD_USED_BY_CFA_1POKE);
3966   UFWORDX("UR-ZX-LAST-FORTH-WORD-NAME", UR_ZX_LAST_FORTH_WORD_NAME);
3967   UFWORDX("UR-ZX-LAST-FORTH-WORD-CFA", UR_ZX_LAST_FORTH_WORD_CFA);
3968   UFWORDX("UR-ZX-WORD-TYPE-BY-CFA", UR_ZX_WORD_TYPE_BY_CFA);
3969
3970   // conditional compilation
3971   UFWORDX_IMM("$IFDEF", DLR_IFDEF_IMM);
3972   UFWORDX_IMM("$IFNDEF", DLR_IFNDEF_IMM);
3973   UFWORDX_IMM("$IF", DLR_IF_IMM);
3974   UFWORDX_IMM("$IFNOT", DLR_IFNOT_IMM);
3975   UFWORDX_IMM("$ELSE", DLR_ELSE_IMM);
3976   UFWORDX_IMM("$ELIFDEF", DLR_ELIFDEF_IMM);
3977   UFWORDX_IMM("$ELIFNDEF", DLR_ELIFNDEF_IMM);
3978   UFWORDX_IMM("$ELIF", DLR_ELIF_IMM);
3979   UFWORDX_IMM("$ELIFNOT", DLR_ELIFNOT_IMM);
3980   UFWORDX_IMM("$IFZX", DLR_IFZX_IMM);
3981   UFWORDX_IMM("$IFNATIVE", DLR_IFNATIVE_IMM);
3982   UFWORDX_IMM("$ELIFZX", DLR_ELIFZX_IMM);
3983   UFWORDX_IMM("$ELIFNATIVE", DLR_ELIFNATIVE_IMM);
3984   UFWORDX_IMM("$ENDIF", DLR_ENDIF_IMM);
3985
3986   UFWORDX_IMM("$DEFINE", DLR_DEFINE);
3987   UFWORDX_IMM("$UNDEF", DLR_UNDEF);
3988
3989   UFWORDX_IMM("$INCLUDE", DLR_INCLUDE_IMM);
3990
3991   UFWORDX("ZX-START-WORD", ZX_START_WORD);
3992
3993   UFWORDX("DUMP-STACK", DUMP_STACK);
3994   UFWORDX("UFE-FATAL", UFE_FATAL);
3995
3996   UFWORDX("(UFE-BP)", UFE_BP);
3997
3998   ufeDefineQuit();
3999   ufeDefineMisc();
4000
4001   ufeSetState(0); // interpreting
4002 }
4003
4004
4005 // ////////////////////////////////////////////////////////////////////////// //
4006 // address interpreter
4007 static void ufeRunVM (void) {
4008   ufeStopVM = 0;
4009   while (!ufeStopVM) {
4010     uint32_t cfaidx = ufeImgGetU32(ufeIP++);
4011     if (cfaidx >= ufeCFAsUsed) {
4012       //abort();
4013       ufeFatal("UFE tried to execute an unknown word: 0x%08x (max is 0x%08x); IP=0x%08x", cfaidx, ufeCFAsUsed, ufeIP-1);
4014     }
4015     UForthWord *fw = ufeForthCFAs[cfaidx];
4016     //fprintf(stderr, "...<%s>\n", fw->name);
4017     fw->cfa(fw);
4018     //fprintf(stderr, "....<%s>\n", fw->name);
4019   }
4020 }
4021
4022 static void ufeRunIt (const char *wname) {
4023   UForthWord *fw = ufeAlwaysWord(wname);
4024   if (fw->cfa != &ufeDoForth) ufeFatal("UFE '%s' word is not Forth word", wname);
4025   ufeIP = fw->pfa;
4026   ufeRunVM();
4027 }
4028
4029
4030 // ////////////////////////////////////////////////////////////////////////// //
4031 static int runForthEngine (const char *fname) {
4032   ufeInit();
4033   ufeInFile = fopen(fname, "rb");
4034   if (!ufeInFile) ufeFatal("cannot open UFE file '%s'", fname);
4035   if (pc != disp) ufeFatal("UFE can be used only for non-disped code");
4036   ufeInFileLine = 0;
4037   ufeInFileName = strdup(fname);
4038   ufeTIB = 0;
4039   ufeIN = 0;
4040   ufeImgEnsure(0);
4041   ufeImgPutU32(0, 0); // trigger next line loading
4042
4043   // load ufe modules
4044   char *ufmname = ufeCreateIncludeName("zzmain.f", 1);
4045   FILE *ufl = fopen(ufmname, "rb");
4046   if (ufl) {
4047     ufePushInFile();
4048     ufeInFileName = ufmname;
4049     ufeInFile = ufl;
4050   } else {
4051     free(ufmname);
4052   }
4053
4054   if (setjmp(ufeEOFJP)) {
4055     fclose(ufeInFile);
4056     printf("UFE complete\n");
4057     //UrLabelInfo *lhb = urFindLabel("VLIST_HASH_BITS");
4058     uint16_t lwa = 0;
4059     for (ForthWord *fw = forthWordList; fw; fw = fw->next) {
4060       if (fw->nfa > lwa) lwa = fw->nfa;
4061     }
4062     UrLabelInfo *zxlblLastWordAddr = urFindLabel("latest_word_addr");
4063     //if (!zxlblLastWordAddr) ufeFatal("label 'latest_word' not found");
4064     if (zxlblLastWordAddr) {
4065       //lwa += (lhb && lhb->value ? 2 : 0);
4066       //fprintf(stderr, "LATEST WORD: #%04X (at #%04X); old=#%04X\n", lwa, (unsigned)zxlblLastWordAddr->value, getWord(zxlblLastWordAddr->value));
4067       putWord(zxlblLastWordAddr->value, lwa);
4068       //fprintf(stderr, "LATEST BYTE: #%04X (#%04X)\n", disp, zxlblLastByte->value);
4069       //zxlblLastByte = urFindLabel("latest_byte");
4070     }
4071     ufeDeinit();
4072     return 0;
4073   }
4074   //UFCALL(INTERPRET);
4075   ufeRunIt("UFE-RUN-LOOP");
4076   abort(); // the thing that should not be
4077   return 0;
4078 }