UrForth: added "FORTH:(DATASKIP)"
[urasm.git] / src / liburforth / urforth.c
blob362953deb576a73cfa4ea7614d03b0ee94a35c46
1 // and now for something completely different...
2 // UrAsm built-in Forth Engine!
3 // GPLv3 ONLY
4 #ifdef WIN32
5 #include <windows.h>
6 #endif
7 #include <stdarg.h>
8 #include <setjmp.h>
9 #include <stdio.h>
10 #include <stdlib.h>
11 #include <string.h>
12 #include <time.h>
13 #include <unistd.h>
15 #include <sys/stat.h>
16 #include <sys/types.h>
18 #include "urforth.h"
20 #ifdef WIN32
21 # define realpath(shit,fuck) _fullpath(fuck, shit, 32768)
22 #endif
25 //#define UFO_DEBUG_WRITE_MAIN_IMAGE
26 //#define UFO_DEBUG_WRITE_DEBUG_IMAGE
29 #define UFO_DEBUG_STARTUP_TIMES
30 //#define UFO_DEBUG_FATAL_ABORT
31 #define UFO_DEBUG_DEBUG /* ;-) */
32 //#define UFO_TRACE_VM_DOER
33 //#define UFO_TRACE_VM_RUN
34 //#define UFO_DEBUG_INCLUDE
35 //#define UFO_DEBUG_DUMP_NEW_HEADERS
36 //#define UFO_DEBUG_FIND_WORD
37 //#define UFO_DEBUG_FIND_WORD_IN_VOC
38 //#define UFO_DEBUG_FIND_WORD_COLON
40 // 2/8 msecs w/o inlining
41 // 1/5 msecs with inlining
42 #if 1
43 # define UFO_FORCE_INLINE static inline __attribute__((always_inline))
44 #else
45 # define UFO_FORCE_INLINE static __attribute__((noinline)) /*__attribute__((unused))*/
46 #endif
47 #define UFO_DISABLE_INLINE static __attribute__((noinline)) /*__attribute__((unused))*/
49 // detect arch, and use faster memory access code on x86
50 #if defined(__x86_64__) || defined(_M_X64) || \
51 defined(i386) || defined(__i386__) || defined(__i386) || defined(_M_IX86)
52 # define UFO_FAST_MEM_ACCESS
53 #endif
55 // should not be bigger than this!
56 #define UFO_MAX_WORD_LENGTH (250)
58 #define UFO_ALIGN4(v_) (((v_) + 3u) / 4u * 4u)
61 // ////////////////////////////////////////////////////////////////////////// //
62 static void ufoFlushOutput (void);
64 static const char *ufo_assert_failure (const char *cond, const char *fname, int fline, const char *func) {
65 for (const char *t = fname; *t; ++t) {
66 #ifdef WIN32
67 if (*t == '/' || *t == '\\') fname = t+1;
68 #else
69 if (*t == '/') fname = t+1;
70 #endif
72 ufoFlushOutput();
73 fprintf(stderr, "\n%s:%d: Assertion in `%s` failed: %s\n", fname, fline, func, cond);
74 ufoFlushOutput();
75 abort();
78 #define ufo_assert(cond_) do { if (__builtin_expect((!(cond_)), 0)) { ufo_assert_failure(#cond_, __FILE__, __LINE__, __PRETTY_FUNCTION__); } } while (0)
81 static char ufoRealPathBuf[32769];
82 static char ufoRealPathHashBuf[32769];
85 //==========================================================================
87 // ufoRealPath
89 //==========================================================================
90 static char *ufoRealPath (const char *fname) {
91 char *res;
92 if (fname != NULL && fname[0] != 0) {
93 res = realpath(fname, NULL);
94 if (res != NULL) {
95 const size_t slen = strlen(res);
96 if (slen < 32768) {
97 strcpy(ufoRealPathBuf, res);
98 free(res);
99 res = ufoRealPathBuf;
100 } else {
101 free(res);
102 res = NULL;
105 } else {
106 res = NULL;
108 return res;
112 #ifndef WIN32
113 static time_t secstart = 0;
114 #endif
118 //==========================================================================
120 // ufo_get_msecs
122 //==========================================================================
123 static uint64_t ufo_get_msecs (void) {
124 #ifdef WIN32
125 return GetTickCount();
126 #else
127 struct timespec ts;
128 #ifdef CLOCK_MONOTONIC
129 ufo_assert(clock_gettime(CLOCK_MONOTONIC, &ts) == 0);
130 #else
131 // this should be available everywhere
132 ufo_assert(clock_gettime(CLOCK_REALTIME, &ts) == 0);
133 #endif
134 // first run?
135 if (secstart == 0) {
136 secstart = ts.tv_sec+1;
137 ufo_assert(secstart); // it should not be zero
139 return (uint64_t)(ts.tv_sec-secstart+2)*1000U+(uint32_t)ts.tv_nsec/1000000U;
140 // nanoseconds
141 //return (uint64_t)(ts.tv_sec-secstart+2)*1000000000U+(uint32_t)ts.tv_nsec;
142 #endif
146 //==========================================================================
148 // joaatHashBuf
150 //==========================================================================
151 UFO_FORCE_INLINE uint32_t joaatHashBuf (const void *buf, size_t len, uint8_t orbyte) {
152 uint32_t hash = 0x29a;
153 const uint8_t *s = (const uint8_t *)buf;
154 while (len--) {
155 hash += (*s++)|orbyte;
156 hash += hash<<10;
157 hash ^= hash>>6;
159 // finalize
160 hash += hash<<3;
161 hash ^= hash>>11;
162 hash += hash<<15;
163 return hash;
167 // this converts ASCII capitals to locase (and destroys other, but who cares)
168 #define joaatHashBufCI(buf_,len_) joaatHashBuf((buf_), (len_), 0x20)
171 //==========================================================================
173 // toUpper
175 //==========================================================================
176 UFO_FORCE_INLINE char toUpper (char ch) {
177 return (ch >= 'a' && ch <= 'z' ? ch-'a'+'A' : ch);
181 //==========================================================================
183 // toUpperU8
185 //==========================================================================
186 UFO_FORCE_INLINE uint8_t toUpperU8 (uint8_t ch) {
187 return (ch >= 'a' && ch <= 'z' ? ch-'a'+'A' : ch);
191 //==========================================================================
193 // digitInBase
195 //==========================================================================
196 UFO_FORCE_INLINE int digitInBase (char ch, int base) {
197 switch (ch) {
198 case '0' ... '9': ch = ch - '0'; break;
199 case 'A' ... 'Z': ch = ch - 'A' + 10; break;
200 case 'a' ... 'z': ch = ch - 'a' + 10; break;
201 default: base = -1; break;
203 return (ch >= 0 && ch < base ? ch : -1);
208 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
209 ;; word header format:
210 ;; note than name hash is ALWAYS calculated with ASCII-uppercased name
211 ;; (actually, bit 5 is always reset for all bytes, because we don't need the
212 ;; exact uppercase, only something that resembles it)
213 ;; bfa points to next bfa or to 0 (this is "hash bucket pointer")
214 ;; before nfa, we have such "hidden" fields:
215 ;; dd xfa ; points to the previous word header SFA, regardless of vocabularies (or 0)
216 ;; dd yfa ; points to the previous word header SFA, regardless of vocabularies (or 0)
217 ;; dd bfa ; next word in hashtable bucket; it is always here, even if hashtable is turned off
218 ;; ; if there is no hashtable, this field is not used
219 ;; lfa:
220 ;; dd lfa ; previous vocabulary word LFA or 0 (lfa links points here)
221 ;; dd namehash ; it is always here, and always calculated, even if hashtable is turned off
222 ;; nfa:
223 ;; dd flags-and-name-len ; see below
224 ;; db name ; no terminating zero or other "termination flag" here
225 ;; here could be some 0 bytes to align everything to 4 bytes
226 ;; db namelen ; yes, name length again, so CFA->NFA can avoid guessing
227 ;; ; full length, including padding, but not including this byte
228 ;; cfa:
229 ;; dd cfaidx ; our internal CFA index, or image address for DOES>
230 ;; pfa:
231 ;; word data follows
233 ;; first word cell contains combined name length (low byte), argtype and flags (other bytes)
234 ;; layout:
235 ;; db namelen
236 ;; db argtype
237 ;; dw flags
238 ;; i.e. we have 16 bits for flags, and 256 possible argument types. why not.
240 ;; flags:
241 ;; bit 0: immediate
242 ;; bit 1: smudge
243 ;; bit 2: noreturn
244 ;; bit 3: hidden
245 ;; bit 4: codeblock
246 ;; bit 5: vocabulary
247 ;; bit 6: *UNUSED* main scattered colon word (with "...")
248 ;; bit 7: protected
250 ;; argtype is the type of the argument that this word reads from the threaded code.
251 ;; possible argument types:
252 ;; 0: none
253 ;; 1: branch address
254 ;; 2: cell-size numeric literal
255 ;; 3: cell-counted string with terminating zero (not counted)
256 ;; 4: cfa of another word
257 ;; 5: cblock
258 ;; 6: vocid
259 ;; 7: byte-counted string with terminating zero (not counted)
260 ;; 8: data skip: the arg is amout of bytes to skip (not including the counter itself)
263 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
264 ;; wordlist structure (at PFA)
265 ;; -4: wordlist type id (used by structs, for example)
266 ;; dd latest
267 ;; dd voclink (voclink always points here)
268 ;; dd parent (if not zero, all parent words are visible)
269 ;; dd header-nfa (can be 0 for anonymous wordlists)
270 ;; hashtable (if enabled), or ~0U if no hash table
274 // ////////////////////////////////////////////////////////////////////////// //
275 #define UFO_BFA_TO_LFA(bfa_) ((bfa_) + 1u * 4u)
276 #define UFO_LFA_TO_XFA(lfa_) ((lfa_) - 3u * 4u)
277 #define UFO_LFA_TO_YFA(lfa_) ((lfa_) - 2u * 4u)
278 #define UFO_LFA_TO_BFA(lfa_) ((lfa_) - 1u * 4u)
279 #define UFO_LFA_TO_NFA(lfa_) ((lfa_) + 2u * 4u)
280 #define UFO_LFA_TO_CFA(lfa_) UFO_ALIGN4((lfa_) + 3u * 4u + 1u + ufoImgGetU8((lfa_) + 2u * 4u))
281 #define UFO_LFA_TO_NHASH(lfa_) ((lfa_) + 1u * 4u)
282 #define UFO_CFA_TO_NFA(cfa_) ((cfa_) - 1u - 4u - ufoImgGetU8((cfa_) - 1u))
283 #define UFO_CFA_TO_LFA(cfa_) ((cfa_) - 1u - 4u * 3u - ufoImgGetU8((cfa_) - 1u))
284 #define UFO_CFA_TO_PFA(cfa_) ((cfa_) + 1u * 4u)
285 #define UFO_PFA_TO_CFA(pfa_) ((pfa_) - 1u * 4u)
286 #define UFO_NFA_TO_CFA(nfa_) UFO_ALIGN4((nfa_) + 4u + 1u + ufoImgGetU8((nfa_)))
287 #define UFO_NFA_TO_LFA(nfa_) ((nfa_) - 2u * 4u)
288 #define UFO_XFA_TO_YFA(xfa_) ((xfa_) + 4u)
289 #define UFO_YFA_TO_XFA(yfa_) ((xfa_) - 4u)
290 #define UFO_XFA_TO_WST(xfa_) ((xfa_) - 4u)
291 #define UFO_YFA_TO_WST(yfa_) ((yfa_) - 2u * 4u)
292 #define UFO_YFA_TO_NFA(yfa_) ((yfa_) + 4u * 4u)
295 // ////////////////////////////////////////////////////////////////////////// //
296 #define UFW_VOCAB_OFS_LATEST (0u * 4u)
297 #define UFW_VOCAB_OFS_VOCLINK (1u * 4u)
298 #define UFW_VOCAB_OFS_PARENT (2u * 4u)
299 #define UFW_VOCAB_OFS_HEADER (3u * 4u)
300 #define UFW_VOCAB_OFS_HTABLE (4u * 4u)
302 #define UFO_HASHTABLE_SIZE (256)
304 #define UFO_NO_HTABLE_FLAG (~(uint32_t)0)
306 #define UFO_MAX_NATIVE_CFAS (1024u)
307 static ufoNativeCFA *ufoForthCFAs = NULL;
308 static uint32_t ufoCFAsUsed = 0;
310 static uint32_t ufoDoForthCFA;
311 static uint32_t ufoDoVariableCFA;
312 static uint32_t ufoDoValueCFA;
313 static uint32_t ufoDoConstCFA;
314 static uint32_t ufoDoDeferCFA;
315 static uint32_t ufoDoVocCFA;
316 static uint32_t ufoDoCreateCFA;
317 static uint32_t ufoDoUserVariableCFA;
319 static uint32_t ufoLitStr8CFA;
321 // special address types:
322 #define UFO_ADDR_CFA_BIT ((uint32_t)1<<31)
323 #define UFO_ADDR_CFA_MASK (UFO_ADDR_CFA_BIT-1u)
325 // handles are somewhat special: first 12 bits can be used as offset for "@", and are ignored
326 #define UFO_ADDR_HANDLE_BIT ((uint32_t)1<<30)
327 #define UFO_ADDR_HANDLE_MASK ((UFO_ADDR_HANDLE_BIT-1u)&~((uint32_t)0xfff))
328 #define UFO_ADDR_HANDLE_SHIFT (12)
329 #define UFO_ADDR_HANDLE_OFS_MASK ((uint32_t)((1 << UFO_ADDR_HANDLE_SHIFT) - 1))
331 // temporary area is 1MB buffer out of the main image
332 #define UFO_ADDR_TEMP_BIT ((uint32_t)1<<29)
333 #define UFO_ADDR_TEMP_MASK (UFO_ADDR_TEMP_BIT-1u)
335 #define UFO_ADDR_SPECIAL_BITS_MASK (UFO_ADDR_CFA_BIT|UFO_ADDR_HANDLE_BIT|UFO_ADDR_TEMP_BIT)
338 static uint32_t *ufoImage = NULL;
339 static uint32_t ufoImageSize = 0;
341 static uint8_t *ufoDebugImage = NULL;
342 static uint32_t ufoDebugImageUsed = 0; // in bytes
343 static uint32_t ufoDebugImageSize = 0; // in bytes
344 static uint32_t ufoDebugFileNameHash = 0; // current file name hash
345 static uint32_t ufoDebugFileNameLen = 0; // current file name length
346 static uint32_t ufoDebugLastLine = 0;
347 static uint32_t ufoDebugLastLinePCOfs = 0;
348 static uint32_t ufoDebugLastLineDP = 0;
349 static uint32_t ufoDebugCurrDP = 0;
351 static uint32_t ufoInRunWord = 0;
353 static volatile int ufoVMAbort = 0;
354 static volatile int ufoVMStop = 0;
356 #define ufoTrueValue (~(uint32_t)0)
358 enum {
359 UFO_MODE_NONE = -1,
360 UFO_MODE_NATIVE = 0, // executing forth code
361 UFO_MODE_MACRO = 1, // executing forth asm macro
363 static uint32_t ufoMode = UFO_MODE_NONE;
365 #define UFO_DSTACK_SIZE (8192)
366 #define UFO_RSTACK_SIZE (4096)
367 #define UFO_LSTACK_SIZE (4096)
368 #define UFO_MAX_TASK_NAME (127)
369 #define UFO_VOCSTACK_SIZE (16u)
371 // to support multitasking (required for the debugger),
372 // our virtual machine state is encapsulated in a struct.
373 typedef struct UfoState_t {
374 uint32_t id;
375 uint32_t dStack[UFO_DSTACK_SIZE];
376 uint32_t rStack[UFO_RSTACK_SIZE];
377 uint32_t lStack[UFO_LSTACK_SIZE];
378 uint32_t IP; // in image
379 uint32_t SP; // points AFTER the last value pushed
380 uint32_t RP; // points AFTER the last value pushed
381 uint32_t RPTop; // stop when RP is this
382 // address register
383 uint32_t regA;
384 // for locals
385 uint32_t LP;
386 uint32_t LBP;
387 uint32_t vmRPopCFA;
388 // vocstack
389 uint32_t vocStack[UFO_VOCSTACK_SIZE]; // cfas
390 uint32_t VSP;
391 // temp image
392 uint32_t *imageTemp;
393 uint32_t imageTempSize;
394 // linked list of all allocated states (tasks)
395 char name[UFO_MAX_TASK_NAME + 1];
396 } UfoState;
398 // 'cmon!
399 #define UFO_MAX_STATES (8192)
401 // this is indexed by id
402 static UfoState *ufoStateMap[UFO_MAX_STATES] = {NULL};
403 static uint32_t ufoStateUsedBitmap[UFO_MAX_STATES/32] = {0};
405 // currently active execution state
406 static UfoState *ufoCurrState = NULL;
407 // state we're yielded from
408 static UfoState *ufoYieldedState = NULL;
409 // if debug state is not NULL, VM will switch to it
410 // after executing one instruction from the current state.
411 // it will store current state in `ufoDebugeeState`.
412 static UfoState *ufoDebuggerState = NULL;
413 static uint32_t ufoSingleStep = 0;
415 #define ufoDStack (ufoCurrState->dStack)
416 #define ufoRStack (ufoCurrState->rStack)
417 #define ufoLStack (ufoCurrState->lStack)
418 #define ufoIP (ufoCurrState->IP)
419 #define ufoSP (ufoCurrState->SP)
420 #define ufoRP (ufoCurrState->RP)
421 #define ufoRPTop (ufoCurrState->RPTop)
422 #define ufoLP (ufoCurrState->LP)
423 #define ufoLBP (ufoCurrState->LBP)
424 #define ufoRegA (ufoCurrState->regA)
425 #define ufoImageTemp (ufoCurrState->imageTemp)
426 #define ufoImageTempSize (ufoCurrState->imageTempSize)
427 #define ufoVMRPopCFA (ufoCurrState->vmRPopCFA)
428 #define ufoVocStack (ufoCurrState->vocStack)
429 #define ufoVSP (ufoCurrState->VSP)
431 // 256 bytes for user variables
432 #define UFO_USER_AREA_ADDR UFO_ADDR_TEMP_BIT
433 #define UFO_USER_AREA_SIZE (256u)
434 #define UFO_NBUF_ADDR UFO_USER_AREA_ADDR + UFO_USER_AREA_SIZE
435 #define UFO_NBUF_SIZE (256u)
436 #define UFO_PAD_ADDR (UFO_NBUF_ADDR + UFO_NBUF_SIZE)
437 #define UFO_DEF_TIB_ADDR (UFO_PAD_ADDR + 2048u)
439 // dynamically allocated text input buffer
440 // always ends with zero (this is word name too)
441 static const uint32_t ufoAddrTIBx = UFO_ADDR_TEMP_BIT + 0u * 4u; // TIB
442 static const uint32_t ufoAddrINx = UFO_ADDR_TEMP_BIT + 1u * 4u; // >IN
443 static const uint32_t ufoAddrDefTIB = UFO_ADDR_TEMP_BIT + 2u * 4u; // default TIB (handle); user cannot change it
444 static const uint32_t ufoAddrBASE = UFO_ADDR_TEMP_BIT + 3u * 4u;
445 static const uint32_t ufoAddrSTATE = UFO_ADDR_TEMP_BIT + 4u * 4u;
446 static const uint32_t ufoAddrContext = UFO_ADDR_TEMP_BIT + 5u * 4u; // CONTEXT
447 static const uint32_t ufoAddrCurrent = UFO_ADDR_TEMP_BIT + 6u * 4u; // CURRENT (definitions will go there)
448 static const uint32_t ufoAddrSelf = UFO_ADDR_TEMP_BIT + 7u * 4u; // CURRENT (definitions will go there)
449 static const uint32_t ufoAddrInterNextLine = UFO_ADDR_TEMP_BIT + 8u * 4u; // (INTERPRET-NEXT-LINE)
450 static const uint32_t ufoAddrEP = UFO_ADDR_TEMP_BIT + 9u * 4u; // (EP) -- exception frame pointer
451 static const uint32_t ufoAddrUserVarUsed = UFO_ADDR_TEMP_BIT + 10u * 4u;
453 static uint32_t ufoAddrVocLink;
454 static uint32_t ufoAddrDP;
455 static uint32_t ufoAddrDPTemp;
456 static uint32_t ufoAddrNewWordFlags;
457 static uint32_t ufoAddrRedefineWarning;
458 static uint32_t ufoAddrLastXFA;
460 static uint32_t ufoForthVocId;
461 static uint32_t ufoCompilerVocId;
462 static uint32_t ufoInterpNextLineCFA;
464 // allows to redefine even protected words
465 #define UFO_REDEF_WARN_DONT_CARE (~(uint32_t)0)
466 // do not warn about ordinary words, allow others
467 #define UFO_REDEF_WARN_NONE (0)
468 // do warn (or fail on protected)
469 #define UFO_REDEF_WARN_NORMAL (1)
470 // do warn (or fail on protected) for parent dicts too
471 #define UFO_REDEF_WARN_PARENTS (2)
473 #define UFO_GET_DP() (ufoImgGetU32(ufoAddrDPTemp) ?: ufoImgGetU32(ufoAddrDP))
474 //#define UFO_SET_DP(val_) ufoImgPutU32(ufoAddrDP, (val_))
476 #define UFO_MAX_NESTED_INCLUDES (32)
477 typedef struct {
478 FILE *fl;
479 char *fname;
480 char *incpath;
481 char *sysincpath;
482 int fline;
483 uint32_t id; // non-zero unique id
484 } UFOFileStackEntry;
486 static UFOFileStackEntry ufoFileStack[UFO_MAX_NESTED_INCLUDES];
487 static uint32_t ufoFileStackPos; // after the last used item
489 static FILE *ufoInFile = NULL;
490 static uint32_t ufoInFileNameLen = 0;
491 static uint32_t ufoInFileNameHash = 0;
492 static char *ufoInFileName = NULL;
493 static char *ufoLastIncPath = NULL;
494 static char *ufoLastSysIncPath = NULL;
495 static int ufoInFileLine = 0;
496 static uint32_t ufoFileId = 0;
497 static uint32_t ufoLastUsedFileId = 0;
498 static int ufoLastEmitWasCR = 1;
500 // dynamic memory handles
501 typedef struct UHandleInfo_t {
502 uint32_t ufoHandle;
503 uint32_t typeid;
504 uint8_t *data;
505 uint32_t size;
506 uint32_t used;
507 // in free list
508 struct UHandleInfo_t *next;
509 } UfoHandle;
511 static UfoHandle *ufoHandleFreeList = NULL;
512 static UfoHandle **ufoHandles = NULL;
513 static uint32_t ufoHandlesUsed = 0;
514 static uint32_t ufoHandlesAlloted = 0;
516 #define UFO_HANDLE_FREE (~(uint32_t)0)
518 static char ufoCurrFileLine[520];
520 // for `ufoFatal()`
521 static uint32_t ufoInBacktrace = 0;
524 // ////////////////////////////////////////////////////////////////////////// //
525 static void ufoClearCondDefines (void);
527 static void ufoRunVMCFA (uint32_t cfa);
529 static void ufoBacktrace (uint32_t ip, int showDataStack);
531 static void ufoClearCondDefines (void);
533 static UfoState *ufoNewState (void);
534 static void ufoInitStateUserVars (UfoState *st, uint32_t cfa);
535 static void ufoFreeState (UfoState *st);
536 static UfoState *ufoFindState (uint32_t stid);
537 static void ufoSwitchToState (UfoState *newst);
539 __attribute__((unused)) static void ufoDumpWordHeader (const uint32_t lfa);
541 #ifndef WIN32
542 static void ufoDisableRaw (void);
543 static void ufoTTYRawFlush (void);
544 #endif
545 static int ufoIsGoodTTY (void);
547 #ifdef UFO_DEBUG_DEBUG
548 static void ufoDumpDebugImage (void);
549 #endif
552 // ////////////////////////////////////////////////////////////////////////// //
553 #define UFWORD(name_) \
554 static void ufoWord_##name_ (uint32_t mypfa)
556 #define UFCALL(name_) ufoWord_##name_(0)
557 #define UFCFA(name_) (&ufoWord_##name_)
559 // for TIB words
560 UFWORD(CPEEK_REGA_IDX);
561 UFWORD(CPOKE_REGA_IDX);
563 // for peek and poke
564 UFWORD(PAR_HANDLE_LOAD_BYTE);
565 UFWORD(PAR_HANDLE_LOAD_WORD);
566 UFWORD(PAR_HANDLE_LOAD_CELL);
567 UFWORD(PAR_HANDLE_STORE_BYTE);
568 UFWORD(PAR_HANDLE_STORE_WORD);
569 UFWORD(PAR_HANDLE_STORE_CELL);
572 //==========================================================================
574 // ufoFlushOutput
576 //==========================================================================
577 static void ufoFlushOutput (void) {
578 #ifndef WIN32
579 ufoTTYRawFlush();
580 #endif
581 fflush(NULL);
585 //==========================================================================
587 // ufoSetInFileName
589 // if `reuse` is not 0, reuse/free `fname`
591 //==========================================================================
592 static void ufoSetInFileNameEx (const char *fname, int reuse) {
593 ufo_assert(fname == NULL || (fname != ufoInFileName));
594 if (fname == NULL || fname[0] == 0) {
595 if (ufoInFileName) { free(ufoInFileName); ufoInFileName = NULL; }
596 ufoInFileNameLen = 0;
597 ufoInFileNameHash = 0;
598 if (reuse && fname != NULL) free((void *)fname);
599 } else {
600 const uint32_t fnlen = (uint32_t)strlen(fname);
601 const uint32_t fnhash = joaatHashBuf(fname, fnlen, 0);
602 if (ufoInFileNameLen != fnlen || ufoInFileNameHash != fnhash) {
603 if (ufoInFileName) { free(ufoInFileName); ufoInFileName = NULL; }
604 if (reuse) {
605 ufoInFileName = (char *)fname;
606 } else {
607 ufoInFileName = strdup(fname);
608 if (ufoInFileName == NULL) ufoFatal("out of memory for filename info");
610 ufoInFileNameLen = fnlen;
611 ufoInFileNameHash = fnhash;
612 } else {
613 if (reuse && fname != NULL) free((void *)fname);
619 //==========================================================================
621 // ufoSetInFileName
623 //==========================================================================
624 UFO_FORCE_INLINE void ufoSetInFileName (const char *fname) {
625 ufoSetInFileNameEx(fname, 0);
629 //==========================================================================
631 // ufoSetInFileNameReuse
633 //==========================================================================
634 UFO_FORCE_INLINE void ufoSetInFileNameReuse (const char *fname) {
635 ufoSetInFileNameEx(fname, 1);
639 //==========================================================================
641 // ufoSetUserAbort
643 //==========================================================================
644 void ufoSetUserAbort (void) {
645 ufoVMAbort = 1;
649 //==========================================================================
651 // ufoAllocHandle
653 //==========================================================================
654 static UfoHandle *ufoAllocHandle (uint32_t typeid) {
655 ufo_assert(typeid != UFO_HANDLE_FREE);
656 UfoHandle *newh = ufoHandleFreeList;
657 if (newh == NULL) {
658 if (ufoHandlesUsed == ufoHandlesAlloted) {
659 uint32_t newsz = ufoHandlesAlloted + 16384;
660 // due to offsets, this is the maximum number of handles we can have
661 if (newsz > 0x1ffffU) {
662 if (ufoHandlesAlloted > 0x1ffffU) ufoFatal("too many dynamic handles");
663 newsz = 0x1ffffU + 1U;
664 ufo_assert(newsz > ufoHandlesAlloted);
666 UfoHandle **nh = realloc(ufoHandles, sizeof(ufoHandles[0]) * newsz);
667 if (nh == NULL) ufoFatal("out of memory for handle table");
668 ufoHandles = nh;
669 ufoHandlesAlloted = newsz;
671 newh = calloc(1, sizeof(UfoHandle));
672 if (newh == NULL) ufoFatal("out of memory for handle info");
673 ufoHandles[ufoHandlesUsed] = newh;
674 // setup new handle info
675 newh->ufoHandle = (ufoHandlesUsed << UFO_ADDR_HANDLE_SHIFT) | UFO_ADDR_HANDLE_BIT;
676 ufoHandlesUsed += 1;
677 } else {
678 ufo_assert(newh->typeid == UFO_HANDLE_FREE);
679 ufoHandleFreeList = newh->next;
681 // setup new handle info
682 newh->typeid = typeid;
683 newh->data = NULL;
684 newh->size = 0;
685 newh->used = 0;
686 newh->next = NULL;
687 return newh;
691 //==========================================================================
693 // ufoFreeHandle
695 //==========================================================================
696 static void ufoFreeHandle (UfoHandle *hh) {
697 if (hh != NULL) {
698 ufo_assert(hh->typeid != UFO_HANDLE_FREE);
699 if (hh->data) free(hh->data);
700 hh->typeid = UFO_HANDLE_FREE;
701 hh->data = NULL;
702 hh->size = 0;
703 hh->used = 0;
704 hh->next = ufoHandleFreeList;
705 ufoHandleFreeList = hh;
710 //==========================================================================
712 // ufoGetHandle
714 //==========================================================================
715 static UfoHandle *ufoGetHandle (uint32_t hh) {
716 UfoHandle *res;
717 if (hh != 0 && (hh & UFO_ADDR_HANDLE_BIT) != 0) {
718 hh = (hh & UFO_ADDR_HANDLE_MASK) >> UFO_ADDR_HANDLE_SHIFT;
719 if (hh < ufoHandlesUsed) {
720 res = ufoHandles[hh];
721 if (res->typeid == UFO_HANDLE_FREE) res = NULL;
722 } else {
723 res = NULL;
725 } else {
726 res = NULL;
728 return res;
732 //==========================================================================
734 // setLastIncPath
736 //==========================================================================
737 static void setLastIncPath (const char *fname, int system) {
738 if (fname == NULL || fname[0] == 0) {
739 if (system) {
740 if (ufoLastSysIncPath) free(ufoLastIncPath);
741 ufoLastSysIncPath = NULL;
742 } else {
743 if (ufoLastIncPath) free(ufoLastIncPath);
744 ufoLastIncPath = strdup(".");
746 } else {
747 char *lslash;
748 char *cpos;
749 if (system) {
750 if (ufoLastSysIncPath) free(ufoLastSysIncPath);
751 ufoLastSysIncPath = strdup(fname);
752 lslash = ufoLastSysIncPath;
753 cpos = ufoLastSysIncPath;
754 } else {
755 if (ufoLastIncPath) free(ufoLastIncPath);
756 ufoLastIncPath = strdup(fname);
757 lslash = ufoLastIncPath;
758 cpos = ufoLastIncPath;
760 while (*cpos) {
761 #ifdef WIN32
762 if (*cpos == '/' || *cpos == '\\') lslash = cpos;
763 #else
764 if (*cpos == '/') lslash = cpos;
765 #endif
766 cpos += 1;
768 *lslash = 0;
773 //==========================================================================
775 // ufoClearIncludePath
777 // required for UrAsm
779 //==========================================================================
780 void ufoClearIncludePath (void) {
781 if (ufoLastIncPath != NULL) {
782 free(ufoLastIncPath);
783 ufoLastIncPath = NULL;
785 if (ufoLastSysIncPath != NULL) {
786 free(ufoLastSysIncPath);
787 ufoLastSysIncPath = NULL;
792 //==========================================================================
794 // ufoErrorPrintFile
796 //==========================================================================
797 static void ufoErrorPrintFile (FILE *fo, const char *errwarn) {
798 if (ufoInFileName != NULL) {
799 fprintf(fo, "UFO %s at file %s, line %d: ", errwarn, ufoInFileName, ufoInFileLine);
800 } else {
801 fprintf(fo, "UFO %s somewhere in time: ", errwarn);
806 //==========================================================================
808 // ufoErrorMsgV
810 //==========================================================================
811 static void ufoErrorMsgV (const char *errwarn, const char *fmt, va_list ap) {
812 ufoFlushOutput();
813 if (!ufoLastEmitWasCR) { printf("\n"); ufoLastEmitWasCR = 1; }
814 ufoErrorPrintFile(stderr, errwarn);
815 vfprintf(stderr, fmt, ap);
816 va_end(ap);
817 fputc('\n', stderr);
818 ufoFlushOutput();
822 //==========================================================================
824 // ufoWarning
826 //==========================================================================
827 __attribute__((format(printf, 1, 2)))
828 void ufoWarning (const char *fmt, ...) {
829 va_list ap;
830 va_start(ap, fmt);
831 ufoErrorMsgV("WARNING", fmt, ap);
835 //==========================================================================
837 // ufoFatal
839 //==========================================================================
840 __attribute__((noreturn)) __attribute__((format(printf, 1, 2)))
841 void ufoFatal (const char *fmt, ...) {
842 va_list ap;
843 #ifndef WIN32
844 ufoDisableRaw();
845 #endif
846 va_start(ap, fmt);
847 ufoErrorMsgV("ERROR", fmt, ap);
848 if (!ufoInBacktrace) {
849 ufoInBacktrace = 1;
850 ufoBacktrace(ufoIP, 1);
851 ufoInBacktrace = 0;
852 } else {
853 fprintf(stderr, "DOUBLE FATAL: error in backtrace!\n");
854 abort();
856 #ifdef UFO_DEBUG_FATAL_ABORT
857 abort();
858 #endif
859 ufoFatalError();
863 // ////////////////////////////////////////////////////////////////////////// //
864 // working with the stacks
865 UFO_FORCE_INLINE void ufoPush (uint32_t v) { if (ufoSP >= UFO_DSTACK_SIZE) ufoFatal("data stack overflow"); ufoDStack[ufoSP++] = v; }
866 UFO_FORCE_INLINE void ufoDrop (void) { if (ufoSP == 0) ufoFatal("data stack underflow"); --ufoSP; }
867 UFO_FORCE_INLINE uint32_t ufoPop (void) { if (ufoSP == 0) { ufoFatal("data stack underflow"); } return ufoDStack[--ufoSP]; }
868 UFO_FORCE_INLINE uint32_t ufoPeek (void) { if (ufoSP == 0) ufoFatal("data stack underflow"); return ufoDStack[ufoSP-1u]; }
869 UFO_FORCE_INLINE void ufoDup (void) { if (ufoSP == 0) ufoFatal("data stack underflow"); ufoPush(ufoDStack[ufoSP-1u]); }
870 UFO_FORCE_INLINE void ufoOver (void) { if (ufoSP < 2u) ufoFatal("data stack underflow"); ufoPush(ufoDStack[ufoSP-2u]); }
871 UFO_FORCE_INLINE void ufoSwap (void) { if (ufoSP < 2u) ufoFatal("data stack underflow"); const uint32_t t = ufoDStack[ufoSP-1u]; ufoDStack[ufoSP-1u] = ufoDStack[ufoSP-2u]; ufoDStack[ufoSP-2u] = t; }
872 UFO_FORCE_INLINE void ufoRot (void) { if (ufoSP < 3u) ufoFatal("data stack underflow"); const uint32_t t = ufoDStack[ufoSP-3u]; ufoDStack[ufoSP-3u] = ufoDStack[ufoSP-2u]; ufoDStack[ufoSP-2u] = ufoDStack[ufoSP-1u]; ufoDStack[ufoSP-1u] = t; }
873 UFO_FORCE_INLINE void ufoNRot (void) { if (ufoSP < 3u) ufoFatal("data stack underflow"); const uint32_t t = ufoDStack[ufoSP-1u]; ufoDStack[ufoSP-1u] = ufoDStack[ufoSP-2u]; ufoDStack[ufoSP-2u] = ufoDStack[ufoSP-3u]; ufoDStack[ufoSP-3u] = t; }
875 UFO_FORCE_INLINE void ufo2Dup (void) { ufoOver(); ufoOver(); }
876 UFO_FORCE_INLINE void ufo2Drop (void) { ufoDrop(); ufoDrop(); }
877 UFO_FORCE_INLINE void ufo2Over (void) { if (ufoSP < 4u) ufoFatal("data stack underflow"); const uint32_t n0 = ufoDStack[ufoSP-4u]; const uint32_t n1 = ufoDStack[ufoSP-3u]; ufoPush(n0); ufoPush(n1); }
878 UFO_FORCE_INLINE void ufo2Swap (void) { if (ufoSP < 4u) ufoFatal("data stack underflow"); const uint32_t n0 = ufoDStack[ufoSP-4u]; const uint32_t n1 = ufoDStack[ufoSP-3u]; ufoDStack[ufoSP-4u] = ufoDStack[ufoSP-2u]; ufoDStack[ufoSP-3u] = ufoDStack[ufoSP-1u]; ufoDStack[ufoSP-2u] = n0; ufoDStack[ufoSP-1u] = n1; }
880 UFO_FORCE_INLINE void ufoRPush (uint32_t v) { if (ufoRP >= UFO_RSTACK_SIZE) ufoFatal("return stack overflow"); ufoRStack[ufoRP++] = v; }
881 UFO_FORCE_INLINE void ufoRDrop (void) { if (ufoRP == 0 || ufoRP == ufoRPTop) ufoFatal("return stack underflow"); --ufoRP; }
882 UFO_FORCE_INLINE uint32_t ufoRPop (void) { if (ufoRP == 0 || ufoRP == ufoRPTop) ufoFatal("return stack underflow"); return ufoRStack[--ufoRP]; }
883 UFO_FORCE_INLINE uint32_t ufoRPeek (void) { if (ufoRP == 0 || ufoRP == ufoRPTop) ufoFatal("return stack underflow"); return ufoRStack[ufoRP-1u]; }
884 UFO_FORCE_INLINE void ufoRDup (void) { if (ufoRP == 0 || ufoRP == ufoRPTop) ufoFatal("return stack underflow"); ufoPush(ufoRStack[ufoRP-1u]); }
886 UFO_FORCE_INLINE void ufoPushBool (int v) { ufoPush(v ? ufoTrueValue : 0u); }
889 //==========================================================================
891 // ufoImgEnsureSize
893 //==========================================================================
894 static void ufoImgEnsureSize (uint32_t addr) {
895 if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) != 0) ufoFatal("ufoImgEnsureSize: internal error");
896 if (addr >= ufoImageSize) {
897 // 64MB should be enough for everyone!
898 if (addr >= 0x04000000U) {
899 ufoFatal("image grown too big (addr=0%08XH)", addr);
901 const const uint32_t osz = ufoImageSize;
902 // grow by 1MB steps
903 const uint32_t nsz = (addr|0x000fffffU) + 1U;
904 ufo_assert(nsz > addr);
905 uint32_t *nimg = realloc(ufoImage, nsz);
906 if (nimg == NULL) {
907 ufoFatal("out of memory for UFO image (%u -> %u MBs)",
908 ufoImageSize / 1024u / 1024u,
909 nsz / 1024u / 1024u);
911 ufoImage = nimg;
912 ufoImageSize = nsz;
913 memset((char *)ufoImage + osz, 0, (nsz - osz));
918 //==========================================================================
920 // ufoImgEnsureTemp
922 //==========================================================================
923 static void ufoImgEnsureTemp (uint32_t addr) {
924 if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) != 0) ufoFatal("ufoImgEnsureTemp: internal error");
925 if (addr >= ufoImageTempSize) {
926 if (addr >= 1024u * 1024u) {
927 ufoFatal("Forth segmentation fault at address 0x%08X", addr | UFO_ADDR_TEMP_BIT);
929 const uint32_t osz = ufoImageTempSize;
930 // grow by 8KB steps
931 const uint32_t nsz = (addr|0x00001fffU) + 1U;
932 uint32_t *nimg = realloc(ufoImageTemp, nsz);
933 if (nimg == NULL) {
934 ufoFatal("out of memory for temp UFO image (%u -> %u KBs)",
935 ufoImageTempSize / 1024u,
936 nsz / 1024u);
938 ufoImageTemp = nimg;
939 ufoImageTempSize = nsz;
940 memset((char *)ufoImageTemp + osz, 0, (nsz - osz));
945 #ifdef UFO_FAST_MEM_ACCESS
946 //==========================================================================
948 // ufoImgPutU8
950 // fast
952 //==========================================================================
953 UFO_FORCE_INLINE void ufoImgPutU8 (uint32_t addr, const uint32_t value) {
954 if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
955 if (addr >= ufoImageSize) ufoImgEnsureSize(addr);
956 *((uint8_t *)ufoImage + addr) = (uint8_t)value;
957 } else if (addr & UFO_ADDR_TEMP_BIT) {
958 addr &= UFO_ADDR_TEMP_MASK;
959 if (addr >= ufoImageTempSize) ufoImgEnsureTemp(addr);
960 *((uint8_t *)ufoImageTemp + addr) = (uint8_t)value;
961 } else {
962 ufoFatal("Forth segmentation fault at address 0x%08X", addr);
967 //==========================================================================
969 // ufoImgPutU16
971 // fast
973 //==========================================================================
974 UFO_FORCE_INLINE void ufoImgPutU16 (uint32_t addr, const uint32_t value) {
975 if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
976 if (addr + 1u >= ufoImageSize) ufoImgEnsureSize(addr + 1u);
977 *(uint16_t *)((uint8_t *)ufoImage + addr) = (uint16_t)value;
978 } else if (addr & UFO_ADDR_TEMP_BIT) {
979 addr &= UFO_ADDR_TEMP_MASK;
980 if (addr + 1u >= ufoImageTempSize) ufoImgEnsureTemp(addr + 1u);
981 *(uint16_t *)((uint8_t *)ufoImageTemp + addr) = (uint16_t)value;
982 } else {
983 ufoFatal("Forth segmentation fault at address 0x%08X", addr);
988 //==========================================================================
990 // ufoImgPutU32
992 // fast
994 //==========================================================================
995 UFO_FORCE_INLINE void ufoImgPutU32 (uint32_t addr, const uint32_t value) {
996 if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
997 if (addr + 3u >= ufoImageSize) ufoImgEnsureSize(addr + 3u);
998 *(uint32_t *)((uint8_t *)ufoImage + addr) = value;
999 } else if (addr & UFO_ADDR_TEMP_BIT) {
1000 addr &= UFO_ADDR_TEMP_MASK;
1001 if (addr + 3u >= ufoImageTempSize) ufoImgEnsureTemp(addr + 3u);
1002 *(uint32_t *)((uint8_t *)ufoImageTemp + addr) = value;
1003 } else {
1004 ufoFatal("Forth segmentation fault at address 0x%08X", addr);
1009 //==========================================================================
1011 // ufoImgGetU8
1013 // false
1015 //==========================================================================
1016 UFO_FORCE_INLINE uint32_t ufoImgGetU8 (uint32_t addr) {
1017 if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
1018 if (addr >= ufoImageSize) {
1019 // accessing unallocated image area is segmentation fault
1020 ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr);
1022 return *((const uint8_t *)ufoImage + addr);
1023 } else if (addr & UFO_ADDR_TEMP_BIT) {
1024 addr &= UFO_ADDR_TEMP_MASK;
1025 if (addr >= ufoImageTempSize) {
1026 // accessing unallocated image area is segmentation fault
1027 ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr | UFO_ADDR_TEMP_BIT);
1029 return *((const uint8_t *)ufoImageTemp + addr);
1030 } else {
1031 ufoFatal("Forth segmentation fault at address 0x%08X", addr);
1036 //==========================================================================
1038 // ufoImgGetU16
1040 // fast
1042 //==========================================================================
1043 UFO_FORCE_INLINE uint32_t ufoImgGetU16 (uint32_t addr) {
1044 if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
1045 if (addr + 1u >= ufoImageSize) {
1046 // accessing unallocated image area is segmentation fault
1047 ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr);
1049 return *(const uint16_t *)((const uint8_t *)ufoImage + addr);
1050 } else if (addr & UFO_ADDR_TEMP_BIT) {
1051 addr &= UFO_ADDR_TEMP_MASK;
1052 if (addr + 1u >= ufoImageTempSize) {
1053 // accessing unallocated image area is segmentation fault
1054 ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr | UFO_ADDR_TEMP_BIT);
1056 return *(const uint16_t *)((const uint8_t *)ufoImageTemp + addr);
1057 } else {
1058 ufoFatal("Forth segmentation fault at address 0x%08X", addr);
1063 //==========================================================================
1065 // ufoImgGetU32
1067 // fast
1069 //==========================================================================
1070 UFO_FORCE_INLINE uint32_t ufoImgGetU32 (uint32_t addr) {
1071 if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
1072 if (addr + 3u >= ufoImageSize) {
1073 // accessing unallocated image area is segmentation fault
1074 ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr);
1076 return *(const uint32_t *)((const uint8_t *)ufoImage + addr);
1077 } else if (addr & UFO_ADDR_TEMP_BIT) {
1078 addr &= UFO_ADDR_TEMP_MASK;
1079 if (addr + 3u >= ufoImageTempSize) {
1080 // accessing unallocated image area is segmentation fault
1081 ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr | UFO_ADDR_TEMP_BIT);
1083 return *(const uint32_t *)((const uint8_t *)ufoImageTemp + addr);
1084 } else {
1085 ufoFatal("Forth segmentation fault at address 0x%08X", addr);
1089 #else
1091 //==========================================================================
1093 // ufoImgPutU8
1095 // general
1097 //==========================================================================
1098 UFO_FORCE_INLINE void ufoImgPutU8 (uint32_t addr, const uint32_t value) {
1099 uint32_t *imgptr;
1100 if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
1101 if (addr >= ufoImageSize) ufoImgEnsureSize(addr);
1102 imgptr = &ufoImage[addr/4u];
1103 } else if (addr & UFO_ADDR_TEMP_BIT) {
1104 addr &= UFO_ADDR_TEMP_MASK;
1105 if (addr >= ufoImageTempSize) ufoImgEnsureTemp(addr);
1106 imgptr = &ufoImageTemp[addr/4u];
1107 } else {
1108 ufoFatal("Forth segmentation fault at address 0x%08X", addr);
1110 const uint8_t val = (uint8_t)value;
1111 memcpy((uint8_t *)imgptr + (addr&3), &val, 1);
1115 //==========================================================================
1117 // ufoImgPutU16
1119 // general
1121 //==========================================================================
1122 UFO_FORCE_INLINE void ufoImgPutU16 (uint32_t addr, const uint32_t value) {
1123 ufoImgPutU8(addr, value&0xffU);
1124 ufoImgPutU8(addr + 1u, (value>>8)&0xffU);
1128 //==========================================================================
1130 // ufoImgPutU32
1132 // general
1134 //==========================================================================
1135 UFO_FORCE_INLINE void ufoImgPutU32 (uint32_t addr, const uint32_t value) {
1136 ufoImgPutU16(addr, value&0xffffU);
1137 ufoImgPutU16(addr + 2u, (value>>16)&0xffffU);
1141 //==========================================================================
1143 // ufoImgGetU8
1145 // general
1147 //==========================================================================
1148 UFO_FORCE_INLINE uint32_t ufoImgGetU8 (uint32_t addr) {
1149 uint32_t *imgptr;
1150 if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
1151 if (addr >= ufoImageSize) return 0;
1152 imgptr = &ufoImage[addr/4u];
1153 } else if (addr & UFO_ADDR_TEMP_BIT) {
1154 addr &= UFO_ADDR_TEMP_MASK;
1155 if (addr >= ufoImageTempSize) return 0;
1156 imgptr = &ufoImageTemp[addr/4u];
1157 } else {
1158 ufoFatal("Forth segmentation fault at address 0x%08X", addr);
1160 uint8_t val;
1161 memcpy(&val, (uint8_t *)imgptr + (addr&3), 1);
1162 return (uint32_t)val;
1166 //==========================================================================
1168 // ufoImgGetU16
1170 // general
1172 //==========================================================================
1173 UFO_FORCE_INLINE uint32_t ufoImgGetU16 (uint32_t addr) {
1174 return ufoImgGetU8(addr) | (ufoImgGetU8(addr + 1u) << 8);
1178 //==========================================================================
1180 // ufoImgGetU32
1182 // general
1184 //==========================================================================
1185 UFO_FORCE_INLINE uint32_t ufoImgGetU32 (uint32_t addr) {
1186 return ufoImgGetU16(addr) | (ufoImgGetU16(addr + 2u) << 16);
1188 #endif
1191 //==========================================================================
1193 // ufoEnsureDebugSize
1195 //==========================================================================
1196 UFO_DISABLE_INLINE void ufoEnsureDebugSize (uint32_t sdelta) {
1197 ufo_assert(sdelta != 0);
1198 if (ufoDebugImageUsed != 0) {
1199 if (ufoDebugImageUsed + sdelta >= 0x40000000U) ufoFatal("debug info too big");
1200 if (ufoDebugImageUsed + sdelta > ufoDebugImageSize) {
1201 // grow by 32KB, this should be more than enough
1202 const uint32_t newsz = ((ufoDebugImageUsed + sdelta) | 0x7fffU) + 1u;
1203 uint8_t *ndb = realloc(ufoDebugImage, newsz);
1204 if (ndb == NULL) ufoFatal("out of memory for debug info");
1205 ufoDebugImage = ndb;
1206 ufoDebugImageSize = newsz;
1208 } else {
1209 // initial allocation: 32KB, quite a lot
1210 ufoDebugImageSize = 1024 * 32;
1211 ufoDebugImage = malloc(ufoDebugImageSize);
1212 if (ufoDebugImage == NULL) ufoFatal("out of memory for debug info");
1217 #define UFO_DBG_PUT_U4(val_) do { \
1218 const uint32_t vv_ = (val_); \
1219 *((uint32_t *)(ufoDebugImage + ufoDebugImageUsed)) = vv_; \
1220 ufoDebugImageUsed += 4u; \
1221 } while (0)
1225 debug info header:
1226 dd lastFileInfoOfs
1227 ...first line info header...
1228 line info header (or reset):
1229 db 0 ; zero line delta
1230 dw followFileInfoSize ; either it, or 0 if reused
1231 dd fileInfoOfs ; present only if reused
1232 lines:
1233 dv lineDelta
1234 dv pcBytes
1236 file info record:
1237 dd prevFileInfoOfs
1238 dd fileNameHash
1239 dd nameLen ; without terminating 0
1240 ...name... (0-terminated)
1242 we will never compare file names: length and hash should provide
1243 good enough unique identifier.
1245 static uint8_t *ufoDebugImage = NULL;
1246 static uint32_t ufoDebugImageUsed = 0; // in bytes
1247 static uint32_t ufoDebugImageSize = 0; // in bytes
1248 static uint32_t ufoDebugFileNameHash = 0; // current file name hash
1249 static uint32_t ufoDebugFileNameLen = 0; // current file name length
1250 static uint32_t ufoDebugCurrDP = 0;
1254 //==========================================================================
1256 // ufoSkipDebugVarInt
1258 //==========================================================================
1259 static __attribute__((unused)) uint32_t ufoSkipDebugVarInt (uint32_t ofs) {
1260 uint8_t byte;
1261 do {
1262 if (ofs >= ufoDebugImageUsed) ufoFatal("invalid debug data");
1263 byte = ufoDebugImage[ofs]; ofs += 1u;
1264 } while (byte >= 0x80);
1265 return ofs;
1269 //==========================================================================
1271 // ufoCalcDebugVarIntSize
1273 //==========================================================================
1274 UFO_FORCE_INLINE uint8_t ufoCalcDebugVarIntSize (uint32_t v) {
1275 uint8_t count = 0;
1276 do {
1277 count += 1u;
1278 v >>= 7;
1279 } while (v != 0);
1280 return count;
1284 //==========================================================================
1286 // ufoGetDebugVarInt
1288 //==========================================================================
1289 static __attribute__((unused)) uint32_t ufoGetDebugVarInt (uint32_t ofs) {
1290 uint32_t v = 0;
1291 uint8_t shift = 0;
1292 uint8_t byte;
1293 do {
1294 if (ofs >= ufoDebugImageUsed) ufoFatal("invalid debug data");
1295 byte = ufoDebugImage[ofs];
1296 v |= (uint32_t)(byte & 0x7f) << shift;
1297 if (byte >= 0x80) {
1298 shift += 7;
1299 ofs += 1u;
1301 } while (byte >= 0x80);
1302 return v;
1306 //==========================================================================
1308 // ufoPutDebugVarInt
1310 //==========================================================================
1311 UFO_FORCE_INLINE void ufoPutDebugVarInt (uint32_t v) {
1312 ufoEnsureDebugSize(5u); // maximum size
1313 do {
1314 if (v >= 0x80) {
1315 ufoDebugImage[ufoDebugImageUsed] = (uint8_t)(v | 0x80u);
1316 } else {
1317 ufoDebugImage[ufoDebugImageUsed] = (uint8_t)v;
1319 ufoDebugImageUsed += 1;
1320 v >>= 7;
1321 } while (v != 0);
1325 #ifdef UFO_DEBUG_DEBUG
1326 //==========================================================================
1328 // ufoDumpDebugInfo
1330 //==========================================================================
1331 static void ufoDumpDebugImage (void) {
1332 #if 0
1333 uint32_t dbgpos = 4u; // first line header info
1334 uint32_t lastline = 0;
1335 uint32_t lastdp = 0;
1336 while (dbgpos < ufoDebugImageUsed) {
1337 if (ufoDebugImage[dbgpos] == 0) {
1338 // new file info
1339 dbgpos += 1u; // skip flag
1340 const uint32_t fhdrSize = *(const uint16_t *)(ufoDebugImage + dbgpos); dbgpos += 2u;
1341 lastdp = ufoGetDebugVarInt(dbgpos);
1342 dbgpos = ufoSkipDebugVarInt(dbgpos);
1343 if (fhdrSize == 0) {
1344 // reused
1345 const uint32_t infoOfs = *(const uint32_t *)(ufoDebugImage + dbgpos); dbgpos += 4u;
1346 fprintf(stderr, "*** OLD FILE: %s\n", (const char *)(ufoDebugImage + infoOfs + 3u * 4u));
1347 fprintf(stderr, "FILE NAME LEN: %u\n", ((const uint32_t *)(ufoDebugImage + infoOfs))[2]);
1348 fprintf(stderr, "FILE NAME HASH: 0x%08x\n", ((const uint32_t *)(ufoDebugImage + infoOfs))[1]);
1349 } else {
1350 // new
1351 fprintf(stderr, "*** NEW FILE: %s\n", (const char *)(ufoDebugImage + dbgpos + 3u * 4u));
1352 fprintf(stderr, "FILE NAME LEN: %u\n", ((const uint32_t *)(ufoDebugImage + dbgpos))[2]);
1353 fprintf(stderr, "FILE NAME HASH: 0x%08x\n", ((const uint32_t *)(ufoDebugImage + dbgpos))[1]);
1355 dbgpos += fhdrSize;
1356 fprintf(stderr, "LINES-OFS: 0x%08x (hsz: %u -- 0x%08x)\n", dbgpos, fhdrSize, fhdrSize);
1357 lastline = ~(uint32_t)0;
1358 } else {
1359 const uint32_t ln = ufoGetDebugVarInt(dbgpos);
1360 dbgpos = ufoSkipDebugVarInt(dbgpos);
1361 ufo_assert(ln != 0);
1362 lastline += ln;
1363 const uint32_t edp = ufoGetDebugVarInt(dbgpos);
1364 dbgpos = ufoSkipDebugVarInt(dbgpos);
1365 lastdp += edp;
1366 fprintf(stderr, " line %6u: edp=%u\n", lastline, lastdp);
1369 #endif
1371 #endif
1374 //==========================================================================
1376 // ufoRecordDebugCheckFile
1378 // if we moved to the new file:
1379 // put "line info header"
1380 // put new file info (or reuse old)
1382 //==========================================================================
1383 UFO_FORCE_INLINE void ufoRecordDebugCheckFile (void) {
1384 if (ufoDebugImageUsed == 0 ||
1385 ufoDebugFileNameLen != ufoInFileNameLen ||
1386 ufoDebugFileNameHash != ufoInFileNameHash)
1388 // new file record (or reuse old one)
1389 const int initial = (ufoDebugImageUsed == 0);
1390 uint32_t fileRec = 0;
1391 // try to find and old one
1392 if (!initial) {
1393 fileRec = *(const uint32_t *)ufoDebugImage;
1394 #if 0
1395 fprintf(stderr, "*** NEW-FILE(%u): 0x%08x: <%s> (frec=0x%08x)\n", ufoInFileNameLen,
1396 ufoInFileNameHash, ufoInFileName, fileRec);
1397 #endif
1398 while (fileRec != 0 &&
1399 (ufoInFileNameLen != ((const uint32_t *)(ufoDebugImage + fileRec))[1] ||
1400 ufoInFileNameHash != ((const uint32_t *)(ufoDebugImage + fileRec))[2]))
1402 #if 0
1403 fprintf(stderr, "*** FRCHECK: 0x%08x\n", fileRec);
1404 fprintf(stderr, " FILE NAME: %s\n", (const char *)(ufoDebugImage + fileRec + 3u * 4u));
1405 fprintf(stderr, " FILE NAME LEN: %u\n", ((const uint32_t *)(ufoDebugImage + fileRec))[2]);
1406 fprintf(stderr, " FILE NAME HASH: 0x%08x\n", ((const uint32_t *)(ufoDebugImage + fileRec))[1]);
1407 fprintf(stderr, " FILE PREV: 0x%08x\n", *(const uint32_t *)(ufoDebugImage + fileRec));
1408 #endif
1409 fileRec = *(const uint32_t *)(ufoDebugImage + fileRec);
1411 #if 0
1412 fprintf(stderr, "*** FRCHECK-DONE: 0x%08x\n", fileRec);
1413 if (fileRec != 0) {
1414 fprintf(stderr, " FILE NAME: %s\n", (const char *)(ufoDebugImage + fileRec + 3u * 4u));
1415 fprintf(stderr, " FILE NAME LEN: %u\n", ((const uint32_t *)(ufoDebugImage + fileRec))[2]);
1416 fprintf(stderr, " FILE NAME HASH: 0x%08x\n", ((const uint32_t *)(ufoDebugImage + fileRec))[1]);
1417 fprintf(stderr, " FILE PREV: 0x%08x\n", *(const uint32_t *)(ufoDebugImage + fileRec));
1419 #endif
1420 } else {
1421 ufoEnsureDebugSize(8u);
1422 *(uint32_t *)ufoDebugImage = 0;
1424 // write "line info header"
1425 if (fileRec != 0) {
1426 ufoEnsureDebugSize(32u);
1427 ufoDebugImage[ufoDebugImageUsed] = 0; ufoDebugImageUsed += 1u; // header flag (0 delta)
1428 // file record size: 0 (reused)
1429 *((uint16_t *)(ufoDebugImage + ufoDebugImageUsed)) = 0; ufoDebugImageUsed += 2u;
1430 // put last DP
1431 ufoPutDebugVarInt(ufoDebugCurrDP);
1432 // file info offset
1433 UFO_DBG_PUT_U4(fileRec);
1434 } else {
1435 // name, trailing 0 byte, 3 dword fields
1436 const uint32_t finfoSize = ufoInFileNameLen + 1u + 3u * 4u;
1437 ufo_assert(finfoSize < 65536u);
1438 ufoEnsureDebugSize(finfoSize + 32u);
1439 if (initial) {
1440 *(uint32_t *)ufoDebugImage = 0;
1441 ufoDebugImageUsed = 4;
1443 ufoDebugImage[ufoDebugImageUsed] = 0; ufoDebugImageUsed += 1u; // header flag (0 delta)
1444 // file record size
1445 *((uint16_t *)(ufoDebugImage + ufoDebugImageUsed)) = (uint16_t)finfoSize; ufoDebugImageUsed += 2u;
1446 // put last DP
1447 ufoPutDebugVarInt(ufoDebugCurrDP);
1448 // file record follows
1449 // fix file info offsets
1450 uint32_t lastOfs = *(const uint32_t *)ufoDebugImage;
1451 *(uint32_t *)ufoDebugImage = ufoDebugImageUsed;
1452 UFO_DBG_PUT_U4(lastOfs);
1453 // save file info hash
1454 UFO_DBG_PUT_U4(ufoInFileNameHash);
1455 // save file info length
1456 UFO_DBG_PUT_U4(ufoInFileNameLen);
1457 // save file name
1458 if (ufoInFileNameLen != 0) {
1459 memcpy(ufoDebugImage + ufoDebugImageUsed, ufoInFileName, ufoInFileNameLen + 1u);
1460 ufoDebugImageUsed += ufoInFileNameLen + 1u;
1461 } else {
1462 ufoDebugImage[ufoDebugImageUsed] = 0; ufoDebugImageUsed += 1u;
1465 ufoDebugFileNameLen = ufoInFileNameLen;
1466 ufoDebugFileNameHash = ufoInFileNameHash;
1467 ufoDebugLastLine = ~(uint32_t)0;
1468 ufoDebugLastLinePCOfs = 0;
1469 ufoDebugLastLineDP = ufoDebugCurrDP;
1474 //==========================================================================
1476 // ufoRecordDebugRecordLine
1478 //==========================================================================
1479 UFO_FORCE_INLINE void ufoRecordDebugRecordLine (uint32_t line, uint32_t newhere) {
1480 if (line == ufoDebugLastLine) {
1481 ufo_assert(ufoDebugLastLinePCOfs != 0);
1482 ufoDebugImageUsed = ufoDebugLastLinePCOfs;
1483 } else {
1484 #if 0
1485 fprintf(stderr, "FL-NEW-LINE(0x%08x): <%s>; new line: %u (old: %u)\n",
1486 ufoDebugImageUsed,
1487 ufoInFileName, line, ufoDebugLastLine);
1488 #endif
1489 ufoPutDebugVarInt(line - ufoDebugLastLine);
1490 ufoDebugLastLinePCOfs = ufoDebugImageUsed;
1491 ufoDebugLastLine = line;
1492 ufoDebugLastLineDP = ufoDebugCurrDP;
1494 ufoPutDebugVarInt(newhere - ufoDebugLastLineDP);
1495 ufoDebugCurrDP = newhere;
1499 //==========================================================================
1501 // ufoRecordDebug
1503 //==========================================================================
1504 UFO_DISABLE_INLINE void ufoRecordDebug (uint32_t newhere) {
1505 if (newhere > ufoDebugCurrDP) {
1506 uint32_t ln = (uint32_t)ufoInFileLine;
1507 if (ln == ~(uint32_t)0) ln = 0;
1508 #if 0
1509 fprintf(stderr, "FL: <%s>; line: %d\n", ufoInFileName, ufoInFileLine);
1510 #endif
1511 ufoRecordDebugCheckFile();
1512 ufoRecordDebugRecordLine(ln, newhere);
1517 //==========================================================================
1519 // ufoGetWordEndAddrYFA
1521 //==========================================================================
1522 static uint32_t ufoGetWordEndAddrYFA (uint32_t yfa) {
1523 if (yfa > 8u) {
1524 const uint32_t oyfa = yfa;
1525 yfa = ufoImgGetU32(yfa);
1526 if (yfa == 0) {
1527 if ((oyfa & UFO_ADDR_TEMP_BIT) == 0) {
1528 yfa = UFO_GET_DP();
1529 if ((yfa & UFO_ADDR_TEMP_BIT) != 0) {
1530 yfa = UFO_CFA_TO_PFA(UFO_NFA_TO_CFA(UFO_YFA_TO_NFA(oyfa)));
1532 } else {
1533 yfa = UFO_CFA_TO_PFA(UFO_NFA_TO_CFA(UFO_YFA_TO_NFA(oyfa)));
1535 } else {
1536 yfa = UFO_YFA_TO_WST(yfa);
1538 } else {
1539 yfa = 0;
1541 return yfa;
1545 //==========================================================================
1547 // ufoGetWordEndAddr
1549 //==========================================================================
1550 static uint32_t ufoGetWordEndAddr (const uint32_t cfa) {
1551 if (cfa != 0) {
1552 return ufoGetWordEndAddrYFA(UFO_LFA_TO_YFA(UFO_CFA_TO_LFA(cfa)));
1553 } else {
1554 return 0;
1559 //==========================================================================
1561 // ufoFindWordForIP
1563 // return NFA or 0
1565 // WARNING: this is SLOW!
1567 //==========================================================================
1568 static uint32_t ufoFindWordForIP (const uint32_t ip) {
1569 uint32_t res = 0;
1570 if (ip != 0) {
1571 //fprintf(stderr, "ufoFindWordForIP:000: ip=0x%08x\n", ip);
1572 // iterate over all words
1573 uint32_t xfa = ufoImgGetU32(ufoAddrLastXFA);
1574 //fprintf(stderr, "ufoFindWordForIP:001: xfa=0x%08x\n", xfa);
1575 if (xfa != 0) {
1576 while (res == 0 && xfa != 0) {
1577 const uint32_t yfa = UFO_XFA_TO_YFA(xfa);
1578 const uint32_t wst = UFO_YFA_TO_WST(yfa);
1579 //fprintf(stderr, "ufoFindWordForIP:002: yfa=0x%08x; wst=0x%08x\n", yfa, wst);
1580 const uint32_t wend = ufoGetWordEndAddrYFA(yfa);
1581 if (ip >= wst && ip < wend) {
1582 res = UFO_YFA_TO_NFA(yfa);
1583 } else {
1584 xfa = ufoImgGetU32(xfa);
1589 return res;
1593 //==========================================================================
1595 // ufoFindFileForIP
1597 // return file name or `NULL`
1599 // WARNING: this is SLOW!
1601 //==========================================================================
1602 static const char *ufoFindFileForIP (uint32_t ip, uint32_t *line,
1603 uint32_t *nlen, uint32_t *nhash)
1605 if (ip != 0 && ufoDebugImageUsed != 0) {
1606 const char *filename = NULL;
1607 uint32_t dbgpos = 4u; // first line header info
1608 uint32_t lastline = 0;
1609 uint32_t lastdp = 0;
1610 uint32_t namelen = 0;
1611 uint32_t namehash = 0;
1612 while (dbgpos < ufoDebugImageUsed) {
1613 if (ufoDebugImage[dbgpos] == 0) {
1614 // new file info
1615 dbgpos += 1u; // skip flag
1616 const uint32_t fhdrSize = *(const uint16_t *)(ufoDebugImage + dbgpos); dbgpos += 2u;
1617 lastdp = ufoGetDebugVarInt(dbgpos);
1618 dbgpos = ufoSkipDebugVarInt(dbgpos);
1619 uint32_t infoOfs;
1620 if (fhdrSize == 0) {
1621 // reused
1622 infoOfs = *(const uint32_t *)(ufoDebugImage + dbgpos); dbgpos += 4u;
1623 } else {
1624 // new
1625 infoOfs = dbgpos;
1627 filename = (const char *)(ufoDebugImage + infoOfs + 3u * 4u);
1628 namelen = ((const uint32_t *)(ufoDebugImage + infoOfs))[2];
1629 namehash = ((const uint32_t *)(ufoDebugImage + infoOfs))[1];
1630 if (filename[0] == 0) filename = NULL;
1631 dbgpos += fhdrSize;
1632 lastline = ~(uint32_t)0;
1633 } else {
1634 const uint32_t ln = ufoGetDebugVarInt(dbgpos);
1635 dbgpos = ufoSkipDebugVarInt(dbgpos);
1636 ufo_assert(ln != 0);
1637 lastline += ln;
1638 const uint32_t edp = ufoGetDebugVarInt(dbgpos);
1639 dbgpos = ufoSkipDebugVarInt(dbgpos);
1640 if (ip >= lastdp && ip < lastdp + edp) {
1641 if (line) *line = lastline;
1642 if (nlen) *nlen = namelen;
1643 if (nhash) *nhash = namehash;
1644 return filename;
1646 lastdp += edp;
1650 if (line) *line = 0;
1651 if (nlen) *nlen = 0;
1652 if (nhash) *nlen = 0;
1653 return NULL;
1657 //==========================================================================
1659 // ufoBumpDP
1661 //==========================================================================
1662 UFO_FORCE_INLINE void ufoBumpDP (uint32_t delta) {
1663 uint32_t dp = ufoImgGetU32(ufoAddrDPTemp);
1664 if (dp == 0) {
1665 dp = ufoImgGetU32(ufoAddrDP);
1666 if ((dp & UFO_ADDR_SPECIAL_BITS_MASK) == 0) ufoRecordDebug(dp + delta);
1667 dp += delta;
1668 ufoImgPutU32(ufoAddrDP, dp);
1669 } else {
1670 dp = ufoImgGetU32(ufoAddrDPTemp);
1671 if ((dp & UFO_ADDR_SPECIAL_BITS_MASK) == 0) ufoRecordDebug(dp + delta);
1672 dp += delta;
1673 ufoImgPutU32(ufoAddrDPTemp, dp);
1678 //==========================================================================
1680 // ufoImgEmitU8
1682 //==========================================================================
1683 UFO_FORCE_INLINE void ufoImgEmitU8 (uint32_t value) {
1684 ufoImgPutU8(UFO_GET_DP(), value);
1685 ufoBumpDP(1);
1689 //==========================================================================
1691 // ufoImgEmitU32
1693 //==========================================================================
1694 UFO_FORCE_INLINE void ufoImgEmitU32 (uint32_t value) {
1695 ufoImgPutU32(UFO_GET_DP(), value);
1696 ufoBumpDP(4);
1700 #ifdef UFO_FAST_MEM_ACCESS
1702 //==========================================================================
1704 // ufoImgEmitU32_NoInline
1706 // false
1708 //==========================================================================
1709 UFO_FORCE_INLINE void ufoImgEmitU32_NoInline (uint32_t value) {
1710 ufoImgPutU32(UFO_GET_DP(), value);
1711 ufoBumpDP(4);
1714 #else
1716 //==========================================================================
1718 // ufoImgEmitU32_NoInline
1720 // general
1722 //==========================================================================
1723 UFO_DISABLE_INLINE void ufoImgEmitU32_NoInline (uint32_t value) {
1724 ufoImgPutU32(UFO_GET_DP(), value);
1725 ufoBumpDP(4);
1728 #endif
1731 //==========================================================================
1733 // ufoImgGetU8Ext
1735 // this understands handle addresses
1737 //==========================================================================
1738 UFO_FORCE_INLINE uint32_t ufoImgGetU8Ext (uint32_t addr) {
1739 if ((addr & UFO_ADDR_HANDLE_BIT) == 0) {
1740 return ufoImgGetU8(addr);
1741 } else {
1742 ufoPush(0);
1743 ufoPush(addr);
1744 UFCALL(PAR_HANDLE_LOAD_BYTE);
1745 return ufoPop();
1750 //==========================================================================
1752 // ufoImgPutU8Ext
1754 // this understands handle addresses
1756 //==========================================================================
1757 UFO_FORCE_INLINE void ufoImgPutU8Ext (uint32_t addr, uint32_t value) {
1758 if ((addr & UFO_ADDR_HANDLE_BIT) == 0) {
1759 ufoImgPutU8(addr, value);
1760 } else {
1761 ufoPush(value);
1762 ufoPush(0);
1763 ufoPush(addr);
1764 UFCALL(PAR_HANDLE_STORE_BYTE);
1769 //==========================================================================
1771 // ufoImgEmitAlign
1773 //==========================================================================
1774 UFO_FORCE_INLINE void ufoImgEmitAlign (void) {
1775 while ((UFO_GET_DP() & 3) != 0) ufoImgEmitU8(0);
1779 //==========================================================================
1781 // ufoResetTib
1783 //==========================================================================
1784 UFO_FORCE_INLINE void ufoResetTib (void) {
1785 uint32_t defTIB = ufoImgGetU32(ufoAddrDefTIB);
1786 //fprintf(stderr, "ufoResetTib(%p): defTIB=0x%08x\n", ufoCurrState, defTIB);
1787 if (defTIB == 0) {
1788 // create new TIB handle
1789 UfoHandle *tibh = ufoAllocHandle(0x69a029a6); // arbitrary number
1790 defTIB = tibh->ufoHandle;
1791 ufoImgPutU32(ufoAddrDefTIB, defTIB);
1793 if ((defTIB & UFO_ADDR_HANDLE_BIT) != 0) {
1794 UfoHandle *hh = ufoGetHandle(defTIB);
1795 if (hh == NULL) ufoFatal("default TIB is not allocated");
1796 if (hh->size == 0) {
1797 ufo_assert(hh->data == NULL);
1798 hh->data = calloc(1, UFO_ADDR_HANDLE_OFS_MASK + 1);
1799 if (hh->data == NULL) ufoFatal("out of memory for default TIB");
1800 hh->size = UFO_ADDR_HANDLE_OFS_MASK + 1;
1803 const uint32_t oldA = ufoRegA;
1804 ufoImgPutU32(ufoAddrTIBx, defTIB);
1805 ufoImgPutU32(ufoAddrINx, 0);
1806 ufoRegA = defTIB;
1807 ufoPush(0); // value
1808 ufoPush(0); // offset
1809 UFCALL(CPOKE_REGA_IDX);
1810 ufoRegA = oldA;
1814 //==========================================================================
1816 // ufoTibEnsureSize
1818 //==========================================================================
1819 UFO_DISABLE_INLINE void ufoTibEnsureSize (uint32_t size) {
1820 if (size > 1024u * 1024u * 256u) ufoFatal("TIB size too big");
1821 const uint32_t tib = ufoImgGetU32(ufoAddrTIBx);
1822 //fprintf(stderr, "ufoTibEnsureSize: TIB=0x%08x; size=%u\n", tib, size);
1823 if ((tib & UFO_ADDR_HANDLE_BIT) != 0) {
1824 UfoHandle *hh = ufoGetHandle(tib);
1825 if (hh == NULL) {
1826 ufoFatal("cannot resize TIB, TIB is not a handle");
1828 if (hh->size < size) {
1829 const uint32_t newsz = (size | 0xfffU) + 1u;
1830 uint8_t *nx = realloc(hh->data, newsz);
1831 if (nx == NULL) ufoFatal("out of memory for restored TIB");
1832 hh->data = nx;
1833 hh->size = newsz;
1836 #if 0
1837 else {
1838 ufoFatal("cannot resize TIB, TIB is not a handle (0x%08x)", tib);
1840 #endif
1844 //==========================================================================
1846 // ufoTibGetSize
1848 //==========================================================================
1850 UFO_DISABLE_INLINE uint32_t ufoTibGetSize (void) {
1851 const uint32_t tib = ufoImgGetU32(ufoAddrTIBx);
1852 if ((tib & UFO_ADDR_HANDLE_BIT) == 0) {
1853 ufoFatal("cannot query TIB, TIB is not a handle");
1855 UfoHandle *hh = ufoGetHandle(tib);
1856 if (hh == NULL) {
1857 ufoFatal("cannot query TIB, TIB is not a handle");
1859 return hh->size;
1864 //==========================================================================
1866 // ufoTibPeekCh
1868 //==========================================================================
1869 UFO_FORCE_INLINE uint8_t ufoTibPeekCh (void) {
1870 return (uint8_t)ufoImgGetU8Ext(ufoImgGetU32(ufoAddrTIBx) + ufoImgGetU32(ufoAddrINx));
1874 //==========================================================================
1876 // ufoTibPeekChOfs
1878 //==========================================================================
1879 UFO_FORCE_INLINE uint8_t ufoTibPeekChOfs (uint32_t ofs) {
1880 const uint32_t tib = ufoImgGetU32(ufoAddrTIBx);
1881 if (ofs <= UFO_ADDR_HANDLE_OFS_MASK || (tib & UFO_ADDR_HANDLE_BIT) == 0) {
1882 return (uint8_t)ufoImgGetU8Ext(tib + ufoImgGetU32(ufoAddrINx) + ofs);
1883 } else {
1884 return 0;
1889 //==========================================================================
1891 // ufoTibPokeChOfs
1893 //==========================================================================
1894 UFO_DISABLE_INLINE void ufoTibPokeChOfs (uint8_t ch, uint32_t ofs) {
1895 const uint32_t oldA = ufoRegA;
1896 ufoRegA = ufoImgGetU32(ufoAddrTIBx);
1897 ufoPush(ch);
1898 ufoPush(ufoImgGetU32(ufoAddrINx) + ofs);
1899 UFCALL(CPOKE_REGA_IDX);
1900 ufoRegA = oldA;
1904 //==========================================================================
1906 // ufoTibGetCh
1908 //==========================================================================
1909 UFO_FORCE_INLINE uint8_t ufoTibGetCh (void) {
1910 const uint8_t ch = ufoTibPeekCh();
1911 if (ch) ufoImgPutU32(ufoAddrINx, ufoImgGetU32(ufoAddrINx) + 1u);
1912 return ch;
1916 //==========================================================================
1918 // ufoTibSkipCh
1920 //==========================================================================
1921 UFO_FORCE_INLINE void ufoTibSkipCh (void) {
1922 (void)ufoTibGetCh();
1926 // ////////////////////////////////////////////////////////////////////////// //
1927 // native CFA implementations
1930 //==========================================================================
1932 // ufoDoForth
1934 //==========================================================================
1935 static void ufoDoForth (uint32_t pfa) {
1936 ufoRPush(ufoIP);
1937 ufoIP = pfa;
1941 //==========================================================================
1943 // ufoDoVariable
1945 //==========================================================================
1946 static void ufoDoVariable (uint32_t pfa) {
1947 ufoPush(pfa);
1951 //==========================================================================
1953 // ufoDoUserVariable
1955 //==========================================================================
1956 static void ufoDoUserVariable (uint32_t pfa) {
1957 ufoPush(ufoImgGetU32(pfa));
1961 //==========================================================================
1963 // ufoDoValue
1965 //==========================================================================
1966 static void ufoDoValue (uint32_t pfa) {
1967 ufoPush(ufoImgGetU32(pfa));
1971 //==========================================================================
1973 // ufoDoConst
1975 //==========================================================================
1976 static void ufoDoConst (uint32_t pfa) {
1977 ufoPush(ufoImgGetU32(pfa));
1981 //==========================================================================
1983 // ufoDoDefer
1985 //==========================================================================
1986 static void ufoDoDefer (uint32_t pfa) {
1987 const uint32_t cfa = ufoImgGetU32(pfa);
1988 if (cfa != 0) {
1989 ufoRPush(cfa);
1990 ufoVMRPopCFA = 1;
1995 //==========================================================================
1997 // ufoDoVoc
1999 //==========================================================================
2000 static void ufoDoVoc (uint32_t pfa) {
2001 ufoImgPutU32(ufoAddrContext, ufoImgGetU32(pfa));
2005 //==========================================================================
2007 // ufoDoCreate
2009 //==========================================================================
2010 static void ufoDoCreate (uint32_t pfa) {
2011 ufoPush(pfa);
2015 //==========================================================================
2017 // ufoPushInFile
2019 // this also increments last used file id
2021 //==========================================================================
2022 static void ufoPushInFile (void) {
2023 if (ufoFileStackPos >= UFO_MAX_NESTED_INCLUDES) ufoFatal("too many includes");
2024 UFOFileStackEntry *stk = &ufoFileStack[ufoFileStackPos];
2025 stk->fl = ufoInFile;
2026 stk->fname = ufoInFileName;
2027 stk->fline = ufoInFileLine;
2028 stk->id = ufoFileId;
2029 stk->incpath = (ufoLastIncPath ? strdup(ufoLastIncPath) : NULL);
2030 stk->sysincpath = (ufoLastSysIncPath ? strdup(ufoLastSysIncPath) : NULL);
2031 ufoFileStackPos += 1;
2032 ufoInFile = NULL;
2033 ufoInFileName = NULL; ufoInFileNameLen = 0; ufoInFileNameHash = 0;
2034 ufoInFileLine = 0;
2035 ufoLastUsedFileId += 1;
2036 ufo_assert(ufoLastUsedFileId != 0); // just in case ;-)
2037 //ufoLastIncPath = NULL;
2041 //==========================================================================
2043 // ufoWipeIncludeStack
2045 //==========================================================================
2046 static void ufoWipeIncludeStack (void) {
2047 if (ufoInFileName) { free(ufoInFileName); ufoInFileName = NULL; }
2048 if (ufoInFile) { fclose(ufoInFile); ufoInFile = NULL; }
2049 if (ufoLastIncPath) { free(ufoLastIncPath); ufoLastIncPath = NULL; }
2050 if (ufoLastSysIncPath) { free(ufoLastSysIncPath); ufoLastSysIncPath = NULL; }
2051 while (ufoFileStackPos != 0) {
2052 ufoFileStackPos -= 1;
2053 UFOFileStackEntry *stk = &ufoFileStack[ufoFileStackPos];
2054 if (stk->fl) fclose(stk->fl);
2055 if (stk->fname) free(stk->fname);
2056 if (stk->incpath) free(stk->incpath);
2061 //==========================================================================
2063 // ufoPopInFile
2065 //==========================================================================
2066 static void ufoPopInFile (void) {
2067 if (ufoFileStackPos == 0) ufoFatal("trying to pop include from empty stack");
2068 if (ufoInFileName) { free(ufoInFileName); ufoInFileName = NULL; }
2069 if (ufoInFile) { fclose(ufoInFile); ufoInFile = NULL; }
2070 if (ufoLastIncPath) { free(ufoLastIncPath); ufoLastIncPath = NULL; }
2071 if (ufoLastSysIncPath) { free(ufoLastSysIncPath); ufoLastSysIncPath = NULL; }
2072 ufoFileStackPos -= 1;
2073 UFOFileStackEntry *stk = &ufoFileStack[ufoFileStackPos];
2074 ufoInFile = stk->fl;
2075 ufoSetInFileNameReuse(stk->fname);
2076 ufoInFileLine = stk->fline;
2077 ufoLastIncPath = stk->incpath;
2078 ufoLastSysIncPath = stk->sysincpath;
2079 ufoFileId = stk->id;
2080 ufoResetTib();
2081 #ifdef UFO_DEBUG_INCLUDE
2082 if (ufoInFileName == NULL) {
2083 fprintf(stderr, "INC-POP: no more files.\n");
2084 } else {
2085 fprintf(stderr, "INC-POP: fname: %s\n", ufoInFileName);
2087 #endif
2091 //==========================================================================
2093 // ufoDeinit
2095 //==========================================================================
2096 void ufoDeinit (void) {
2097 #ifdef UFO_DEBUG_WRITE_MAIN_IMAGE
2099 FILE *fo = fopen("zufo_main.img", "w");
2100 uint32_t dpTemp = ufoImgGetU32(ufoAddrDPTemp);
2101 uint32_t dpMain = ufoImgGetU32(ufoAddrDP);
2102 if ((dpMain & UFO_ADDR_SPECIAL_BITS_MASK) != 0) dpMain = ufoImageSize;
2103 if (dpTemp != 0 && (dpTemp & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
2104 if (dpTemp > dpMain) dpMain = dpTemp;
2106 fwrite(ufoImage, dpMain, 1, fo);
2107 fclose(fo);
2109 #endif
2111 #ifdef UFO_DEBUG_WRITE_DEBUG_IMAGE
2113 FILE *fo = fopen("zufo_debug.img", "w");
2114 fwrite(ufoDebugImage, ufoDebugImageUsed, 1, fo);
2115 fclose(fo);
2117 #endif
2119 #ifdef UFO_DEBUG_DEBUG
2121 uint32_t dpTemp = ufoImgGetU32(ufoAddrDPTemp);
2122 uint32_t dpMain = ufoImgGetU32(ufoAddrDP);
2123 if ((dpMain & UFO_ADDR_SPECIAL_BITS_MASK) != 0) dpMain = ufoImageSize;
2124 if (dpTemp != 0 && (dpTemp & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
2125 if (dpTemp > dpMain) dpMain = dpTemp;
2127 fprintf(stderr, "UFO: image used: %u; size: %u\n",
2128 dpMain, ufoImageSize);
2129 fprintf(stderr, "UFO: debug image used: %u; size: %u\n",
2130 ufoDebugImageUsed, ufoDebugImageSize);
2131 ufoDumpDebugImage();
2133 #endif
2135 // free all states
2136 ufoCurrState = NULL;
2137 ufoYieldedState = NULL;
2138 ufoDebuggerState = NULL;
2139 for (uint32_t fidx = 0; fidx < (uint32_t)(UFO_MAX_STATES/32); fidx += 1u) {
2140 uint32_t bmp = ufoStateUsedBitmap[fidx];
2141 if (bmp != 0) {
2142 uint32_t stid = fidx * 32u;
2143 while (bmp != 0) {
2144 if ((bmp & 0x01) != 0) ufoFreeState(ufoStateMap[stid]);
2145 stid += 1u; bmp >>= 1;
2150 free(ufoDebugImage);
2151 ufoDebugImage = NULL;
2152 ufoDebugImageUsed = 0;
2153 ufoDebugImageSize = 0;
2154 ufoDebugFileNameHash = 0;
2155 ufoDebugFileNameLen = 0;
2156 ufoDebugLastLine = 0;
2157 ufoDebugLastLinePCOfs = 0;
2158 ufoDebugLastLineDP = 0;
2159 ufoDebugCurrDP = 0;
2161 ufoInBacktrace = 0;
2162 ufoClearCondDefines();
2163 ufoWipeIncludeStack();
2165 // release all includes
2166 ufoInFile = NULL;
2167 if (ufoInFileName) free(ufoInFileName);
2168 if (ufoLastIncPath) free(ufoLastIncPath);
2169 if (ufoLastSysIncPath) free(ufoLastSysIncPath);
2170 ufoInFileName = NULL; ufoLastIncPath = NULL; ufoLastSysIncPath = NULL;
2171 ufoInFileNameHash = 0; ufoInFileNameLen = 0;
2172 ufoInFileLine = 0;
2174 free(ufoForthCFAs);
2175 ufoForthCFAs = NULL;
2176 ufoCFAsUsed = 0;
2178 free(ufoImage);
2179 ufoImage = NULL;
2180 ufoImageSize = 0;
2182 ufoMode = UFO_MODE_NATIVE;
2183 ufoForthVocId = 0; ufoCompilerVocId = 0;
2184 ufoSingleStep = 0;
2186 // free all handles
2187 for (uint32_t f = 0; f < ufoHandlesUsed; f += 1) {
2188 UfoHandle *hh = ufoHandles[f];
2189 if (hh != NULL) {
2190 if (hh->data != NULL) free(hh->data);
2191 free(hh);
2194 if (ufoHandles != NULL) free(ufoHandles);
2195 ufoHandles = NULL; ufoHandlesUsed = 0; ufoHandlesAlloted = 0;
2196 ufoHandleFreeList = NULL;
2198 ufoLastEmitWasCR = 1;
2200 ufoClearCondDefines();
2204 //==========================================================================
2206 // ufoDumpWordHeader
2208 //==========================================================================
2209 __attribute__((unused)) static void ufoDumpWordHeader (const uint32_t lfa) {
2210 fprintf(stderr, "=== WORD: LFA: 0x%08x ===\n", lfa);
2211 if (lfa != 0) {
2212 fprintf(stderr, " (XFA): 0x%08x\n", ufoImgGetU32(UFO_LFA_TO_XFA(lfa)));
2213 fprintf(stderr, " (YFA): 0x%08x\n", ufoImgGetU32(UFO_LFA_TO_YFA(lfa)));
2214 fprintf(stderr, " (BFA): 0x%08x\n", ufoImgGetU32(UFO_LFA_TO_BFA(lfa)));
2215 fprintf(stderr, " (LFA): 0x%08x\n", ufoImgGetU32(lfa));
2216 fprintf(stderr, " (NHH): 0x%08x\n", ufoImgGetU32(UFO_LFA_TO_NHASH(lfa)));
2217 const uint32_t cfa = UFO_LFA_TO_CFA(lfa);
2218 fprintf(stderr, " CFA: 0x%08x\n", cfa);
2219 fprintf(stderr, " PFA: 0x%08x\n", UFO_CFA_TO_PFA(cfa));
2220 fprintf(stderr, " (CFA): 0x%08x\n", ufoImgGetU32(cfa));
2221 const uint32_t nfa = UFO_LFA_TO_NFA(lfa);
2222 const uint32_t nlen = ufoImgGetU8(nfa);
2223 fprintf(stderr, " NFA: 0x%08x (nlen: %u)\n", nfa, nlen);
2224 const uint32_t flags = ufoImgGetU32(nfa);
2225 fprintf(stderr, " FLAGS: 0x%08x\n", flags);
2226 if ((flags & 0xffff0000U) != 0) {
2227 fprintf(stderr, " FLAGS:");
2228 if (flags & UFW_FLAG_IMMEDIATE) fprintf(stderr, " IMM");
2229 if (flags & UFW_FLAG_SMUDGE) fprintf(stderr, " SMUDGE");
2230 if (flags & UFW_FLAG_NORETURN) fprintf(stderr, " NORET");
2231 if (flags & UFW_FLAG_HIDDEN) fprintf(stderr, " HIDDEN");
2232 if (flags & UFW_FLAG_CBLOCK) fprintf(stderr, " CBLOCK");
2233 if (flags & UFW_FLAG_VOCAB) fprintf(stderr, " VOCAB");
2234 if (flags & UFW_FLAG_SCOLON) fprintf(stderr, " SCOLON");
2235 if (flags & UFW_FLAG_PROTECTED) fprintf(stderr, " PROTECTED");
2236 fputc('\n', stderr);
2238 if ((flags & 0xff00U) != 0) {
2239 fprintf(stderr, " ARGS: ");
2240 switch (flags & UFW_WARG_MASK) {
2241 case UFW_WARG_NONE: fprintf(stderr, "NONE"); break;
2242 case UFW_WARG_BRANCH: fprintf(stderr, "BRANCH"); break;
2243 case UFW_WARG_LIT: fprintf(stderr, "LIT"); break;
2244 case UFW_WARG_C4STRZ: fprintf(stderr, "C4STRZ"); break;
2245 case UFW_WARG_CFA: fprintf(stderr, "CFA"); break;
2246 case UFW_WARG_CBLOCK: fprintf(stderr, "CBLOCK"); break;
2247 case UFW_WARG_VOCID: fprintf(stderr, "VOCID"); break;
2248 case UFW_WARG_C1STRZ: fprintf(stderr, "C1STRZ"); break;
2249 case UFW_WARG_DATASKIP: fprintf(stderr, "DATA"); break;
2250 default: fprintf(stderr, "wtf?!"); break;
2252 fputc('\n', stderr);
2254 fprintf(stderr, " BACKLEN: %u (nfa at 0x%08x)\n", ufoImgGetU8(cfa - 1u), UFO_CFA_TO_NFA(cfa));
2255 fprintf(stderr, " NAME(%u): ", nlen);
2256 for (uint32_t f = 0; f < nlen; f += 1) {
2257 const uint8_t ch = ufoImgGetU8(nfa + 4u + f);
2258 if (ch <= 32 || ch >= 127) {
2259 fprintf(stderr, "\\x%02x", ch);
2260 } else {
2261 fprintf(stderr, "%c", (char)ch);
2264 fprintf(stderr, "\n");
2265 ufo_assert(UFO_CFA_TO_LFA(cfa) == lfa);
2270 //==========================================================================
2272 // ufoVocCheckName
2274 // return 0 or CFA
2276 //==========================================================================
2277 static uint32_t ufoVocCheckName (uint32_t lfa, const void *wname, uint32_t wnlen, uint32_t hash,
2278 int allowvochid)
2280 uint32_t res = 0;
2281 #ifdef UFO_DEBUG_FIND_WORD
2282 fprintf(stderr, "CHECK-NAME: %.*s; LFA: 0x%08x; hash: 0x%08x (wname: 0x%08x)\n",
2283 (unsigned) wnlen, (const char *)wname,
2284 lfa, (lfa != 0 ? ufoImgGetU32(UFO_LFA_TO_NHASH(lfa)) : 0), hash);
2285 ufoDumpWordHeader(lfa);
2286 #endif
2287 if (lfa != 0 && ufoImgGetU32(UFO_LFA_TO_NHASH(lfa)) == hash) {
2288 const uint32_t lenflags = ufoImgGetU32(UFO_LFA_TO_NFA(lfa));
2289 if ((lenflags & UFW_FLAG_SMUDGE) == 0 &&
2290 (allowvochid || (lenflags & UFW_FLAG_HIDDEN) == 0))
2292 const uint32_t nlen = lenflags&0xffU;
2293 if (nlen == wnlen) {
2294 uint32_t naddr = UFO_LFA_TO_NFA(lfa) + 4u;
2295 uint32_t pos = 0;
2296 while (pos < nlen) {
2297 uint8_t c0 = ((const unsigned char *)wname)[pos];
2298 if (c0 >= 'a' && c0 <= 'z') c0 = c0 - 'a' + 'A';
2299 uint8_t c1 = ufoImgGetU8(naddr + pos);
2300 if (c1 >= 'a' && c1 <= 'z') c1 = c1 - 'a' + 'A';
2301 if (c0 != c1) break;
2302 pos += 1u;
2304 if (pos == nlen) {
2305 // i found her!
2306 naddr += pos + 1u;
2307 res = UFO_ALIGN4(naddr);
2312 return res;
2316 //==========================================================================
2318 // ufoFindWordInVoc
2320 // return 0 or CFA
2322 //==========================================================================
2323 static uint32_t ufoFindWordInVoc (const void *wname, uint32_t wnlen, uint32_t hash,
2324 uint32_t vocid, int allowvochid)
2326 uint32_t res = 0;
2327 if (wname == NULL) ufo_assert(wnlen == 0);
2328 if (wnlen != 0 && vocid != 0) {
2329 if (hash == 0) hash = joaatHashBufCI(wname, wnlen);
2330 #if defined(UFO_DEBUG_FIND_WORD) || defined(UFO_DEBUG_FIND_WORD_IN_VOC)
2331 fprintf(stderr, "IN-VOC: %.*s; VOCID: 0x%08x; whash: 0x%08x; htbl[0]: 0x%08x\n",
2332 (unsigned) wnlen, (const char *)wname,
2333 vocid, hash, ufoImgGetU32(vocid + UFW_VOCAB_OFS_HTABLE));
2334 #endif
2335 const uint32_t htbl = vocid + UFW_VOCAB_OFS_HTABLE;
2336 if (ufoImgGetU32(htbl) != UFO_NO_HTABLE_FLAG) {
2337 // hash table present, use it
2338 uint32_t bfa = htbl + (hash % (uint32_t)UFO_HASHTABLE_SIZE) * 4u;
2339 bfa = ufoImgGetU32(bfa);
2340 while (res == 0 && bfa != 0) {
2341 #if defined(UFO_DEBUG_FIND_WORD) || defined(UFO_DEBUG_FIND_WORD_IN_VOC)
2342 fprintf(stderr, "IN-VOC: bfa: 0x%08x\n", bfa);
2343 #endif
2344 res = ufoVocCheckName(UFO_BFA_TO_LFA(bfa), wname, wnlen, hash, allowvochid);
2345 bfa = ufoImgGetU32(bfa);
2347 } else {
2348 // no hash table, use linear search
2349 uint32_t lfa = vocid + UFW_VOCAB_OFS_LATEST;
2350 lfa = ufoImgGetU32(lfa);
2351 while (res == 0 && lfa != 0) {
2352 res = ufoVocCheckName(lfa, wname, wnlen, hash, allowvochid);
2353 lfa = ufoImgGetU32(lfa);
2357 return res;
2361 //==========================================================================
2363 // ufoFindColon
2365 // return part after the colon, or `NULL`
2367 //==========================================================================
2368 static const void *ufoFindColon (const void *wname, uint32_t wnlen) {
2369 const void *res = NULL;
2370 if (wnlen != 0) {
2371 ufo_assert(wname != NULL);
2372 const char *str = (const char *)wname;
2373 while (wnlen != 0 && str[0] != ':') {
2374 str += 1; wnlen -= 1;
2376 if (wnlen != 0) {
2377 res = (const void *)(str + 1); // skip colon
2380 return res;
2384 //==========================================================================
2386 // ufoFindWordInVocAndParents
2388 //==========================================================================
2389 static uint32_t ufoFindWordInVocAndParents (const void *wname, uint32_t wnlen, uint32_t hash,
2390 uint32_t vocid, int allowvochid)
2392 uint32_t res = 0;
2393 if (hash == 0) hash = joaatHashBufCI(wname, wnlen);
2394 while (res == 0 && vocid != 0) {
2395 res = ufoFindWordInVoc(wname, wnlen, hash, vocid, allowvochid);
2396 vocid = ufoImgGetU32(vocid + UFW_VOCAB_OFS_PARENT);
2398 return res;
2402 //==========================================================================
2404 // ufoFindWordNameRes
2406 // find with name resolution
2408 // return 0 or CFA
2410 //==========================================================================
2411 static uint32_t ufoFindWordNameRes (const void *wname, uint32_t wnlen) {
2412 uint32_t res = 0;
2413 if (wnlen != 0 && *(const char *)wname != ':') {
2414 ufo_assert(wname != NULL);
2416 const void *stx = wname;
2417 wname = ufoFindColon(wname, wnlen);
2418 if (wname != NULL) {
2419 // look in all vocabs (excluding hidden ones)
2420 uint32_t xlen = (uint32_t)(ptrdiff_t)(wname - stx) - 1u;
2421 ufo_assert(xlen > 0 && xlen < 255);
2422 uint32_t xhash = joaatHashBufCI(stx, xlen);
2423 uint32_t voclink = ufoImgGetU32(ufoAddrVocLink);
2424 #ifdef UFO_DEBUG_FIND_WORD_COLON
2425 fprintf(stderr, "COLON-FIND: first voc: {%.*s}; xhash=0x%08x; voc-link: 0x%08x\n",
2426 (unsigned)xlen, (const char *)stx, xhash, voclink);
2427 #endif
2428 while (res == 0 && voclink != 0) {
2429 const uint32_t vhdraddr = voclink - UFW_VOCAB_OFS_VOCLINK + UFW_VOCAB_OFS_HEADER;
2430 const uint32_t vhdr = ufoImgGetU32(vhdraddr);
2431 if (vhdr != 0) {
2432 res = ufoVocCheckName(UFO_NFA_TO_LFA(vhdr), stx, xlen, xhash, 0);
2434 if (res == 0) voclink = ufoImgGetU32(voclink);
2436 if (res != 0) {
2437 uint32_t vocid = voclink - UFW_VOCAB_OFS_VOCLINK;
2438 ufo_assert(voclink != 0);
2439 wnlen -= xlen + 1;
2440 #ifdef UFO_DEBUG_FIND_WORD_COLON
2441 fprintf(stderr, "searching {%.*s}(%u) in {%.*s}\n",
2442 (unsigned)wnlen, wname, wnlen, (unsigned)xlen, stx);
2443 #endif
2444 while (res != 0 && wname != NULL) {
2445 // first, the whole rest
2446 res = ufoFindWordInVocAndParents(wname, wnlen, 0, vocid, 1);
2447 if (res != 0) {
2448 wname = NULL;
2449 } else {
2450 stx = wname;
2451 wname = ufoFindColon(wname, wnlen);
2452 if (wname == NULL) xlen = wnlen; else xlen = (uint32_t)(ptrdiff_t)(wname - stx) - 1u;
2453 ufo_assert(xlen > 0 && xlen < 255);
2454 res = ufoFindWordInVocAndParents(stx, xlen, 0, vocid, 1);
2455 if (res != 0) {
2456 wnlen -= xlen + 1;
2457 if (wname != NULL) {
2458 // it should be a vocabulary
2459 const uint32_t nfa = UFO_CFA_TO_NFA(res);
2460 if ((ufoImgGetU32(nfa) & UFW_FLAG_VOCAB) != 0) {
2461 vocid = ufoImgGetU32(UFO_CFA_TO_PFA(res)); // pfa points to vocabulary
2462 } else {
2463 res = 0;
2473 return res;
2477 //==========================================================================
2479 // ufoFindWord
2481 // doesn't look in CURRENT, does name resolution ("a:b" is word "b" in "a")
2483 // return 0 or CFA
2485 //==========================================================================
2486 static uint32_t ufoFindWord (const char *wname) {
2487 uint32_t res = 0;
2488 if (wname && wname[0] != 0) {
2489 const size_t wnlen = strlen(wname);
2490 ufo_assert(wnlen < 8192);
2491 uint32_t ctx = ufoImgGetU32(ufoAddrContext);
2492 const uint32_t hash = joaatHashBufCI(wname, (uint32_t)wnlen);
2494 //fprintf(stderr, "FIND-WORD: whash: 0x%08x; name:{%s}\n", hash, wname);
2496 // first search in context
2497 res = ufoFindWordInVocAndParents(wname, (uint32_t)wnlen, hash, ctx, (ctx == ufoImgGetU32(ufoAddrCurrent)));
2499 // now try vocabulary stack
2500 uint32_t vstp = ufoVSP;
2501 while (res == 0 && vstp != 0) {
2502 vstp -= 1;
2503 ctx = ufoVocStack[vstp];
2504 res = ufoFindWordInVocAndParents(wname, (uint32_t)wnlen, hash, ctx, (ctx == ufoImgGetU32(ufoAddrCurrent)));
2507 // if not found, try name resolution
2508 if (res == 0) res = ufoFindWordNameRes(wname, (uint32_t)wnlen);
2511 return res;
2515 //==========================================================================
2517 // ufoCreateWordHeader
2519 // create word header up to CFA, link to the current dictionary
2521 //==========================================================================
2522 static void ufoCreateWordHeader (const char *wname, uint32_t flags) {
2523 if (wname == NULL) wname = "";
2524 const size_t wnlen = strlen(wname);
2525 ufo_assert(wnlen < UFO_MAX_WORD_LENGTH);
2526 const uint32_t hash = joaatHashBufCI(wname, (uint32_t)wnlen);
2527 const uint32_t curr = ufoImgGetU32(ufoAddrCurrent);
2528 ufo_assert(curr != 0);
2529 // redefine check
2530 const uint32_t warn = ufoImgGetU32(ufoAddrRedefineWarning);
2531 if (wnlen != 0 && warn != UFO_REDEF_WARN_DONT_CARE) {
2532 uint32_t cfa;
2533 if (warn != UFO_REDEF_WARN_PARENTS) {
2534 cfa = ufoFindWordInVoc(wname, wnlen, hash, curr, 1);
2535 } else {
2536 cfa = ufoFindWordInVocAndParents(wname, wnlen, hash, curr, 1);
2538 if (cfa != 0) {
2539 const uint32_t nfa = UFO_CFA_TO_NFA(cfa);
2540 const uint32_t flags = ufoImgGetU32(nfa);
2541 if ((flags & UFW_FLAG_PROTECTED) != 0) {
2542 ufoFatal("trying to redefine protected word '%s'", wname);
2543 } else if (warn != UFO_REDEF_WARN_NONE) {
2544 ufoWarning("redefining word '%s'", wname);
2548 //fprintf(stderr, "000: HERE: 0x%08x\n", UFO_GET_DP());
2549 const uint32_t bkt = (hash % (uint32_t)UFO_HASHTABLE_SIZE) * 4u;
2550 const uint32_t htbl = curr + UFW_VOCAB_OFS_HTABLE;
2551 ufoImgEmitAlign();
2552 const uint32_t xfaAddr = UFO_GET_DP();
2553 if ((xfaAddr & UFO_ADDR_TEMP_BIT) == 0) {
2554 // link previous yfa here
2555 const uint32_t lastxfa = ufoImgGetU32(ufoAddrLastXFA);
2556 // fix YFA of the previous word
2557 if (lastxfa != 0) {
2558 ufoImgPutU32(UFO_XFA_TO_YFA(lastxfa), UFO_XFA_TO_YFA(xfaAddr));
2560 // our XFA points to the previous XFA
2561 ufoImgEmitU32(lastxfa); // xfa
2562 // update last XFA
2563 ufoImgPutU32(ufoAddrLastXFA, xfaAddr);
2564 } else {
2565 ufoImgEmitU32(0); // xfa
2567 ufoImgEmitU32(0); // yfa
2568 // bucket link (bfa)
2569 if (wnlen == 0 || ufoImgGetU32(htbl) == UFO_NO_HTABLE_FLAG) {
2570 ufoImgEmitU32(0);
2571 } else {
2572 #ifdef UFO_DEBUG_DUMP_NEW_HEADERS
2573 fprintf(stderr, "NEW HEADER: %s; curr: 0x%08x; htbl: 0x%08x; bkt: 0x%08x\n",
2574 wname, curr, htbl, bkt);
2575 fprintf(stderr, " [bkt]: 0x%08x; nbk: 0x%08x\n", ufoImgGetU32(htbl + bkt), UFO_GET_DP());
2576 #endif
2577 // bfa points to bfa
2578 const uint32_t bfa = UFO_GET_DP();
2579 ufoImgEmitU32(ufoImgGetU32(htbl + bkt));
2580 ufoImgPutU32(htbl + bkt, bfa);
2582 // lfa
2583 const uint32_t lfa = UFO_GET_DP();
2584 ufoImgEmitU32(ufoImgGetU32(curr + UFW_VOCAB_OFS_LATEST));
2585 // fix voc latest
2586 ufoImgPutU32(curr + UFW_VOCAB_OFS_LATEST, lfa);
2587 // name hash
2588 ufoImgEmitU32(hash);
2589 // name length
2590 const uint32_t nfa = UFO_GET_DP();
2591 ufoImgEmitU32(((uint32_t)wnlen&0xffU) | (flags & 0xffffff00U));
2592 const uint32_t nstart = UFO_GET_DP();
2593 // put name
2594 for (size_t f = 0; f < wnlen; f += 1) {
2595 ufoImgEmitU8(((const unsigned char *)wname)[f]);
2597 while ((UFO_GET_DP() & 3) != 3) ufoImgEmitU8(0);
2598 const uint32_t nend = UFO_GET_DP(); // length byte itself is not included
2599 // name length, again
2600 ufo_assert(nend - nstart <= 255);
2601 ufoImgEmitU8((uint8_t)(nend - nstart));
2602 ufo_assert((UFO_GET_DP() & 3) == 0);
2603 ufo_assert(UFO_CFA_TO_NFA(UFO_GET_DP()) == nfa);
2604 if ((nend & UFO_ADDR_SPECIAL_BITS_MASK) == 0) ufoRecordDebug(nend);
2605 #ifdef UFO_DEBUG_DUMP_NEW_HEADERS
2606 fprintf(stderr, "*** NEW HEADER ***\n");
2607 fprintf(stderr, "CFA: 0x%08x\n", UFO_GET_DP());
2608 fprintf(stderr, "NSTART: 0x%08x\n", nstart);
2609 fprintf(stderr, "NEND: 0x%08x\n", nend);
2610 fprintf(stderr, "NLEN: %u (%u)\n", nend - nstart, ufoImgGetU8(UFO_GET_DP() - 1u));
2611 ufoDumpWordHeader(lfa);
2612 #endif
2613 #if 0
2614 fprintf(stderr, "NEW WORD CFA 0x%08x: %s\n", UFO_GET_DP(), wname);
2615 #endif
2619 //==========================================================================
2621 // ufoDecompilePart
2623 //==========================================================================
2624 static void ufoDecompilePart (uint32_t addr, uint32_t eaddr, int indent) {
2625 uint32_t count;
2626 FILE *fo = stdout;
2627 while (addr < eaddr) {
2628 uint32_t cfa = ufoImgGetU32(addr);
2629 for (int n = 0; n < indent; n += 1) fputc(' ', fo);
2630 fprintf(fo, "%6u: 0x%08x: ", addr, cfa);
2631 uint32_t nfa = UFO_CFA_TO_NFA(cfa);
2632 uint32_t flags = ufoImgGetU32(nfa);
2633 //fprintf(fo, "[0x%08x] ", flags & UFW_WARG_MASK);
2634 uint32_t nlen = flags & 0xffU;
2635 for (uint32_t f = 0; f < nlen; f += 1) {
2636 const uint8_t ch = ufoImgGetU8(nfa + 4u + f);
2637 if (ch <= 32 || ch >= 127) {
2638 fprintf(fo, "\\x%02x", ch);
2639 } else {
2640 fprintf(fo, "%c", (char)ch);
2643 addr += 4u;
2644 switch (flags & UFW_WARG_MASK) {
2645 case UFW_WARG_NONE:
2646 break;
2647 case UFW_WARG_BRANCH:
2648 fprintf(fo, " @%u", ufoImgGetU32(addr)); addr += 4u;
2649 break;
2650 case UFW_WARG_LIT:
2651 fprintf(fo, " %u : %d : 0x%08x", ufoImgGetU32(addr),
2652 (int32_t)ufoImgGetU32(addr), ufoImgGetU32(addr)); addr += 4u;
2653 break;
2654 case UFW_WARG_C4STRZ:
2655 count = ufoImgGetU32(addr); addr += 4;
2656 print_str:
2657 fprintf(fo, " str:");
2658 for (int f = 0; f < count; f += 1) {
2659 const uint8_t ch = ufoImgGetU8(addr); addr += 1u;
2660 if (ch <= 32 || ch >= 127) {
2661 fprintf(fo, "\\x%02x", ch);
2662 } else {
2663 fprintf(fo, "%c", (char)ch);
2666 addr += 1u; // skip zero byte
2667 addr = UFO_ALIGN4(addr);
2668 break;
2669 case UFW_WARG_CFA:
2670 cfa = ufoImgGetU32(addr); addr += 4u;
2671 fprintf(fo, " CFA:%u: ", cfa);
2672 nfa = UFO_CFA_TO_NFA(cfa);
2673 nlen = ufoImgGetU8(nfa);
2674 for (uint32_t f = 0; f < nlen; f += 1) {
2675 const uint8_t ch = ufoImgGetU8(nfa + 4u + f);
2676 if (ch <= 32 || ch >= 127) {
2677 fprintf(fo, "\\x%02x", ch);
2678 } else {
2679 fprintf(fo, "%c", (char)ch);
2682 break;
2683 case UFW_WARG_CBLOCK:
2684 fprintf(fo, " CBLOCK:%u", ufoImgGetU32(addr)); addr += 4u;
2685 break;
2686 case UFW_WARG_VOCID:
2687 fprintf(fo, " VOCID:%u", ufoImgGetU32(addr)); addr += 4u;
2688 break;
2689 case UFW_WARG_C1STRZ:
2690 count = ufoImgGetU8(addr); addr += 1;
2691 goto print_str;
2692 case UFW_WARG_DATASKIP:
2693 fprintf(fo, " DATA:%u", ufoImgGetU32(addr));
2694 addr += ufoImgGetU32(addr) + 4u;
2695 break;
2696 default:
2697 fprintf(fo, " -- WTF?!\n");
2698 abort();
2700 fputc('\n', fo);
2705 //==========================================================================
2707 // ufoDecompileWord
2709 //==========================================================================
2710 static void ufoDecompileWord (const uint32_t cfa) {
2711 if (cfa != 0) {
2712 const uint32_t lfa = UFO_CFA_TO_LFA(cfa);
2713 fprintf(stdout, "#### DECOMPILING CFA %u ###\n", cfa);
2714 ufoDumpWordHeader(lfa);
2715 const uint32_t yfa = ufoGetWordEndAddr(cfa);
2716 if (ufoImgGetU32(cfa) == ufoDoForthCFA) {
2717 fprintf(stdout, "--- DECOMPILED CODE ---\n");
2718 ufoDecompilePart(UFO_CFA_TO_PFA(cfa), yfa, 0);
2719 fprintf(stdout, "=======================\n");
2725 //==========================================================================
2727 // ufoBTShowWordName
2729 //==========================================================================
2730 static void ufoBTShowWordName (uint32_t nfa) {
2731 if (nfa != 0) {
2732 uint32_t len = ufoImgGetU8(nfa); nfa += 4u;
2733 //fprintf(stderr, "(0x%08x)", ufoImgGetU32(nfa - 4u));
2734 while (len != 0) {
2735 uint8_t ch = ufoImgGetU8(nfa); nfa += 1u; len -= 1u;
2736 if (ch <= 32 || ch >= 127) {
2737 fprintf(stderr, "\\x%02x", ch);
2738 } else {
2739 fprintf(stderr, "%c", (char)ch);
2746 //==========================================================================
2748 // ufoBacktrace
2750 //==========================================================================
2751 static void ufoBacktrace (uint32_t ip, int showDataStack) {
2752 // dump data stack (top 16)
2753 ufoFlushOutput();
2754 if (!ufoLastEmitWasCR) { printf("\n"); ufoLastEmitWasCR = 1; }
2756 if (showDataStack) {
2757 fprintf(stderr, "***UFO STACK DEPTH: %u\n", ufoSP);
2758 uint32_t xsp = ufoSP;
2759 if (xsp > 16) xsp = 16;
2760 for (uint32_t sp = 0; sp < xsp; ++sp) {
2761 fprintf(stderr, " %2u: 0x%08x %d%s\n",
2762 sp, ufoDStack[xsp - sp - 1], (int32_t)ufoDStack[xsp - sp - 1],
2763 (sp == 0 ? " -- TOS" : ""));
2765 if (ufoSP > 16) fprintf(stderr, " ...more...\n");
2768 // dump return stack (top 32)
2769 uint32_t nfa;
2770 uint32_t fline;
2771 const char *fname;
2773 fprintf(stderr, "***UFO RETURN STACK DEPTH: %u\n", ufoRP);
2774 if (ip != 0) {
2775 nfa = ufoFindWordForIP(ip);
2776 if (nfa != 0) {
2777 fprintf(stderr, " **: %8u -- ", ip);
2778 ufoBTShowWordName(nfa);
2779 fname = ufoFindFileForIP(ip, &fline, NULL, NULL);
2780 if (fname != NULL) { fprintf(stderr, " (at %s:%u)", fname, fline); }
2781 fputc('\n', stderr);
2784 uint32_t rp = ufoRP;
2785 uint32_t rscount = 0;
2786 if (rp > UFO_RSTACK_SIZE) rp = UFO_RSTACK_SIZE;
2787 while (rscount != 32 && rp != 0) {
2788 rp -= 1;
2789 const uint32_t val = ufoRStack[rp];
2790 nfa = ufoFindWordForIP(val);
2791 if (nfa != 0) {
2792 fprintf(stderr, " %2u: %8u -- ", ufoRP - rp - 1u, val);
2793 ufoBTShowWordName(nfa);
2794 fname = ufoFindFileForIP(val - 4u, &fline, NULL, NULL);
2795 if (fname != NULL) { fprintf(stderr, " (at %s:%u)", fname, fline); }
2796 fputc('\n', stderr);
2797 } else {
2798 fprintf(stderr, " %2u: 0x%08x %d\n", ufoRP - rp - 1u, val, (int32_t)val);
2800 rscount += 1;
2802 if (ufoRP > 32) fprintf(stderr, " ...more...\n");
2804 ufoFlushOutput();
2808 //==========================================================================
2810 // ufoDumpVocab
2812 //==========================================================================
2814 static void ufoDumpVocab (uint32_t vocid) {
2815 if (vocid != 0) {
2816 fprintf(stderr, "*** VOCID: 0x%08x ***\n", vocid);
2817 uint32_t vochdr = vocid + UFW_VOCAB_OFS_HEADER;
2818 vochdr = ufoImgGetU32(vochdr);
2819 if (vochdr != 0) {
2820 fprintf(stderr, "--- HEADER ---\n");
2821 ufoDumpWordHeader(UFO_NFA_TO_LFA(vochdr));
2822 fprintf(stderr, "========\n");
2823 uint32_t htbl = vocid + UFW_VOCAB_OFS_HTABLE;
2824 if (ufoImgGetU32(htbl) != UFO_NO_HTABLE_FLAG) {
2825 fprintf(stderr, "--- HASH TABLE ---\n");
2826 for (int f = 0; f < UFO_HASHTABLE_SIZE; f += 1) {
2827 uint32_t bfa = ufoImgGetU32(htbl);
2828 if (bfa != 0) {
2829 fprintf(stderr, "**** %2d: 0x%08x\n", f, bfa);
2830 do {
2831 ufoDumpWordHeader(UFO_BFA_TO_LFA(bfa));
2832 bfa = ufoImgGetU32(bfa);
2833 } while (bfa != 0);
2835 htbl += 4u;
2844 // if set, this will be used when we are out of include files. intended for UrAsm.
2845 // return 0 if there is no more lines, otherwise the string should be copied
2846 // to buffer, `*fname` and `*fline` should be properly set.
2847 int (*ufoFileReadLine) (void *buf, size_t bufsize, const char **fname, int *fline) = NULL;
2850 //==========================================================================
2852 // ufoLoadNextUserLine
2854 //==========================================================================
2855 static int ufoLoadNextUserLine (void) {
2856 uint32_t tibPos = 0;
2857 const char *fname = NULL;
2858 int fline = 0;
2859 ufoResetTib();
2860 if (ufoFileReadLine != NULL && ufoFileReadLine(ufoCurrFileLine, 510, &fname, &fline) != 0) {
2861 ufoCurrFileLine[510] = 0;
2862 uint32_t slen = (uint32_t)strlen(ufoCurrFileLine);
2863 while (slen != 0 && (ufoCurrFileLine[slen - 1u] == 10 || ufoCurrFileLine[slen - 1u] == 13)) {
2864 slen -= 1u;
2866 if (tibPos + slen + 1u > UFO_ADDR_HANDLE_OFS_MASK) {
2867 ufoFatal("input text line too long (at least %u bytes)", tibPos + slen);
2869 ufoTibEnsureSize(tibPos + slen + 1u);
2870 for (uint32_t f = 0; f < slen; f += 1) {
2871 ufoTibPokeChOfs(((const unsigned char *)ufoCurrFileLine)[f], tibPos + f);
2873 ufoTibPokeChOfs(0, tibPos + slen);
2874 tibPos += slen;
2875 if (fname == NULL) fname = "<user>";
2876 ufoSetInFileName(fname);
2877 ufoInFileLine = fline;
2878 return 1;
2879 } else {
2880 return 0;
2885 //==========================================================================
2887 // ufoLoadNextLine_NativeMode
2889 // load next file line into TIB
2890 // always strips final '\n'
2892 // return 0 on EOF, 1 on success
2894 //==========================================================================
2895 static int ufoLoadNextLine (int crossInclude) {
2896 int done = 0;
2897 uint32_t tibPos = 0;
2898 ufoResetTib();
2900 if (ufoMode == UFO_MODE_MACRO) {
2901 //fprintf(stderr, "***MAC!\n");
2902 return 0;
2905 while (ufoInFile != NULL && !done) {
2906 if (fgets(ufoCurrFileLine, 510, ufoInFile) != NULL) {
2907 // check for a newline
2908 // if there is no newline char at the end, the string was truncated
2909 ufoCurrFileLine[510] = 0;
2910 const uint32_t slen = (uint32_t)strlen(ufoCurrFileLine);
2911 if (tibPos + slen + 1u > UFO_ADDR_HANDLE_OFS_MASK) {
2912 ufoFatal("input text line too long (at least %u bytes)", tibPos + slen);
2914 ufoTibEnsureSize(tibPos + slen + 1u);
2915 for (uint32_t f = 0; f < slen; f += 1) {
2916 ufoTibPokeChOfs(((const unsigned char *)ufoCurrFileLine)[f], tibPos + f);
2918 ufoTibPokeChOfs(0, tibPos + slen);
2919 tibPos += slen;
2920 if (slen != 0 && (ufoCurrFileLine[slen - 1u] == 13 || ufoCurrFileLine[slen - 1u] == 10)) {
2921 ++ufoInFileLine;
2922 done = 1;
2923 } else {
2924 // continuation, nothing to do
2926 } else {
2927 // if we read nothing, this is EOF
2928 if (tibPos == 0 && crossInclude) {
2929 // we read nothing, and allowed to cross include boundaries
2930 ufoPopInFile();
2931 } else {
2932 done = 1;
2937 if (tibPos == 0) {
2938 // eof, try user-supplied input
2939 if (ufoFileStackPos == 0) {
2940 return ufoLoadNextUserLine();
2941 } else {
2942 return 0;
2944 } else {
2945 // if we read at least something, this is not EOF
2946 return 1;
2951 // ////////////////////////////////////////////////////////////////////////// //
2952 // debug
2954 // DUMP-STACK
2955 // ( -- )
2956 UFWORD(DUMP_STACK) {
2957 if (!ufoLastEmitWasCR) { printf("\n"); ufoLastEmitWasCR = 1; }
2958 printf("***UFO STACK DEPTH: %u\n", ufoSP);
2959 uint32_t xsp = ufoSP;
2960 if (xsp > 16) xsp = 16;
2961 for (uint32_t sp = 0; sp < xsp; ++sp) {
2962 printf(" %2u: 0x%08x %d%s\n",
2963 sp, ufoDStack[xsp - sp - 1], (int32_t)ufoDStack[xsp - sp - 1],
2964 (sp == 0 ? " -- TOS" : ""));
2966 if (ufoSP > 16) printf(" ...more...\n");
2967 ufoLastEmitWasCR = 1;
2970 // BACKTRACE
2971 // ( -- )
2972 UFWORD(UFO_BACKTRACE) {
2973 ufoFlushOutput();
2974 if (!ufoLastEmitWasCR) { printf("\n"); ufoLastEmitWasCR = 1; }
2975 if (ufoInFile != NULL) {
2976 fprintf(stderr, "*** at file %s, line %d ***\n", ufoInFileName, ufoInFileLine);
2977 } else {
2978 fprintf(stderr, "*** somewhere in time ***\n");
2980 ufoBacktrace(ufoIP, 1);
2983 // DUMP-STACK-TASK
2984 // ( stid -- )
2985 UFWORD(DUMP_STACK_TASK) {
2986 UfoState *st = ufoFindState(ufoPop());
2987 if (st == NULL) ufoFatal("invalid state id");
2988 // temporarily switch the task
2989 UfoState *oldst = ufoCurrState; ufoCurrState = st;
2990 // dump
2991 if (!ufoLastEmitWasCR) { printf("\n"); ufoLastEmitWasCR = 1; }
2992 printf("***UFO STACK DEPTH: %u\n", ufoSP);
2993 uint32_t xsp = ufoSP;
2994 if (xsp > 16) xsp = 16;
2995 for (uint32_t sp = 0; sp < xsp; ++sp) {
2996 printf(" %2u: 0x%08x %d%s\n",
2997 sp, ufoDStack[xsp - sp - 1], (int32_t)ufoDStack[xsp - sp - 1],
2998 (sp == 0 ? " -- TOS" : ""));
3000 if (ufoSP > 16) printf(" ...more...\n");
3001 ufoLastEmitWasCR = 1;
3002 // restore state
3003 ufoCurrState = oldst;
3006 // DUMP-RSTACK-TASK
3007 // ( stid -- )
3008 UFWORD(DUMP_RSTACK_TASK) {
3009 UfoState *st = ufoFindState(ufoPop());
3010 if (st == NULL) ufoFatal("invalid state id");
3011 // temporarily switch the task
3012 UfoState *oldst = ufoCurrState; ufoCurrState = st;
3013 // dump
3014 ufoFlushOutput();
3015 if (!ufoLastEmitWasCR) { printf("\n"); ufoLastEmitWasCR = 1; }
3016 if (ufoInFile != NULL) {
3017 fprintf(stderr, "*** at file %s, line %d ***\n", ufoInFileName, ufoInFileLine);
3018 } else {
3019 fprintf(stderr, "*** somewhere in time ***\n");
3021 ufoBacktrace(ufoIP, 0);
3022 // restore state
3023 ufoCurrState = oldst;
3026 // BACKTRACE-TASK
3027 // ( stid -- )
3028 UFWORD(UFO_BACKTRACE_TASK) {
3029 UfoState *st = ufoFindState(ufoPop());
3030 if (st == NULL) ufoFatal("invalid state id");
3031 // temporarily switch the task
3032 UfoState *oldst = ufoCurrState; ufoCurrState = st;
3033 // dump
3034 ufoFlushOutput();
3035 if (!ufoLastEmitWasCR) { printf("\n"); ufoLastEmitWasCR = 1; }
3036 if (ufoInFile != NULL) {
3037 fprintf(stderr, "*** at file %s, line %d ***\n", ufoInFileName, ufoInFileLine);
3038 } else {
3039 fprintf(stderr, "*** somewhere in time ***\n");
3041 ufoBacktrace(ufoIP, 1);
3042 // restore state
3043 ufoCurrState = oldst;
3047 // ////////////////////////////////////////////////////////////////////////// //
3048 // some init words, and PAD
3051 // SP0!
3052 // ( -- )
3053 UFWORD(SP0_STORE) { ufoSP = 0; }
3055 // RP0!
3056 // ( -- )
3057 UFWORD(RP0_STORE) {
3058 if (ufoRP != ufoRPTop) {
3059 ufoRP = ufoRPTop;
3060 // we need to push a dummy value
3061 ufoRPush(0xdeadf00d);
3065 // PAD
3066 // ( -- pad )
3067 // PAD is at the beginning of temp area
3068 UFWORD(PAD) {
3069 ufoPush(UFO_PAD_ADDR);
3073 // ////////////////////////////////////////////////////////////////////////// //
3074 // peeks and pokes with address register
3077 // A>
3078 // ( -- regA )
3079 UFWORD(REGA_LOAD) {
3080 ufoPush(ufoRegA);
3083 // >A
3084 // ( regA -- )
3085 UFWORD(REGA_STORE) {
3086 ufoRegA = ufoPop();
3089 // A-SWAP
3090 // ( regA -- oldA )
3091 // swap TOS and A
3092 UFWORD(REGA_SWAP) {
3093 const uint32_t newa = ufoPop();
3094 ufoPush(ufoRegA);
3095 ufoRegA = newa;
3098 // +1>A
3099 // ( -- )
3100 UFWORD(REGA_INC) {
3101 ufoRegA += 1u;
3104 // +4>A
3105 // ( -- )
3106 UFWORD(REGA_INC_CELL) {
3107 ufoRegA += 4u;
3110 // A>R
3111 // ( -- | rega )
3112 UFWORD(REGA_TO_R) {
3113 ufoRPush(ufoRegA);
3116 // R>A
3117 // ( | rega -- )
3118 UFWORD(R_TO_REGA) {
3119 ufoRegA = ufoRPop();
3123 // ////////////////////////////////////////////////////////////////////////// //
3124 // useful to work with handles and normal addreses uniformly
3127 // C@A+
3128 // ( idx -- byte )
3129 UFWORD(CPEEK_REGA_IDX) {
3130 if ((ufoRegA & UFO_ADDR_HANDLE_BIT) == 0) {
3131 const uint32_t idx = ufoPop();
3132 const uint32_t newaddr = ufoRegA + idx;
3133 if ((ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == (newaddr & UFO_ADDR_SPECIAL_BITS_MASK)) {
3134 ufoPush(ufoImgGetU8Ext(newaddr));
3135 } else {
3136 ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
3137 ufoRegA, idx, newaddr);
3139 } else {
3140 ufoPush(ufoRegA);
3141 UFCALL(PAR_HANDLE_LOAD_BYTE);
3145 // W@A+
3146 // ( idx -- word )
3147 UFWORD(WPEEK_REGA_IDX) {
3148 if ((ufoRegA & UFO_ADDR_HANDLE_BIT) == 0) {
3149 const uint32_t idx = ufoPop();
3150 const uint32_t newaddr = ufoRegA + idx;
3151 if ((ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == (newaddr & UFO_ADDR_SPECIAL_BITS_MASK) &&
3152 (ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == ((newaddr + 1u) & UFO_ADDR_SPECIAL_BITS_MASK))
3154 ufoPush(ufoImgGetU16(newaddr));
3155 } else {
3156 ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
3157 ufoRegA, idx, newaddr);
3159 } else {
3160 ufoPush(ufoRegA);
3161 UFCALL(PAR_HANDLE_LOAD_WORD);
3165 // @A+
3166 // ( idx -- value )
3167 UFWORD(PEEK_REGA_IDX) {
3168 if ((ufoRegA & UFO_ADDR_HANDLE_BIT) == 0) {
3169 const uint32_t idx = ufoPop();
3170 const uint32_t newaddr = ufoRegA + idx;
3171 if ((ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == (newaddr & UFO_ADDR_SPECIAL_BITS_MASK) &&
3172 (ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == ((newaddr + 3u) & UFO_ADDR_SPECIAL_BITS_MASK))
3174 ufoPush(ufoImgGetU32(newaddr));
3175 } else {
3176 ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
3177 ufoRegA, idx, newaddr);
3179 } else {
3180 ufoPush(ufoRegA);
3181 UFCALL(PAR_HANDLE_LOAD_CELL);
3185 // C!A+
3186 // ( byte idx -- )
3187 UFWORD(CPOKE_REGA_IDX) {
3188 if ((ufoRegA & UFO_ADDR_HANDLE_BIT) == 0) {
3189 const uint32_t idx = ufoPop();
3190 const uint32_t newaddr = ufoRegA + idx;
3191 if ((ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == (newaddr & UFO_ADDR_SPECIAL_BITS_MASK)) {
3192 const uint32_t value = ufoPop();
3193 ufoImgPutU8(newaddr, value);
3194 } else {
3195 ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
3196 ufoRegA, idx, newaddr);
3198 } else {
3199 ufoPush(ufoRegA);
3200 UFCALL(PAR_HANDLE_STORE_BYTE);
3204 // W!A+
3205 // ( word idx -- )
3206 UFWORD(WPOKE_REGA_IDX) {
3207 if ((ufoRegA & UFO_ADDR_HANDLE_BIT) == 0) {
3208 const uint32_t idx = ufoPop();
3209 const uint32_t newaddr = ufoRegA + idx;
3210 if ((ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == (newaddr & UFO_ADDR_SPECIAL_BITS_MASK) &&
3211 (ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == ((newaddr + 1u) & UFO_ADDR_SPECIAL_BITS_MASK))
3213 const uint32_t value = ufoPop();
3214 ufoImgPutU16(newaddr, value);
3215 } else {
3216 ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
3217 ufoRegA, idx, newaddr);
3219 } else {
3220 ufoPush(ufoRegA);
3221 UFCALL(PAR_HANDLE_STORE_WORD);
3225 // !A+
3226 // ( value idx -- )
3227 UFWORD(POKE_REGA_IDX) {
3228 if ((ufoRegA & UFO_ADDR_HANDLE_BIT) == 0) {
3229 const uint32_t idx = ufoPop();
3230 const uint32_t newaddr = ufoRegA + idx;
3231 if ((ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == (newaddr & UFO_ADDR_SPECIAL_BITS_MASK) &&
3232 (ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == ((newaddr + 3u) & UFO_ADDR_SPECIAL_BITS_MASK))
3234 const uint32_t value = ufoPop();
3235 ufoImgPutU32(newaddr, value);
3236 } else {
3237 ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
3238 ufoRegA, idx, newaddr);
3240 } else {
3241 ufoPush(ufoRegA);
3242 UFCALL(PAR_HANDLE_STORE_CELL);
3247 // ////////////////////////////////////////////////////////////////////////// //
3248 // peeks and pokes
3251 // C@
3252 // ( addr -- value8 )
3253 UFWORD(CPEEK) {
3254 ufoPush(ufoImgGetU8Ext(ufoPop()));
3257 // W@
3258 // ( addr -- value16 )
3259 UFWORD(WPEEK) {
3260 const uint32_t addr = ufoPop();
3261 if ((addr & UFO_ADDR_HANDLE_BIT) == 0) {
3262 ufoPush(ufoImgGetU16(addr));
3263 } else {
3264 ufoPush(0);
3265 ufoPush(addr);
3266 UFCALL(PAR_HANDLE_LOAD_WORD);
3270 // @
3271 // ( addr -- value32 )
3272 UFWORD(PEEK) {
3273 const uint32_t addr = ufoPop();
3274 if ((addr & UFO_ADDR_HANDLE_BIT) == 0) {
3275 ufoPush(ufoImgGetU32(addr));
3276 } else {
3277 ufoPush(0);
3278 ufoPush(addr);
3279 UFCALL(PAR_HANDLE_LOAD_CELL);
3283 // C!
3284 // ( val8 addr -- )
3285 UFWORD(CPOKE) {
3286 const uint32_t addr = ufoPop();
3287 const uint32_t val = ufoPop();
3288 ufoImgPutU8Ext(addr, val);
3291 // W!
3292 // ( val16 addr -- )
3293 UFWORD(WPOKE) {
3294 const uint32_t addr = ufoPop();
3295 const uint32_t val = ufoPop();
3296 if ((addr & UFO_ADDR_HANDLE_BIT) == 0) {
3297 ufoImgPutU16(addr, val);
3298 } else {
3299 ufoPush(val);
3300 ufoPush(0);
3301 ufoPush(addr);
3302 UFCALL(PAR_HANDLE_STORE_WORD);
3306 // !
3307 // ( val32 addr -- )
3308 UFWORD(POKE) {
3309 const uint32_t addr = ufoPop();
3310 const uint32_t val = ufoPop();
3311 if ((addr & UFO_ADDR_HANDLE_BIT) == 0) {
3312 ufoImgPutU32(addr, val);
3313 } else {
3314 ufoPush(val);
3315 ufoPush(0);
3316 ufoPush(addr);
3317 UFCALL(PAR_HANDLE_STORE_CELL);
3322 // ////////////////////////////////////////////////////////////////////////// //
3323 // dictionary emitters
3326 // C,
3327 // ( val8 -- )
3328 UFWORD(CCOMMA) { const uint32_t val = ufoPop(); ufoImgEmitU8(val); }
3330 // W,
3331 // ( val16 -- )
3332 UFWORD(WCOMMA) { const uint32_t val = ufoPop(); ufoImgEmitU8(val&0xffU); ufoImgEmitU8((val >> 8)&0xffU); }
3334 // ,
3335 // ( val -- )
3336 UFWORD(COMMA) { const uint32_t val = ufoPop(); ufoImgEmitU32(val); }
3339 // ////////////////////////////////////////////////////////////////////////// //
3340 // literal pushers
3343 // (LIT) ( -- n )
3344 UFWORD(PAR_LIT) {
3345 const uint32_t v = ufoImgGetU32(ufoIP); ufoIP += 4;
3346 ufoPush(v);
3349 // (LITCFA) ( -- n )
3350 UFWORD(PAR_LITCFA) {
3351 const uint32_t v = ufoImgGetU32(ufoIP); ufoIP += 4;
3352 ufoPush(v);
3355 // (LITVOCID) ( -- n )
3356 UFWORD(PAR_LITVOCID) {
3357 const uint32_t v = ufoImgGetU32(ufoIP); ufoIP += 4;
3358 ufoPush(v);
3361 // (LITSTR8)
3362 UFWORD(PAR_LITSTR8) {
3363 const uint32_t count = ufoImgGetU8(ufoIP); ufoIP += 1;
3364 ufoPush(ufoIP);
3365 ufoPush(count);
3366 ufoIP += count + 1; // 1 for terminating 0
3367 // align
3368 ufoIP = UFO_ALIGN4(ufoIP);
3372 // ////////////////////////////////////////////////////////////////////////// //
3373 // jumps, etc.
3376 // (BRANCH) ( -- )
3377 UFWORD(PAR_BRANCH) {
3378 ufoIP = ufoImgGetU32(ufoIP);
3381 // (TBRANCH) ( flag )
3382 UFWORD(PAR_TBRANCH) {
3383 if (ufoPop()) {
3384 ufoIP = ufoImgGetU32(ufoIP);
3385 } else {
3386 ufoIP += 4;
3390 // (0BRANCH) ( flag )
3391 UFWORD(PAR_0BRANCH) {
3392 if (!ufoPop()) {
3393 ufoIP = ufoImgGetU32(ufoIP);
3394 } else {
3395 ufoIP += 4;
3399 // (+0BRANCH) ( flag )
3400 UFWORD(PAR_P0BRANCH) {
3401 if ((ufoPop() & 0x80000000u) == 0) {
3402 ufoIP = ufoImgGetU32(ufoIP);
3403 } else {
3404 ufoIP += 4;
3408 // (+BRANCH) ( flag )
3409 UFWORD(PAR_PBRANCH) {
3410 const uint32_t v = ufoPop();
3411 if (v > 0 && v < 0x80000000u) {
3412 ufoIP = ufoImgGetU32(ufoIP);
3413 } else {
3414 ufoIP += 4;
3418 // (-0BRANCH) ( flag )
3419 UFWORD(PAR_M0BRANCH) {
3420 const uint32_t v = ufoPop();
3421 if (v == 0 || v >= 0x80000000u) {
3422 ufoIP = ufoImgGetU32(ufoIP);
3423 } else {
3424 ufoIP += 4;
3428 // (-BRANCH) ( flag )
3429 UFWORD(PAR_MBRANCH) {
3430 if ((ufoPop() & 0x80000000u) != 0) {
3431 ufoIP = ufoImgGetU32(ufoIP);
3432 } else {
3433 ufoIP += 4;
3437 // (DATASKIP) ( -- )
3438 UFWORD(PAR_DATASKIP) {
3439 ufoIP += ufoImgGetU32(ufoIP) + 4u;
3443 // ////////////////////////////////////////////////////////////////////////// //
3444 // execute words by CFA
3447 // EXECUTE ( cfa )
3448 UFWORD(EXECUTE) {
3449 ufoRPush(ufoPop());
3450 ufoVMRPopCFA = 1;
3453 // EXECUTE-TAIL ( cfa )
3454 UFWORD(EXECUTE_TAIL) {
3455 ufoIP = ufoRPop();
3456 ufoRPush(ufoPop());
3457 ufoVMRPopCFA = 1;
3461 // ////////////////////////////////////////////////////////////////////////// //
3462 // word termination, locals support
3465 // (EXIT)
3466 UFWORD(PAR_EXIT) {
3467 ufoIP = ufoRPop();
3470 // (L-ENTER)
3471 // ( loccount -- )
3472 UFWORD(PAR_LENTER) {
3473 // low byte of loccount is total number of locals
3474 // high byte is the number of args
3475 uint32_t lcount = ufoImgGetU32(ufoIP); ufoIP += 4u;
3476 uint32_t acount = (lcount >> 8) & 0xff;
3477 lcount &= 0xff;
3478 if (lcount == 0 || lcount < acount) ufoFatal("invalid call to (L-ENTER)");
3479 if ((ufoLBP != 0 && ufoLBP >= ufoLP) || UFO_LSTACK_SIZE - ufoLP <= lcount + 2) {
3480 ufoFatal("out of locals stack");
3482 uint32_t newbp;
3483 if (ufoLP == 0) { ufoLP = 1; newbp = 1; } else newbp = ufoLP;
3484 //fprintf(stderr, "LP: %u; LBP: %u; locs: %u; word: %s\n", ufoLP, ufoLBP, fw->locs, fw->name);
3485 ufoLStack[ufoLP] = ufoLBP; ufoLP += 1;
3486 ufoLBP = newbp; ufoLP += lcount;
3487 // and copy args
3488 newbp += acount;
3489 while (newbp != ufoLBP) {
3490 ufoLStack[newbp] = ufoPop();
3491 newbp -= 1;
3495 // (L-LEAVE)
3496 UFWORD(PAR_LLEAVE) {
3497 if (ufoLBP == 0) ufoFatal("(L-LEAVE) with empty locals stack");
3498 if (ufoLBP >= ufoLP) ufoFatal("(L-LEAVE) broken locals stack");
3499 ufoLP = ufoLBP;
3500 ufoLBP = ufoLStack[ufoLBP];
3503 //==========================================================================
3505 // ufoLoadLocal
3507 //==========================================================================
3508 UFO_FORCE_INLINE void ufoLoadLocal (const uint32_t lidx) {
3509 if (lidx == 0 || lidx >= UFO_LSTACK_SIZE) ufoFatal("invalid local index");
3510 if (ufoLBP == 0 || ufoLBP >= ufoLP || ufoLP - ufoLBP <= lidx) ufoFatal("invalid local index");
3511 ufoPush(ufoLStack[ufoLBP + lidx]);
3514 //==========================================================================
3516 // ufoStoreLocal
3518 //==========================================================================
3519 UFO_FORCE_INLINE void ufoStoreLocal (const uint32_t lidx) {
3520 const uint32_t value = ufoPop();
3521 if (lidx == 0 || lidx >= UFO_LSTACK_SIZE) ufoFatal("invalid local index");
3522 if (ufoLBP == 0 || ufoLBP >= ufoLP || ufoLP - ufoLBP <= lidx) ufoFatal("invalid local index");
3523 ufoLStack[ufoLBP + lidx] = value;
3526 // (LOCAL@)
3527 // ( idx -- value )
3528 UFWORD(PAR_LOCAL_LOAD) { ufoLoadLocal(ufoPop()); }
3530 // (LOCAL!)
3531 // ( value idx -- )
3532 UFWORD(PAR_LOCAL_STORE) { ufoStoreLocal(ufoPop()); }
3535 // ////////////////////////////////////////////////////////////////////////// //
3536 // stack manipulation
3539 // DUP
3540 // ( n -- n n )
3541 UFWORD(DUP) { ufoDup(); }
3542 // ?DUP
3543 // ( n -- n n ) | ( 0 -- 0 )
3544 UFWORD(QDUP) { if (ufoPeek()) ufoDup(); }
3545 // 2DUP
3546 // ( n0 n1 -- n0 n1 n0 n1 )
3547 UFWORD(DDUP) { ufo2Dup(); }
3548 // DROP
3549 // ( n -- )
3550 UFWORD(DROP) { ufoDrop(); }
3551 // 2DROP
3552 // ( n0 n1 -- )
3553 UFWORD(DDROP) { ufo2Drop(); }
3554 // SWAP
3555 // ( n0 n1 -- n1 n0 )
3556 UFWORD(SWAP) { ufoSwap(); }
3557 // 2SWAP
3558 // ( n0 n1 -- n1 n0 )
3559 UFWORD(DSWAP) { ufo2Swap(); }
3560 // OVER
3561 // ( n0 n1 -- n0 n1 n0 )
3562 UFWORD(OVER) { ufoOver(); }
3563 // 2OVER
3564 // ( n0 n1 -- n0 n1 n0 )
3565 UFWORD(DOVER) { ufo2Over(); }
3566 // ROT
3567 // ( n0 n1 n2 -- n1 n2 n0 )
3568 UFWORD(ROT) { ufoRot(); }
3569 // NROT
3570 // ( n0 n1 n2 -- n2 n0 n1 )
3571 UFWORD(NROT) { ufoNRot(); }
3573 // RDUP
3574 // ( n -- n n )
3575 UFWORD(RDUP) { ufoRDup(); }
3576 // RDROP
3577 // ( n -- )
3578 UFWORD(RDROP) { ufoRDrop(); }
3580 // >R
3581 // ( n -- | n )
3582 UFWORD(DTOR) { ufoRPush(ufoPop()); }
3583 // R>
3584 // ( | n -- n )
3585 UFWORD(RTOD) { ufoPush(ufoRPop()); }
3586 // R@
3587 // ( | n -- n | n)
3588 UFWORD(RPEEK) { ufoPush(ufoRPeek()); }
3590 // PICK
3591 // ( idx -- n )
3592 UFWORD(PICK) {
3593 const uint32_t n = ufoPop();
3594 if (n >= ufoSP) ufoFatal("invalid PICK index %u", n);
3595 ufoPush(ufoDStack[ufoSP - n - 1u]);
3598 // RPICK
3599 // ( idx -- n )
3600 UFWORD(RPICK) {
3601 const uint32_t n = ufoPop();
3602 if (n >= ufoRP - ufoRPTop) ufoFatal("invalid RPICK index %u", n);
3603 const uint32_t rp = ufoRP - n - 1u;
3604 ufoPush(ufoRStack[rp]);
3607 // ROLL
3608 // ( idx -- n )
3609 UFWORD(ROLL) {
3610 const uint32_t n = ufoPop();
3611 if (n >= ufoSP) ufoFatal("invalid ROLL index %u", n);
3612 switch (n) {
3613 case 0: break; // do nothing
3614 case 1: ufoSwap(); break;
3615 case 2: ufoRot(); break;
3616 default:
3618 const uint32_t val = ufoDStack[ufoSP - n - 1u];
3619 for (uint32_t f = ufoSP - n; f < ufoSP; f += 1) ufoDStack[f - 1] = ufoDStack[f];
3620 ufoDStack[ufoSP - 1u] = val;
3622 break;
3626 // RROLL
3627 // ( idx -- n )
3628 UFWORD(RROLL) {
3629 const uint32_t n = ufoPop();
3630 if (n >= ufoRP - ufoRPTop) ufoFatal("invalid RROLL index %u", n);
3631 if (n != 0) {
3632 const uint32_t rp = ufoRP - n - 1u;
3633 const uint32_t val = ufoRStack[rp];
3634 for (uint32_t f = rp + 1u; f < ufoRP; f += 1u) ufoRStack[f - 1u] = ufoRStack[f];
3635 ufoRStack[ufoRP - 1u] = val;
3639 // RSWAP
3640 // ( | a b -- | b a )
3641 UFWORD(RSWAP) {
3642 const uint32_t b = ufoRPop();
3643 const uint32_t a = ufoRPop();
3644 ufoRPush(b); ufoRPush(a);
3647 // ROVER
3648 // ( | a b -- | a b a )
3649 UFWORD(ROVER) {
3650 const uint32_t b = ufoRPop();
3651 const uint32_t a = ufoRPop();
3652 ufoRPush(a); ufoRPush(b); ufoRPush(a);
3655 // RROT
3656 // ( | a b c -- | b c a )
3657 UFWORD(RROT) {
3658 const uint32_t c = ufoRPop();
3659 const uint32_t b = ufoRPop();
3660 const uint32_t a = ufoRPop();
3661 ufoRPush(b); ufoRPush(c); ufoRPush(a);
3664 // RNROT
3665 // ( | a b c -- | c a b )
3666 UFWORD(RNROT) {
3667 const uint32_t c = ufoRPop();
3668 const uint32_t b = ufoRPop();
3669 const uint32_t a = ufoRPop();
3670 ufoRPush(c); ufoRPush(a); ufoRPush(b);
3674 // ////////////////////////////////////////////////////////////////////////// //
3675 // TIB API
3678 // REFILL
3679 // ( -- eofflag )
3680 UFWORD(REFILL) {
3681 ufoPushBool(ufoLoadNextLine(1));
3684 // REFILL-NOCROSS
3685 // ( -- eofflag )
3686 UFWORD(REFILL_NOCROSS) {
3687 ufoPushBool(ufoLoadNextLine(0));
3690 // (TIB-IN)
3691 // ( -- addr )
3692 UFWORD(TIB_IN) {
3693 ufoPush(ufoImgGetU32(ufoAddrTIBx) + ufoImgGetU32(ufoAddrINx));
3696 // TIB-PEEKCH
3697 // ( -- char )
3698 UFWORD(TIB_PEEKCH) {
3699 ufoPush(ufoTibPeekCh());
3702 // TIB-PEEKCH-OFS
3703 // ( ofs -- char )
3704 UFWORD(TIB_PEEKCH_OFS) {
3705 const uint32_t ofs = ufoPop();
3706 ufoPush(ufoTibPeekChOfs(ofs));
3709 // TIB-GETCH
3710 // ( -- char )
3711 UFWORD(TIB_GETCH) {
3712 ufoPush(ufoTibGetCh());
3715 // TIB-SKIPCH
3716 // ( -- )
3717 UFWORD(TIB_SKIPCH) {
3718 ufoTibSkipCh();
3722 // ////////////////////////////////////////////////////////////////////////// //
3723 // TIB parsing
3726 //==========================================================================
3728 // ufoIsDelim
3730 //==========================================================================
3731 UFO_FORCE_INLINE int ufoIsDelim (uint8_t ch, uint8_t delim) {
3732 return (delim == 32 ? (ch <= 32) : (ch == delim));
3735 // (PARSE)
3736 // ( delim skip-leading-delim? -- addr count TRUE / FALSE )
3737 // does base TIB parsing; never copies anything.
3738 // as our reader is line-based, returns FALSE on EOL.
3739 // EOL is detected after skipping leading delimiters.
3740 // passing -1 as delimiter skips the whole line, and always returns FALSE.
3741 // trailing delimiter is always skipped.
3742 UFWORD(PAR_PARSE) {
3743 const uint32_t skipDelim = ufoPop();
3744 const uint32_t delim = ufoPop();
3745 uint8_t ch;
3747 if (delim == 0 || delim > 0xffU) {
3748 // skip everything
3749 while (ufoTibGetCh() != 0) {}
3750 ufoPushBool(0);
3751 } else {
3752 ch = ufoTibPeekCh();
3753 // skip initial delimiters
3754 if (skipDelim) {
3755 while (ch != 0 && ufoIsDelim(ch, delim)) {
3756 ufoTibSkipCh();
3757 ch = ufoTibPeekCh();
3760 if (ch == 0) {
3761 ufoPushBool(0);
3762 } else {
3763 // parse
3764 const uint32_t staddr = ufoImgGetU32(ufoAddrTIBx) + ufoImgGetU32(ufoAddrINx);
3765 uint32_t count = 0;
3766 while (ch != 0 && !ufoIsDelim(ch, delim)) {
3767 count += 1u;
3768 ufoTibSkipCh();
3769 ch = ufoTibPeekCh();
3771 // skip delimiter
3772 if (ch != 0) ufoTibSkipCh();
3773 ufoPush(staddr);
3774 ufoPush(count);
3775 ufoPushBool(1);
3780 // PARSE-SKIP-BLANKS
3781 // ( -- )
3782 UFWORD(PARSE_SKIP_BLANKS) {
3783 uint8_t ch = ufoTibPeekCh();
3784 while (ch != 0 && ch <= 32) {
3785 ufoTibSkipCh();
3786 ch = ufoTibPeekCh();
3790 //==========================================================================
3792 // ufoParseMLComment
3794 // initial two chars are skipped
3796 //==========================================================================
3797 static void ufoParseMLComment (uint32_t allowMulti, int nested) {
3798 uint32_t level = 1;
3799 uint8_t ch, ch1;
3800 while (level != 0) {
3801 ch = ufoTibGetCh();
3802 if (ch == 0) {
3803 if (allowMulti) {
3804 UFCALL(REFILL_NOCROSS);
3805 if (ufoPop() == 0) ufoFatal("unexpected end of file in comment");
3806 } else {
3807 ufoFatal("unexpected end of line in comment");
3809 } else {
3810 ch1 = ufoTibPeekCh();
3811 if (nested && ch == '(' && ch1 == '(') { ufoTibSkipCh(); level += 1; }
3812 else if (nested && ch == ')' && ch1 == ')') { ufoTibSkipCh(); level -= 1; }
3813 else if (!nested && ch == '*' && ch1 == ')') { ufo_assert(level == 1); ufoTibSkipCh(); level = 0; }
3818 // (PARSE-SKIP-COMMENTS)
3819 // ( allow-multiline? -- )
3820 // skip all blanks and comments
3821 UFWORD(PAR_PARSE_SKIP_COMMENTS) {
3822 const uint32_t allowMulti = ufoPop();
3823 uint8_t ch, ch1;
3824 ch = ufoTibPeekCh();
3825 #if 0
3826 fprintf(stderr, "(PARSE-SKIP-COMMENTS): first-ch:'%c'\n", (char)ch);
3827 #endif
3828 while (ch != 0) {
3829 if (ch <= 32) {
3830 ufoTibSkipCh();
3831 ch = ufoTibPeekCh();
3832 #if 0
3833 fprintf(stderr, "(PARSE-SKIP-COMMENTS): blank-ch:'%c'\n", (char)ch);
3834 #endif
3835 } else if (ch == '(') {
3836 #if 0
3837 fprintf(stderr, "(PARSE-SKIP-COMMENTS): ch:'%c'; ch1:'%c' ('%c')\n", (char)ch, (char)ch1,
3838 ufoTibPeekChOfs(0));
3839 #endif
3840 ch1 = ufoTibPeekChOfs(1);
3841 if (ch1 <= 32) {
3842 // single-line comment
3843 do { ch = ufoTibGetCh(); } while (ch != 0 && ch != ')');
3844 ch = ufoTibPeekCh();
3845 } else if ((ch1 == '*' || ch1 == '(') && ufoTibPeekChOfs(2) <= 32) {
3846 // possibly multiline
3847 ufoTibSkipCh(); ufoTibSkipCh(); // skip opening
3848 ufoParseMLComment(allowMulti, (ch1 == '('));
3849 ch = ufoTibPeekCh();
3850 } else {
3851 ch = 0;
3853 } else if (ch == '\\' && ufoTibPeekChOfs(1) <= 32) {
3854 // single-line comment
3855 while (ch != 0) ch = ufoTibGetCh();
3856 } else if ((ch == ';' || ch == '-' || ch == '/') && (ufoTibPeekChOfs(1) == ch)) {
3857 // skip to EOL
3858 while (ch != 0) ch = ufoTibGetCh();
3859 } else {
3860 ch = 0;
3863 #if 0
3864 fprintf(stderr, "(PARSE-SKIP-COMMENTS): end-ch:'%c'\n", ufoTibPeekCh());
3865 #endif
3868 // PARSE-SKIP-LINE
3869 // ( -- )
3870 UFWORD(PARSE_SKIP_LINE) {
3871 ufoPush(0); ufoPushBool(0); UFCALL(PAR_PARSE);
3872 if (ufoPop() != 0) {
3873 ufo2Drop();
3877 // PARSE-NAME
3878 // ( -- addr count )
3879 // parse with leading blanks skipping. doesn't copy anything.
3880 // return empty string on EOL.
3881 UFWORD(PARSE_NAME) {
3882 ufoPush(32); ufoPushBool(1); UFCALL(PAR_PARSE);
3883 if (ufoPop() == 0) {
3884 ufoPush(0);
3885 ufoPush(0);
3889 // PARSE
3890 // ( delim -- addr count TRUE / FALSE )
3891 // parse without skipping delimiters; never copies anything.
3892 // as our reader is line-based, returns FALSE on EOL.
3893 // passing 0 as delimiter skips the whole line, and always returns FALSE.
3894 // trailing delimiter is always skipped.
3895 UFWORD(PARSE) {
3896 ufoPushBool(0); UFCALL(PAR_PARSE);
3900 // ////////////////////////////////////////////////////////////////////////// //
3901 // char output
3904 // (NORM-EMIT-CHAR)
3905 // ( ch -- )
3906 UFWORD(PAR_NORM_EMIT_CHAR) {
3907 uint32_t ch = ufoPop()&0xffU;
3908 if (ch < 32 || ch == 127) {
3909 if (ch != 9 && ch != 10 && ch != 13) ch = '?';
3911 ufoPush(ch);
3914 // (NORM-XEMIT-CHAR)
3915 // ( ch -- )
3916 UFWORD(PAR_NORM_XEMIT_CHAR) {
3917 uint32_t ch = ufoPop()&0xffU;
3918 if (ch < 32 || ch == 127) ch = '?';
3919 ufoPush(ch);
3922 // (EMIT)
3923 // ( n -- )
3924 UFWORD(PAR_EMIT) {
3925 uint32_t ch = ufoPop()&0xffU;
3926 ufoLastEmitWasCR = (ch == 10);
3927 putchar((char)ch);
3930 // LASTCR?
3931 // ( -- bool )
3932 UFWORD(LASTCRQ) {
3933 ufoPushBool(ufoLastEmitWasCR);
3936 // LASTCR!
3937 // ( bool -- )
3938 UFWORD(LASTCRSET) {
3939 ufoLastEmitWasCR = !!ufoPop();
3942 // FLUSH-EMIT
3943 // ( -- )
3944 UFWORD(FLUSH_EMIT) {
3945 ufoFlushOutput();
3949 // ////////////////////////////////////////////////////////////////////////// //
3950 // simple math
3953 #define UF_UMATH(name_,op_) \
3954 UFWORD(name_) { \
3955 const uint32_t a = ufoPop(); \
3956 ufoPush(op_); \
3959 #define UF_BMATH(name_,op_) \
3960 UFWORD(name_) { \
3961 const uint32_t b = ufoPop(); \
3962 const uint32_t a = ufoPop(); \
3963 ufoPush(op_); \
3966 #define UF_BDIV(name_,op_) \
3967 UFWORD(name_) { \
3968 const uint32_t b = ufoPop(); \
3969 const uint32_t a = ufoPop(); \
3970 if (b == 0) ufoFatal("division by zero"); \
3971 ufoPush(op_); \
3974 #define UFO_POP_U64() ({ \
3975 const uint32_t hi_ = ufoPop(); \
3976 const uint32_t lo_ = ufoPop(); \
3977 (((uint64_t)hi_ << 32) | lo_); \
3980 // this is UB by the idiotic C standard. i don't care.
3981 #define UFO_POP_I64() ((int64_t)UFO_POP_U64())
3983 #define UFO_PUSH_U64(vn_) do { \
3984 ufoPush((uint32_t)(vn_)); \
3985 ufoPush((uint32_t)((vn_) >> 32)); \
3986 } while (0)
3988 // this is UB by the idiotic C standard. i don't care.
3989 #define UFO_PUSH_I64(vn_) UFO_PUSH_U64((uint64_t)(vn_))
3991 // +
3992 // ( a b -- a+b )
3993 UF_BMATH(PLUS, a + b);
3995 // -
3996 // ( a b -- a-b )
3997 UF_BMATH(MINUS, a - b);
3999 // *
4000 // ( a b -- a*b )
4001 UF_BMATH(MUL, (uint32_t)((int32_t)a * (int32_t)b));
4003 // U*
4004 // ( a b -- a*b )
4005 UF_BMATH(UMUL, a * b);
4007 // /
4008 // ( a b -- a/b )
4009 UF_BDIV(DIV, (uint32_t)((int32_t)a / (int32_t)b));
4011 // U/
4012 // ( a b -- a/b )
4013 UF_BDIV(UDIV, a / b);
4015 // MOD
4016 // ( a b -- a%b )
4017 UF_BDIV(MOD, (uint32_t)((int32_t)a % (int32_t)b));
4019 // UMOD
4020 // ( a b -- a%b )
4021 UF_BDIV(UMOD, a % b);
4023 // /MOD
4024 // ( a b -- a/b, a%b )
4025 UFWORD(DIVMOD) {
4026 const int32_t b = (int32_t)ufoPop();
4027 const int32_t a = (int32_t)ufoPop();
4028 if (b == 0) ufoFatal("division by zero");
4029 ufoPush((uint32_t)(a/b));
4030 ufoPush((uint32_t)(a%b));
4033 // U/MOD
4034 // ( a b -- a/b, a%b )
4035 UFWORD(UDIVMOD) {
4036 const uint32_t b = ufoPop();
4037 const uint32_t a = ufoPop();
4038 if (b == 0) ufoFatal("division by zero");
4039 ufoPush((uint32_t)(a/b));
4040 ufoPush((uint32_t)(a%b));
4043 // */
4044 // ( a b c -- a*b/c )
4045 // this uses 64-bit intermediate value
4046 UFWORD(MULDIV) {
4047 const int32_t c = (int32_t)ufoPop();
4048 const int32_t b = (int32_t)ufoPop();
4049 const int32_t a = (int32_t)ufoPop();
4050 if (c == 0) ufoFatal("division by zero");
4051 int64_t xval = a; xval *= b; xval /= c;
4052 ufoPush((uint32_t)(int32_t)xval);
4055 // U*/
4056 // ( a b c -- a*b/c )
4057 // this uses 64-bit intermediate value
4058 UFWORD(UMULDIV) {
4059 const uint32_t c = ufoPop();
4060 const uint32_t b = ufoPop();
4061 const uint32_t a = ufoPop();
4062 if (c == 0) ufoFatal("division by zero");
4063 uint64_t xval = a; xval *= b; xval /= c;
4064 ufoPush((uint32_t)xval);
4067 // */MOD
4068 // ( a b c -- a*b/c a*b%c )
4069 // this uses 64-bit intermediate value
4070 UFWORD(MULDIVMOD) {
4071 const int32_t c = (int32_t)ufoPop();
4072 const int32_t b = (int32_t)ufoPop();
4073 const int32_t a = (int32_t)ufoPop();
4074 if (c == 0) ufoFatal("division by zero");
4075 int64_t xval = a; xval *= b;
4076 ufoPush((uint32_t)(int32_t)(xval / c));
4077 ufoPush((uint32_t)(int32_t)(xval % c));
4080 // U*/
4081 // ( a b c -- a*b/c )
4082 // this uses 64-bit intermediate value
4083 UFWORD(UMULDIVMOD) {
4084 const uint32_t c = ufoPop();
4085 const uint32_t b = ufoPop();
4086 const uint32_t a = ufoPop();
4087 if (c == 0) ufoFatal("division by zero");
4088 uint64_t xval = a; xval *= b;
4089 ufoPush((uint32_t)(xval / c));
4090 ufoPush((uint32_t)(xval % c));
4093 // M*
4094 // ( a b -- lo(a*b) hi(a*b) )
4095 // this leaves 64-bit result
4096 UFWORD(MMUL) {
4097 const int32_t b = (int32_t)ufoPop();
4098 const int32_t a = (int32_t)ufoPop();
4099 int64_t xval = a; xval *= b;
4100 UFO_PUSH_I64(xval);
4103 // UM*
4104 // ( a b -- lo(a*b) hi(a*b) )
4105 // this leaves 64-bit result
4106 UFWORD(UMMUL) {
4107 const uint32_t b = ufoPop();
4108 const uint32_t a = ufoPop();
4109 uint64_t xval = a; xval *= b;
4110 UFO_PUSH_U64(xval);
4113 // M/MOD
4114 // ( alo ahi b -- a/b a%b )
4115 UFWORD(MDIVMOD) {
4116 const int32_t b = (int32_t)ufoPop();
4117 if (b == 0) ufoFatal("division by zero");
4118 int64_t a = UFO_POP_I64();
4119 int32_t adiv = (int32_t)(a / b);
4120 int32_t amod = (int32_t)(a % b);
4121 ufoPush((uint32_t)adiv);
4122 ufoPush((uint32_t)amod);
4125 // UM/MOD
4126 // ( alo ahi b -- a/b a%b )
4127 UFWORD(UMDIVMOD) {
4128 const uint32_t b = ufoPop();
4129 if (b == 0) ufoFatal("division by zero");
4130 uint64_t a = UFO_POP_U64();
4131 uint32_t adiv = (uint32_t)(a / b);
4132 uint32_t amod = (uint32_t)(a % b);
4133 ufoPush(adiv);
4134 ufoPush(amod);
4137 // UDS*
4138 // ( alo ahi u -- lo hi )
4139 UFWORD(UDSMUL) {
4140 const uint32_t b = ufoPop();
4141 uint64_t a = UFO_POP_U64();
4142 a *= b;
4143 UFO_PUSH_U64(a);
4146 // D-
4147 // ( lo0 hi0 lo1 hi1 -- lo hi )
4148 UFWORD(DMINUS) {
4149 uint64_t n1 = UFO_POP_U64();
4150 uint64_t n0 = UFO_POP_U64();
4151 n0 -= n1;
4152 UFO_PUSH_U64(n0);
4155 // D+
4156 // ( lo0 hi0 lo1 hi1 -- lo hi )
4157 UFWORD(DPLUS) {
4158 uint64_t n1 = UFO_POP_U64();
4159 uint64_t n0 = UFO_POP_U64();
4160 n0 += n1;
4161 UFO_PUSH_U64(n0);
4164 // D=
4165 // ( lo0 hi0 lo1 hi1 -- bool )
4166 UFWORD(DEQU) {
4167 uint64_t n1 = UFO_POP_U64();
4168 uint64_t n0 = UFO_POP_U64();
4169 ufoPushBool(n0 == n1);
4172 // D<
4173 // ( lo0 hi0 lo1 hi1 -- bool )
4174 UFWORD(DLESS) {
4175 int64_t n1 = UFO_POP_I64();
4176 int64_t n0 = UFO_POP_I64();
4177 ufoPushBool(n0 < n1);
4180 // D<=
4181 // ( lo0 hi0 lo1 hi1 -- bool )
4182 UFWORD(DLESSEQU) {
4183 int64_t n1 = UFO_POP_I64();
4184 int64_t n0 = UFO_POP_I64();
4185 ufoPushBool(n0 <= n1);
4188 // DU<
4189 // ( lo0 hi0 lo1 hi1 -- bool )
4190 UFWORD(DULESS) {
4191 uint64_t n1 = UFO_POP_U64();
4192 uint64_t n0 = UFO_POP_U64();
4193 ufoPushBool(n0 < n1);
4196 // DU<=
4197 // ( lo0 hi0 lo1 hi1 -- bool )
4198 UFWORD(DULESSEQU) {
4199 uint64_t n1 = UFO_POP_U64();
4200 uint64_t n0 = UFO_POP_U64();
4201 ufoPushBool(n0 <= n1);
4204 // SM/REM
4205 // ( dlo dhi n -- nmod ndiv )
4206 // rounds toward zero
4207 UFWORD(SMREM) {
4208 const int32_t n = (int32_t)ufoPop();
4209 if (n == 0) ufoFatal("division by zero");
4210 int64_t d = UFO_POP_I64();
4211 int32_t ndiv = (int32_t)(d / n);
4212 int32_t nmod = (int32_t)(d % n);
4213 ufoPush(nmod);
4214 ufoPush(ndiv);
4217 // FM/MOD
4218 // ( dlo dhi n -- nmod ndiv )
4219 // rounds toward negative infinity
4220 UFWORD(FMMOD) {
4221 const int32_t n = (int32_t)ufoPop();
4222 if (n == 0) ufoFatal("division by zero");
4223 int64_t d = UFO_POP_I64();
4224 int32_t ndiv = (int32_t)(d / n);
4225 int32_t nmod = (int32_t)(d % n);
4226 if (nmod != 0 && ((uint32_t)n ^ (uint32_t)(d >> 32)) >= 0x80000000u) {
4227 ndiv -= 1;
4228 nmod += n;
4230 ufoPush(nmod);
4231 ufoPush(ndiv);
4235 // ////////////////////////////////////////////////////////////////////////// //
4236 // simple logic and bit manipulation
4239 #define UF_CMP(name_,op_) \
4240 UFWORD(name_) { \
4241 const uint32_t b = ufoPop(); \
4242 const uint32_t a = ufoPop(); \
4243 ufoPushBool(op_); \
4246 // <
4247 // ( a b -- a<b )
4248 UF_CMP(LESS, (int32_t)a < (int32_t)b);
4250 // U<
4251 // ( a b -- a<b )
4252 UF_CMP(ULESS, a < b);
4254 // >
4255 // ( a b -- a>b )
4256 UF_CMP(GREAT, (int32_t)a > (int32_t)b);
4258 // U>
4259 // ( a b -- a>b )
4260 UF_CMP(UGREAT, a > b);
4262 // <=
4263 // ( a b -- a<=b )
4264 UF_CMP(LESSEQU, (int32_t)a <= (int32_t)b);
4266 // U<=
4267 // ( a b -- a<=b )
4268 UF_CMP(ULESSEQU, a <= b);
4270 // >=
4271 // ( a b -- a>=b )
4272 UF_CMP(GREATEQU, (int32_t)a >= (int32_t)b);
4274 // U>=
4275 // ( a b -- a>=b )
4276 UF_CMP(UGREATEQU, a >= b);
4278 // =
4279 // ( a b -- a=b )
4280 UF_CMP(EQU, a == b);
4282 // <>
4283 // ( a b -- a<>b )
4284 UF_CMP(NOTEQU, a != b);
4286 // 0=
4287 // ( a -- a==0 )
4288 UFWORD(ZERO_EQU) {
4289 const uint32_t a = ufoPop();
4290 ufoPushBool(a == 0);
4293 // 0<>
4294 // ( a -- a<>0 )
4295 UFWORD(ZERO_NOTEQU) {
4296 const uint32_t a = ufoPop();
4297 ufoPushBool(a != 0);
4300 // LAND
4301 // ( a b -- a&&b )
4302 UF_CMP(LOGAND, a && b);
4304 // LOR
4305 // ( a b -- a||b )
4306 UF_CMP(LOGOR, a || b);
4308 // AND
4309 // ( a b -- a&b )
4310 UFWORD(AND) {
4311 const uint32_t b = ufoPop();
4312 const uint32_t a = ufoPop();
4313 ufoPush(a&b);
4316 // OR
4317 // ( a b -- a|b )
4318 UFWORD(OR) {
4319 const uint32_t b = ufoPop();
4320 const uint32_t a = ufoPop();
4321 ufoPush(a|b);
4324 // XOR
4325 // ( a b -- a^b )
4326 UFWORD(XOR) {
4327 const uint32_t b = ufoPop();
4328 const uint32_t a = ufoPop();
4329 ufoPush(a^b);
4332 // BITNOT
4333 // ( a -- ~a )
4334 UFWORD(BITNOT) {
4335 const uint32_t a = ufoPop();
4336 ufoPush(~a);
4339 // ASH
4340 // ( n count -- )
4341 // arithmetic shift; positive `n` shifts to the left
4342 UFWORD(ASH) {
4343 int32_t c = (int32_t)ufoPop();
4344 if (c < 0) {
4345 // right
4346 int32_t n = (int32_t)ufoPop();
4347 if (c < -30) {
4348 if (n < 0) n = -1; else n = 0;
4349 } else {
4350 n >>= (uint8_t)(-c);
4352 ufoPush((uint32_t)n);
4353 } else if (c > 0) {
4354 // left
4355 uint32_t u = ufoPop();
4356 if (c > 31) {
4357 u = 0;
4358 } else {
4359 u <<= (uint8_t)c;
4361 ufoPush(u);
4365 // LSH
4366 // ( n count -- )
4367 // logical shift; positive `n` shifts to the left
4368 UFWORD(LSH) {
4369 int32_t c = (int32_t) ufoPop();
4370 uint32_t u = ufoPop();
4371 if (c < 0) {
4372 // right
4373 if (c < -31) {
4374 u = 0;
4375 } else {
4376 u >>= (uint8_t)(-c);
4378 } else if (c > 0) {
4379 // left
4380 if (c > 31) {
4381 u = 0;
4382 } else {
4383 u <<= (uint8_t)c;
4386 ufoPush(u);
4390 // ////////////////////////////////////////////////////////////////////////// //
4391 // string unescaping
4394 // (UNESCAPE)
4395 // ( addr count -- addr count )
4396 UFWORD(PAR_UNESCAPE) {
4397 const uint32_t count = ufoPop();
4398 const uint32_t addr = ufoPeek();
4399 if ((count & ((uint32_t)1<<31)) == 0) {
4400 const uint32_t eaddr = addr + count;
4401 uint32_t caddr = addr;
4402 uint32_t daddr = addr;
4403 while (caddr != eaddr) {
4404 uint8_t ch = ufoImgGetU8Ext(caddr); caddr += 1u;
4405 if (ch == '\\' && caddr != eaddr) {
4406 ch = ufoImgGetU8Ext(caddr); caddr += 1u;
4407 switch (ch) {
4408 case 'r': ch = '\r'; break;
4409 case 'n': ch = '\n'; break;
4410 case 't': ch = '\t'; break;
4411 case 'e': ch = '\x1b'; break;
4412 case '`': ch = '"'; break; // special escape to insert double-quote
4413 case '"': ch = '"'; break;
4414 case '\\': ch = '\\'; break;
4415 case 'x': case 'X':
4416 if (eaddr - daddr >= 1) {
4417 const int dg0 = digitInBase((char)(ufoImgGetU8Ext(caddr)), 16);
4418 if (dg0 < 0) ufoFatal("invalid hex string escape");
4419 if (eaddr - daddr >= 2) {
4420 const int dg1 = digitInBase((char)(ufoImgGetU8Ext(caddr + 1u)), 16);
4421 if (dg1 < 0) ufoFatal("invalid hex string escape");
4422 ch = (uint8_t)(dg0 * 16 + dg1);
4423 caddr += 2u;
4424 } else {
4425 ch = (uint8_t)dg0;
4426 caddr += 1u;
4428 } else {
4429 ufoFatal("invalid hex string escape");
4431 break;
4432 default: ufoFatal("invalid string escape");
4435 ufoImgPutU8Ext(daddr, ch); daddr += 1u;
4437 ufoPush(daddr - addr);
4438 } else {
4439 ufoPush(count);
4444 // ////////////////////////////////////////////////////////////////////////// //
4445 // numeric conversions
4448 // (BASED-NUMBER) ( addr count allowsign? base -- num TRUE / FALSE )
4449 UFWORD(PAR_BASED_NUMBER) {
4450 const uint32_t xbase = ufoPop();
4451 const uint32_t allowSign = ufoPop();
4452 int32_t count = (int32_t)ufoPop();
4453 uint32_t addr = ufoPop();
4454 uint32_t n = 0;
4455 int base = 0;
4456 int neg = 0;
4457 uint8_t ch;
4459 if (allowSign && count > 1) {
4460 ch = ufoImgGetU8Ext(addr);
4461 if (ch == '-') { neg = 1; addr += 1u; count -= 1; }
4462 else if (ch == '+') { neg = 0; addr += 1u; count -= 1; }
4465 // special-based numbers
4466 if (count >= 3 && ufoImgGetU8Ext(addr) == '0') {
4467 switch (ufoImgGetU8Ext(addr + 1u)) {
4468 case 'x': case 'X': base = 16; break;
4469 case 'o': case 'O': base = 8; break;
4470 case 'b': case 'B': base = 2; break;
4471 case 'd': case 'D': base = 10; break;
4472 default: break;
4474 if (base) { addr += 2; count -= 2; }
4475 } else if (count >= 2 && ufoImgGetU8Ext(addr) == '$') {
4476 base = 16;
4477 addr += 1; count -= 1;
4478 } else if (count >= 2 && ufoImgGetU8Ext(addr) == '#') {
4479 base = 16;
4480 addr += 1; count -= 1;
4481 } else if (count >= 2 && ufoImgGetU8Ext(addr) == '%') {
4482 base = 2;
4483 addr += 1; count -= 1;
4484 } else if (count >= 3 && ufoImgGetU8Ext(addr) == '&') {
4485 switch (ufoImgGetU8Ext(addr + 1u)) {
4486 case 'h': case 'H': base = 16; break;
4487 case 'o': case 'O': base = 8; break;
4488 case 'b': case 'B': base = 2; break;
4489 case 'd': case 'D': base = 10; break;
4490 default: break;
4492 if (base) { addr += 2; count -= 2; }
4493 } else if (xbase < 12 && count > 2 && toUpperU8(ufoImgGetU8Ext(addr + (uint32_t)count - 1u)) == 'B') {
4494 base = 2;
4495 count -= 1;
4496 } else if (xbase < 18 && count > 2 && toUpperU8(ufoImgGetU8Ext(addr + (uint32_t)count - 1u)) == 'H') {
4497 base = 16;
4498 count -= 1;
4499 } else if (xbase < 25 && count > 2 && toUpperU8(ufoImgGetU8Ext(addr + (uint32_t)count - 1u)) == 'O') {
4500 base = 8;
4501 count -= 1;
4504 // in current base?
4505 if (!base && xbase < 255) base = xbase;
4507 if (count <= 0 || base < 1 || base > 36) {
4508 ufoPushBool(0);
4509 } else {
4510 uint32_t nc;
4511 int wasDig = 0, wasUnder = 1, error = 0, dig;
4512 while (!error && count != 0) {
4513 ch = ufoImgGetU8Ext(addr); addr += 1u; count -= 1;
4514 if (ch != '_') {
4515 error = 1; wasUnder = 0; wasDig = 1;
4516 dig = digitInBase((char)ch, (int)base);
4517 if (dig >= 0) {
4518 nc = n * (uint32_t)base;
4519 if (nc >= n) {
4520 nc += (uint32_t)dig;
4521 if (nc >= n) {
4522 n = nc;
4523 error = 0;
4527 } else {
4528 error = wasUnder;
4529 wasUnder = 1;
4533 if (!error && wasDig && !wasUnder) {
4534 if (allowSign && neg) n = ~n + 1u;
4535 ufoPush(n);
4536 ufoPushBool(1);
4537 } else {
4538 ufoPushBool(0);
4544 // ////////////////////////////////////////////////////////////////////////// //
4545 // compiler-related, dictionary-related
4548 static char ufoWNameBuf[256];
4550 // (CREATE-WORD-HEADER)
4551 // ( addr count word-flags -- )
4552 UFWORD(PAR_CREATE_WORD_HEADER) {
4553 const uint32_t flags = ufoPop();
4554 const uint32_t wlen = ufoPop();
4555 const uint32_t waddr = ufoPop();
4556 if (wlen == 0) ufoFatal("word name expected");
4557 if (wlen >= UFO_MAX_WORD_LENGTH) ufoFatal("word name too long");
4558 // copy to separate buffer
4559 for (uint32_t f = 0; f < wlen; f += 1) {
4560 ufoWNameBuf[f] = (char)ufoImgGetU8Ext(waddr + f);
4562 ufoWNameBuf[wlen] = 0;
4563 ufoCreateWordHeader(ufoWNameBuf, flags);
4566 // (CREATE-NAMELESS-WORD-HEADER)
4567 // ( word-flags -- )
4568 UFWORD(PAR_CREATE_NAMELESS_WORD_HEADER) {
4569 const uint32_t flags = ufoPop();
4570 ufoCreateWordHeader("", flags);
4573 // FIND-WORD
4574 // ( addr count -- cfa TRUE / FALSE)
4575 UFWORD(FIND_WORD) {
4576 const uint32_t wlen = ufoPop();
4577 const uint32_t waddr = ufoPop();
4578 if (wlen > 0 && wlen < UFO_MAX_WORD_LENGTH) {
4579 // copy to separate buffer
4580 for (uint32_t f = 0; f < wlen; f += 1) {
4581 ufoWNameBuf[f] = (char)ufoImgGetU8Ext(waddr + f);
4583 ufoWNameBuf[wlen] = 0;
4584 const uint32_t cfa = ufoFindWord(ufoWNameBuf);
4585 if (cfa != 0) {
4586 ufoPush(cfa);
4587 ufoPushBool(1);
4588 } else {
4589 ufoPushBool(0);
4591 } else {
4592 ufoPushBool(0);
4596 // (FIND-WORD-IN-VOC)
4597 // ( addr count vocid allowhidden -- cfa TRUE / FALSE)
4598 // find only in the given voc; no name resolution
4599 UFWORD(FIND_WORD_IN_VOC) {
4600 const uint32_t allowHidden = ufoPop();
4601 const uint32_t vocid = ufoPop();
4602 const uint32_t wlen = ufoPop();
4603 const uint32_t waddr = ufoPop();
4604 if (wlen > 0 && wlen < UFO_MAX_WORD_LENGTH) {
4605 // copy to separate buffer
4606 for (uint32_t f = 0; f < wlen; f += 1) {
4607 ufoWNameBuf[f] = (char)ufoImgGetU8Ext(waddr + f);
4609 ufoWNameBuf[wlen] = 0;
4610 const uint32_t cfa = ufoFindWordInVoc(ufoWNameBuf, wlen, 0, vocid, (allowHidden ? 1 : 0));
4611 if (cfa != 0) {
4612 ufoPush(cfa);
4613 ufoPushBool(1);
4614 } else {
4615 ufoPushBool(0);
4617 } else {
4618 ufoPushBool(0);
4622 // (FIND-WORD-IN-VOC-AND-PARENTS)
4623 // ( addr count vocid allowhidden -- cfa TRUE / FALSE)
4624 // find only in the given voc; no name resolution
4625 UFWORD(FIND_WORD_IN_VOC_AND_PARENTS) {
4626 const uint32_t allowHidden = ufoPop();
4627 const uint32_t vocid = ufoPop();
4628 const uint32_t wlen = ufoPop();
4629 const uint32_t waddr = ufoPop();
4630 if (wlen > 0 && wlen < UFO_MAX_WORD_LENGTH) {
4631 // copy to separate buffer
4632 for (uint32_t f = 0; f < wlen; f += 1) {
4633 ufoWNameBuf[f] = (char)ufoImgGetU8Ext(waddr + f);
4635 ufoWNameBuf[wlen] = 0;
4636 const uint32_t cfa = ufoFindWordInVocAndParents(ufoWNameBuf, wlen, 0, vocid, (allowHidden ? 1 : 0));
4637 if (cfa != 0) {
4638 ufoPush(cfa);
4639 ufoPushBool(1);
4640 } else {
4641 ufoPushBool(0);
4643 } else {
4644 ufoPushBool(0);
4649 // ////////////////////////////////////////////////////////////////////////// //
4650 // more compiler words
4653 // ////////////////////////////////////////////////////////////////////////// //
4654 // vocabulary and wordlist utilities
4657 // (VSP@)
4658 // ( -- vsp )
4659 UFWORD(PAR_GET_VSP) {
4660 ufoPush(ufoVSP);
4663 // (VSP!)
4664 // ( vsp -- )
4665 UFWORD(PAR_SET_VSP) {
4666 const uint32_t vsp = ufoPop();
4667 if (vsp >= UFO_VOCSTACK_SIZE) ufoFatal("VSP %u out of range (%u)", vsp, UFO_VOCSTACK_SIZE);
4668 ufoVSP = vsp;
4671 // (VSP-AT@)
4672 // ( idx -- value )
4673 UFWORD(PAR_VSP_LOAD) {
4674 const uint32_t vsp = ufoPop();
4675 if (vsp >= UFO_VOCSTACK_SIZE) ufoFatal("VSP %u out of range (%u)", vsp, UFO_VOCSTACK_SIZE);
4676 ufoPush(ufoVocStack[vsp]);
4679 // (VSP-AT!)
4680 // ( value idx -- )
4681 UFWORD(PAR_VSP_STORE) {
4682 const uint32_t vsp = ufoPop();
4683 const uint32_t value = ufoPop();
4684 if (vsp > UFO_VOCSTACK_SIZE) ufoFatal("VSP %u out of range (%u)", vsp, UFO_VOCSTACK_SIZE);
4685 ufoVocStack[vsp] = value;
4689 // ////////////////////////////////////////////////////////////////////////// //
4690 // word field address conversion
4693 // CFA->PFA
4694 // ( cfa -- pfa )
4695 UFWORD(CFA2PFA) {
4696 const uint32_t cfa = ufoPop();
4697 ufoPush(UFO_CFA_TO_PFA(cfa));
4700 // CFA->NFA
4701 // ( cfa -- nfa )
4702 UFWORD(CFA2NFA) {
4703 const uint32_t cfa = ufoPop();
4704 ufoPush(UFO_CFA_TO_NFA(cfa));
4707 // CFA->LFA
4708 // ( cfa -- lfa )
4709 UFWORD(CFA2LFA) {
4710 const uint32_t cfa = ufoPop();
4711 ufoPush(UFO_CFA_TO_LFA(cfa));
4714 // CFA->WEND
4715 // ( cfa -- wend-addr )
4716 UFWORD(CFA2WEND) {
4717 const uint32_t cfa = ufoPop();
4718 ufoPush(ufoGetWordEndAddr(cfa));
4721 // PFA->CFA
4722 // ( pfa -- cfa )
4723 UFWORD(PFA2CFA) {
4724 const uint32_t pfa = ufoPop();
4725 ufoPush(UFO_PFA_TO_CFA(pfa));
4728 // PFA->NFA
4729 // ( pfa -- nfa )
4730 UFWORD(PFA2NFA) {
4731 const uint32_t pfa = ufoPop();
4732 const uint32_t cfa = UFO_PFA_TO_CFA(pfa);
4733 ufoPush(UFO_CFA_TO_NFA(cfa));
4736 // NFA->CFA
4737 // ( nfa -- cfa )
4738 UFWORD(NFA2CFA) {
4739 const uint32_t nfa = ufoPop();
4740 ufoPush(UFO_NFA_TO_CFA(nfa));
4743 // NFA->PFA
4744 // ( nfa -- pfa )
4745 UFWORD(NFA2PFA) {
4746 const uint32_t nfa = ufoPop();
4747 const uint32_t cfa = UFO_NFA_TO_CFA(nfa);
4748 ufoPush(UFO_CFA_TO_PFA(cfa));
4751 // NFA->LFA
4752 // ( nfa -- lfa )
4753 UFWORD(NFA2LFA) {
4754 const uint32_t nfa = ufoPop();
4755 ufoPush(UFO_NFA_TO_LFA(nfa));
4758 // LFA->CFA
4759 // ( lfa -- cfa )
4760 UFWORD(LFA2CFA) {
4761 const uint32_t lfa = ufoPop();
4762 ufoPush(UFO_LFA_TO_CFA(lfa));
4765 // LFA->PFA
4766 // ( lfa -- pfa )
4767 UFWORD(LFA2PFA) {
4768 const uint32_t lfa = ufoPop();
4769 const uint32_t cfa = UFO_LFA_TO_CFA(lfa);
4770 ufoPush(UFO_CFA_TO_PFA(cfa));
4773 // LFA->BFA
4774 // ( lfa -- bfa )
4775 UFWORD(LFA2BFA) {
4776 const uint32_t lfa = ufoPop();
4777 ufoPush(UFO_LFA_TO_BFA(lfa));
4780 // LFA->XFA
4781 // ( lfa -- xfa )
4782 UFWORD(LFA2XFA) {
4783 const uint32_t lfa = ufoPop();
4784 ufoPush(UFO_LFA_TO_XFA(lfa));
4787 // LFA->YFA
4788 // ( lfa -- yfa )
4789 UFWORD(LFA2YFA) {
4790 const uint32_t lfa = ufoPop();
4791 ufoPush(UFO_LFA_TO_YFA(lfa));
4794 // LFA->NFA
4795 // ( lfa -- nfa )
4796 UFWORD(LFA2NFA) {
4797 const uint32_t lfa = ufoPop();
4798 ufoPush(UFO_LFA_TO_NFA(lfa));
4801 // IP->NFA
4802 // ( ip -- nfa / 0 )
4803 UFWORD(IP2NFA) {
4804 const uint32_t ip = ufoPop();
4805 ufoPush(ufoFindWordForIP(ip));
4808 // IP->FILE/LINE
4809 // ( ip -- addr count line TRUE / FALSE )
4810 // name is at PAD; it is safe to use PAD, because each task has its own temp image
4811 UFWORD(IP2FILELINE) {
4812 const uint32_t ip = ufoPop();
4813 uint32_t fline;
4814 const char *fname = ufoFindFileForIP(ip, &fline, NULL, NULL);
4815 if (fname != NULL) {
4816 UFCALL(PAD);
4817 uint32_t addr = ufoPeek();
4818 uint32_t count = 0;
4819 while (*fname != 0) {
4820 ufoImgPutU8(addr, *(const unsigned char *)fname);
4821 fname += 1u; addr += 1u; count += 1u;
4823 ufoImgPutU8(addr, 0); // just in case
4824 ufoPush(count);
4825 ufoPush(fline);
4826 ufoPushBool(1);
4827 } else {
4828 ufoPushBool(0);
4833 // IP->FILE-HASH/LINE
4834 // ( ip -- len hash line TRUE / FALSE )
4835 UFWORD(IP2FILEHASHLINE) {
4836 const uint32_t ip = ufoPop();
4837 uint32_t fline, fhash, flen;
4838 const char *fname = ufoFindFileForIP(ip, &fline, &flen, &fhash);
4839 if (fname != NULL) {
4840 ufoPush(flen);
4841 ufoPush(fhash);
4842 ufoPush(fline);
4843 ufoPushBool(1);
4844 } else {
4845 ufoPushBool(0);
4850 // ////////////////////////////////////////////////////////////////////////// //
4851 // string operations
4854 UFO_FORCE_INLINE uint32_t ufoHashBuf (uint32_t addr, uint32_t size, uint8_t orbyte) {
4855 uint32_t hash = 0x29a;
4856 if ((size & ((uint32_t)1<<31)) == 0) {
4857 while (size != 0) {
4858 hash += ufoImgGetU8Ext(addr) | orbyte;
4859 hash += hash<<10;
4860 hash ^= hash>>6;
4861 addr += 1u; size -= 1u;
4864 // finalize
4865 hash += hash<<3;
4866 hash ^= hash>>11;
4867 hash += hash<<15;
4868 return hash;
4871 //==========================================================================
4873 // ufoBufEqu
4875 //==========================================================================
4876 UFO_FORCE_INLINE int ufoBufEqu (uint32_t addr0, uint32_t addr1, uint32_t count) {
4877 int res;
4878 if ((count & ((uint32_t)1<<31)) == 0) {
4879 res = 1;
4880 while (res != 0 && count != 0) {
4881 res = (toUpperU8(ufoImgGetU8Ext(addr0)) == toUpperU8(ufoImgGetU8Ext(addr1)));
4882 addr0 += 1u; addr1 += 1u; count -= 1u;
4884 } else {
4885 res = 0;
4887 return res;
4890 // STRING:=
4891 // ( a0 c0 a1 c1 -- bool )
4892 UFWORD(STREQU) {
4893 int32_t c1 = (int32_t)ufoPop();
4894 uint32_t a1 = ufoPop();
4895 int32_t c0 = (int32_t)ufoPop();
4896 uint32_t a0 = ufoPop();
4897 if (c0 < 0) c0 = 0;
4898 if (c1 < 0) c1 = 0;
4899 if (c0 == c1) {
4900 int res = 1;
4901 while (res != 0 && c0 != 0) {
4902 res = (ufoImgGetU8Ext(a0) == ufoImgGetU8Ext(a1));
4903 a0 += 1; a1 += 1; c0 -= 1;
4905 ufoPushBool(res);
4906 } else {
4907 ufoPushBool(0);
4911 // STRING:=CI
4912 // ( a0 c0 a1 c1 -- bool )
4913 UFWORD(STREQUCI) {
4914 int32_t c1 = (int32_t)ufoPop();
4915 uint32_t a1 = ufoPop();
4916 int32_t c0 = (int32_t)ufoPop();
4917 uint32_t a0 = ufoPop();
4918 if (c0 < 0) c0 = 0;
4919 if (c1 < 0) c1 = 0;
4920 if (c0 == c1) {
4921 int res = 1;
4922 while (res != 0 && c0 != 0) {
4923 res = (toUpperU8(ufoImgGetU8Ext(a0)) == toUpperU8(ufoImgGetU8Ext(a1)));
4924 a0 += 1; a1 += 1; c0 -= 1;
4926 ufoPushBool(res);
4927 } else {
4928 ufoPushBool(0);
4932 // search the string specified by c-addr1 u1 for the string specified by c-addr2 u2.
4933 // if flag is true, a match was found at c-addr3 with u3 characters remaining.
4934 // if flag is false there was no match and c-addr3 is c-addr1 and u3 is u1.
4935 // ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 flag )
4936 UFWORD(SEARCH) {
4937 const uint32_t pcount = ufoPop();
4938 const uint32_t paddr = ufoPop();
4939 const uint32_t tcount = ufoPop();
4940 const uint32_t taddr = ufoPop();
4941 if ((pcount & ((uint32_t)1 << 31)) == 0 && (tcount & ((uint32_t)1 << 31)) == 0) {
4942 for (uint32_t f = 0; tcount - f >= pcount; f += 1) {
4943 if (ufoBufEqu(taddr + f, paddr, pcount)) {
4944 ufoPush(taddr + f);
4945 ufoPush(tcount - f);
4946 ufoPushBool(1);
4947 return;
4951 ufoPush(taddr);
4952 ufoPush(tcount);
4953 ufoPushBool(0);
4956 // STRING:HASH
4957 // ( addr count -- hash )
4958 UFWORD(STRHASH) {
4959 uint32_t count = ufoPop();
4960 uint32_t addr = ufoPop();
4961 ufoPush(ufoHashBuf(addr, count, 0));
4964 // STRING:HASH-CI
4965 // ( addr count -- hash )
4966 UFWORD(STRHASHCI) {
4967 uint32_t count = ufoPop();
4968 uint32_t addr = ufoPop();
4969 ufoPush(ufoHashBuf(addr, count, 0x20));
4973 // ////////////////////////////////////////////////////////////////////////// //
4974 // conditional defines
4977 typedef struct UForthCondDefine_t UForthCondDefine;
4978 struct UForthCondDefine_t {
4979 char *name;
4980 uint32_t namelen;
4981 uint32_t hash;
4982 UForthCondDefine *next;
4985 static UForthCondDefine *ufoCondDefines = NULL;
4986 static char ufoErrMsgBuf[4096];
4989 //==========================================================================
4991 // ufoStrEquCI
4993 //==========================================================================
4994 UFO_DISABLE_INLINE int ufoStrEquCI (const void *str0, const void *str1) {
4995 const unsigned char *s0 = (const unsigned char *)str0;
4996 const unsigned char *s1 = (const unsigned char *)str1;
4997 while (*s0 && *s1) {
4998 if (toUpperU8(*s0) != toUpperU8(*s1)) return 0;
4999 s0 += 1; s1 += 1;
5001 return (*s0 == 0 && *s1 == 0);
5005 //==========================================================================
5007 // ufoBufEquCI
5009 //==========================================================================
5010 UFO_FORCE_INLINE int ufoBufEquCI (uint32_t addr, uint32_t count, const void *buf) {
5011 int res;
5012 if ((count & ((uint32_t)1<<31)) == 0) {
5013 const unsigned char *src = (const unsigned char *)buf;
5014 res = 1;
5015 while (res != 0 && count != 0) {
5016 res = (toUpperU8(*src) == toUpperU8(ufoImgGetU8Ext(addr)));
5017 src += 1; addr += 1u; count -= 1u;
5019 } else {
5020 res = 0;
5022 return res;
5026 //==========================================================================
5028 // ufoClearCondDefines
5030 //==========================================================================
5031 static void ufoClearCondDefines (void) {
5032 while (ufoCondDefines) {
5033 UForthCondDefine *df = ufoCondDefines;
5034 ufoCondDefines = df->next;
5035 if (df->name) free(df->name);
5036 free(df);
5041 //==========================================================================
5043 // ufoHasCondDefine
5045 //==========================================================================
5046 int ufoHasCondDefine (const char *name) {
5047 int res = 0;
5048 if (name != NULL && name[0] != 0) {
5049 const size_t nlen = strlen(name);
5050 if (nlen <= 255) {
5051 const uint32_t hash = joaatHashBufCI(name, nlen);
5052 UForthCondDefine *dd = ufoCondDefines;
5053 while (res == 0 && dd != NULL) {
5054 if (dd->hash == hash && dd->namelen == (uint32_t)nlen) {
5055 res = ufoStrEquCI(name, dd->name);
5057 dd = dd->next;
5061 return res;
5065 //==========================================================================
5067 // ufoCondDefine
5069 //==========================================================================
5070 void ufoCondDefine (const char *name) {
5071 if (name != NULL && name[0] != 0) {
5072 const size_t nlen = strlen(name);
5073 if (nlen > 255) ufoFatal("conditional define name too long");
5074 const uint32_t hash = joaatHashBufCI(name, nlen);
5075 UForthCondDefine *dd = ufoCondDefines;
5076 int res = 0;
5077 while (res == 0 && dd != NULL) {
5078 if (dd->hash == hash && dd->namelen == (uint32_t)nlen) {
5079 res = ufoStrEquCI(name, dd->name);
5081 dd = dd->next;
5083 if (res == 0) {
5084 // new define
5085 dd = calloc(1, sizeof(UForthCondDefine));
5086 if (dd == NULL) ufoFatal("out of memory for defines");
5087 dd->name = strdup(name);
5088 if (dd->name == NULL) { free(dd); ufoFatal("out of memory for defines"); }
5089 dd->namelen = (uint32_t)nlen;
5090 dd->hash = hash;
5091 dd->next = ufoCondDefines;
5092 ufoCondDefines = dd;
5098 //==========================================================================
5100 // ufoCondUndef
5102 //==========================================================================
5103 void ufoCondUndef (const char *name) {
5104 if (name != NULL && name[0] != 0) {
5105 const size_t nlen = strlen(name);
5106 if (nlen <= 255) {
5107 const uint32_t hash = joaatHashBufCI(name, nlen);
5108 UForthCondDefine *dd = ufoCondDefines;
5109 UForthCondDefine *prev = NULL;
5110 while (dd != NULL) {
5111 if (dd->hash == hash && dd->namelen == (uint32_t)nlen) {
5112 if (ufoStrEquCI(name, dd->name)) {
5113 if (prev != NULL) prev->next = dd->next; else ufoCondDefines = dd->next;
5114 free(dd->name);
5115 free(dd);
5116 dd = NULL;
5119 if (dd != NULL) { prev = dd; dd = dd->next; }
5126 // ($DEFINE)
5127 // ( addr count -- )
5128 UFWORD(PAR_DLR_DEFINE) {
5129 uint32_t count = ufoPop();
5130 uint32_t addr = ufoPop();
5131 if (count == 0) ufoFatal("empty define");
5132 if (count >= UFO_MAX_WORD_LENGTH) ufoFatal("define too long");
5133 const uint32_t hash = ufoHashBuf(addr, count, 0x20);
5134 UForthCondDefine *dd;
5135 for (dd = ufoCondDefines; dd != NULL; dd = dd->next) {
5136 if (dd->hash == hash && dd->namelen == count) {
5137 if (ufoBufEquCI(addr, count, dd->name)) return;
5140 // new define
5141 dd = calloc(1, sizeof(UForthCondDefine));
5142 if (dd == NULL) ufoFatal("out of memory for defines");
5143 dd->name = calloc(1, count + 1u);
5144 if (dd->name == NULL) { free(dd); ufoFatal("out of memory for defines"); }
5145 for (uint32_t f = 0; f < count; f += 1) {
5146 ((unsigned char *)dd->name)[f] = ufoImgGetU8Ext(addr + f);
5148 dd->namelen = count;
5149 dd->hash = hash;
5150 dd->next = ufoCondDefines;
5151 ufoCondDefines = dd;
5154 // ($UNDEF)
5155 // ( addr count -- )
5156 UFWORD(PAR_DLR_UNDEF) {
5157 uint32_t count = ufoPop();
5158 uint32_t addr = ufoPop();
5159 if (count == 0) ufoFatal("empty define");
5160 if (count >= UFO_MAX_WORD_LENGTH) ufoFatal("define too long");
5161 const uint32_t hash = ufoHashBuf(addr, count, 0x20);
5162 UForthCondDefine *prev = NULL;
5163 UForthCondDefine *dd;
5164 for (dd = ufoCondDefines; dd != NULL; prev = dd, dd = dd->next) {
5165 if (dd->hash == hash && dd->namelen == count) {
5166 if (ufoBufEquCI(addr, count, dd->name)) {
5167 if (prev == NULL) ufoCondDefines = dd->next; else prev->next = dd->next;
5168 free(dd->name);
5169 free(dd);
5170 return;
5176 // ($DEFINED?)
5177 // ( addr count -- bool )
5178 UFWORD(PAR_DLR_DEFINEDQ) {
5179 uint32_t count = ufoPop();
5180 uint32_t addr = ufoPop();
5181 if (count == 0) ufoFatal("empty define");
5182 if (count >= UFO_MAX_WORD_LENGTH) ufoFatal("define too long");
5183 const uint32_t hash = ufoHashBuf(addr, count, 0x20);
5184 int found = 0;
5185 UForthCondDefine *dd = ufoCondDefines;
5186 while (!found && dd != NULL) {
5187 if (dd->hash == hash && dd->namelen == count) {
5188 found = ufoBufEquCI(addr, count, dd->name);
5190 dd = dd->next;
5192 ufoPushBool(found);
5196 // ////////////////////////////////////////////////////////////////////////// //
5197 // error reporting
5200 // ERROR
5201 // ( addr count -- )
5202 UFWORD(ERROR) {
5203 uint32_t count = ufoPop();
5204 uint32_t addr = ufoPop();
5205 if (count & (1u<<31)) ufoFatal("invalid error message");
5206 if (count == 0) ufoFatal("some error");
5207 if (count > (uint32_t)sizeof(ufoErrMsgBuf) - 1u) count = (uint32_t)sizeof(ufoErrMsgBuf) - 1u;
5208 for (uint32_t f = 0; f < count; f += 1) {
5209 ufoErrMsgBuf[f] = (char)ufoImgGetU8Ext(addr + f);
5211 ufoErrMsgBuf[count] = 0;
5212 ufoFatal("%s", ufoErrMsgBuf);
5215 // ////////////////////////////////////////////////////////////////////////// //
5216 // includes
5219 static char ufoFNameBuf[4096];
5222 //==========================================================================
5224 // ufoScanIncludeFileName
5226 // `*psys` and `*psoft` must be initialised!
5228 //==========================================================================
5229 static void ufoScanIncludeFileName (uint32_t addr, uint32_t count, char *dest, size_t destsz,
5230 uint32_t *psys, uint32_t *psoft)
5232 uint8_t ch;
5233 uint32_t dpos;
5234 ufo_assert(dest != NULL);
5235 ufo_assert(destsz > 0);
5237 while (count != 0) {
5238 ch = ufoImgGetU8Ext(addr);
5239 if (ch == '!') {
5240 //if (system) ufoFatal("invalid file name (duplicate system mark)");
5241 *psys = 1;
5242 } else if (ch == '?') {
5243 //if (softinclude) ufoFatal("invalid file name (duplicate soft mark)");
5244 *psoft = 1;
5245 } else {
5246 break;
5248 do {
5249 addr += 1; count -= 1;
5250 ch = ufoImgGetU8Ext(addr);
5251 } while (ch <= 32 && count != 0);
5254 if (count == 0) ufoFatal("empty include file name");
5255 if (count >= destsz) ufoFatal("include file name too long");
5257 dpos = 0;
5258 while (count != 0) {
5259 dest[dpos] = (char)ufoImgGetU8Ext(addr); dpos += 1;
5260 addr += 1; count -= 1;
5262 dest[dpos] = 0;
5266 // (INCLUDE-DEPTH)
5267 // ( -- depth )
5268 // return number of items in include stack
5269 UFWORD(PAR_INCLUDE_DEPTH) {
5270 ufoPush(ufoFileStackPos);
5273 // (INCLUDE-FILE-ID)
5274 // ( isp -- id ) -- isp 0 is current, then 1, etc.
5275 // each include file has unique non-zero id.
5276 UFWORD(PAR_INCLUDE_FILE_ID) {
5277 const uint32_t isp = ufoPop();
5278 if (isp == 0) {
5279 ufoPush(ufoFileId);
5280 } else if (isp <= ufoFileStackPos) {
5281 UFOFileStackEntry *stk = &ufoFileStack[ufoFileStackPos - isp];
5282 ufoPush(stk->id);
5283 } else {
5284 ufoFatal("invalid include stack index");
5288 // (INCLUDE-FILE-LINE)
5289 // ( isp -- line )
5290 UFWORD(PAR_INCLUDE_FILE_LINE) {
5291 const uint32_t isp = ufoPop();
5292 if (isp == 0) {
5293 ufoPush(ufoInFileLine);
5294 } else if (isp <= ufoFileStackPos) {
5295 UFOFileStackEntry *stk = &ufoFileStack[ufoFileStackPos - isp];
5296 ufoPush(stk->fline);
5297 } else {
5298 ufoFatal("invalid include stack index");
5300 ufoPush(ufoInFileLine);
5303 // (INCLUDE-FILE-NAME)
5304 // ( isp -- addr count )
5305 // current file name; at PAD
5306 UFWORD(PAR_INCLUDE_FILE_NAME) {
5307 const uint32_t isp = ufoPop();
5308 const char *fname = NULL;
5309 if (isp == 0) {
5310 fname = ufoInFileName;
5311 } else if (isp <= ufoFileStackPos) {
5312 UFOFileStackEntry *stk = &ufoFileStack[ufoFileStackPos - isp];
5313 fname = stk->fname;
5314 } else {
5315 ufoFatal("invalid include stack index");
5317 UFCALL(PAD);
5318 uint32_t addr = ufoPop();
5319 uint32_t count = 0;
5320 while (fname[count] != 0) {
5321 ufoImgPutU8Ext(addr + count, ((const unsigned char *)fname)[count]);
5322 count += 1;
5324 ufoImgPutU8Ext(addr + count, 0);
5325 ufoPush(addr);
5326 ufoPush(count);
5329 // (INCLUDE)
5330 // ( addr count soft? system? -- )
5331 UFWORD(PAR_INCLUDE) {
5332 uint32_t system = ufoPop();
5333 uint32_t softinclude = ufoPop();
5334 uint32_t count = ufoPop();
5335 uint32_t addr = ufoPop();
5337 if (ufoMode == UFO_MODE_MACRO) ufoFatal("macros cannot include files");
5339 if ((count & ((uint32_t)1<<31)) != 0) ufoFatal("invalid include name");
5341 ufoScanIncludeFileName(addr, count, ufoFNameBuf, sizeof(ufoFNameBuf),
5342 &system, &softinclude);
5344 char *ffn = ufoCreateIncludeName(ufoFNameBuf, system, (system ? ufoLastSysIncPath : ufoLastIncPath));
5345 #ifdef WIN32
5346 FILE *fl = fopen(ffn, "rb");
5347 #else
5348 FILE *fl = fopen(ffn, "r");
5349 #endif
5350 if (!fl) {
5351 if (softinclude) { free(ffn); return; }
5352 ufoFatal("include file '%s' not found", ffn);
5354 #ifdef UFO_DEBUG_INCLUDE
5355 fprintf(stderr, "INC-PUSH: new fname: %s\n", ffn);
5356 #endif
5357 ufoPushInFile();
5358 ufoInFile = fl;
5359 ufoInFileLine = 0;
5360 ufoSetInFileNameReuse(ffn);
5361 ufoFileId = ufoLastUsedFileId;
5362 setLastIncPath(ufoInFileName, system);
5363 // trigger next line loading
5364 UFCALL(REFILL);
5365 if (!ufoPop()) ufoFatal("(INCLUDE) internal error");
5368 // $INCLUDE "str"
5369 UFWORD(DLR_INCLUDE_IMM) {
5370 int soft = 0, system = 0;
5371 // parse include filename
5372 //UFCALL(PARSE_SKIP_BLANKS);
5373 ufoPushBool(0); UFCALL(PAR_PARSE_SKIP_COMMENTS);
5374 uint8_t ch = ufoTibPeekCh();
5375 if (ch == '"') {
5376 ufoTibSkipCh(); // skip quote
5377 ufoPush(34);
5378 } else if (ch == '<') {
5379 ufoTibSkipCh(); // skip quote
5380 ufoPush(62);
5381 system = 1;
5382 } else {
5383 ufoFatal("expected quoted string");
5385 UFCALL(PARSE);
5386 if (!ufoPop()) ufoFatal("file name expected");
5387 ufoPushBool(0); UFCALL(PAR_PARSE_SKIP_COMMENTS);
5388 if (ufoTibPeekCh() != 0) {
5389 ufoFatal("$INCLUDE doesn't accept extra args yet");
5391 // ( addr count soft? system? -- )
5392 ufoPushBool(soft); ufoPushBool(system); UFCALL(PAR_INCLUDE);
5396 //==========================================================================
5398 // ufoCreateFileGuard
5400 //==========================================================================
5401 static const char *ufoCreateFileGuard (const char *fname) {
5402 if (fname == NULL || fname[0] == 0) return NULL;
5403 char *rp = ufoRealPath(fname);
5404 if (rp == NULL) return NULL;
5405 #ifdef WIN32
5406 for (char *s = rp; *s; s += 1) if (*s == '\\') *s = '/';
5407 #endif
5408 // hash the buffer; extract file name; create string with path len, file name, and hash
5409 const size_t orgplen = strlen(rp);
5410 const uint32_t phash = joaatHashBuf(rp, orgplen, 0);
5411 size_t plen = orgplen;
5412 while (plen != 0 && rp[plen - 1u] != '/') plen -= 1;
5413 snprintf(ufoRealPathHashBuf, sizeof(ufoRealPathHashBuf),
5414 "__INCLUDE_GUARD_%08X_%08X_%s__", phash, (uint32_t)orgplen, rp + plen);
5415 return ufoRealPathHashBuf;
5419 // $INCLUDE-ONCE "str"
5420 // includes file only once; unreliable on shitdoze, i believe
5421 UFWORD(DLR_INCLUDE_ONCE_IMM) {
5422 uint32_t softinclude = 0, system = 0;
5423 // parse include filename
5424 //UFCALL(PARSE_SKIP_BLANKS);
5425 ufoPushBool(0); UFCALL(PAR_PARSE_SKIP_COMMENTS);
5426 uint8_t ch = ufoTibPeekCh();
5427 if (ch == '"') {
5428 ufoTibSkipCh(); // skip quote
5429 ufoPush(34);
5430 } else if (ch == '<') {
5431 ufoTibSkipCh(); // skip quote
5432 ufoPush(62);
5433 system = 1;
5434 } else {
5435 ufoFatal("expected quoted string");
5437 UFCALL(PARSE);
5438 if (!ufoPop()) ufoFatal("file name expected");
5439 const uint32_t count = ufoPop();
5440 const uint32_t addr = ufoPop();
5441 ufoPushBool(0); UFCALL(PAR_PARSE_SKIP_COMMENTS);
5442 if (ufoTibPeekCh() != 0) {
5443 ufoFatal("$REQUIRE doesn't accept extra args yet");
5445 ufoScanIncludeFileName(addr, count, ufoRealPathHashBuf, sizeof(ufoRealPathHashBuf),
5446 &system, &softinclude);
5447 char *incfname = ufoCreateIncludeName(ufoRealPathHashBuf, system, (system ? ufoLastSysIncPath : ufoLastIncPath));
5448 if (incfname == NULL) ufoFatal("cannot resolve include file '%s'", ufoRealPathHashBuf);
5449 //fprintf(stderr, "?:%d;!:%d;%s|%s\n", softinclude, system, ufoRealPathHashBuf, incfname);
5450 // this will overwrite `ufoRealPathHashBuf`
5451 const char *guard = ufoCreateFileGuard(incfname);
5452 free(incfname);
5453 if (guard == NULL) {
5454 if (!softinclude) ufoFatal("cannot include file '%s'", ufoRealPathHashBuf);
5455 return;
5457 #if 0
5458 fprintf(stderr, "GUARD: <%s>\n", guard);
5459 #endif
5460 // now check for the guard
5461 const uint32_t glen = (uint32_t)strlen(guard);
5462 const uint32_t ghash = joaatHashBuf(guard, glen, 0);
5463 UForthCondDefine *dd;
5464 for (dd = ufoCondDefines; dd != NULL; dd = dd->next) {
5465 if (dd->hash == ghash && dd->namelen == glen && strcmp(guard, dd->name) == 0) {
5466 // nothing to do: already included
5467 return;
5470 // add guard
5471 dd = calloc(1, sizeof(UForthCondDefine));
5472 if (dd == NULL) ufoFatal("out of memory for defines");
5473 dd->name = calloc(1, glen + 1u);
5474 if (dd->name == NULL) { free(dd); ufoFatal("out of memory for defines"); }
5475 strcpy(dd->name, guard);
5476 dd->namelen = glen;
5477 dd->hash = ghash;
5478 dd->next = ufoCondDefines;
5479 ufoCondDefines = dd;
5480 // ( addr count soft? system? -- )
5481 ufoPush(addr); ufoPush(count); ufoPushBool(softinclude); ufoPushBool(system);
5482 UFCALL(PAR_INCLUDE);
5486 // ////////////////////////////////////////////////////////////////////////// //
5487 // handles
5490 // HANDLE:NEW
5491 // ( typeid -- hx )
5492 UFWORD(PAR_NEW_HANDLE) {
5493 const uint32_t typeid = ufoPop();
5494 if (typeid == UFO_HANDLE_FREE) ufoFatal("invalid handle typeid");
5495 UfoHandle *hh = ufoAllocHandle(typeid);
5496 ufoPush(hh->ufoHandle);
5499 // HANDLE:FREE
5500 // ( hx -- )
5501 UFWORD(PAR_FREE_HANDLE) {
5502 const uint32_t hx = ufoPop();
5503 if (hx != 0) {
5504 if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("trying to free something that is not a handle");
5505 UfoHandle *hh = ufoGetHandle(hx);
5506 if (hh == NULL) ufoFatal("trying to free invalid handle");
5507 ufoFreeHandle(hh);
5511 // HANDLE:TYPEID@
5512 // ( hx -- typeid )
5513 UFWORD(PAR_HANDLE_GET_TYPEID) {
5514 const uint32_t hx = ufoPop();
5515 if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle");
5516 UfoHandle *hh = ufoGetHandle(hx);
5517 if (hh == NULL) ufoFatal("invalid handle");
5518 ufoPush(hh->typeid);
5521 // HANDLE:TYPEID!
5522 // ( typeid hx -- )
5523 UFWORD(PAR_HANDLE_SET_TYPEID) {
5524 const uint32_t hx = ufoPop();
5525 const uint32_t typeid = ufoPop();
5526 if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle");
5527 if (typeid == UFO_HANDLE_FREE) ufoFatal("invalid handle typeid");
5528 UfoHandle *hh = ufoGetHandle(hx);
5529 if (hh == NULL) ufoFatal("invalid handle");
5530 hh->typeid = typeid;
5533 // HANDLE:SIZE@
5534 // ( hx -- size )
5535 UFWORD(PAR_HANDLE_GET_SIZE) {
5536 const uint32_t hx = ufoPop();
5537 if (hx != 0) {
5538 if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle");
5539 UfoHandle *hh = ufoGetHandle(hx);
5540 if (hh == NULL) ufoFatal("invalid handle");
5541 ufoPush(hh->size);
5542 } else {
5543 ufoPush(0);
5547 // HANDLE:SIZE!
5548 // ( size hx -- )
5549 UFWORD(PAR_HANDLE_SET_SIZE) {
5550 const uint32_t hx = ufoPop();
5551 const uint32_t size = ufoPop();
5552 if (size > 0x04000000) ufoFatal("invalid handle size");
5553 if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle");
5554 UfoHandle *hh = ufoGetHandle(hx);
5555 if (hh == NULL) ufoFatal("invalid handle");
5556 if (hh->size != size) {
5557 if (size == 0) {
5558 free(hh->data);
5559 hh->data = NULL;
5560 } else {
5561 uint8_t *nx = realloc(hh->data, size * sizeof(hh->data[0]));
5562 if (nx == NULL) ufoFatal("out of memory for handle of size %u", size);
5563 hh->data = nx;
5564 if (size > hh->size) memset(hh->data, 0, size - hh->size);
5566 hh->size = size;
5567 if (hh->used > size) hh->used = size;
5571 // HANDLE:USED@
5572 // ( hx -- used )
5573 UFWORD(PAR_HANDLE_GET_USED) {
5574 const uint32_t hx = ufoPop();
5575 if (hx != 0) {
5576 if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle");
5577 UfoHandle *hh = ufoGetHandle(hx);
5578 if (hh == NULL) ufoFatal("invalid handle");
5579 ufoPush(hh->used);
5580 } else {
5581 ufoPush(0);
5585 // HANDLE:USED!
5586 // ( size hx -- )
5587 UFWORD(PAR_HANDLE_SET_USED) {
5588 const uint32_t hx = ufoPop();
5589 const uint32_t used = ufoPop();
5590 if (used > 0x04000000) ufoFatal("invalid handle used");
5591 if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle");
5592 UfoHandle *hh = ufoGetHandle(hx);
5593 if (hh == NULL) ufoFatal("invalid handle");
5594 if (used > hh->size) ufoFatal("handle used %u out of range (%u)", used, hh->size);
5595 hh->used = used;
5598 #define POP_PREPARE_HANDLE() \
5599 const uint32_t hx = ufoPop(); \
5600 uint32_t idx = ufoPop(); \
5601 if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle"); \
5602 if (idx > 0x1fffffffU - UFO_ADDR_HANDLE_OFS_MASK) ufoFatal("handle index %u out of range", idx); \
5603 idx += (hx & UFO_ADDR_HANDLE_OFS_MASK); \
5604 UfoHandle *hh = ufoGetHandle(hx); \
5605 if (hh == NULL) ufoFatal("invalid handle")
5607 // HANDLE:C@
5608 // ( idx hx -- value )
5609 UFWORD(PAR_HANDLE_LOAD_BYTE) {
5610 POP_PREPARE_HANDLE();
5611 if (idx >= hh->size) ufoFatal("handle index %u out of range (%u)", idx, hh->size);
5612 ufoPush(hh->data[idx]);
5615 // HANDLE:W@
5616 // ( idx hx -- value )
5617 UFWORD(PAR_HANDLE_LOAD_WORD) {
5618 POP_PREPARE_HANDLE();
5619 if (idx >= hh->size || hh->size - idx < 2u) {
5620 ufoFatal("handle index %u out of range (%u)", idx, hh->size);
5622 #ifdef UFO_FAST_MEM_ACCESS
5623 ufoPush(*(const uint16_t *)(hh->data + idx));
5624 #else
5625 uint32_t res = hh->data[idx];
5626 res |= hh->data[idx + 1u] << 8;
5627 ufoPush(res);
5628 #endif
5631 // HANDLE:@
5632 // ( idx hx -- value )
5633 UFWORD(PAR_HANDLE_LOAD_CELL) {
5634 POP_PREPARE_HANDLE();
5635 if (idx >= hh->size || hh->size - idx < 4u) {
5636 ufoFatal("handle index %u out of range (%u)", idx, hh->size);
5638 #ifdef UFO_FAST_MEM_ACCESS
5639 ufoPush(*(const uint32_t *)(hh->data + idx));
5640 #else
5641 uint32_t res = hh->data[idx];
5642 res |= hh->data[idx + 1u] << 8;
5643 res |= hh->data[idx + 2u] << 16;
5644 res |= hh->data[idx + 3u] << 24;
5645 ufoPush(res);
5646 #endif
5649 // HANDLE:C!
5650 // ( value idx hx -- value )
5651 UFWORD(PAR_HANDLE_STORE_BYTE) {
5652 POP_PREPARE_HANDLE();
5653 const uint32_t value = ufoPop();
5654 if (idx >= hh->size) ufoFatal("handle index %u out of range (%u)", idx, hh->size);
5655 hh->data[idx] = value;
5658 // HANDLE:W!
5659 // ( value idx hx -- )
5660 UFWORD(PAR_HANDLE_STORE_WORD) {
5661 POP_PREPARE_HANDLE();
5662 const uint32_t value = ufoPop();
5663 if (idx >= hh->size || hh->size - idx < 2u) {
5664 ufoFatal("handle index %u out of range (%u)", idx, hh->size);
5666 #ifdef UFO_FAST_MEM_ACCESS
5667 *(uint16_t *)(hh->data + idx) = (uint16_t)value;
5668 #else
5669 hh->data[idx] = (uint8_t)value;
5670 hh->data[idx + 1u] = (uint8_t)(value >> 8);
5671 #endif
5674 // HANDLE:!
5675 // ( value idx hx -- )
5676 UFWORD(PAR_HANDLE_STORE_CELL) {
5677 POP_PREPARE_HANDLE();
5678 const uint32_t value = ufoPop();
5679 if (idx >= hh->size || hh->size - idx < 4u) {
5680 ufoFatal("handle index %u out of range (%u)", idx, hh->size);
5682 #ifdef UFO_FAST_MEM_ACCESS
5683 *(uint32_t *)(hh->data + idx) = value;
5684 #else
5685 hh->data[idx] = (uint8_t)value;
5686 hh->data[idx + 1u] = (uint8_t)(value >> 8);
5687 hh->data[idx + 2u] = (uint8_t)(value >> 16);
5688 hh->data[idx + 3u] = (uint8_t)(value >> 24);
5689 #endif
5693 // HANDLE:LOAD-FILE
5694 // ( addr count -- stx / FALSE )
5695 UFWORD(PAR_HANDLE_LOAD_FILE) {
5696 uint32_t count = ufoPop();
5697 uint32_t addr = ufoPop();
5699 if ((count & ((uint32_t)1<<31)) != 0) ufoFatal("invalid file name");
5701 uint8_t *dest = (uint8_t *)ufoFNameBuf;
5702 while (count != 0 && dest < (uint8_t *)ufoFNameBuf + sizeof(ufoFNameBuf)) {
5703 uint8_t ch = ufoImgGetU8Ext(addr);
5704 *dest = ch;
5705 dest += 1u; addr += 1u; count -= 1u;
5707 if (dest == (uint8_t *)ufoFNameBuf + sizeof(ufoFNameBuf)) ufoFatal("file name too long");
5708 *dest = 0;
5710 if (*ufoFNameBuf == 0) ufoFatal("empty file name");
5712 char *ffn = ufoCreateIncludeName(ufoFNameBuf, 0/*system*/, ufoLastIncPath);
5713 #ifdef WIN32
5714 FILE *fl = fopen(ffn, "rb");
5715 #else
5716 FILE *fl = fopen(ffn, "r");
5717 #endif
5718 if (!fl) {
5719 free(ffn);
5720 ufoPush(0);
5721 return;
5724 if (fseek(fl, 0, SEEK_END) != 0) {
5725 fclose(fl);
5726 ufoFatal("seek error in file '%s'", ffn);
5729 long sz = ftell(fl);
5730 if (sz < 0 || sz >= 1024 * 1024 * 64) {
5731 fclose(fl);
5732 ufoFatal("tell error in file '%s' (or too big)", ffn);
5735 if (fseek(fl, 0, SEEK_SET) != 0) {
5736 fclose(fl);
5737 ufoFatal("seek error in file '%s'", ffn);
5740 UfoHandle *hh = ufoAllocHandle(0);
5741 if (sz != 0) {
5742 hh->data = malloc((uint32_t)sz);
5743 if (hh->data == NULL) {
5744 fclose(fl);
5745 ufoFatal("out of memory for file '%s'", ffn);
5747 hh->size = (uint32_t)sz;
5748 if (fread(hh->data, (uint32_t)sz, 1, fl) != 1) {
5749 fclose(fl);
5750 ufoFatal("error reading file '%s'", ffn);
5752 fclose(fl);
5755 free(ffn);
5756 ufoPush(hh->ufoHandle);
5760 // ////////////////////////////////////////////////////////////////////////// //
5761 // utils
5764 // DEBUG:(DECOMPILE-CFA)
5765 // ( cfa -- )
5766 UFWORD(DEBUG_DECOMPILE_CFA) {
5767 const uint32_t cfa = ufoPop();
5768 ufoFlushOutput();
5769 ufoDecompileWord(cfa);
5772 // DEBUG:(DECOMPILE-MEM)
5773 // ( addr-start addr-end -- )
5774 UFWORD(DEBUG_DECOMPILE_MEM) {
5775 const uint32_t end = ufoPop();
5776 const uint32_t start = ufoPop();
5777 ufoFlushOutput();
5778 ufoDecompilePart(start, end, 0);
5781 // GET-MSECS
5782 // ( -- u32 )
5783 UFWORD(GET_MSECS) {
5784 ufoPush((uint32_t)ufo_get_msecs());
5787 // this is called by INTERPRET when it is out of input stream
5788 UFWORD(UFO_INTERPRET_FINISHED_ACTION) {
5789 ufoVMStop = 1;
5792 // MTASK:NEW-STATE
5793 // ( cfa -- stid )
5794 UFWORD(MT_NEW_STATE) {
5795 UfoState *st = ufoNewState();
5796 ufoInitStateUserVars(st, ufoPop());
5797 ufoPush(st->id);
5800 // MTASK:FREE-STATE
5801 // ( stid -- )
5802 UFWORD(MT_FREE_STATE) {
5803 UfoState *st = ufoFindState(ufoPop());
5804 if (st == NULL) ufoFatal("cannot free unknown state");
5805 if (st == ufoCurrState) ufoFatal("cannot free current state");
5806 ufoFreeState(st);
5809 // MTASK:STATE-NAME@
5810 // ( stid -- addr count )
5811 // to PAD
5812 UFWORD(MT_GET_STATE_NAME) {
5813 UfoState *st = ufoFindState(ufoPop());
5814 if (st == NULL) ufoFatal("unknown state");
5815 UFCALL(PAD);
5816 uint32_t addr = ufoPop();
5817 uint32_t count = 0;
5818 while (st->name[count] != 0) {
5819 ufoImgPutU8Ext(addr + count, ((const unsigned char *)st->name)[count]);
5820 count += 1u;
5822 ufoImgPutU8Ext(addr + count, 0);
5823 ufoPush(addr);
5824 ufoPush(count);
5827 // MTASK:STATE-NAME!
5828 // ( addr count stid -- )
5829 UFWORD(MT_SET_STATE_NAME) {
5830 UfoState *st = ufoFindState(ufoPop());
5831 if (st == NULL) ufoFatal("unknown state");
5832 uint32_t count = ufoPop();
5833 uint32_t addr = ufoPop();
5834 if ((count & ((uint32_t)1 << 31)) == 0) {
5835 if (count > UFO_MAX_TASK_NAME) ufoFatal("task name too long");
5836 for (uint32_t f = 0; f < count; f += 1u) {
5837 ((unsigned char *)st->name)[f] = ufoImgGetU8Ext(addr + f);
5839 st->name[count] = 0;
5843 // MTASK:STATE-FIRST
5844 // ( -- stid )
5845 UFWORD(MT_STATE_FIRST) {
5846 uint32_t fidx = 0;
5847 while (fidx != (uint32_t)(UFO_MAX_STATES/32) && ufoStateUsedBitmap[fidx] == 0) fidx += 1u;
5848 // there should be at least one allocated state
5849 ufo_assert(fidx != (uint32_t)(UFO_MAX_STATES/32));
5850 uint32_t bmp = ufoStateUsedBitmap[fidx];
5851 fidx *= 32u;
5852 while ((bmp & 0x01) == 0) { fidx += 1u; bmp >>= 1; }
5853 ufoPush(fidx + 1u);
5856 // MTASK:STATE-NEXT
5857 // ( stid -- stid / 0 )
5858 UFWORD(MT_STATE_NEXT) {
5859 uint32_t stid = ufoPop();
5860 if (stid != 0 && stid < (uint32_t)(UFO_MAX_STATES/32)) {
5861 // it is already incremented for us, yay!
5862 uint32_t fidx = stid / 32u;
5863 uint8_t fofs = stid & 0x1f;
5864 while (fidx < (uint32_t)(UFO_MAX_STATES/32)) {
5865 const uint32_t bmp = ufoStateUsedBitmap[fidx];
5866 if (bmp != 0) {
5867 while (fofs != 32u) {
5868 if ((bmp & ((uint32_t)1 << (fofs & 0x1f))) == 0) fofs += 1u;
5870 if (fofs != 32u) {
5871 ufoPush(fidx * 32u + fofs + 1u);
5872 return; // sorry!
5875 fidx += 1u; fofs = 0;
5878 ufoPush(0);
5882 // MTASK:YIELD-TO
5883 // ( ... argc stid -- )
5884 UFWORD(MT_YIELD_TO) {
5885 UfoState *st = ufoFindState(ufoPop());
5886 if (st == NULL) ufoFatal("cannot yield to unknown state");
5887 //if (st == ufoDebuggerState) ufoFatal("cannot yield to debugger"); // why not?
5888 const uint32_t argc = ufoPop();
5889 if (argc > 256) ufoFatal("too many YIELD-TO arguments");
5890 UfoState *curst = ufoCurrState;
5891 if (st != ufoCurrState) {
5892 for (uint32_t f = 0; f < argc; f += 1) {
5893 ufoCurrState = curst;
5894 const uint32_t n = ufoPop();
5895 ufoCurrState = st;
5896 ufoPush(n);
5898 ufoCurrState = curst; // we need to use API call to switch states
5900 ufoSwitchToState(st); // always use API call for this!
5901 ufoPush(argc);
5902 ufoPush(curst->id);
5905 // MTASK:SET-SELF-AS-DEBUGGER
5906 // ( -- )
5907 UFWORD(MT_SET_SELF_AS_DEBUGGER) {
5908 ufoDebuggerState = ufoCurrState;
5911 // DEBUG:(BP)
5912 // ( -- )
5913 // debugger task receives debugge stid on the data stack, and -1 as argc.
5914 // i.e. debugger stask is: ( -1 old-stid )
5915 UFWORD(MT_DEBUGGER_BP) {
5916 if (ufoDebuggerState != NULL && ufoCurrState != ufoDebuggerState && ufoIsGoodTTY()) {
5917 UfoState *st = ufoCurrState;
5918 ufoSwitchToState(ufoDebuggerState); // always use API call for this!
5919 ufoPush(-1);
5920 ufoPush(st->id);
5921 ufoSingleStep = 0;
5922 } else {
5923 UFCALL(UFO_BACKTRACE);
5927 // MTASK:DEBUGGER-RESUME
5928 // ( stid -- )
5929 UFWORD(MT_RESUME_DEBUGEE) {
5930 if (ufoCurrState != ufoDebuggerState) ufoFatal("cannot resume from non-debugger");
5931 UfoState *st = ufoFindState(ufoPop());
5932 if (st == NULL) ufoFatal("cannot yield to unknown state");
5933 if (st == ufoCurrState) ufoFatal("cannot resume into debugger itself");
5934 ufoSwitchToState(st); // always use API call for this!
5935 ufoSingleStep = 0;
5938 // MTASK:DEBUGGER-SINGLE-STEP
5939 // ( stid -- )
5940 UFWORD(MT_SINGLE_STEP_DEBUGEE) {
5941 if (ufoCurrState != ufoDebuggerState) ufoFatal("cannot resume from non-debugger");
5942 UfoState *st = ufoFindState(ufoPop());
5943 if (st == NULL) ufoFatal("cannot yield to unknown state");
5944 if (st == ufoCurrState) ufoFatal("cannot resume into debugger itself");
5945 ufoSwitchToState(st); // always use API call for this!
5946 ufoSingleStep = 2; // it will be decremented after returning from this word
5949 // MTASK:STATE-IP@
5950 // ( stid -- ip )
5951 UFWORD(MT_STATE_IP_GET) {
5952 UfoState *st = ufoFindState(ufoPop());
5953 if (st == NULL) ufoFatal("unknown state");
5954 ufoPush(st->IP);
5957 // MTASK:STATE-IP!
5958 // ( ip stid -- )
5959 UFWORD(MT_STATE_IP_SET) {
5960 UfoState *st = ufoFindState(ufoPop());
5961 if (st == NULL) ufoFatal("unknown state");
5962 st->IP = ufoPop();
5965 // MTASK:STATE-A>
5966 // ( stid -- ip )
5967 UFWORD(MT_STATE_REGA_GET) {
5968 UfoState *st = ufoFindState(ufoPop());
5969 if (st == NULL) ufoFatal("unknown state");
5970 ufoPush(st->regA);
5973 // MTASK:STATE->A
5974 // ( ip stid -- )
5975 UFWORD(MT_STATE_REGA_SET) {
5976 UfoState *st = ufoFindState(ufoPop());
5977 if (st == NULL) ufoFatal("unknown state");
5978 st->regA = ufoPop();
5981 // MTASK:STATE-USER@
5982 // ( addr stid -- value )
5983 UFWORD(MT_STATE_USER_GET) {
5984 UfoState *st = ufoFindState(ufoPop());
5985 if (st == NULL) ufoFatal("unknown state");
5986 const uint32_t addr = ufoPop();
5987 if ((addr & UFO_ADDR_TEMP_BIT) != 0 && (addr & UFO_ADDR_TEMP_MASK) + 3u < st->imageTempSize) {
5988 uint32_t v = *(const uint32_t *)((const uint8_t *)st->imageTemp + (addr & UFO_ADDR_TEMP_MASK));
5989 ufoPush(v);
5990 } else {
5991 ufoFatal("invalid user area address");
5995 // MTASK:STATE-USER!
5996 // ( value addr stid -- )
5997 UFWORD(MT_STATE_USER_SET) {
5998 UfoState *st = ufoFindState(ufoPop());
5999 if (st == NULL) ufoFatal("unknown state");
6000 const uint32_t addr = ufoPop();
6001 const uint32_t value = ufoPop();
6002 if ((addr & UFO_ADDR_TEMP_BIT) != 0 && (addr & UFO_ADDR_TEMP_MASK) + 3u < st->imageTempSize) {
6003 *(uint32_t *)((const uint8_t *)st->imageTemp + (addr & UFO_ADDR_TEMP_MASK)) = value;
6004 } else {
6005 ufoFatal("invalid user area address");
6009 // MTASK:STATE-RPOPCFA@
6010 // ( -- flag )
6011 UFWORD(MT_STATE_RPOPCFA_GET) {
6012 UfoState *st = ufoFindState(ufoPop());
6013 if (st == NULL) ufoFatal("unknown state");
6014 ufoPush(st->vmRPopCFA);
6017 // MTASK:STATE-RPOPCFA!
6018 // ( flag -- )
6019 UFWORD(MT_STATE_RPOPCFA_SET) {
6020 UfoState *st = ufoFindState(ufoPop());
6021 if (st == NULL) ufoFatal("unknown state");
6022 st->vmRPopCFA = ufoPop();
6025 // MTASK:ACTIVE-STATE
6026 // ( -- stid )
6027 UFWORD(MT_ACTIVE_STATE) {
6028 ufoPush(ufoCurrState->id);
6031 // MTASK:YIELDED-FROM
6032 // ( -- stid / 0 )
6033 UFWORD(MT_YIELDED_FROM) {
6034 if (ufoYieldedState != NULL) {
6035 ufoPush(ufoYieldedState->id);
6036 } else {
6037 ufoPush(0);
6041 // MTASK:STATE-SP@
6042 // ( stid -- depth )
6043 UFWORD(MT_DSTACK_DEPTH_GET) {
6044 UfoState *st = ufoFindState(ufoPop());
6045 if (st == NULL) ufoFatal("unknown state");
6046 ufoPush(st->SP);
6049 // MTASK:STATE-RP@
6050 // ( stid -- depth )
6051 UFWORD(MT_RSTACK_DEPTH_GET) {
6052 UfoState *st = ufoFindState(ufoPop());
6053 if (st == NULL) ufoFatal("unknown state");
6054 ufoPush(st->RP - st->RPTop);
6057 // MTASK:STATE-LP@
6058 // ( stid -- lp )
6059 UFWORD(MT_LP_GET) {
6060 UfoState *st = ufoFindState(ufoPop());
6061 if (st == NULL) ufoFatal("unknown state");
6062 ufoPush(st->LP);
6065 // MTASK:STATE-LBP@
6066 // ( stid -- lbp )
6067 UFWORD(MT_LBP_GET) {
6068 UfoState *st = ufoFindState(ufoPop());
6069 if (st == NULL) ufoFatal("unknown state");
6070 ufoPush(st->LBP);
6073 // MTASK:STATE-SP!
6074 // ( depth stid -- )
6075 UFWORD(MT_DSTACK_DEPTH_SET) {
6076 UfoState *st = ufoFindState(ufoPop());
6077 if (st == NULL) ufoFatal("unknown state");
6078 const uint32_t idx = ufoPop();
6079 if (idx >= UFO_DSTACK_SIZE) ufoFatal("invalid stack index %u (%u)", idx, UFO_DSTACK_SIZE);
6080 st->SP = idx;
6083 // MTASK:STATE-RP!
6084 // ( depth stid -- )
6085 UFWORD(MT_RSTACK_DEPTH_SET) {
6086 UfoState *st = ufoFindState(ufoPop());
6087 if (st == NULL) ufoFatal("unknown state");
6088 const uint32_t idx = ufoPop();
6089 const uint32_t left = UFO_RSTACK_SIZE - st->RPTop;
6090 if (idx >= left) ufoFatal("invalid rstack index %u (%u)", idx, left);
6091 st->RP = st->RPTop + idx;
6094 // MTASK:STATE-LP!
6095 // ( lp stid -- )
6096 UFWORD(MT_LP_SET) {
6097 UfoState *st = ufoFindState(ufoPop());
6098 if (st == NULL) ufoFatal("unknown state");
6099 st->LP = ufoPop();
6102 // MTASK:STATE-LBP!
6103 // ( lbp stid -- )
6104 UFWORD(MT_LBP_SET) {
6105 UfoState *st = ufoFindState(ufoPop());
6106 if (st == NULL) ufoFatal("unknown state");
6107 st->LBP = ufoPop();
6110 // MTASK:STATE-DS@
6111 // ( idx stid -- value )
6112 UFWORD(MT_DSTACK_LOAD) {
6113 UfoState *st = ufoFindState(ufoPop());
6114 if (st == NULL) ufoFatal("unknown state");
6115 const uint32_t idx = ufoPop();
6116 if (idx >= st->SP) ufoFatal("invalid stack index %u (%u)", idx, st->SP);
6117 ufoPush(st->dStack[st->SP - idx - 1u]);
6120 // MTASK:STATE-RS@
6121 // ( idx stid -- value )
6122 UFWORD(MT_RSTACK_LOAD) {
6123 UfoState *st = ufoFindState(ufoPop());
6124 if (st == NULL) ufoFatal("unknown state");
6125 const uint32_t idx = ufoPop();
6126 if (idx >= st->RP - st->RPTop) ufoFatal("invalid stack index %u (%u)", idx, st->RP - st->RPTop);
6127 ufoPush(st->dStack[st->RP - idx - 1u]);
6130 // MTASK:STATE-LS@
6131 // ( idx stid -- value )
6132 UFWORD(MT_LSTACK_LOAD) {
6133 UfoState *st = ufoFindState(ufoPop());
6134 if (st == NULL) ufoFatal("unknown state");
6135 const uint32_t idx = ufoPop();
6136 if (idx >= st->LP) ufoFatal("invalid lstack index %u (%u)", idx, st->LP);
6137 ufoPush(st->lStack[st->LP - idx - 1u]);
6140 // MTASK:STATE-DS!
6141 // ( value idx stid -- )
6142 UFWORD(MT_DSTACK_STORE) {
6143 UfoState *st = ufoFindState(ufoPop());
6144 if (st == NULL) ufoFatal("unknown state");
6145 const uint32_t idx = ufoPop();
6146 const uint32_t value = ufoPop();
6147 if (idx >= st->SP) ufoFatal("invalid stack index %u (%u)", idx, st->SP);
6148 st->dStack[st->SP - idx - 1u] = value;
6151 // MTASK:STATE-RS!
6152 // ( value idx stid -- )
6153 UFWORD(MT_RSTACK_STORE) {
6154 UfoState *st = ufoFindState(ufoPop());
6155 if (st == NULL) ufoFatal("unknown state");
6156 const uint32_t idx = ufoPop();
6157 const uint32_t value = ufoPop();
6158 if (idx >= st->RP - st->RPTop) ufoFatal("invalid stack index %u (%u)", idx, st->RP - st->RPTop);
6159 st->dStack[st->RP - idx - 1u] = value;
6162 // MTASK:STATE-LS!
6163 // ( value idx stid -- )
6164 UFWORD(MT_LSTACK_STORE) {
6165 UfoState *st = ufoFindState(ufoPop());
6166 if (st == NULL) ufoFatal("unknown state");
6167 const uint32_t idx = ufoPop();
6168 const uint32_t value = ufoPop();
6169 if (idx >= st->LP) ufoFatal("invalid stack index %u (%u)", idx, st->LP);
6170 st->dStack[st->LP - idx - 1u] = value;
6174 #include "urforth_tty.c"
6177 // ////////////////////////////////////////////////////////////////////////// //
6178 // states
6181 //==========================================================================
6183 // ufoNewState
6185 // create a new state, its execution will start from the given CFA.
6186 // state is not automatically activated.
6188 //==========================================================================
6189 static UfoState *ufoNewState (void) {
6190 // find free state id
6191 uint32_t fidx = 0;
6192 uint32_t bmp = ufoStateUsedBitmap[0];
6193 while (fidx != (uint32_t)(UFO_MAX_STATES/32) && bmp == ~(uint32_t)0) {
6194 fidx += 1u;
6195 bmp = ufoStateUsedBitmap[fidx];
6197 if (fidx == (uint32_t)(UFO_MAX_STATES/32)) ufoFatal("too many execution states");
6198 //fprintf(stderr, "NST:000: fidx=%u; bmp=0x%08x\n", fidx, bmp);
6199 fidx *= 32u;
6200 while ((bmp & 0x01) != 0) { fidx += 1u; bmp >>= 1; }
6201 ufo_assert(fidx < UFO_MAX_STATES);
6202 ufo_assert((ufoStateUsedBitmap[fidx / 32u] & ((uint32_t)1 << (fidx & 0x1f))) == 0);
6203 ufo_assert(ufoStateMap[fidx] == NULL);
6204 UfoState *st = calloc(1, sizeof(UfoState));
6205 if (st == NULL) ufoFatal("out of memory for states");
6206 st->id = fidx + 1u;
6207 ufoStateMap[fidx] = st;
6208 ufoStateUsedBitmap[fidx / 32u] |= ((uint32_t)1 << (fidx & 0x1f));
6209 //fprintf(stderr, "NST: fidx=%u; 0x%08x\n", fidx, ufoStateUsedBitmap[fidx / 32u]);
6210 return st;
6214 //==========================================================================
6216 // ufoFreeState
6218 // free all memory used for the state, remove it from state list.
6219 // WARNING! never free current state!
6221 //==========================================================================
6222 static void ufoFreeState (UfoState *st) {
6223 if (st != NULL) {
6224 if (st == ufoCurrState) ufoFatal("cannot free active state");
6225 if (ufoYieldedState == st) ufoYieldedState = NULL;
6226 if (ufoDebuggerState == st) ufoDebuggerState = NULL;
6227 const uint32_t fidx = st->id - 1u;
6228 //fprintf(stderr, "FST: fidx=%u; 0x%08x\n", fidx, ufoStateUsedBitmap[fidx / 32u]);
6229 ufo_assert(fidx < UFO_MAX_STATES);
6230 ufo_assert((ufoStateUsedBitmap[fidx / 32u] & (1u << (fidx & 0x1f))) != 0);
6231 ufo_assert(ufoStateMap[fidx] == st);
6232 // free default TIB handle
6233 UfoState *oldst = ufoCurrState;
6234 ufoCurrState = st;
6235 const uint32_t tib = ufoImgGetU32(ufoAddrDefTIB);
6236 if ((tib & UFO_ADDR_TEMP_BIT) != 0) {
6237 UfoHandle *tibh = ufoGetHandle(tib);
6238 if (tibh != NULL) ufoFreeHandle(tibh);
6240 ufoCurrState = oldst;
6241 // free temp buffer
6242 if (st->imageTemp != NULL) free(st->imageTemp);
6243 free(st);
6244 ufoStateMap[fidx] = NULL;
6245 ufoStateUsedBitmap[fidx / 32u] &= ~((uint32_t)1 << (fidx & 0x1f));
6250 //==========================================================================
6252 // ufoFindState
6254 //==========================================================================
6255 static UfoState *ufoFindState (uint32_t stid) {
6256 UfoState *res = NULL;
6257 if (stid >= 0 && stid <= UFO_MAX_STATES) {
6258 if (stid == 0) {
6259 // current
6260 ufo_assert(ufoCurrState != NULL);
6261 stid = ufoCurrState->id - 1u;
6262 } else {
6263 stid -= 1u;
6265 res = ufoStateMap[stid];
6266 if (res != NULL) {
6267 ufo_assert((ufoStateUsedBitmap[stid / 32u] & (1u << (stid & 0x1f))) != 0);
6268 ufo_assert(res->id == stid + 1u);
6269 } else {
6270 ufo_assert((ufoStateUsedBitmap[stid / 32u] & (1u << (stid & 0x1f))) == 0);
6273 return res;
6277 //==========================================================================
6279 // ufoSwitchToState
6281 //==========================================================================
6282 static void ufoSwitchToState (UfoState *newst) {
6283 ufo_assert(newst != NULL);
6284 if (newst != ufoCurrState) {
6285 ufoCurrState = newst;
6291 // ////////////////////////////////////////////////////////////////////////// //
6292 // initial dictionary definitions
6295 #undef UFWORD
6297 #define UFWORD(name_) do { \
6298 const uint32_t xcfa_ = ufoCFAsUsed; \
6299 ufo_assert(xcfa_ < UFO_MAX_NATIVE_CFAS); \
6300 ufoForthCFAs[xcfa_] = &ufoWord_##name_; \
6301 ufoCFAsUsed += 1; \
6302 ufoDefineNative(""#name_, xcfa_, 0); \
6303 } while (0)
6305 #define UFWORDX(strname_,name_) do { \
6306 const uint32_t xcfa_ = ufoCFAsUsed; \
6307 ufo_assert(xcfa_ < UFO_MAX_NATIVE_CFAS); \
6308 ufoForthCFAs[xcfa_] = &ufoWord_##name_; \
6309 ufoCFAsUsed += 1; \
6310 ufoDefineNative(strname_, xcfa_, 0); \
6311 } while (0)
6313 #define UFWORD_IMM(name_) do { \
6314 const uint32_t xcfa_ = ufoCFAsUsed; \
6315 ufo_assert(xcfa_ < UFO_MAX_NATIVE_CFAS); \
6316 ufoForthCFAs[xcfa_] = &ufoWord_##name_; \
6317 ufoCFAsUsed += 1; \
6318 ufoDefineNative(""#name_, xcfa_, 1); \
6319 } while (0)
6321 #define UFWORDX_IMM(strname_,name_) do { \
6322 const uint32_t xcfa_ = ufoCFAsUsed; \
6323 ufo_assert(xcfa_ < UFO_MAX_NATIVE_CFAS); \
6324 ufoForthCFAs[xcfa_] = &ufoWord_##name_; \
6325 ufoCFAsUsed += 1; \
6326 ufoDefineNative(strname_, xcfa_, 1); \
6327 } while (0)
6329 #define UFC(name_) ufoImgEmitU32_NoInline(ufoFindWordChecked(name_))
6332 //==========================================================================
6334 // ufoFindWordChecked
6336 //==========================================================================
6337 UFO_DISABLE_INLINE uint32_t ufoFindWordChecked (const char *wname) {
6338 const uint32_t cfa = ufoFindWord(wname);
6339 if (cfa == 0) ufoFatal("word '%s' not found", wname);
6340 return cfa;
6344 //==========================================================================
6346 // ufoGetForthVocId
6348 // get "FORTH" vocid
6350 //==========================================================================
6351 uint32_t ufoGetForthVocId (void) {
6352 return ufoForthVocId;
6356 //==========================================================================
6358 // ufoVocSetOnlyDefs
6360 //==========================================================================
6361 void ufoVocSetOnlyDefs (uint32_t vocid) {
6362 ufoImgPutU32(ufoAddrCurrent, vocid);
6363 ufoImgPutU32(ufoAddrContext, vocid);
6367 //==========================================================================
6369 // ufoCreateVoc
6371 // return voc PFA (vocid)
6373 //==========================================================================
6374 uint32_t ufoCreateVoc (const char *wname, uint32_t parentvocid, uint32_t flags) {
6375 // create wordlist struct
6376 // typeid, used by Forth code (structs and such)
6377 ufoImgEmitU32(0); // typeid
6378 // vocid points here, to "LATEST-LFA"
6379 const uint32_t vocid = UFO_GET_DP();
6380 //fprintf(stderr, "NEW VOCID (%s): 0x%08x\n", wname, vocid);
6381 ufoImgEmitU32(0); // latest
6382 const uint32_t vlink = UFO_GET_DP();
6383 if ((vocid & UFO_ADDR_TEMP_BIT) == 0) {
6384 ufoImgEmitU32(ufoImgGetU32(ufoAddrVocLink)); // voclink
6385 ufoImgPutU32(ufoAddrVocLink, vlink); // update voclink
6386 } else {
6387 abort();
6388 ufoImgEmitU32(0);
6390 ufoImgEmitU32(parentvocid); // parent
6391 const uint32_t hdraddr = UFO_GET_DP();
6392 ufoImgEmitU32(0); // word header
6393 // create empty hash table
6394 for (int f = 0; f < UFO_HASHTABLE_SIZE; f += 1) ufoImgEmitU32(0);
6395 // update CONTEXT and CURRENT if this is the first wordlist ever
6396 if (ufoImgGetU32(ufoAddrContext) == 0) {
6397 ufoImgPutU32(ufoAddrContext, vocid);
6399 if (ufoImgGetU32(ufoAddrCurrent) == 0) {
6400 ufoImgPutU32(ufoAddrCurrent, vocid);
6402 // create word header
6403 if (wname != NULL && wname[0] != 0) {
6405 uint32_t flags = ufoImgGetU32(ufoAddrNewWordFlags);
6406 flags &=
6407 //UFW_FLAG_IMMEDIATE|
6408 //UFW_FLAG_SMUDGE|
6409 //UFW_FLAG_NORETURN|
6410 UFW_FLAG_HIDDEN|
6411 //UFW_FLAG_CBLOCK|
6412 //UFW_FLAG_VOCAB|
6413 //UFW_FLAG_SCOLON|
6414 UFW_FLAG_PROTECTED;
6415 flags |= UFW_FLAG_VOCAB;
6417 flags &= 0xffffff00u;
6418 flags |= UFW_FLAG_VOCAB;
6419 ufoCreateWordHeader(wname, flags);
6420 const uint32_t cfa = UFO_GET_DP();
6421 ufoImgEmitU32(ufoDoVocCFA); // cfa
6422 ufoImgEmitU32(vocid); // pfa
6423 // update vocab header pointer
6424 const uint32_t lfa = UFO_CFA_TO_LFA(cfa);
6425 ufoImgPutU32(hdraddr, UFO_LFA_TO_NFA(lfa));
6426 #ifdef UFO_DEBUG_DUMP_NEW_HEADERS
6427 ufoDumpWordHeader(lfa);
6428 #endif
6430 return vocid;
6434 //==========================================================================
6436 // ufoSetLatestArgs
6438 //==========================================================================
6439 static void ufoSetLatestArgs (uint32_t warg) {
6440 const uint32_t curr = ufoImgGetU32(ufoAddrCurrent);
6441 const uint32_t lfa = ufoImgGetU32(curr);
6442 const uint32_t nfa = UFO_LFA_TO_NFA(lfa);
6443 uint32_t flags = ufoImgGetU32(nfa);
6444 //fprintf(stderr, "OLD FLAGS: 0x%08x\n", flags);
6445 flags &= ~UFW_WARG_MASK;
6446 flags |= warg & UFW_WARG_MASK;
6447 //fprintf(stderr, "NEW FLAGS: 0x%08x\n", flags);
6448 ufoImgPutU32(nfa, flags);
6449 #ifdef UFO_DEBUG_DUMP_NEW_HEADERS
6450 ufoDumpWordHeader(lfa);
6451 #endif
6455 //==========================================================================
6457 // ufoDefine
6459 //==========================================================================
6460 static void ufoDefineNative (const char *wname, uint32_t cfaidx, int immed) {
6461 cfaidx |= UFO_ADDR_CFA_BIT;
6462 uint32_t flags = ufoImgGetU32(ufoAddrNewWordFlags);
6463 flags &=
6464 //UFW_FLAG_IMMEDIATE|
6465 //UFW_FLAG_SMUDGE|
6466 //UFW_FLAG_NORETURN|
6467 UFW_FLAG_HIDDEN|
6468 //UFW_FLAG_CBLOCK|
6469 //UFW_FLAG_VOCAB|
6470 //UFW_FLAG_SCOLON|
6471 UFW_FLAG_PROTECTED;
6472 if (immed) flags |= UFW_FLAG_IMMEDIATE;
6473 ufoCreateWordHeader(wname, flags);
6474 ufoImgEmitU32(cfaidx);
6478 //==========================================================================
6480 // ufoDefineConstant
6482 //==========================================================================
6483 static void ufoDefineConstant (const char *name, uint32_t value) {
6484 ufoDefineNative(name, ufoDoConstCFA, 0);
6485 ufoImgEmitU32(value);
6489 //==========================================================================
6491 // ufoDefineUserVar
6493 //==========================================================================
6494 static void ufoDefineUserVar (const char *name, uint32_t addr) {
6495 ufoDefineNative(name, ufoDoUserVariableCFA, 0);
6496 ufoImgEmitU32(addr);
6500 //==========================================================================
6502 // ufoDefineVar
6504 //==========================================================================
6506 static void ufoDefineVar (const char *name, uint32_t value) {
6507 ufoDefineNative(name, ufoDoVarCFA, 0);
6508 ufoImgEmitU32(value);
6513 //==========================================================================
6515 // ufoDefineDefer
6517 //==========================================================================
6519 static void ufoDefineDefer (const char *name, uint32_t value) {
6520 ufoDefineNative(name, ufoDoDeferCFA, 0);
6521 ufoImgEmitU32(value);
6526 //==========================================================================
6528 // ufoHiddenWords
6530 //==========================================================================
6531 static void ufoHiddenWords (void) {
6532 const uint32_t flags = ufoImgGetU32(ufoAddrNewWordFlags);
6533 ufoImgPutU32(ufoAddrNewWordFlags, flags | UFW_FLAG_HIDDEN);
6537 //==========================================================================
6539 // ufoPublicWords
6541 //==========================================================================
6542 static void ufoPublicWords (void) {
6543 const uint32_t flags = ufoImgGetU32(ufoAddrNewWordFlags);
6544 ufoImgPutU32(ufoAddrNewWordFlags, flags & ~UFW_FLAG_HIDDEN);
6548 //==========================================================================
6550 // ufoDefineForth
6552 //==========================================================================
6554 static void ufoDefineForth (const char *name) {
6555 ufoDefineNative(name, ufoDoForthCFA, 0);
6560 //==========================================================================
6562 // ufoDefineForthImm
6564 //==========================================================================
6566 static void ufoDefineForthImm (const char *name) {
6567 ufoDefineNative(name, ufoDoForthCFA, 1);
6572 //==========================================================================
6574 // ufoDefineForthHidden
6576 //==========================================================================
6578 static void ufoDefineForthHidden (const char *name) {
6579 const uint32_t flags = ufoImgGetU32(ufoAddrNewWordFlags);
6580 ufoImgPutU32(ufoAddrNewWordFlags, flags | UFW_FLAG_HIDDEN);
6581 ufoDefineNative(name, ufoDoForthCFA, 0);
6582 ufoImgPutU32(ufoAddrNewWordFlags, flags);
6587 //==========================================================================
6589 // ufoDefineSColonForth
6591 // create word suitable for scattered colon extension
6593 //==========================================================================
6594 static void ufoDefineSColonForth (const char *name) {
6595 ufoDefineNative(name, ufoDoForthCFA, 0);
6596 // placeholder for scattered colon
6597 // it will compile two branches:
6598 // the first branch will jump to the first "..:" word (or over the two branches)
6599 // the second branch is never taken, and works as a pointer to the latest branch addr in the list
6600 // this way, each extension word will simply fix the last branch address, and update list tail
6601 // at the creation time, second branch points to the first branch
6602 UFC("FORTH:(BRANCH)");
6603 const uint32_t xjmp = UFO_GET_DP();
6604 ufoImgEmitU32(0);
6605 UFC("FORTH:(BRANCH)"); ufoImgEmitU32(xjmp);
6606 ufoImgPutU32(xjmp, UFO_GET_DP());
6610 //==========================================================================
6612 // ufoDoneForth
6614 //==========================================================================
6615 UFO_FORCE_INLINE void ufoDoneForth (void) {
6616 UFC("FORTH:(EXIT)");
6620 //==========================================================================
6622 // ufoCompileStrLit
6624 // compile string literal, the same as QUOTE_IMM
6626 //==========================================================================
6627 static void ufoCompileStrLitEx (const char *str, const uint32_t slen) {
6628 if (str == NULL) str = "";
6629 if (slen > 255) ufoFatal("string literal too long");
6630 UFC("FORTH:(LITSTR8)");
6631 ufoImgEmitU8((uint8_t)slen);
6632 for (size_t f = 0; f < slen; f += 1) {
6633 ufoImgEmitU8(((const unsigned char *)str)[f]);
6635 ufoImgEmitU8(0);
6636 ufoImgEmitAlign();
6640 //==========================================================================
6642 // ufoCompileStrLit
6644 //==========================================================================
6646 static void ufoCompileStrLit (const char *str) {
6647 ufoCompileStrLitEx(str, (uint32_t)strlen(str));
6652 //==========================================================================
6654 // ufoCompileLit
6656 //==========================================================================
6657 static void ufoCompileLit (uint32_t value) {
6658 UFC("FORTH:(LIT)");
6659 ufoImgEmitU32(value);
6663 //==========================================================================
6665 // ufoCompileCFALit
6667 //==========================================================================
6669 static void ufoCompileCFALit (const char *wname) {
6670 UFC("FORTH:(LITCFA)");
6671 const uint32_t cfa = ufoFindWordChecked(wname);
6672 ufoImgEmitU32(cfa);
6677 //==========================================================================
6679 // ufoXStrEquCI
6681 //==========================================================================
6682 static int ufoXStrEquCI (const char *word, const char *text, uint32_t tlen) {
6683 while (tlen != 0 && *word) {
6684 if (toUpper(*word) != toUpper(*text)) return 0;
6685 word += 1u; text += 1u; tlen -= 1u;
6687 return (tlen == 0 && *word == 0);
6691 #define UFO_MAX_LABEL_NAME (63)
6692 typedef struct UfoLabel_t {
6693 uint32_t hash;
6694 uint32_t namelen;
6695 char name[UFO_MAX_LABEL_NAME];
6696 uint32_t addr; // jump chain tail, or address
6697 uint32_t defined;
6698 uint32_t word; // is this a forward word definition?
6699 struct UfoLabel_t *next;
6700 } UfoLabel;
6702 static UfoLabel *ufoLabels = NULL;
6705 //==========================================================================
6707 // ufoFindAddLabelEx
6709 //==========================================================================
6710 static UfoLabel *ufoFindAddLabelEx (const char *name, uint32_t namelen, int allowAdd) {
6711 if (namelen == 0 || namelen > UFO_MAX_LABEL_NAME) ufoFatal("invalid label name");
6712 const uint32_t hash = joaatHashBufCI(name, namelen);
6713 UfoLabel *lbl = ufoLabels;
6714 while (lbl != NULL) {
6715 if (lbl->hash == hash && lbl->namelen == namelen) {
6716 int ok = 1;
6717 uint32_t sidx = 0;
6718 while (ok && sidx != namelen) {
6719 ok = (toUpper(name[sidx]) == toUpper(lbl->name[sidx]));
6720 sidx += 1;
6722 if (ok) return lbl;
6724 lbl = lbl->next;
6726 if (allowAdd) {
6727 // create new label
6728 lbl = calloc(1, sizeof(UfoLabel));
6729 lbl->hash = hash;
6730 lbl->namelen = namelen;
6731 memcpy(lbl->name, name, namelen);
6732 lbl->name[namelen] = 0;
6733 lbl->next = ufoLabels;
6734 ufoLabels = lbl;
6735 return lbl;
6736 } else {
6737 return NULL;
6742 //==========================================================================
6744 // ufoFindAddLabel
6746 //==========================================================================
6747 static UfoLabel *ufoFindAddLabel (const char *name, uint32_t namelen) {
6748 return ufoFindAddLabelEx(name, namelen, 1);
6752 //==========================================================================
6754 // ufoFindLabel
6756 //==========================================================================
6757 static UfoLabel *ufoFindLabel (const char *name, uint32_t namelen) {
6758 return ufoFindAddLabelEx(name, namelen, 0);
6762 //==========================================================================
6764 // ufoTrySimpleNumber
6766 // only decimal and C-like hexes; with an optional sign
6768 //==========================================================================
6769 static int ufoTrySimpleNumber (const char *text, uint32_t tlen, uint32_t *num) {
6770 int neg = 0;
6772 if (tlen != 0 && *text == '+') { text += 1u; tlen -= 1u; }
6773 else if (tlen != 0 && *text == '-') { neg = 1; text += 1u; tlen -= 1u; }
6775 int base = 10; // default base
6776 if (tlen > 2 && text[0] == '0' && toUpper(text[1]) == 'X') {
6777 // hex
6778 base = 16;
6779 text += 2u; tlen -= 2u;
6782 if (tlen == 0 || digitInBase(*text, base) < 0) return 0;
6784 int wasDigit = 0;
6785 uint32_t n = 0;
6786 int dig;
6787 while (tlen != 0) {
6788 if (*text == '_') {
6789 if (!wasDigit) return 0;
6790 wasDigit = 0;
6791 } else {
6792 dig = digitInBase(*text, base);
6793 if (dig < 0) return 0;
6794 wasDigit = 1;
6795 n = n * (uint32_t)base + (uint32_t)dig;
6797 text += 1u; tlen -= 1u;
6800 if (!wasDigit) return 0;
6801 if (neg) n = ~n + 1u;
6802 *num = n;
6803 return 1;
6807 //==========================================================================
6809 // ufoEmitLabelChain
6811 //==========================================================================
6812 static void ufoEmitLabelChain (UfoLabel *lbl) {
6813 ufo_assert(lbl != NULL);
6814 ufo_assert(lbl->defined == 0);
6815 const uint32_t here = UFO_GET_DP();
6816 ufoImgEmitU32(lbl->addr);
6817 lbl->addr = here;
6821 //==========================================================================
6823 // ufoFixLabelChainHere
6825 //==========================================================================
6826 static void ufoFixLabelChainHere (UfoLabel *lbl) {
6827 ufo_assert(lbl != NULL);
6828 ufo_assert(lbl->defined == 0);
6829 const uint32_t here = UFO_GET_DP();
6830 while (lbl->addr != 0) {
6831 const uint32_t aprev = ufoImgGetU32(lbl->addr);
6832 ufoImgPutU32(lbl->addr, here);
6833 lbl->addr = aprev;
6835 lbl->addr = here;
6836 lbl->defined = 1;
6840 #define UFO_MII_WORD_COMPILE_IMM (-4)
6841 #define UFO_MII_WORD_CFA_LIT (-3)
6842 #define UFO_MII_WORD_COMPILE (-2)
6843 #define UFO_MII_IN_WORD (-1)
6844 #define UFO_MII_NO_WORD (0)
6845 #define UFO_MII_WORD_NAME (1)
6846 #define UFO_MII_WORD_NAME_IMM (2)
6847 #define UFO_MII_WORD_NAME_HIDDEN (3)
6849 static int ufoMinInterpState = UFO_MII_NO_WORD;
6852 //==========================================================================
6854 // ufoFinalLabelCheck
6856 //==========================================================================
6857 static void ufoFinalLabelCheck (void) {
6858 int errorCount = 0;
6859 if (ufoMinInterpState != UFO_MII_NO_WORD) {
6860 ufoFatal("missing semicolon");
6862 while (ufoLabels != NULL) {
6863 UfoLabel *lbl = ufoLabels; ufoLabels = lbl->next;
6864 if (!lbl->defined) {
6865 fprintf(stderr, "UFO ERROR: label '%s' is not defined!\n", lbl->name);
6866 errorCount += 1;
6868 free(lbl);
6870 if (errorCount != 0) {
6871 ufoFatal("%d undefined label%s", errorCount, (errorCount != 1 ? "s" : ""));
6876 //==========================================================================
6878 // ufoInterpretLine
6880 // this is so i could write Forth definitions more easily
6882 // labels:
6883 // $name -- reference
6884 // $name: -- definition
6886 //==========================================================================
6887 UFO_DISABLE_INLINE void ufoInterpretLine (const char *line) {
6888 char wname[UFO_MAX_WORD_LENGTH];
6889 uint32_t wlen, num, cfa;
6890 UfoLabel *lbl;
6891 while (*line) {
6892 if (*(const unsigned char *)line <= 32) {
6893 line += 1;
6894 } else if (ufoMinInterpState == UFO_MII_WORD_CFA_LIT ||
6895 ufoMinInterpState == UFO_MII_WORD_COMPILE ||
6896 ufoMinInterpState == UFO_MII_WORD_COMPILE_IMM)
6898 // "[']"/"COMPILE"/"[COMPILE]" argument
6899 wlen = 1;
6900 while (((const unsigned char *)line)[wlen] > 32) wlen += 1;
6901 if (wlen >= UFO_MAX_WORD_LENGTH) ufoFatal("word name too long");
6902 memcpy(wname, line, wlen);
6903 wname[wlen] = 0;
6904 switch (ufoMinInterpState) {
6905 case UFO_MII_WORD_CFA_LIT: UFC("FORTH:(LITCFA)"); break;
6906 case UFO_MII_WORD_COMPILE: UFC("FORTH:(LITCFA)"); break;
6907 case UFO_MII_WORD_COMPILE_IMM: break;
6908 default: ufo_assert(0);
6910 cfa = ufoFindWord(wname);
6911 if (cfa != 0) {
6912 ufoImgEmitU32(cfa);
6913 } else {
6914 // forward reference
6915 lbl = ufoFindAddLabel(line, wlen);
6916 if (lbl->defined || (lbl->word == 0 && lbl->addr)) {
6917 ufoFatal("unknown word: '%s'", wname);
6919 lbl->word = 1;
6920 ufoEmitLabelChain(lbl);
6922 switch (ufoMinInterpState) {
6923 case UFO_MII_WORD_CFA_LIT: break;
6924 case UFO_MII_WORD_COMPILE: UFC("FORTH:COMPILE,"); break;
6925 case UFO_MII_WORD_COMPILE_IMM: break;
6926 default: ufo_assert(0);
6928 ufoMinInterpState = UFO_MII_IN_WORD;
6929 line += wlen;
6930 } else if (ufoMinInterpState > UFO_MII_NO_WORD) {
6931 // new word
6932 wlen = 1;
6933 while (((const unsigned char *)line)[wlen] > 32) wlen += 1;
6934 if (wlen >= UFO_MAX_WORD_LENGTH) ufoFatal("word name too long");
6935 if (wlen > 2 && line[0] == ':' && line[wlen - 1u] == ':') ufoFatal("invalid word name");
6936 memcpy(wname, line, wlen);
6937 wname[wlen] = 0;
6938 const uint32_t oldFlags = ufoImgGetU32(ufoAddrNewWordFlags);
6939 if (ufoMinInterpState == UFO_MII_WORD_NAME_HIDDEN) {
6940 ufoImgPutU32(ufoAddrNewWordFlags, oldFlags | UFW_FLAG_HIDDEN);
6942 ufoDefineNative(wname, ufoDoForthCFA, (ufoMinInterpState == UFO_MII_WORD_NAME_IMM));
6943 ufoImgPutU32(ufoAddrNewWordFlags, oldFlags);
6944 ufoMinInterpState = UFO_MII_IN_WORD;
6945 // check for forward references
6946 lbl = ufoFindLabel(line, wlen);
6947 if (lbl != NULL) {
6948 if (lbl->defined || !lbl->word) {
6949 ufoFatal("label/word conflict for '%.*s'", (unsigned)wlen, line);
6951 ufoFixLabelChainHere(lbl);
6953 line += wlen;
6954 } else if ((line[0] == ';' && line[1] == ';') ||
6955 (line[0] == '-' && line[1] == '-') ||
6956 (line[0] == '/' && line[1] == '/') ||
6957 (line[0] == '\\' && ((const unsigned char *)line)[1] <= 32))
6959 ufoFatal("do not use single-line comments");
6960 } else if (line[0] == '(' && ((const unsigned char *)line)[1] <= 32) {
6961 while (*line && *line != ')') line += 1;
6962 if (*line == ')') line += 1;
6963 } else {
6964 // word
6965 wlen = 1;
6966 while (((const unsigned char *)line)[wlen] > 32) wlen += 1;
6967 if (wlen == 1 && (line[0] == '"' || line[0] == '`')) {
6968 // string literal
6969 const char qch = line[0];
6970 if (!line[1]) ufoFatal("unterminated string literal");
6971 // skip quote and space
6972 if (((const unsigned char *)line)[1] <= 32) line += 2u; else line += 1u;
6973 wlen = 0;
6974 while (line[wlen] && line[wlen] != qch) wlen += 1u;
6975 if (line[wlen] != qch) ufoFatal("unterminated string literal");
6976 ufoCompileStrLitEx(line, wlen);
6977 line += wlen + 1u; // skip final quote
6978 } else if (wlen == 1 && line[0] == ':') {
6979 // new word
6980 if (ufoMinInterpState != UFO_MII_NO_WORD) ufoFatal("unexpected colon");
6981 ufoMinInterpState = UFO_MII_WORD_NAME;
6982 line += wlen;
6983 } else if (wlen == 1 && line[0] == ';') {
6984 // end word
6985 if (ufoMinInterpState != UFO_MII_IN_WORD) ufoFatal("unexpected semicolon");
6986 ufoImgEmitU32(ufoFindWordChecked("FORTH:(EXIT)"));
6987 ufoMinInterpState = UFO_MII_NO_WORD;
6988 line += wlen;
6989 } else if (wlen == 2 && line[0] == '!' && line[1] == ':') {
6990 // new immediate word
6991 if (ufoMinInterpState != UFO_MII_NO_WORD) ufoFatal("unexpected colon");
6992 ufoMinInterpState = UFO_MII_WORD_NAME_IMM;
6993 line += wlen;
6994 } else if (wlen == 2 && line[0] == '*' && line[1] == ':') {
6995 // new hidden word
6996 if (ufoMinInterpState != UFO_MII_NO_WORD) ufoFatal("unexpected colon");
6997 ufoMinInterpState = UFO_MII_WORD_NAME_HIDDEN;
6998 line += wlen;
6999 } else if (wlen == 3 && memcmp(line, "[']", 3) == 0) {
7000 // cfa literal
7001 if (ufoMinInterpState != UFO_MII_IN_WORD) ufoFatal("unexpected immediate tick");
7002 ufoMinInterpState = UFO_MII_WORD_CFA_LIT;
7003 line += wlen;
7004 } else if (wlen == 7 && ufoXStrEquCI("COMPILE", line, wlen)) {
7005 // "COMPILE"
7006 if (ufoMinInterpState != UFO_MII_IN_WORD) ufoFatal("unexpected immediate tick");
7007 ufoMinInterpState = UFO_MII_WORD_COMPILE;
7008 line += wlen;
7009 } else if (wlen == 9 && ufoXStrEquCI("[COMPILE]", line, wlen)) {
7010 // "[COMPILE]"
7011 if (ufoMinInterpState != UFO_MII_IN_WORD) ufoFatal("unexpected immediate tick");
7012 ufoMinInterpState = UFO_MII_WORD_COMPILE_IMM;
7013 line += wlen;
7014 } else {
7015 // look for a word
7016 if (wlen >= UFO_MAX_WORD_LENGTH) ufoFatal("word name too long");
7017 memcpy(wname, line, wlen);
7018 wname[wlen] = 0;
7019 cfa = ufoFindWord(wname);
7020 if (cfa != 0) {
7021 // compile word
7022 ufoImgEmitU32(cfa);
7023 } else if (ufoTrySimpleNumber(line, wlen, &num)) {
7024 // compile numeric literal
7025 ufoCompileLit(num);
7026 } else {
7027 // unknown word, this may be a forward reference, or a label definition
7028 // label defintion starts with "$"
7029 // (there are no words starting with "$" in the initial image)
7030 if (line[0] == '$') {
7031 if (wlen == 1) ufoFatal("dollar what?");
7032 if (wlen > 2 && line[wlen - 1u] == ':') {
7033 // label definition
7034 lbl = ufoFindAddLabel(line, wlen - 1u);
7035 if (lbl->defined) ufoFatal("double label '%s' definition", lbl->name);
7036 ufoFixLabelChainHere(lbl);
7037 } else {
7038 // label reference
7039 lbl = ufoFindAddLabel(line, wlen);
7040 if (lbl->defined) {
7041 ufoImgEmitU32(lbl->addr);
7042 } else {
7043 ufoEmitLabelChain(lbl);
7046 } else {
7047 // forward reference
7048 lbl = ufoFindAddLabel(line, wlen);
7049 if (lbl->defined || (lbl->word == 0 && lbl->addr)) {
7050 ufoFatal("unknown word: '%s'", wname);
7052 lbl->word = 1;
7053 ufoEmitLabelChain(lbl);
7056 line += wlen;
7063 //==========================================================================
7065 // ufoReset
7067 //==========================================================================
7068 UFO_DISABLE_INLINE void ufoReset (void) {
7069 if (ufoCurrState == NULL) ufoFatal("no active execution state");
7071 ufoSP = 0; ufoRP = 0;
7072 ufoLP = 0; ufoLBP = 0;
7074 ufoInRunWord = 0;
7075 ufoVMStop = 0; ufoVMAbort = 0;
7077 ufoInBacktrace = 0;
7079 // save TIB
7080 const uint32_t tib = ufoImgGetU32(ufoAddrTIBx);
7081 const uint32_t tibDef = ufoImgGetU32(ufoAddrDefTIB);
7082 ufoInitStateUserVars(ufoCurrState, 0);
7083 // restore TIB
7084 ufoImgPutU32(ufoAddrTIBx, tib);
7085 ufoImgPutU32(ufoAddrDefTIB, tibDef);
7086 ufoImgPutU32(ufoAddrRedefineWarning, UFO_REDEF_WARN_NORMAL);
7087 ufoResetTib();
7089 ufoImgPutU32(ufoAddrDPTemp, 0);
7091 ufoImgPutU32(ufoAddrNewWordFlags, 0);
7092 ufoVocSetOnlyDefs(ufoForthVocId);
7096 //==========================================================================
7098 // ufoDefineEmitType
7100 //==========================================================================
7101 UFO_DISABLE_INLINE void ufoDefineEmitType (void) {
7102 // EMIT
7103 // ( ch -- )
7104 ufoInterpretLine(": EMIT ( ch -- ) (NORM-EMIT-CHAR) (EMIT) ;");
7106 // XEMIT
7107 // ( ch -- )
7108 ufoInterpretLine(": XEMIT ( ch -- ) (NORM-XEMIT-CHAR) (EMIT) ;");
7110 // CR
7111 // ( -- )
7112 ufoInterpretLine(": CR ( -- ) NL (EMIT) ;");
7114 // ENDCR
7115 // ( -- )
7116 ufoInterpretLine(
7117 ": ENDCR ( -- ) "
7118 " LASTCR? FORTH:(TBRANCH) $endcr-exit CR "
7119 "$endcr-exit: "
7120 ";");
7121 //ufoDecompileWord(ufoFindWordChecked("ENDCR"));
7123 // SPACE
7124 // ( -- )
7125 ufoInterpretLine(": SPACE ( -- ) BL (EMIT) ;");
7127 // SPACES
7128 // ( count -- )
7129 ufoInterpretLine(
7130 ": SPACES ( count -- ) "
7131 "$spaces-again: "
7132 " DUP 0> FORTH:(0BRANCH) $spaces-exit "
7133 " SPACE 1- "
7134 " FORTH:(BRANCH) $spaces-again "
7135 "$spaces-exit: "
7136 " DROP "
7137 ";");
7139 // TYPE
7140 // ( addr count -- )
7141 ufoInterpretLine(
7142 ": TYPE ( addr count -- ) "
7143 " A>R SWAP >A "
7144 "$type-again: "
7145 " DUP 0> FORTH:(0BRANCH) $type-exit "
7146 " C@A EMIT +1>A "
7147 " 1- "
7148 " FORTH:(BRANCH) $type-again "
7149 "$type-exit: "
7150 " DROP R>A "
7151 ";");
7153 // XTYPE
7154 // ( addr count -- )
7155 ufoInterpretLine(
7156 ": XTYPE ( addr count -- ) "
7157 " A>R SWAP >A "
7158 "$xtype-again: "
7159 " DUP 0> FORTH:(0BRANCH) $xtype-exit "
7160 " C@A XEMIT +1>A "
7161 " 1- "
7162 " FORTH:(BRANCH) $xtype-again "
7163 "$xtype-exit: "
7164 " DROP R>A "
7165 ";");
7167 // HERE
7168 // ( -- here )
7169 ufoInterpretLine(
7170 ": HERE ( -- here ) "
7171 " FORTH:(DP-TEMP) @ ?DUP "
7172 " FORTH:(TBRANCH) $here-exit "
7173 " FORTH:(DP) @ "
7174 "$here-exit: "
7175 ";");
7177 // ALIGN-HERE
7178 // ( -- )
7179 ufoInterpretLine(
7180 ": ALIGN-HERE ( -- ) "
7181 "$align-here-loop: "
7182 " HERE 3 AND "
7183 " FORTH:(0BRANCH) $align-here-exit "
7184 " 0 C, "
7185 " FORTH:(BRANCH) $align-here-loop "
7186 "$align-here-exit: "
7187 ";");
7189 // STRLITERAL
7190 // ( C:addr count -- ) ( E: -- addr count )
7191 ufoInterpretLine(
7192 ": STRLITERAL ( C:addr count -- ) ( E: -- addr count ) "
7193 " DUP 255 U> ` string literal too long` ?ERROR "
7194 " STATE @ FORTH:(0BRANCH) $strlit-exit "
7195 " ( addr count ) "
7196 " ['] FORTH:(LITSTR8) COMPILE, "
7197 " A>R SWAP >A "
7198 " ( compile length ) "
7199 " DUP C, "
7200 " ( compile chars ) "
7201 "$strlit-loop: "
7202 " DUP 0<> FORTH:(0BRANCH) $strlit-loop-exit "
7203 " C@A C, +1>A 1- "
7204 " FORTH:(BRANCH) $strlit-loop "
7205 "$strlit-loop-exit: "
7206 " R>A "
7207 " ( final 0: our counter is 0 here, so use it ) "
7208 " C, ALIGN-HERE "
7209 "$strlit-exit: "
7210 ";");
7212 // quote
7213 // ( -- addr count )
7214 ufoInterpretLine(
7215 "!: \" ( -- addr count ) "
7216 " 34 PARSE ` string literal expected` ?NOT-ERROR "
7217 " COMPILER:(UNESCAPE) STRLITERAL "
7218 ";");
7222 //==========================================================================
7224 // ufoDefineInterpret
7226 // define "INTERPRET" in Forth
7228 //==========================================================================
7229 UFO_DISABLE_INLINE void ufoDefineInterpret (void) {
7230 UFWORDX("(UFO-INTERPRET-FINISHED-ACTION)", UFO_INTERPRET_FINISHED_ACTION);
7232 // return "stop flag"
7233 ufoInterpretLine(
7234 "*: (UFO-INTERPRET-NEXT-LINE) ( -- continue? ) "
7235 " STATE @ FORTH:(TBRANCH) $ipn_incomp "
7236 " ( interpreter allowed to cross include boundary ) "
7237 " REFILL FORTH:(BRANCH) $ipn_done "
7238 "$ipn_incomp: "
7239 " ( compiler is not allowed to cross include boundary ) "
7240 " REFILL-NOCROSS ` compiler cannot cross file boundaries` ?NOT-ERROR "
7241 " TRUE "
7242 "$ipn_done: "
7243 ";");
7245 ufoInterpNextLineCFA = ufoFindWordChecked("FORTH:(UFO-INTERPRET-NEXT-LINE)");
7246 ufoInterpretLine("*: (INTERPRET-NEXT-LINE) (USER-INTERPRET-NEXT-LINE) @ EXECUTE-TAIL ;");
7248 // skip comments, parse name, refilling lines if necessary
7249 // returning FALSE as counter means: "no addr, exit INTERPRET"
7250 ufoInterpretLine(
7251 "*: (INTERPRET-PARSE-NAME) ( -- addr count / FALSE ) "
7252 "$label_ipn_again: "
7253 " TRUE (PARSE-SKIP-COMMENTS) PARSE-NAME "
7254 " DUP FORTH:(TBRANCH) $label_ipn_exit_fwd "
7255 " 2DROP (INTERPRET-NEXT-LINE) "
7256 " FORTH:(TBRANCH) $label_ipn_again "
7257 " FALSE "
7258 "$label_ipn_exit_fwd: "
7259 ";");
7260 //ufoDecompileWord(ufoFindWordChecked("(INTERPRET-PARSE-NAME)"));
7262 ufoInterpretLine(
7263 ": INTERPRET "
7264 "$interp-again: "
7265 " FORTH:(INTERPRET-PARSE-NAME) ( addr count / FALSE )"
7266 " ?DUP FORTH:(0BRANCH) $interp-done "
7267 " ( try defered checker ) "
7268 " ( addr count FALSE -- addr count FALSE / TRUE ) "
7269 " FALSE (INTERPRET-CHECK-WORD) FORTH:(TBRANCH) $interp-again "
7270 " 2DUP FIND-WORD ( addr count cfa TRUE / addr count FALSE ) "
7271 " FORTH:(0BRANCH) $interp-try-number "
7272 " ( word found ) "
7273 " NROT 2DROP ( drop word string ) "
7274 " STATE @ FORTH:(0BRANCH) $interp-exec "
7275 " ( compiling; check immediate bit ) "
7276 " DUP CFA->NFA @ COMPILER:(WFLAG-IMMEDIATE) AND FORTH:(TBRANCH) $interp-exec "
7277 " ( compile it ) "
7278 " FORTH:COMPILE, FORTH:(BRANCH) $interp-again "
7279 " ( execute it ) "
7280 "$interp-exec: "
7281 " EXECUTE FORTH:(BRANCH) $interp-again "
7282 " ( not a word, try a number ) "
7283 "$interp-try-number: "
7284 " 2DUP TRUE BASE @ (BASED-NUMBER) ( addr count allowsign? base -- num TRUE / FALSE ) "
7285 " FORTH:(0BRANCH) $interp-number-error "
7286 " ( number ) "
7287 " NROT 2DROP ( drop word string ) "
7288 " ( do we need to compile it? ) "
7289 " STATE @ FORTH:(0BRANCH) $interp-again "
7290 " COMPILE FORTH:(LIT) FORTH:, "
7291 " FORTH:(BRANCH) $interp-again "
7292 " ( error ) "
7293 "$interp-number-error: "
7294 " ( addr count FALSE -- addr count FALSE / TRUE ) "
7295 " FALSE (INTERPRET-WORD-NOT-FOUND) FORTH:(TBRANCH) $interp-again "
7296 " ENDCR SPACE XTYPE ` -- wut?` TYPE CR "
7297 " ` unknown word` ERROR "
7298 "$interp-done: "
7299 ";");
7300 //ufoDecompileWord(ufoFindWordChecked("INTERPRET"));
7304 //==========================================================================
7306 // ufoInitBaseDict
7308 //==========================================================================
7309 UFO_DISABLE_INLINE void ufoInitBaseDict (void) {
7310 uint32_t imgAddr = 0;
7312 // reserve 32 bytes for nothing
7313 for (uint32_t f = 0; f < 32; f += 1) {
7314 ufoImgPutU8(imgAddr, 0);
7315 imgAddr += 1;
7317 // align
7318 while ((imgAddr & 3) != 0) {
7319 ufoImgPutU8(imgAddr, 0);
7320 imgAddr += 1;
7323 // DP
7324 ufoAddrDP = imgAddr;
7325 ufoImgPutU32(imgAddr, 0); imgAddr += 4u;
7327 // DP-TEMP
7328 ufoAddrDPTemp = imgAddr;
7329 ufoImgPutU32(imgAddr, 0); imgAddr += 4u;
7331 // (LATEST-XFA)
7332 ufoAddrLastXFA = imgAddr;
7333 ufoImgPutU32(imgAddr, 0); imgAddr += 4u;
7335 // (VOC-LINK)
7336 ufoAddrVocLink = imgAddr;
7337 ufoImgPutU32(imgAddr, 0); imgAddr += 4u;
7339 // (NEW-WORD-FLAGS)
7340 ufoAddrNewWordFlags = imgAddr;
7341 ufoImgPutU32(imgAddr, UFW_FLAG_PROTECTED); imgAddr += 4u;
7343 // WORD-REDEFINE-WARN-MODE
7344 ufoAddrRedefineWarning = imgAddr;
7345 ufoImgPutU32(imgAddr, UFO_REDEF_WARN_NORMAL); imgAddr += 4u;
7347 // setup (DP) and (DP-TEMP)
7348 ufoImgPutU32(ufoAddrDP, imgAddr);
7349 ufoImgPutU32(ufoAddrDPTemp, 0);
7351 #if 0
7352 fprintf(stderr, "INITIAL HERE: 0x%08x (0x%08x)\n", imgAddr, UFO_GET_DP());
7353 #endif
7357 //==========================================================================
7359 // ufoInitStateUserVars
7361 //==========================================================================
7362 static void ufoInitStateUserVars (UfoState *st, uint32_t cfa) {
7363 ufo_assert(st != NULL);
7364 if (st->imageTempSize < 8192u) {
7365 uint32_t *itmp = realloc(st->imageTemp, 8192);
7366 if (itmp == NULL) ufoFatal("out of memory for state user area");
7367 st->imageTemp = itmp;
7368 memset((uint8_t *)st->imageTemp + st->imageTempSize, 0, 8192u - st->imageTempSize);
7369 st->imageTempSize = 8192;
7371 st->imageTemp[(ufoAddrBASE & UFO_ADDR_TEMP_MASK) / 4u] = 10;
7372 st->imageTemp[(ufoAddrSTATE & UFO_ADDR_TEMP_MASK) / 4u] = 0;
7373 st->imageTemp[(ufoAddrUserVarUsed & UFO_ADDR_TEMP_MASK) / 4u] = ufoAddrUserVarUsed;
7374 st->imageTemp[(ufoAddrDefTIB & UFO_ADDR_TEMP_MASK) / 4u] = UFO_DEF_TIB_ADDR;
7375 st->imageTemp[(ufoAddrTIBx & UFO_ADDR_TEMP_MASK) / 4u] = UFO_DEF_TIB_ADDR;
7376 st->imageTemp[(ufoAddrINx & UFO_ADDR_TEMP_MASK) / 4u] = 0;
7377 st->imageTemp[(ufoAddrContext & UFO_ADDR_TEMP_MASK) / 4u] = ufoForthVocId;
7378 st->imageTemp[(ufoAddrCurrent & UFO_ADDR_TEMP_MASK) / 4u] = ufoForthVocId;
7379 st->imageTemp[(ufoAddrSelf & UFO_ADDR_TEMP_MASK) / 4u] = 0;
7380 st->imageTemp[(ufoAddrInterNextLine & UFO_ADDR_TEMP_MASK) / 4u] = ufoInterpNextLineCFA;
7381 st->imageTemp[(ufoAddrEP & UFO_ADDR_TEMP_MASK) / 4u] = 0;
7382 // init other things, because this procedure is used in `ufoReset()` too
7383 st->SP = 0; st->RP = 0; st->RPTop = 0; st->regA = 0;
7384 st->LP = 0; st->LBP = 0; st->vmRPopCFA = 0;
7385 st->VSP = 0;
7386 // init it
7387 if (cfa != 0) {
7388 st->vmRPopCFA = 1;
7389 st->rStack[0] = 0xdeadf00d; // dummy value
7390 st->rStack[1] = cfa;
7391 st->RP = 2;
7396 //==========================================================================
7398 // ufoInitBasicWords
7400 //==========================================================================
7401 UFO_DISABLE_INLINE void ufoInitBasicWords (void) {
7402 ufoDefineConstant("FALSE", 0);
7403 ufoDefineConstant("TRUE", ufoTrueValue);
7405 ufoDefineConstant("BL", 32);
7406 ufoDefineConstant("NL", 10);
7408 // user variables
7409 ufoDefineUserVar("BASE", ufoAddrBASE);
7410 ufoDefineUserVar("TIB", ufoAddrTIBx);
7411 ufoDefineUserVar(">IN", ufoAddrINx);
7412 ufoDefineUserVar("(STD-TIB-ADDR)", ufoAddrDefTIB);
7413 ufoDefineUserVar("(USER-VAR-USED)", ufoAddrUserVarUsed);
7414 ufoDefineConstant("(USER-VAR-ADDR)", UFO_ADDR_TEMP_BIT);
7415 ufoDefineConstant("(USER-VAR-SIZE)", UFO_USER_AREA_SIZE);
7416 ufoDefineConstant("(USER-TIB)", UFO_DEF_TIB_ADDR);
7417 ufoDefineConstant("(USER-TIB-SIZE)", UFO_ADDR_HANDLE_OFS_MASK);
7419 ufoDefineUserVar("STATE", ufoAddrSTATE);
7420 ufoDefineConstant("CONTEXT", ufoAddrContext);
7421 ufoDefineConstant("CURRENT", ufoAddrCurrent);
7422 ufoDefineConstant("(SELF)", ufoAddrSelf); // used in OOP implementations
7423 ufoDefineConstant("(USER-INTERPRET-NEXT-LINE)", ufoAddrInterNextLine);
7424 ufoDefineConstant("(EXC-FRAME-PTR)", ufoAddrEP);
7426 ufoHiddenWords();
7427 ufoDefineConstant("(LATEST-XFA)", ufoAddrLastXFA);
7428 ufoDefineConstant("(VOC-LINK)", ufoAddrVocLink);
7429 ufoDefineConstant("(NEW-WORD-FLAGS)", ufoAddrNewWordFlags);
7430 ufoDefineConstant("(ADDR-TEMP-BIT)", UFO_ADDR_TEMP_BIT);
7431 ufoDefineConstant("(ADDR-CFA-BIT)", UFO_ADDR_CFA_BIT);
7432 ufoDefineConstant("(ADDR-HANDLE-BIT)", UFO_ADDR_HANDLE_BIT);
7433 ufoDefineConstant("(MAX-HANDLE-OFS)", UFO_ADDR_HANDLE_OFS_MASK);
7435 ufoDefineConstant("(PAD-ADDR)", UFO_PAD_ADDR);
7436 ufoDefineConstant("(#BUF)", UFO_NBUF_ADDR + 4u); // reserve room for counter
7437 ufoDefineConstant("(#BUF-SIZE)", UFO_NBUF_SIZE - 8u);
7439 ufoDefineConstant("(DP)", ufoAddrDP);
7440 ufoDefineConstant("(DP-TEMP)", ufoAddrDPTemp);
7441 ufoPublicWords();
7443 //UFWORDX("(UFO-BUCKET-STATS)", PAR_UFO_BUCKET_STATS);
7444 UFWORDX("SP0!", SP0_STORE);
7445 UFWORDX("RP0!", RP0_STORE);
7447 UFWORDX("PAD", PAD);
7449 UFWORDX("@", PEEK);
7450 UFWORDX("C@", CPEEK);
7451 UFWORDX("W@", WPEEK);
7453 UFWORDX("!", POKE);
7454 UFWORDX("C!", CPOKE);
7455 UFWORDX("W!", WPOKE);
7457 UFWORDX(",", COMMA);
7458 UFWORDX("C,", CCOMMA);
7459 UFWORDX("W,", WCOMMA);
7461 UFWORDX("A>", REGA_LOAD);
7462 UFWORDX(">A", REGA_STORE);
7463 UFWORDX("A-SWAP", REGA_SWAP);
7464 UFWORDX("+1>A", REGA_INC);
7465 UFWORDX("+4>A", REGA_INC_CELL);
7466 UFWORDX("A>R", REGA_TO_R);
7467 UFWORDX("R>A", R_TO_REGA);
7469 UFWORDX("@A+", PEEK_REGA_IDX);
7470 UFWORDX("C@A+", CPEEK_REGA_IDX);
7471 UFWORDX("W@A+", WPEEK_REGA_IDX);
7473 UFWORDX("!A+", POKE_REGA_IDX);
7474 UFWORDX("C!A+", CPOKE_REGA_IDX);
7475 UFWORDX("W!A+", WPOKE_REGA_IDX);
7477 ufoHiddenWords();
7478 UFWORDX("(LIT)", PAR_LIT); ufoSetLatestArgs(UFW_WARG_LIT);
7479 UFWORDX("(LITCFA)", PAR_LITCFA); ufoSetLatestArgs(UFW_WARG_CFA);
7480 UFWORDX("(LITVOCID)", PAR_LITVOCID); ufoSetLatestArgs(UFW_WARG_VOCID);
7481 UFWORDX("(LITSTR8)", PAR_LITSTR8); ufoSetLatestArgs(UFW_WARG_C1STRZ);
7482 UFWORDX("(EXIT)", PAR_EXIT);
7484 ufoLitStr8CFA = ufoFindWordChecked("FORTH:(LITSTR8)");
7486 UFWORDX("(L-ENTER)", PAR_LENTER); ufoSetLatestArgs(UFW_WARG_LIT);
7487 UFWORDX("(L-LEAVE)", PAR_LLEAVE);
7488 UFWORDX("(LOCAL@)", PAR_LOCAL_LOAD);
7489 UFWORDX("(LOCAL!)", PAR_LOCAL_STORE);
7491 UFWORDX("(BRANCH)", PAR_BRANCH); ufoSetLatestArgs(UFW_WARG_BRANCH);
7492 UFWORDX("(TBRANCH)", PAR_TBRANCH); ufoSetLatestArgs(UFW_WARG_BRANCH);
7493 UFWORDX("(0BRANCH)", PAR_0BRANCH); ufoSetLatestArgs(UFW_WARG_BRANCH);
7494 UFWORDX("(+0BRANCH)", PAR_P0BRANCH); ufoSetLatestArgs(UFW_WARG_BRANCH);
7495 UFWORDX("(+BRANCH)", PAR_PBRANCH); ufoSetLatestArgs(UFW_WARG_BRANCH);
7496 UFWORDX("(-0BRANCH)", PAR_M0BRANCH); ufoSetLatestArgs(UFW_WARG_BRANCH);
7497 UFWORDX("(-BRANCH)", PAR_MBRANCH); ufoSetLatestArgs(UFW_WARG_BRANCH);
7498 UFWORDX("(DATASKIP)", PAR_DATASKIP); ufoSetLatestArgs(UFW_WARG_DATASKIP);
7499 ufoPublicWords();
7503 //==========================================================================
7505 // ufoInitBasicCompilerWords
7507 //==========================================================================
7508 UFO_DISABLE_INLINE void ufoInitBasicCompilerWords (void) {
7509 // create "COMPILER" vocabulary
7510 ufoCompilerVocId = ufoCreateVoc("COMPILER", 0, UFW_FLAG_PROTECTED);
7511 ufoVocSetOnlyDefs(ufoCompilerVocId);
7513 ufoDefineConstant("(CFAIDX-DO-FORTH)", ufoDoForthCFA);
7514 ufoDefineConstant("(CFAIDX-DO-VAR)", ufoDoVariableCFA);
7515 ufoDefineConstant("(CFAIDX-DO-VALUE)", ufoDoValueCFA);
7516 ufoDefineConstant("(CFAIDX-DO-CONST)", ufoDoConstCFA);
7517 ufoDefineConstant("(CFAIDX-DO-DEFER)", ufoDoDeferCFA);
7518 ufoDefineConstant("(CFAIDX-DO-VOC)", ufoDoVocCFA);
7519 ufoDefineConstant("(CFAIDX-DO-CREATE)", ufoDoCreateCFA);
7520 ufoDefineConstant("(CFAIDX-DO-USER-VAR)", ufoDoUserVariableCFA);
7522 ufoDefineConstant("(WFLAG-IMMEDIATE)", UFW_FLAG_IMMEDIATE);
7523 ufoDefineConstant("(WFLAG-SMUDGE)", UFW_FLAG_SMUDGE);
7524 ufoDefineConstant("(WFLAG-NORETURN)", UFW_FLAG_NORETURN);
7525 ufoDefineConstant("(WFLAG-HIDDEN)", UFW_FLAG_HIDDEN);
7526 ufoDefineConstant("(WFLAG-CBLOCK)", UFW_FLAG_CBLOCK);
7527 ufoDefineConstant("(WFLAG-VOCAB)", UFW_FLAG_VOCAB);
7528 ufoDefineConstant("(WFLAG-SCOLON)", UFW_FLAG_SCOLON);
7529 ufoDefineConstant("(WFLAG-PROTECTED)", UFW_FLAG_PROTECTED);
7531 ufoDefineConstant("(WARG-MASK)", UFW_WARG_MASK);
7532 ufoDefineConstant("(WARG-NONE)", UFW_WARG_NONE);
7533 ufoDefineConstant("(WARG-BRANCH)", UFW_WARG_BRANCH);
7534 ufoDefineConstant("(WARG-LIT)", UFW_WARG_LIT);
7535 ufoDefineConstant("(WARG-C4STRZ)", UFW_WARG_C4STRZ);
7536 ufoDefineConstant("(WARG-CFA)", UFW_WARG_CFA);
7537 ufoDefineConstant("(WARG-CBLOCK)", UFW_WARG_CBLOCK);
7538 ufoDefineConstant("(WARG-VOCID)", UFW_WARG_VOCID);
7539 ufoDefineConstant("(WARG-C1STRZ)", UFW_WARG_C1STRZ);
7541 ufoDefineConstant("(VOCOFS-LATEST)", UFW_VOCAB_OFS_LATEST);
7542 ufoDefineConstant("(VOCOFS-VOCLINK)", UFW_VOCAB_OFS_VOCLINK);
7543 ufoDefineConstant("(VOCOFS-PARENT)", UFW_VOCAB_OFS_PARENT);
7544 ufoDefineConstant("(VOCOFS-HEADER)", UFW_VOCAB_OFS_HEADER);
7545 ufoDefineConstant("(VOCOFS-HTABLE)", UFW_VOCAB_OFS_HTABLE);
7546 ufoDefineConstant("(VOC-HTABLE-SIZE)", UFO_HASHTABLE_SIZE);
7547 ufoDefineConstant("(VOC-HTABLE-NOFLAG)", UFO_NO_HTABLE_FLAG);
7549 ufoDefineConstant("(REDEFINE-WARN-DON'T-CARE)", UFO_REDEF_WARN_DONT_CARE);
7550 ufoDefineConstant("(REDEFINE-WARN-NONE)", UFO_REDEF_WARN_NONE);
7551 ufoDefineConstant("(REDEFINE-WARN-NORMAL)", UFO_REDEF_WARN_NORMAL);
7552 ufoDefineConstant("(REDEFINE-WARN-PARENTS)", UFO_REDEF_WARN_PARENTS);
7554 ufoDefineConstant("WORD-REDEFINE-WARN-MODE", ufoAddrRedefineWarning);
7556 UFWORDX("(UNESCAPE)", PAR_UNESCAPE);
7558 ufoInterpretLine(
7559 ": ?EXEC ( -- ) "
7560 " FORTH:STATE FORTH:@ ` expecting interpretation mode` FORTH:?ERROR "
7561 ";");
7563 ufoInterpretLine(
7564 ": ?COMP ( -- ) "
7565 " FORTH:STATE FORTH:@ ` expecting compilation mode` FORTH:?NOT-ERROR "
7566 ";");
7568 UFWORDX("(CREATE-WORD-HEADER)", PAR_CREATE_WORD_HEADER);
7569 UFWORDX("(CREATE-NAMELESS-WORD-HEADER)", PAR_CREATE_NAMELESS_WORD_HEADER);
7571 ufoVocSetOnlyDefs(ufoForthVocId);
7573 // [
7574 ufoInterpretLine("!: [ COMPILER:?COMP 0 STATE ! ;");
7575 // ]
7576 ufoInterpretLine(": ] COMPILER:?EXEC 1 STATE ! ;");
7580 //==========================================================================
7582 // ufoInitMoreWords
7584 //==========================================================================
7585 UFO_DISABLE_INLINE void ufoInitMoreWords (void) {
7586 UFWORDX("COMPILE,", COMMA); // just an alias, for clarity
7588 UFWORDX("CFA->PFA", CFA2PFA);
7589 UFWORDX("CFA->NFA", CFA2NFA);
7590 UFWORDX("CFA->LFA", CFA2LFA);
7591 UFWORDX("CFA->WEND", CFA2WEND);
7593 UFWORDX("PFA->CFA", PFA2CFA);
7594 UFWORDX("PFA->NFA", PFA2NFA);
7596 UFWORDX("NFA->CFA", NFA2CFA);
7597 UFWORDX("NFA->PFA", NFA2PFA);
7598 UFWORDX("NFA->LFA", NFA2LFA);
7600 UFWORDX("LFA->CFA", LFA2CFA);
7601 UFWORDX("LFA->PFA", LFA2PFA);
7602 UFWORDX("LFA->BFA", LFA2BFA);
7603 UFWORDX("LFA->XFA", LFA2XFA);
7604 UFWORDX("LFA->YFA", LFA2YFA);
7605 UFWORDX("LFA->NFA", LFA2NFA);
7607 UFWORDX("(BASED-NUMBER)", PAR_BASED_NUMBER);
7608 UFWORDX("FIND-WORD", FIND_WORD);
7609 UFWORDX("(FIND-WORD-IN-VOC)", FIND_WORD_IN_VOC);
7610 UFWORDX("(FIND-WORD-IN-VOC-AND-PARENTS)", FIND_WORD_IN_VOC_AND_PARENTS);
7612 UFWORD(EXECUTE);
7613 UFWORDX("EXECUTE-TAIL", EXECUTE_TAIL);
7615 UFWORD(DUP);
7616 UFWORDX("?DUP", QDUP);
7617 UFWORDX("2DUP", DDUP);
7618 UFWORD(DROP);
7619 UFWORDX("2DROP", DDROP);
7620 UFWORD(SWAP);
7621 UFWORDX("2SWAP", DSWAP);
7622 UFWORD(OVER);
7623 UFWORDX("2OVER", DOVER);
7624 UFWORD(ROT);
7625 UFWORD(NROT);
7626 UFWORDX("PICK", PICK);
7627 UFWORDX("ROLL", ROLL);
7629 UFWORD(RDUP);
7630 UFWORD(RDROP);
7631 UFWORDX(">R", DTOR);
7632 UFWORDX("R>", RTOD);
7633 UFWORDX("R@", RPEEK);
7634 UFWORDX("RPICK", RPICK);
7635 UFWORDX("RROLL", RROLL);
7636 UFWORDX("RSWAP", RSWAP);
7637 UFWORDX("ROVER", ROVER);
7638 UFWORDX("RROT", RROT);
7639 UFWORDX("RNROT", RNROT);
7641 UFWORDX("FLUSH-EMIT", FLUSH_EMIT);
7642 UFWORDX("(EMIT)", PAR_EMIT);
7643 UFWORDX("(NORM-EMIT-CHAR)", PAR_NORM_EMIT_CHAR);
7644 UFWORDX("(NORM-XEMIT-CHAR)", PAR_NORM_XEMIT_CHAR);
7645 UFWORDX("LASTCR?", LASTCRQ);
7646 UFWORDX("LASTCR!", LASTCRSET);
7648 // simple math
7649 UFWORDX("+", PLUS);
7650 UFWORDX("-", MINUS);
7651 UFWORDX("*", MUL);
7652 UFWORDX("U*", UMUL);
7653 UFWORDX("/", DIV);
7654 UFWORDX("U/", UDIV);
7655 UFWORDX("MOD", MOD);
7656 UFWORDX("UMOD", UMOD);
7657 UFWORDX("/MOD", DIVMOD);
7658 UFWORDX("U/MOD", UDIVMOD);
7659 UFWORDX("*/", MULDIV);
7660 UFWORDX("U*/", UMULDIV);
7661 UFWORDX("*/MOD", MULDIVMOD);
7662 UFWORDX("U*/MOD", UMULDIVMOD);
7663 UFWORDX("M*", MMUL);
7664 UFWORDX("UM*", UMMUL);
7665 UFWORDX("M/MOD", MDIVMOD);
7666 UFWORDX("UM/MOD", UMDIVMOD);
7667 UFWORDX("UDS*", UDSMUL);
7669 UFWORDX("SM/REM", SMREM);
7670 UFWORDX("FM/MOD", FMMOD);
7672 UFWORDX("D-", DMINUS);
7673 UFWORDX("D+", DPLUS);
7674 UFWORDX("D=", DEQU);
7675 UFWORDX("D<", DLESS);
7676 UFWORDX("D<=", DLESSEQU);
7677 UFWORDX("DU<", DULESS);
7678 UFWORDX("DU<=", DULESSEQU);
7680 UFWORD(ASH);
7681 UFWORD(LSH);
7683 // logic
7684 UFWORDX("<", LESS);
7685 UFWORDX(">", GREAT);
7686 UFWORDX("<=", LESSEQU);
7687 UFWORDX(">=", GREATEQU);
7688 UFWORDX("U<", ULESS);
7689 UFWORDX("U>", UGREAT);
7690 UFWORDX("U<=", ULESSEQU);
7691 UFWORDX("U>=", UGREATEQU);
7692 UFWORDX("=", EQU);
7693 UFWORDX("<>", NOTEQU);
7695 UFWORDX("0=", ZERO_EQU);
7696 UFWORDX("0<>", ZERO_NOTEQU);
7698 UFWORDX("NOT", ZERO_EQU);
7699 UFWORDX("NOTNOT", ZERO_NOTEQU);
7701 UFWORD(BITNOT);
7702 UFWORD(AND);
7703 UFWORD(OR);
7704 UFWORD(XOR);
7705 UFWORDX("LOGAND", LOGAND);
7706 UFWORDX("LOGOR", LOGOR);
7708 // TIB and parser
7709 UFWORDX("(TIB-IN)", TIB_IN);
7710 UFWORDX("TIB-PEEKCH", TIB_PEEKCH);
7711 UFWORDX("TIB-PEEKCH-OFS", TIB_PEEKCH_OFS);
7712 UFWORDX("TIB-GETCH", TIB_GETCH);
7713 UFWORDX("TIB-SKIPCH", TIB_SKIPCH);
7715 UFWORDX("REFILL", REFILL);
7716 UFWORDX("REFILL-NOCROSS", REFILL_NOCROSS);
7718 ufoHiddenWords();
7719 UFWORDX("(PARSE)", PAR_PARSE);
7720 UFWORDX("(PARSE-SKIP-COMMENTS)", PAR_PARSE_SKIP_COMMENTS);
7721 ufoPublicWords();
7722 UFWORDX("PARSE-SKIP-BLANKS", PARSE_SKIP_BLANKS);
7723 UFWORDX("PARSE-NAME", PARSE_NAME);
7724 UFWORDX("PARSE-SKIP-LINE", PARSE_SKIP_LINE);
7725 UFWORDX("PARSE", PARSE);
7727 ufoHiddenWords();
7728 UFWORDX("(VSP@)", PAR_GET_VSP);
7729 UFWORDX("(VSP!)", PAR_SET_VSP);
7730 UFWORDX("(VSP-AT@)", PAR_VSP_LOAD);
7731 UFWORDX("(VSP-AT!)", PAR_VSP_STORE);
7732 ufoDefineConstant("(VSP-SIZE)", UFO_VOCSTACK_SIZE);
7734 ufoDefineConstant("(SP-SIZE)", UFO_DSTACK_SIZE);
7735 ufoDefineConstant("(RP-SIZE)", UFO_RSTACK_SIZE);
7736 ufoDefineConstant("(LP-SIZE)", UFO_LSTACK_SIZE);
7737 ufoPublicWords();
7739 UFWORDX("ERROR", ERROR);
7740 UFWORDX("FATAL-ERROR", ERROR);
7742 ufoInterpretLine(": 1+ ( n -- n+1 ) 1 + ;");
7743 ufoInterpretLine(": 1- ( n -- n-1 ) 1 - ;");
7744 ufoInterpretLine(": 2+ ( n -- n+2 ) 2 + ;");
7745 ufoInterpretLine(": 2- ( n -- n-2 ) 2 - ;");
7746 ufoInterpretLine(": 4+ ( n -- n+4 ) 4 + ;");
7747 ufoInterpretLine(": 4- ( n -- n-4 ) 4 - ;");
7749 ufoInterpretLine(": 2* ( n -- n*2 ) 1 ASH ;");
7750 ufoInterpretLine(": 2/ ( n -- n/2 ) -1 ASH ;");
7751 ufoInterpretLine(": 4* ( n -- n*4 ) 2 ASH ;");
7752 ufoInterpretLine(": 4/ ( n -- n/4 ) -2 ASH ;");
7754 ufoInterpretLine(": 2U* ( u -- u*2 ) 1 LSH ;");
7755 ufoInterpretLine(": 2U/ ( u -- u/2 ) -1 LSH ;");
7756 ufoInterpretLine(": 4U* ( u -- u*4 ) 2 LSH ;");
7757 ufoInterpretLine(": 4U/ ( u -- u/4 ) -2 LSH ;");
7759 ufoInterpretLine(": 0< ( n -- n<0 ) 0 < ;");
7760 ufoInterpretLine(": 0> ( n -- n>0 ) 0 > ;");
7761 ufoInterpretLine(": 0<= ( n -- n<0 ) 0 <= ;");
7762 ufoInterpretLine(": 0>= ( n -- n>0 ) 0 >= ;");
7764 ufoInterpretLine(": @A ( idx -- v ) 0 @A+ ;");
7765 ufoInterpretLine(": C@A ( idx -- v ) 0 C@A+ ;");
7766 ufoInterpretLine(": W@A ( idx -- v ) 0 W@A+ ;");
7768 ufoInterpretLine(": !A ( idx -- v ) 0 !A+ ;");
7769 ufoInterpretLine(": C!A ( idx -- v ) 0 C!A+ ;");
7770 ufoInterpretLine(": W!A ( idx -- v ) 0 W!A+ ;");
7772 // ABORT
7773 // ( -- )
7774 ufoInterpretLine(": ABORT ` \"ABORT\" called` ERROR ;");
7776 // ?ERROR
7777 // ( errflag addr count -- )
7778 ufoInterpretLine(
7779 ": ?ERROR ( errflag addr count -- ) "
7780 " ROT FORTH:(0BRANCH) $qerr_skip ERROR "
7781 "$qerr_skip: "
7782 " 2DROP "
7783 ";");
7785 // ?NOT-ERROR
7786 // ( errflag addr count -- )
7787 ufoInterpretLine(
7788 ": ?NOT-ERROR ( errflag addr count -- ) "
7789 " ROT FORTH:(TBRANCH) $qnoterr_skip ERROR "
7790 "$qnoterr_skip: "
7791 " 2DROP "
7792 ";");
7794 ufoInterpretLine(
7795 ": FIND-WORD-IN-VOC ( vocid addr count -- cfa TRUE / FALSE ) "
7796 " 0 (FIND-WORD-IN-VOC) ;");
7798 ufoInterpretLine(
7799 ": FIND-WORD-IN-VOC-AND-PARENTS ( vocid addr count -- cfa TRUE / FALSE ) "
7800 " 0 (FIND-WORD-IN-VOC-AND-PARENTS) ;");
7802 UFWORDX("GET-MSECS", GET_MSECS);
7806 //==========================================================================
7808 // ufoInitHandleWords
7810 //==========================================================================
7811 UFO_DISABLE_INLINE void ufoInitHandleWords (void) {
7812 // create "HANDLE" vocabulary
7813 const uint32_t handleVocId = ufoCreateVoc("HANDLE", 0, UFW_FLAG_PROTECTED);
7814 ufoVocSetOnlyDefs(handleVocId);
7815 UFWORDX("NEW", PAR_NEW_HANDLE);
7816 UFWORDX("FREE", PAR_FREE_HANDLE);
7817 UFWORDX("TYPEID@", PAR_HANDLE_GET_TYPEID);
7818 UFWORDX("TYPEID!", PAR_HANDLE_SET_TYPEID);
7819 UFWORDX("SIZE@", PAR_HANDLE_GET_SIZE);
7820 UFWORDX("SIZE!", PAR_HANDLE_SET_SIZE);
7821 UFWORDX("USED@", PAR_HANDLE_GET_USED);
7822 UFWORDX("USED!", PAR_HANDLE_SET_USED);
7823 UFWORDX("C@", PAR_HANDLE_LOAD_BYTE);
7824 UFWORDX("W@", PAR_HANDLE_LOAD_WORD);
7825 UFWORDX("@", PAR_HANDLE_LOAD_CELL);
7826 UFWORDX("C!", PAR_HANDLE_STORE_BYTE);
7827 UFWORDX("W!", PAR_HANDLE_STORE_WORD);
7828 UFWORDX("!", PAR_HANDLE_STORE_CELL);
7829 UFWORDX("LOAD-FILE", PAR_HANDLE_LOAD_FILE);
7830 ufoVocSetOnlyDefs(ufoForthVocId);
7834 //==========================================================================
7836 // ufoInitHigherWords
7838 //==========================================================================
7839 UFO_DISABLE_INLINE void ufoInitHigherWords (void) {
7840 UFWORDX("(INCLUDE)", PAR_INCLUDE);
7842 UFWORDX("(INCLUDE-DEPTH)", PAR_INCLUDE_DEPTH);
7843 UFWORDX("(INCLUDE-FILE-ID)", PAR_INCLUDE_FILE_ID);
7844 UFWORDX("(INCLUDE-FILE-LINE)", PAR_INCLUDE_FILE_LINE);
7845 UFWORDX("(INCLUDE-FILE-NAME)", PAR_INCLUDE_FILE_NAME);
7847 UFWORDX("($DEFINED?)", PAR_DLR_DEFINEDQ);
7848 UFWORDX("($DEFINE)", PAR_DLR_DEFINE);
7849 UFWORDX("($UNDEF)", PAR_DLR_UNDEF);
7851 UFWORDX_IMM("$INCLUDE", DLR_INCLUDE_IMM);
7852 UFWORDX_IMM("$INCLUDE-ONCE", DLR_INCLUDE_ONCE_IMM);
7856 //==========================================================================
7858 // ufoInitStringWords
7860 //==========================================================================
7861 UFO_DISABLE_INLINE void ufoInitStringWords (void) {
7862 // create "STRING" vocabulary
7863 const uint32_t stringVocId = ufoCreateVoc("STRING", 0, UFW_FLAG_PROTECTED);
7864 ufoVocSetOnlyDefs(stringVocId);
7865 UFWORDX("=", STREQU);
7866 UFWORDX("=CI", STREQUCI);
7867 UFWORDX("SEARCH", SEARCH);
7868 UFWORDX("HASH", STRHASH);
7869 UFWORDX("HASH-CI", STRHASHCI);
7870 ufoVocSetOnlyDefs(ufoForthVocId);
7874 //==========================================================================
7876 // ufoInitDebugWords
7878 //==========================================================================
7879 UFO_DISABLE_INLINE void ufoInitDebugWords (void) {
7880 // create "DEBUG" vocabulary
7881 const uint32_t debugVocId = ufoCreateVoc("DEBUG", 0, UFW_FLAG_PROTECTED);
7882 ufoVocSetOnlyDefs(debugVocId);
7883 UFWORDX("(DECOMPILE-CFA)", DEBUG_DECOMPILE_CFA);
7884 UFWORDX("(DECOMPILE-MEM)", DEBUG_DECOMPILE_MEM);
7885 UFWORDX("BACKTRACE", UFO_BACKTRACE);
7886 UFWORDX("DUMP-STACK", DUMP_STACK);
7887 UFWORDX("BACKTRACE-TASK", UFO_BACKTRACE_TASK);
7888 UFWORDX("DUMP-STACK-TASK", DUMP_STACK_TASK);
7889 UFWORDX("DUMP-RSTACK-TASK", DUMP_RSTACK_TASK);
7890 UFWORDX("(BP)", MT_DEBUGGER_BP);
7891 UFWORDX("IP->NFA", IP2NFA);
7892 UFWORDX("IP->FILE/LINE", IP2FILELINE);
7893 UFWORDX("IP->FILE-HASH/LINE", IP2FILEHASHLINE);
7894 ufoVocSetOnlyDefs(ufoForthVocId);
7898 //==========================================================================
7900 // ufoInitMTWords
7902 //==========================================================================
7903 UFO_DISABLE_INLINE void ufoInitMTWords (void) {
7904 // create "MTASK" vocabulary
7905 const uint32_t mtVocId = ufoCreateVoc("MTASK", 0, UFW_FLAG_PROTECTED);
7906 ufoVocSetOnlyDefs(mtVocId);
7907 UFWORDX("NEW-STATE", MT_NEW_STATE);
7908 UFWORDX("FREE-STATE", MT_FREE_STATE);
7909 UFWORDX("STATE-NAME@", MT_GET_STATE_NAME);
7910 UFWORDX("STATE-NAME!", MT_SET_STATE_NAME);
7911 UFWORDX("STATE-FIRST", MT_STATE_FIRST);
7912 UFWORDX("STATE-NEXT", MT_STATE_NEXT);
7913 UFWORDX("YIELD-TO", MT_YIELD_TO);
7914 UFWORDX("SET-SELF-AS-DEBUGGER", MT_SET_SELF_AS_DEBUGGER);
7915 UFWORDX("DEBUGGER-RESUME", MT_RESUME_DEBUGEE);
7916 UFWORDX("DEBUGGER-SINGLE-STEP", MT_SINGLE_STEP_DEBUGEE);
7917 UFWORDX("ACTIVE-STATE", MT_ACTIVE_STATE);
7918 UFWORDX("STATE-IP@", MT_STATE_IP_GET);
7919 UFWORDX("STATE-IP!", MT_STATE_IP_SET);
7920 UFWORDX("STATE-A>", MT_STATE_REGA_GET);
7921 UFWORDX("STATE->A", MT_STATE_REGA_SET);
7922 UFWORDX("STATE-USER@", MT_STATE_USER_GET);
7923 UFWORDX("STATE-USER!", MT_STATE_USER_SET);
7924 UFWORDX("STATE-RPOPCFA@", MT_STATE_RPOPCFA_GET);
7925 UFWORDX("STATE-RPOPCFA!", MT_STATE_RPOPCFA_SET);
7926 UFWORDX("YIELDED-FROM", MT_YIELDED_FROM);
7927 UFWORDX("STATE-SP@", MT_DSTACK_DEPTH_GET);
7928 UFWORDX("STATE-RP@", MT_RSTACK_DEPTH_GET);
7929 UFWORDX("STATE-LP@", MT_LP_GET);
7930 UFWORDX("STATE-LBP@", MT_LBP_GET);
7931 UFWORDX("STATE-SP!", MT_DSTACK_DEPTH_SET);
7932 UFWORDX("STATE-RP!", MT_RSTACK_DEPTH_SET);
7933 UFWORDX("STATE-LP!", MT_LP_SET);
7934 UFWORDX("STATE-LBP!", MT_LBP_SET);
7935 UFWORDX("STATE-DS@", MT_DSTACK_LOAD);
7936 UFWORDX("STATE-RS@", MT_RSTACK_LOAD);
7937 UFWORDX("STATE-LS@", MT_LSTACK_LOAD);
7938 UFWORDX("STATE-DS!", MT_DSTACK_STORE);
7939 UFWORDX("STATE-RS!", MT_RSTACK_STORE);
7940 UFWORDX("STATE-LS!", MT_LSTACK_STORE);
7941 ufoVocSetOnlyDefs(ufoForthVocId);
7945 //==========================================================================
7947 // ufoInitTTYWords
7949 //==========================================================================
7950 UFO_DISABLE_INLINE void ufoInitTTYWords (void) {
7951 // create "TTY" vocabulary
7952 const uint32_t ttyVocId = ufoCreateVoc("TTY", 0, UFW_FLAG_PROTECTED);
7953 ufoVocSetOnlyDefs(ttyVocId);
7954 UFWORDX("TTY?", TTY_TTYQ);
7955 UFWORDX("RAW?", TTY_RAWQ);
7956 UFWORDX("SIZE", TTY_SIZE);
7957 UFWORDX("SET-RAW", TTY_SET_RAW);
7958 UFWORDX("SET-COOKED", TTY_SET_COOKED);
7959 UFWORDX("RAW-EMIT", TTY_RAW_EMIT);
7960 UFWORDX("RAW-TYPE", TTY_RAW_TYPE);
7961 UFWORDX("RAW-FLUSH", TTY_RAW_FLUSH);
7962 UFWORDX("RAW-READCH", TTY_RAW_READCH);
7963 UFWORDX("RAW-READY?", TTY_RAW_READYQ);
7964 ufoVocSetOnlyDefs(ufoForthVocId);
7968 //==========================================================================
7970 // ufoInitVeryVeryHighWords
7972 //==========================================================================
7973 UFO_DISABLE_INLINE void ufoInitVeryVeryHighWords (void) {
7974 // interpret defer
7975 //ufoDefineDefer("INTERPRET", idumbCFA);
7977 ufoDefineEmitType();
7979 // ( addr count FALSE -- addr count FALSE / TRUE )
7980 ufoDefineSColonForth("(INTERPRET-CHECK-WORD)");
7981 ufoDoneForth();
7982 // ( addr count FALSE -- addr count FALSE / TRUE )
7983 ufoDefineSColonForth("(INTERPRET-WORD-NOT-FOUND)");
7984 ufoDoneForth();
7985 // ( -- ) -- called in "EXIT", before compiling "FORTH:(EXIT)"
7986 ufoDefineSColonForth("(EXIT-EXTENDER)");
7987 ufoDoneForth();
7989 // EXIT ( -- )
7990 ufoInterpretLine("!: EXIT ( -- ) COMPILER:?COMP (EXIT-EXTENDER) COMPILE FORTH:(EXIT) ;");
7992 ufoDefineInterpret();
7994 //ufoDumpVocab(ufoCompilerVocId);
7996 ufoInterpretLine(
7997 ": RUN-INTERPRET-LOOP "
7998 "$run-interp-loop-again: "
7999 " RP0! INTERPRET (UFO-INTERPRET-FINISHED-ACTION) "
8000 " FORTH:(BRANCH) $run-interp-loop-again "
8001 ";");
8004 #define UFO_ADD_DO_CFA(cfx_) do { \
8005 ufoDo##cfx_##CFA = ufoCFAsUsed | UFO_ADDR_CFA_BIT; \
8006 ufoForthCFAs[ufoCFAsUsed] = &ufoDo##cfx_; \
8007 ufoCFAsUsed += 1; \
8008 } while (0)
8011 //==========================================================================
8013 // ufoInitCommon
8015 //==========================================================================
8016 UFO_DISABLE_INLINE void ufoInitCommon (void) {
8017 ufoVSP = 0;
8018 ufoForthVocId = 0; ufoCompilerVocId = 0;
8020 ufoForthCFAs = calloc(UFO_MAX_NATIVE_CFAS, sizeof(ufoForthCFAs[0]));
8022 // allocate default TIB handle
8023 //UfoHandle *tibh = ufoAllocHandle(0x69a029a6); // arbitrary number
8024 //ufoDefTIB = tibh->ufoHandle;
8026 ufoForthCFAs[0] = NULL; ufoCFAsUsed = 1u;
8027 UFO_ADD_DO_CFA(Forth);
8028 UFO_ADD_DO_CFA(Variable);
8029 UFO_ADD_DO_CFA(Value);
8030 UFO_ADD_DO_CFA(Const);
8031 UFO_ADD_DO_CFA(Defer);
8032 UFO_ADD_DO_CFA(Voc);
8033 UFO_ADD_DO_CFA(Create);
8034 UFO_ADD_DO_CFA(UserVariable);
8036 //fprintf(stderr, "DO-FORTH-CFA: 0x%08x\n", ufoDoForthCFA);
8038 ufoInitBaseDict();
8040 // create "FORTH" vocabulary (it should be the first one)
8041 ufoForthVocId = ufoCreateVoc("FORTH", 0, UFW_FLAG_PROTECTED);
8042 ufoVocSetOnlyDefs(ufoForthVocId);
8044 // base low-level interpreter words
8045 ufoInitBasicWords();
8047 // more FORTH words
8048 ufoInitMoreWords();
8050 // some COMPILER words
8051 ufoInitBasicCompilerWords();
8053 // STRING vocabulary
8054 ufoInitStringWords();
8056 // DEBUG vocabulary
8057 ufoInitDebugWords();
8059 // MTASK vocabulary
8060 ufoInitMTWords();
8062 // HANDLE vocabulary
8063 ufoInitHandleWords();
8065 // TTY vocabulary
8066 ufoInitTTYWords();
8068 // some higher-level FORTH words (includes, etc.)
8069 ufoInitHigherWords();
8071 // very-very high-level FORTH words
8072 ufoInitVeryVeryHighWords();
8074 ufoFinalLabelCheck();
8076 #if 0
8077 ufoDecompileWord(ufoFindWordChecked("RUN-INTERPRET-LOOP"));
8078 #endif
8080 ufoReset();
8083 #undef UFC
8086 // ////////////////////////////////////////////////////////////////////////// //
8087 // virtual machine executor
8091 //==========================================================================
8093 // ufoRunVM
8095 // address interpreter
8097 //==========================================================================
8098 static void ufoRunVMCFA (uint32_t cfa) {
8099 const uint32_t oldRPTop = ufoRPTop;
8100 ufoRPTop = ufoRP;
8101 #ifdef UFO_TRACE_VM_RUN
8102 fprintf(stderr, "**VM-INITIAL**: cfa=%u\n", cfa);
8103 UFCALL(DUMP_STACK);
8104 #endif
8105 ufoRPush(cfa);
8106 ufoVMRPopCFA = 1;
8107 ufoVMStop = 0;
8108 // VM execution loop
8109 do {
8110 if (ufoVMAbort) ufoFatal("user abort");
8111 if (ufoVMStop) { ufoRP = oldRPTop; break; }
8112 if (ufoCurrState == NULL) ufoFatal("execution state is lost");
8113 if (ufoVMRPopCFA == 0) {
8114 // check IP
8115 if (ufoIP == 0) ufoFatal("IP is NULL");
8116 if (ufoIP & UFO_ADDR_HANDLE_BIT) ufoFatal("IP is a handle");
8117 cfa = ufoImgGetU32(ufoIP); ufoIP += 4u;
8118 } else {
8119 cfa = ufoRPop(); ufoVMRPopCFA = 0;
8121 // check CFA sanity
8122 if (cfa == 0) ufoFatal("EXECUTE: NULL CFA");
8123 if (cfa & UFO_ADDR_HANDLE_BIT) ufoFatal("cannot execute handle");
8124 // get next word CFAIDX, and check it
8125 uint32_t cfaidx = ufoImgGetU32(cfa);
8126 if (cfaidx & UFO_ADDR_HANDLE_BIT) ufoFatal("cannot execute CFAIDX-handle");
8127 #ifdef UFO_TRACE_VM_RUN
8128 fprintf(stderr, "**VM**: IP=%u; cfa=%u; cfaidx=0x%08x\n", ufoIP - 4u, cfa, cfaidx);
8129 UFCALL(DUMP_STACK);
8130 ufoDumpWordHeader(UFO_CFA_TO_LFA(cfa));
8131 fprintf(stderr, "######################################\n");
8132 #endif
8133 if (cfaidx & UFO_ADDR_CFA_BIT) {
8134 cfaidx &= UFO_ADDR_CFA_MASK;
8135 if (cfaidx >= ufoCFAsUsed || ufoForthCFAs[cfaidx] == NULL) {
8136 ufoFatal("tried to execute an unknown word: %u (max is %u); IP=%u",
8137 cfaidx, ufoCFAsUsed, ufoIP - 4u);
8139 #ifdef UFO_TRACE_VM_RUN
8140 fprintf(stderr, "**VM-NATIVE**: cfaidx=%u (doForth=%u)\n", cfaidx,
8141 (ufoDoForthCFA & UFO_ADDR_CFA_MASK));
8142 #endif
8143 ufoForthCFAs[cfaidx](UFO_CFA_TO_PFA(cfa));
8144 } else {
8145 // if CFA points somewhere inside a dict, this is "DOES>" word
8146 // IP points to PFA we need to push
8147 // CFA points to Forth word we need to jump to
8148 #ifdef UFO_TRACE_VM_DOER
8149 fprintf(stderr, "*** DOER! IP=%u; cfa=%u; cfaidx=%u ***\n", ufoIP, cfa, cfaidx);
8150 UFCALL(UFO_BACKTRACE);
8151 #endif
8152 ufoPush(UFO_CFA_TO_PFA(cfa)); // push PFA
8153 ufoRPush(ufoIP); // push IP
8154 ufoIP = cfaidx; // fix IP
8156 // that's all we need to activate the debugger
8157 if (ufoSingleStep) {
8158 ufoSingleStep -= 1;
8159 if (ufoSingleStep == 0 && ufoDebuggerState != NULL) {
8160 if (ufoCurrState == ufoDebuggerState) ufoFatal("debugger cannot debug itself");
8161 UfoState *ost = ufoCurrState;
8162 ufoSwitchToState(ufoDebuggerState); // always use API call for this!
8163 ufoPush(-2);
8164 ufoPush(ost->id);
8167 } while (ufoRP != oldRPTop);
8168 //ufoVMStop = 0;
8172 // ////////////////////////////////////////////////////////////////////////// //
8173 // high-level API
8176 //==========================================================================
8178 // ufoRegisterWord
8180 // register new word
8182 //==========================================================================
8183 uint32_t ufoRegisterWord (const char *wname, ufoNativeCFA cfa, uint32_t flags) {
8184 ufo_assert(cfa != NULL);
8185 ufo_assert(wname != NULL && wname[0] != 0);
8186 uint32_t cfaidx = ufoCFAsUsed;
8187 if (cfaidx >= UFO_MAX_NATIVE_CFAS) ufoFatal("too many native words");
8188 ufoForthCFAs[cfaidx] = cfa;
8189 ufoCFAsUsed += 1;
8190 //ufoDefineNative(wname, xcfa, 0);
8191 cfaidx |= UFO_ADDR_CFA_BIT;
8192 flags &= 0xffffff00u;
8193 ufoCreateWordHeader(wname, flags);
8194 const uint32_t res = UFO_GET_DP();
8195 ufoImgEmitU32(cfaidx);
8196 return res;
8200 //==========================================================================
8202 // ufoRegisterDataWord
8204 //==========================================================================
8205 static uint32_t ufoRegisterDataWord (const char *wname, uint32_t cfaidx, uint32_t value,
8206 uint32_t flags)
8208 ufo_assert(wname != NULL && wname[0] != 0);
8209 flags &= 0xffffff00u;
8210 ufoCreateWordHeader(wname, flags);
8211 ufoImgEmitU32(cfaidx);
8212 const uint32_t res = UFO_GET_DP();
8213 ufoImgEmitU32(value);
8214 return res;
8218 //==========================================================================
8220 // ufoRegisterConstant
8222 //==========================================================================
8223 void ufoRegisterConstant (const char *wname, uint32_t value, uint32_t flags) {
8224 (void)ufoRegisterDataWord(wname, ufoDoConstCFA, value, flags);
8228 //==========================================================================
8230 // ufoRegisterVariable
8232 //==========================================================================
8233 uint32_t ufoRegisterVariable (const char *wname, uint32_t value, uint32_t flags) {
8234 return ufoRegisterDataWord(wname, ufoDoVariableCFA, value, flags);
8238 //==========================================================================
8240 // ufoRegisterValue
8242 //==========================================================================
8243 uint32_t ufoRegisterValue (const char *wname, uint32_t value, uint32_t flags) {
8244 return ufoRegisterDataWord(wname, ufoDoValueCFA, value, flags);
8248 //==========================================================================
8250 // ufoRegisterDefer
8252 //==========================================================================
8253 uint32_t ufoRegisterDefer (const char *wname, uint32_t value, uint32_t flags) {
8254 return ufoRegisterDataWord(wname, ufoDoDeferCFA, value, flags);
8258 //==========================================================================
8260 // ufoFindWordInVocabulary
8262 // check if we have the corresponding word.
8263 // return CFA suitable for executing, or 0.
8265 //==========================================================================
8266 uint32_t ufoFindWordInVocabulary (const char *wname, uint32_t vocid) {
8267 if (wname == NULL || wname[0] == 0) return 0;
8268 size_t wlen = strlen(wname);
8269 if (wlen >= UFO_MAX_WORD_LENGTH) return 0;
8270 return ufoFindWordInVocAndParents(wname, (uint32_t)wlen, 0, vocid, 0);
8274 //==========================================================================
8276 // ufoGetIP
8278 //==========================================================================
8279 uint32_t ufoGetIP (void) {
8280 return ufoIP;
8284 //==========================================================================
8286 // ufoSetIP
8288 //==========================================================================
8289 void ufoSetIP (uint32_t newip) {
8290 ufoIP = newip;
8294 //==========================================================================
8296 // ufoIsExecuting
8298 //==========================================================================
8299 int ufoIsExecuting (void) {
8300 return (ufoImgGetU32(ufoAddrSTATE) == 0);
8304 //==========================================================================
8306 // ufoIsCompiling
8308 //==========================================================================
8309 int ufoIsCompiling (void) {
8310 return (ufoImgGetU32(ufoAddrSTATE) != 0);
8314 //==========================================================================
8316 // ufoSetExecuting
8318 //==========================================================================
8319 void ufoSetExecuting (void) {
8320 ufoImgPutU32(ufoAddrSTATE, 0);
8324 //==========================================================================
8326 // ufoSetCompiling
8328 //==========================================================================
8329 void ufoSetCompiling (void) {
8330 ufoImgPutU32(ufoAddrSTATE, 1);
8334 //==========================================================================
8336 // ufoGetHere
8338 //==========================================================================
8339 uint32_t ufoGetHere () {
8340 return UFO_GET_DP();
8344 //==========================================================================
8346 // ufoGetPad
8348 //==========================================================================
8349 uint32_t ufoGetPad () {
8350 UFCALL(PAD);
8351 return ufoPop();
8355 //==========================================================================
8357 // ufoTIBPeekCh
8359 //==========================================================================
8360 uint8_t ufoTIBPeekCh (uint32_t ofs) {
8361 return ufoTibPeekChOfs(ofs);
8365 //==========================================================================
8367 // ufoTIBGetCh
8369 //==========================================================================
8370 uint8_t ufoTIBGetCh (void) {
8371 return ufoTibGetCh();
8375 //==========================================================================
8377 // ufoTIBSkipCh
8379 //==========================================================================
8380 void ufoTIBSkipCh (void) {
8381 ufoTibSkipCh();
8385 //==========================================================================
8387 // ufoTIBSRefill
8389 // returns 0 on EOF
8391 //==========================================================================
8392 int ufoTIBSRefill (int allowCrossIncludes) {
8393 return ufoLoadNextLine(allowCrossIncludes);
8397 //==========================================================================
8399 // ufoPeekData
8401 //==========================================================================
8402 uint32_t ufoPeekData (void) {
8403 return ufoPeek();
8407 //==========================================================================
8409 // ufoPopData
8411 //==========================================================================
8412 uint32_t ufoPopData (void) {
8413 return ufoPop();
8417 //==========================================================================
8419 // ufoPushData
8421 //==========================================================================
8422 void ufoPushData (uint32_t value) {
8423 return ufoPush(value);
8427 //==========================================================================
8429 // ufoPushBoolData
8431 //==========================================================================
8432 void ufoPushBoolData (int val) {
8433 ufoPushBool(val);
8437 //==========================================================================
8439 // ufoPeekRet
8441 //==========================================================================
8442 uint32_t ufoPeekRet (void) {
8443 return ufoRPeek();
8447 //==========================================================================
8449 // ufoPopRet
8451 //==========================================================================
8452 uint32_t ufoPopRet (void) {
8453 return ufoRPop();
8457 //==========================================================================
8459 // ufoPushRet
8461 //==========================================================================
8462 void ufoPushRet (uint32_t value) {
8463 return ufoRPush(value);
8467 //==========================================================================
8469 // ufoPushBoolRet
8471 //==========================================================================
8472 void ufoPushBoolRet (int val) {
8473 ufoRPush(val ? ufoTrueValue : 0);
8477 //==========================================================================
8479 // ufoPeekByte
8481 //==========================================================================
8482 uint8_t ufoPeekByte (uint32_t addr) {
8483 return ufoImgGetU8Ext(addr);
8487 //==========================================================================
8489 // ufoPeekWord
8491 //==========================================================================
8492 uint16_t ufoPeekWord (uint32_t addr) {
8493 ufoPush(addr);
8494 UFCALL(WPEEK);
8495 return ufoPop();
8499 //==========================================================================
8501 // ufoPeekCell
8503 //==========================================================================
8504 uint32_t ufoPeekCell (uint32_t addr) {
8505 ufoPush(addr);
8506 UFCALL(PEEK);
8507 return ufoPop();
8511 //==========================================================================
8513 // ufoPokeByte
8515 //==========================================================================
8516 void ufoPokeByte (uint32_t addr, uint32_t value) {
8517 ufoImgPutU8(addr, value);
8521 //==========================================================================
8523 // ufoPokeWord
8525 //==========================================================================
8526 void ufoPokeWord (uint32_t addr, uint32_t value) {
8527 ufoPush(value);
8528 ufoPush(addr);
8529 UFCALL(WPOKE);
8533 //==========================================================================
8535 // ufoPokeCell
8537 //==========================================================================
8538 void ufoPokeCell (uint32_t addr, uint32_t value) {
8539 ufoPush(value);
8540 ufoPush(addr);
8541 UFCALL(POKE);
8545 //==========================================================================
8547 // ufoEmitByte
8549 //==========================================================================
8550 void ufoEmitByte (uint32_t value) {
8551 ufoImgEmitU8(value);
8555 //==========================================================================
8557 // ufoEmitWord
8559 //==========================================================================
8560 void ufoEmitWord (uint32_t value) {
8561 ufoImgEmitU8(value & 0xff);
8562 ufoImgEmitU8((value >> 8) & 0xff);
8566 //==========================================================================
8568 // ufoEmitCell
8570 //==========================================================================
8571 void ufoEmitCell (uint32_t value) {
8572 ufoImgEmitU32(value);
8576 //==========================================================================
8578 // ufoIsInited
8580 //==========================================================================
8581 int ufoIsInited (void) {
8582 return (ufoMode != UFO_MODE_NONE);
8586 static void (*ufoUserPostInitCB) (void);
8589 //==========================================================================
8591 // ufoSetUserPostInit
8593 // called after main initialisation
8595 //==========================================================================
8596 void ufoSetUserPostInit (void (*cb) (void)) {
8597 ufoUserPostInitCB = cb;
8601 //==========================================================================
8603 // ufoInit
8605 //==========================================================================
8606 void ufoInit (void) {
8607 if (ufoMode != UFO_MODE_NONE) return;
8608 ufoMode = UFO_MODE_NATIVE;
8610 ufoInFileLine = 0;
8611 ufoInFileName = NULL; ufoInFileNameLen = 0; ufoInFileNameHash = 0;
8612 ufoInFile = NULL;
8613 ufoLastIncPath = NULL; ufoLastSysIncPath = NULL;
8615 for (uint32_t f = 0; f < UFO_MAX_STATES; f += 1u) ufoStateMap[f] = NULL;
8616 memset(ufoStateUsedBitmap, 0, sizeof(ufoStateUsedBitmap));
8618 ufoCurrState = ufoNewState();
8619 strcpy(ufoCurrState->name, "MAIN");
8620 ufoInitStateUserVars(ufoCurrState, 0);
8621 ufoImgPutU32(ufoAddrDefTIB, 0); // create TIB handle
8622 ufoImgPutU32(ufoAddrTIBx, 0); // create TIB handle
8624 ufoYieldedState = NULL;
8625 ufoDebuggerState = NULL;
8626 ufoSingleStep = 0;
8628 #ifdef UFO_DEBUG_STARTUP_TIMES
8629 uint32_t stt = ufo_get_msecs();
8630 ufoCondDefine("UFO-DEBUG-STARTUP-TIMES");
8631 #endif
8632 ufoInitCommon();
8633 #ifdef UFO_DEBUG_STARTUP_TIMES
8634 uint32_t ett = ufo_get_msecs();
8635 fprintf(stderr, "UrForth init time: %u msecs\n", (unsigned)(ett - stt));
8636 #endif
8638 ufoReset();
8640 if (ufoUserPostInitCB) {
8641 ufoUserPostInitCB();
8642 ufoReset();
8645 // load ufo modules
8646 char *ufmname = ufoCreateIncludeName("init", 1, NULL);
8647 #ifdef WIN32
8648 FILE *ufl = fopen(ufmname, "rb");
8649 #else
8650 FILE *ufl = fopen(ufmname, "r");
8651 #endif
8652 if (ufl) {
8653 ufoPushInFile();
8654 ufoSetInFileNameReuse(ufmname);
8655 ufoInFile = ufl;
8656 ufoFileId = ufoLastUsedFileId;
8657 setLastIncPath(ufoInFileName, 1);
8658 } else {
8659 free(ufmname);
8660 ufoFatal("cannot load init code");
8663 if (ufoInFile != NULL) {
8664 ufoRunInterpretLoop();
8669 //==========================================================================
8671 // ufoFinishVM
8673 //==========================================================================
8674 void ufoFinishVM (void) {
8675 ufoVMStop = 1;
8679 //==========================================================================
8681 // ufoWasVMFinished
8683 // check if VM was exited due to `ufoFinishVM()`
8685 //==========================================================================
8686 int ufoWasVMFinished (void) {
8687 return (ufoVMStop != 0);
8691 //==========================================================================
8693 // ufoCallParseIntr
8695 // ( -- addr count TRUE / FALSE )
8696 // does base TIB parsing; never copies anything.
8697 // as our reader is line-based, returns FALSE on EOL.
8698 // EOL is detected after skipping leading delimiters.
8699 // passing -1 as delimiter skips the whole line, and always returns FALSE.
8700 // trailing delimiter is always skipped.
8701 // result is on the data stack.
8703 //==========================================================================
8704 void ufoCallParseIntr (uint32_t delim, int skipLeading) {
8705 ufoPush(delim); ufoPushBool(skipLeading);
8706 UFCALL(PAR_PARSE);
8709 //==========================================================================
8711 // ufoCallParseName
8713 // ( -- addr count )
8714 // parse with leading blanks skipping. doesn't copy anything.
8715 // return empty string on EOL.
8717 //==========================================================================
8718 void ufoCallParseName (void) {
8719 UFCALL(PARSE_NAME);
8723 //==========================================================================
8725 // ufoCallParse
8727 // ( -- addr count TRUE / FALSE )
8728 // parse without skipping delimiters; never copies anything.
8729 // as our reader is line-based, returns FALSE on EOL.
8730 // passing 0 as delimiter skips the whole line, and always returns FALSE.
8731 // trailing delimiter is always skipped.
8733 //==========================================================================
8734 void ufoCallParse (uint32_t delim) {
8735 ufoPush(delim);
8736 UFCALL(PARSE);
8740 //==========================================================================
8742 // ufoCallParseSkipBlanks
8744 //==========================================================================
8745 void ufoCallParseSkipBlanks (void) {
8746 UFCALL(PARSE_SKIP_BLANKS);
8750 //==========================================================================
8752 // ufoCallParseSkipComments
8754 //==========================================================================
8755 void ufoCallParseSkipComments (void) {
8756 ufoPushBool(1); UFCALL(PAR_PARSE_SKIP_COMMENTS);
8760 //==========================================================================
8762 // ufoCallParseSkipLineComments
8764 //==========================================================================
8765 void ufoCallParseSkipLineComments (void) {
8766 ufoPushBool(0); UFCALL(PAR_PARSE_SKIP_COMMENTS);
8770 //==========================================================================
8772 // ufoCallParseSkipLine
8774 // to the end of line; doesn't refill
8776 //==========================================================================
8777 void ufoCallParseSkipLine (void) {
8778 UFCALL(PARSE_SKIP_LINE);
8782 //==========================================================================
8784 // ufoCallBasedNumber
8786 // convert number from addrl+1
8787 // returns address of the first inconvertible char
8788 // (BASED-NUMBER) ( addr count allowsign? base -- num TRUE / FALSE )
8790 //==========================================================================
8791 void ufoCallBasedNumber (uint32_t addr, uint32_t count, int allowSign, int base) {
8792 ufoPush(addr); ufoPush(count); ufoPushBool(allowSign);
8793 if (base < 0) ufoPush(0); else ufoPush((uint32_t)base);
8794 UFCALL(PAR_BASED_NUMBER);
8798 //==========================================================================
8800 // ufoRunWord
8802 //==========================================================================
8803 void ufoRunWord (uint32_t cfa) {
8804 if (cfa != 0) {
8805 if (ufoMode == UFO_MODE_NONE) ufoFatal("UrForth is not properly inited");
8806 if (ufoInRunWord) ufoFatal("`ufoRunWord` cannot be called recursively");
8807 ufoMode = UFO_MODE_NATIVE;
8808 ufoInRunWord = 1;
8809 ufoRunVMCFA(cfa);
8810 ufoInRunWord = 0;
8815 //==========================================================================
8817 // ufoRunMacroWord
8819 //==========================================================================
8820 void ufoRunMacroWord (uint32_t cfa) {
8821 if (cfa != 0) {
8822 if (ufoMode == UFO_MODE_NONE) ufoFatal("UrForth is not properly inited");
8823 if (ufoInRunWord) ufoFatal("`ufoRunWord` cannot be called recursively");
8824 ufoMode = UFO_MODE_MACRO;
8825 const uint32_t oisp = ufoFileStackPos;
8826 ufoPushInFile();
8827 ufoFileId = 0;
8828 (void)ufoLoadNextUserLine();
8829 ufoInRunWord = 1;
8830 ufoRunVMCFA(cfa);
8831 ufoInRunWord = 0;
8832 ufoPopInFile();
8833 ufo_assert(ufoFileStackPos == oisp); // sanity check
8838 //==========================================================================
8840 // ufoIsInMacroMode
8842 // check if we are currently in "MACRO" mode.
8843 // should be called from registered words.
8845 //==========================================================================
8846 int ufoIsInMacroMode (void) {
8847 return (ufoMode == UFO_MODE_MACRO);
8851 //==========================================================================
8853 // ufoRunInterpretLoop
8855 // run default interpret loop.
8857 //==========================================================================
8858 void ufoRunInterpretLoop (void) {
8859 if (ufoMode == UFO_MODE_NONE) {
8860 ufoInit();
8862 const uint32_t cfa = ufoFindWord("RUN-INTERPRET-LOOP");
8863 if (cfa == 0) ufoFatal("'RUN-INTERPRET-LOOP' word not found");
8864 ufoReset();
8865 ufoMode = UFO_MODE_NATIVE;
8866 ufoInRunWord = 1;
8867 ufoRunVMCFA(cfa);
8868 ufoInRunWord = 0;
8869 while (ufoFileStackPos != 0) ufoPopInFile();
8873 //==========================================================================
8875 // ufoRunFile
8877 //==========================================================================
8878 void ufoRunFile (const char *fname) {
8879 if (ufoMode == UFO_MODE_NONE) {
8880 ufoInit();
8882 if (ufoInRunWord) ufoFatal("`ufoRunFile` cannot be called recursively");
8883 ufoMode = UFO_MODE_NATIVE;
8885 ufoReset();
8886 char *ufmname = ufoCreateIncludeName(fname, 0, ".");
8887 #ifdef WIN32
8888 FILE *ufl = fopen(ufmname, "rb");
8889 #else
8890 FILE *ufl = fopen(ufmname, "r");
8891 #endif
8892 if (ufl) {
8893 ufoPushInFile();
8894 ufoSetInFileNameReuse(ufmname);
8895 ufoInFile = ufl;
8896 ufoFileId = ufoLastUsedFileId;
8897 setLastIncPath(ufoInFileName, 0);
8898 } else {
8899 free(ufmname);
8900 ufoFatal("cannot load source file '%s'", fname);
8902 ufoRunInterpretLoop();