UrForth: more words
[urasm.git] / src / liburforth / urforth.c
blob0381f18125ad47fb06da7c4f4a0758569e2b92b5
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: *UNUSED* unsigned byte
261 ;; 9: *UNUSED* signed byte
262 ;; 10: *UNUSED* unsigned word
263 ;; 11: *UNUSED* signed word
266 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
267 ;; wordlist structure (at PFA)
268 ;; -4: wordlist type id (used by structs, for example)
269 ;; dd latest
270 ;; dd voclink (voclink always points here)
271 ;; dd parent (if not zero, all parent words are visible)
272 ;; dd header-nfa (can be 0 for anonymous wordlists)
273 ;; hashtable (if enabled), or ~0U if no hash table
277 // ////////////////////////////////////////////////////////////////////////// //
278 #define UFO_BFA_TO_LFA(bfa_) ((bfa_) + 1u * 4u)
279 #define UFO_LFA_TO_XFA(lfa_) ((lfa_) - 3u * 4u)
280 #define UFO_LFA_TO_YFA(lfa_) ((lfa_) - 2u * 4u)
281 #define UFO_LFA_TO_BFA(lfa_) ((lfa_) - 1u * 4u)
282 #define UFO_LFA_TO_NFA(lfa_) ((lfa_) + 2u * 4u)
283 #define UFO_LFA_TO_CFA(lfa_) UFO_ALIGN4((lfa_) + 3u * 4u + 1u + ufoImgGetU8((lfa_) + 2u * 4u))
284 #define UFO_LFA_TO_NHASH(lfa_) ((lfa_) + 1u * 4u)
285 #define UFO_CFA_TO_NFA(cfa_) ((cfa_) - 1u - 4u - ufoImgGetU8((cfa_) - 1u))
286 #define UFO_CFA_TO_LFA(cfa_) ((cfa_) - 1u - 4u * 3u - ufoImgGetU8((cfa_) - 1u))
287 #define UFO_CFA_TO_PFA(cfa_) ((cfa_) + 1u * 4u)
288 #define UFO_PFA_TO_CFA(pfa_) ((pfa_) - 1u * 4u)
289 #define UFO_NFA_TO_CFA(nfa_) UFO_ALIGN4((nfa_) + 4u + 1u + ufoImgGetU8((nfa_)))
290 #define UFO_NFA_TO_LFA(nfa_) ((nfa_) - 2u * 4u)
291 #define UFO_XFA_TO_YFA(xfa_) ((xfa_) + 4u)
292 #define UFO_YFA_TO_XFA(yfa_) ((xfa_) - 4u)
293 #define UFO_XFA_TO_WST(xfa_) ((xfa_) - 4u)
294 #define UFO_YFA_TO_WST(yfa_) ((yfa_) - 2u * 4u)
295 #define UFO_YFA_TO_NFA(yfa_) ((yfa_) + 4u * 4u)
298 // ////////////////////////////////////////////////////////////////////////// //
299 //#define UFW_WARG_U8 (8u<<8)
300 //#define UFW_WARG_S8 (9u<<8)
301 //#define UFW_WARG_U16 (10u<<8)
302 //#define UFW_WARG_S16 (11u<<8)
304 #define UFW_VOCAB_OFS_LATEST (0u * 4u)
305 #define UFW_VOCAB_OFS_VOCLINK (1u * 4u)
306 #define UFW_VOCAB_OFS_PARENT (2u * 4u)
307 #define UFW_VOCAB_OFS_HEADER (3u * 4u)
308 #define UFW_VOCAB_OFS_HTABLE (4u * 4u)
310 #define UFO_HASHTABLE_SIZE (256)
312 #define UFO_NO_HTABLE_FLAG (~(uint32_t)0)
314 #define UFO_MAX_NATIVE_CFAS (1024u)
315 static ufoNativeCFA *ufoForthCFAs = NULL;
316 static uint32_t ufoCFAsUsed = 0;
318 static uint32_t ufoDoForthCFA;
319 static uint32_t ufoDoVariableCFA;
320 static uint32_t ufoDoValueCFA;
321 static uint32_t ufoDoConstCFA;
322 static uint32_t ufoDoDeferCFA;
323 static uint32_t ufoDoVocCFA;
324 static uint32_t ufoDoCreateCFA;
325 static uint32_t ufoDoUserVariableCFA;
327 static uint32_t ufoLitStr8CFA;
329 // special address types:
330 #define UFO_ADDR_CFA_BIT ((uint32_t)1<<31)
331 #define UFO_ADDR_CFA_MASK (UFO_ADDR_CFA_BIT-1u)
333 // handles are somewhat special: first 12 bits can be used as offset for "@", and are ignored
334 #define UFO_ADDR_HANDLE_BIT ((uint32_t)1<<30)
335 #define UFO_ADDR_HANDLE_MASK ((UFO_ADDR_HANDLE_BIT-1u)&~((uint32_t)0xfff))
336 #define UFO_ADDR_HANDLE_SHIFT (12)
337 #define UFO_ADDR_HANDLE_OFS_MASK ((uint32_t)((1 << UFO_ADDR_HANDLE_SHIFT) - 1))
339 // temporary area is 1MB buffer out of the main image
340 #define UFO_ADDR_TEMP_BIT ((uint32_t)1<<29)
341 #define UFO_ADDR_TEMP_MASK (UFO_ADDR_TEMP_BIT-1u)
343 #define UFO_ADDR_SPECIAL_BITS_MASK (UFO_ADDR_CFA_BIT|UFO_ADDR_HANDLE_BIT|UFO_ADDR_TEMP_BIT)
346 static uint32_t *ufoImage = NULL;
347 static uint32_t ufoImageSize = 0;
349 static uint8_t *ufoDebugImage = NULL;
350 static uint32_t ufoDebugImageUsed = 0; // in bytes
351 static uint32_t ufoDebugImageSize = 0; // in bytes
352 static uint32_t ufoDebugFileNameHash = 0; // current file name hash
353 static uint32_t ufoDebugFileNameLen = 0; // current file name length
354 static uint32_t ufoDebugLastLine = 0;
355 static uint32_t ufoDebugLastLinePCOfs = 0;
356 static uint32_t ufoDebugLastLineDP = 0;
357 static uint32_t ufoDebugCurrDP = 0;
359 static uint32_t ufoInRunWord = 0;
361 static volatile int ufoVMAbort = 0;
362 static volatile int ufoVMStop = 0;
364 #define ufoTrueValue (~(uint32_t)0)
366 enum {
367 UFO_MODE_NONE = -1,
368 UFO_MODE_NATIVE = 0, // executing forth code
369 UFO_MODE_MACRO = 1, // executing forth asm macro
371 static uint32_t ufoMode = UFO_MODE_NONE;
373 #define UFO_DSTACK_SIZE (8192)
374 #define UFO_RSTACK_SIZE (4096)
375 #define UFO_LSTACK_SIZE (4096)
376 #define UFO_MAX_TASK_NAME (127)
377 #define UFO_VOCSTACK_SIZE (16u)
379 // to support multitasking (required for the debugger),
380 // our virtual machine state is encapsulated in a struct.
381 typedef struct UfoState_t {
382 uint32_t id;
383 uint32_t dStack[UFO_DSTACK_SIZE];
384 uint32_t rStack[UFO_RSTACK_SIZE];
385 uint32_t lStack[UFO_LSTACK_SIZE];
386 uint32_t IP; // in image
387 uint32_t SP; // points AFTER the last value pushed
388 uint32_t RP; // points AFTER the last value pushed
389 uint32_t RPTop; // stop when RP is this
390 // address register
391 uint32_t regA;
392 // for locals
393 uint32_t LP;
394 uint32_t LBP;
395 uint32_t vmRPopCFA;
396 // vocstack
397 uint32_t vocStack[UFO_VOCSTACK_SIZE]; // cfas
398 uint32_t VSP;
399 // temp image
400 uint32_t *imageTemp;
401 uint32_t imageTempSize;
402 // linked list of all allocated states (tasks)
403 char name[UFO_MAX_TASK_NAME + 1];
404 } UfoState;
406 // 'cmon!
407 #define UFO_MAX_STATES (8192)
409 // this is indexed by id
410 static UfoState *ufoStateMap[UFO_MAX_STATES] = {NULL};
411 static uint32_t ufoStateUsedBitmap[UFO_MAX_STATES/32] = {0};
413 // currently active execution state
414 static UfoState *ufoCurrState = NULL;
415 // state we're yielded from
416 static UfoState *ufoYieldedState = NULL;
417 // if debug state is not NULL, VM will switch to it
418 // after executing one instruction from the current state.
419 // it will store current state in `ufoDebugeeState`.
420 static UfoState *ufoDebuggerState = NULL;
421 static uint32_t ufoSingleStep = 0;
423 #define ufoDStack (ufoCurrState->dStack)
424 #define ufoRStack (ufoCurrState->rStack)
425 #define ufoLStack (ufoCurrState->lStack)
426 #define ufoIP (ufoCurrState->IP)
427 #define ufoSP (ufoCurrState->SP)
428 #define ufoRP (ufoCurrState->RP)
429 #define ufoRPTop (ufoCurrState->RPTop)
430 #define ufoLP (ufoCurrState->LP)
431 #define ufoLBP (ufoCurrState->LBP)
432 #define ufoRegA (ufoCurrState->regA)
433 #define ufoImageTemp (ufoCurrState->imageTemp)
434 #define ufoImageTempSize (ufoCurrState->imageTempSize)
435 #define ufoVMRPopCFA (ufoCurrState->vmRPopCFA)
436 #define ufoVocStack (ufoCurrState->vocStack)
437 #define ufoVSP (ufoCurrState->VSP)
439 // 256 bytes for user variables
440 #define UFO_USER_AREA_ADDR UFO_ADDR_TEMP_BIT
441 #define UFO_USER_AREA_SIZE (256u)
442 #define UFO_NBUF_ADDR UFO_USER_AREA_ADDR + UFO_USER_AREA_SIZE
443 #define UFO_NBUF_SIZE (256u)
444 #define UFO_PAD_ADDR (UFO_NBUF_ADDR + UFO_NBUF_SIZE)
445 #define UFO_DEF_TIB_ADDR (UFO_PAD_ADDR + 2048u)
447 // dynamically allocated text input buffer
448 // always ends with zero (this is word name too)
449 static const uint32_t ufoAddrTIBx = UFO_ADDR_TEMP_BIT + 0u * 4u; // TIB
450 static const uint32_t ufoAddrINx = UFO_ADDR_TEMP_BIT + 1u * 4u; // >IN
451 static const uint32_t ufoAddrDefTIB = UFO_ADDR_TEMP_BIT + 2u * 4u; // default TIB (handle); user cannot change it
452 static const uint32_t ufoAddrBASE = UFO_ADDR_TEMP_BIT + 3u * 4u;
453 static const uint32_t ufoAddrSTATE = UFO_ADDR_TEMP_BIT + 4u * 4u;
454 static const uint32_t ufoAddrContext = UFO_ADDR_TEMP_BIT + 5u * 4u; // CONTEXT
455 static const uint32_t ufoAddrCurrent = UFO_ADDR_TEMP_BIT + 6u * 4u; // CURRENT (definitions will go there)
456 static const uint32_t ufoAddrSelf = UFO_ADDR_TEMP_BIT + 7u * 4u; // CURRENT (definitions will go there)
457 static const uint32_t ufoAddrInterNextLine = UFO_ADDR_TEMP_BIT + 8u * 4u; // (INTERPRET-NEXT-LINE)
458 static const uint32_t ufoAddrEP = UFO_ADDR_TEMP_BIT + 9u * 4u; // (EP) -- exception frame pointer
459 static const uint32_t ufoAddrUserVarUsed = UFO_ADDR_TEMP_BIT + 10u * 4u;
461 static uint32_t ufoAddrVocLink;
462 static uint32_t ufoAddrDP;
463 static uint32_t ufoAddrDPTemp;
464 static uint32_t ufoAddrNewWordFlags;
465 static uint32_t ufoAddrRedefineWarning;
466 static uint32_t ufoAddrLastXFA;
468 static uint32_t ufoForthVocId;
469 static uint32_t ufoCompilerVocId;
470 static uint32_t ufoInterpNextLineCFA;
472 // allows to redefine even protected words
473 #define UFO_REDEF_WARN_DONT_CARE (~(uint32_t)0)
474 // do not warn about ordinary words, allow others
475 #define UFO_REDEF_WARN_NONE (0)
476 // do warn (or fail on protected)
477 #define UFO_REDEF_WARN_NORMAL (1)
478 // do warn (or fail on protected) for parent dicts too
479 #define UFO_REDEF_WARN_PARENTS (2)
481 #define UFO_GET_DP() (ufoImgGetU32(ufoAddrDPTemp) ?: ufoImgGetU32(ufoAddrDP))
482 //#define UFO_SET_DP(val_) ufoImgPutU32(ufoAddrDP, (val_))
484 #define UFO_MAX_NESTED_INCLUDES (32)
485 typedef struct {
486 FILE *fl;
487 char *fname;
488 char *incpath;
489 char *sysincpath;
490 int fline;
491 uint32_t id; // non-zero unique id
492 } UFOFileStackEntry;
494 static UFOFileStackEntry ufoFileStack[UFO_MAX_NESTED_INCLUDES];
495 static uint32_t ufoFileStackPos; // after the last used item
497 static FILE *ufoInFile = NULL;
498 static uint32_t ufoInFileNameLen = 0;
499 static uint32_t ufoInFileNameHash = 0;
500 static char *ufoInFileName = NULL;
501 static char *ufoLastIncPath = NULL;
502 static char *ufoLastSysIncPath = NULL;
503 static int ufoInFileLine = 0;
504 static uint32_t ufoFileId = 0;
505 static uint32_t ufoLastUsedFileId = 0;
506 static int ufoLastEmitWasCR = 1;
508 // dynamic memory handles
509 typedef struct UHandleInfo_t {
510 uint32_t ufoHandle;
511 uint32_t typeid;
512 uint8_t *data;
513 uint32_t size;
514 uint32_t used;
515 // in free list
516 struct UHandleInfo_t *next;
517 } UfoHandle;
519 static UfoHandle *ufoHandleFreeList = NULL;
520 static UfoHandle **ufoHandles = NULL;
521 static uint32_t ufoHandlesUsed = 0;
522 static uint32_t ufoHandlesAlloted = 0;
524 #define UFO_HANDLE_FREE (~(uint32_t)0)
526 static char ufoCurrFileLine[520];
528 // for `ufoFatal()`
529 static uint32_t ufoInBacktrace = 0;
532 // ////////////////////////////////////////////////////////////////////////// //
533 static void ufoClearCondDefines (void);
535 static void ufoRunVMCFA (uint32_t cfa);
537 static void ufoBacktrace (uint32_t ip, int showDataStack);
539 static void ufoClearCondDefines (void);
541 static UfoState *ufoNewState (void);
542 static void ufoInitStateUserVars (UfoState *st, uint32_t cfa);
543 static void ufoFreeState (UfoState *st);
544 static UfoState *ufoFindState (uint32_t stid);
545 static void ufoSwitchToState (UfoState *newst);
547 __attribute__((unused)) static void ufoDumpWordHeader (const uint32_t lfa);
549 #ifndef WIN32
550 static void ufoDisableRaw (void);
551 static void ufoTTYRawFlush (void);
552 #endif
553 static int ufoIsGoodTTY (void);
555 #ifdef UFO_DEBUG_DEBUG
556 static void ufoDumpDebugImage (void);
557 #endif
560 // ////////////////////////////////////////////////////////////////////////// //
561 #define UFWORD(name_) \
562 static void ufoWord_##name_ (uint32_t mypfa)
564 #define UFCALL(name_) ufoWord_##name_(0)
565 #define UFCFA(name_) (&ufoWord_##name_)
567 // for TIB words
568 UFWORD(CPEEK_REGA_IDX);
569 UFWORD(CPOKE_REGA_IDX);
571 // for peek and poke
572 UFWORD(PAR_HANDLE_LOAD_BYTE);
573 UFWORD(PAR_HANDLE_LOAD_WORD);
574 UFWORD(PAR_HANDLE_LOAD_CELL);
575 UFWORD(PAR_HANDLE_STORE_BYTE);
576 UFWORD(PAR_HANDLE_STORE_WORD);
577 UFWORD(PAR_HANDLE_STORE_CELL);
580 //==========================================================================
582 // ufoFlushOutput
584 //==========================================================================
585 static void ufoFlushOutput (void) {
586 #ifndef WIN32
587 ufoTTYRawFlush();
588 #endif
589 fflush(NULL);
593 //==========================================================================
595 // ufoSetInFileName
597 // if `reuse` is not 0, reuse/free `fname`
599 //==========================================================================
600 static void ufoSetInFileNameEx (const char *fname, int reuse) {
601 ufo_assert(fname == NULL || (fname != ufoInFileName));
602 if (fname == NULL || fname[0] == 0) {
603 if (ufoInFileName) { free(ufoInFileName); ufoInFileName = NULL; }
604 ufoInFileNameLen = 0;
605 ufoInFileNameHash = 0;
606 if (reuse && fname != NULL) free((void *)fname);
607 } else {
608 const uint32_t fnlen = (uint32_t)strlen(fname);
609 const uint32_t fnhash = joaatHashBuf(fname, fnlen, 0);
610 if (ufoInFileNameLen != fnlen || ufoInFileNameHash != fnhash) {
611 if (ufoInFileName) { free(ufoInFileName); ufoInFileName = NULL; }
612 if (reuse) {
613 ufoInFileName = (char *)fname;
614 } else {
615 ufoInFileName = strdup(fname);
616 if (ufoInFileName == NULL) ufoFatal("out of memory for filename info");
618 ufoInFileNameLen = fnlen;
619 ufoInFileNameHash = fnhash;
620 } else {
621 if (reuse && fname != NULL) free((void *)fname);
627 //==========================================================================
629 // ufoSetInFileName
631 //==========================================================================
632 UFO_FORCE_INLINE void ufoSetInFileName (const char *fname) {
633 ufoSetInFileNameEx(fname, 0);
637 //==========================================================================
639 // ufoSetInFileNameReuse
641 //==========================================================================
642 UFO_FORCE_INLINE void ufoSetInFileNameReuse (const char *fname) {
643 ufoSetInFileNameEx(fname, 1);
647 //==========================================================================
649 // ufoSetUserAbort
651 //==========================================================================
652 void ufoSetUserAbort (void) {
653 ufoVMAbort = 1;
657 //==========================================================================
659 // ufoAllocHandle
661 //==========================================================================
662 static UfoHandle *ufoAllocHandle (uint32_t typeid) {
663 ufo_assert(typeid != UFO_HANDLE_FREE);
664 UfoHandle *newh = ufoHandleFreeList;
665 if (newh == NULL) {
666 if (ufoHandlesUsed == ufoHandlesAlloted) {
667 uint32_t newsz = ufoHandlesAlloted + 16384;
668 // due to offsets, this is the maximum number of handles we can have
669 if (newsz > 0x1ffffU) {
670 if (ufoHandlesAlloted > 0x1ffffU) ufoFatal("too many dynamic handles");
671 newsz = 0x1ffffU + 1U;
672 ufo_assert(newsz > ufoHandlesAlloted);
674 UfoHandle **nh = realloc(ufoHandles, sizeof(ufoHandles[0]) * newsz);
675 if (nh == NULL) ufoFatal("out of memory for handle table");
676 ufoHandles = nh;
677 ufoHandlesAlloted = newsz;
679 newh = calloc(1, sizeof(UfoHandle));
680 if (newh == NULL) ufoFatal("out of memory for handle info");
681 ufoHandles[ufoHandlesUsed] = newh;
682 // setup new handle info
683 newh->ufoHandle = (ufoHandlesUsed << UFO_ADDR_HANDLE_SHIFT) | UFO_ADDR_HANDLE_BIT;
684 ufoHandlesUsed += 1;
685 } else {
686 ufo_assert(newh->typeid == UFO_HANDLE_FREE);
687 ufoHandleFreeList = newh->next;
689 // setup new handle info
690 newh->typeid = typeid;
691 newh->data = NULL;
692 newh->size = 0;
693 newh->used = 0;
694 newh->next = NULL;
695 return newh;
699 //==========================================================================
701 // ufoFreeHandle
703 //==========================================================================
704 static void ufoFreeHandle (UfoHandle *hh) {
705 if (hh != NULL) {
706 ufo_assert(hh->typeid != UFO_HANDLE_FREE);
707 if (hh->data) free(hh->data);
708 hh->typeid = UFO_HANDLE_FREE;
709 hh->data = NULL;
710 hh->size = 0;
711 hh->used = 0;
712 hh->next = ufoHandleFreeList;
713 ufoHandleFreeList = hh;
718 //==========================================================================
720 // ufoGetHandle
722 //==========================================================================
723 static UfoHandle *ufoGetHandle (uint32_t hh) {
724 UfoHandle *res;
725 if (hh != 0 && (hh & UFO_ADDR_HANDLE_BIT) != 0) {
726 hh = (hh & UFO_ADDR_HANDLE_MASK) >> UFO_ADDR_HANDLE_SHIFT;
727 if (hh < ufoHandlesUsed) {
728 res = ufoHandles[hh];
729 if (res->typeid == UFO_HANDLE_FREE) res = NULL;
730 } else {
731 res = NULL;
733 } else {
734 res = NULL;
736 return res;
740 //==========================================================================
742 // setLastIncPath
744 //==========================================================================
745 static void setLastIncPath (const char *fname, int system) {
746 if (fname == NULL || fname[0] == 0) {
747 if (system) {
748 if (ufoLastSysIncPath) free(ufoLastIncPath);
749 ufoLastSysIncPath = NULL;
750 } else {
751 if (ufoLastIncPath) free(ufoLastIncPath);
752 ufoLastIncPath = strdup(".");
754 } else {
755 char *lslash;
756 char *cpos;
757 if (system) {
758 if (ufoLastSysIncPath) free(ufoLastSysIncPath);
759 ufoLastSysIncPath = strdup(fname);
760 lslash = ufoLastSysIncPath;
761 cpos = ufoLastSysIncPath;
762 } else {
763 if (ufoLastIncPath) free(ufoLastIncPath);
764 ufoLastIncPath = strdup(fname);
765 lslash = ufoLastIncPath;
766 cpos = ufoLastIncPath;
768 while (*cpos) {
769 #ifdef WIN32
770 if (*cpos == '/' || *cpos == '\\') lslash = cpos;
771 #else
772 if (*cpos == '/') lslash = cpos;
773 #endif
774 cpos += 1;
776 *lslash = 0;
781 //==========================================================================
783 // ufoClearIncludePath
785 // required for UrAsm
787 //==========================================================================
788 void ufoClearIncludePath (void) {
789 if (ufoLastIncPath != NULL) {
790 free(ufoLastIncPath);
791 ufoLastIncPath = NULL;
793 if (ufoLastSysIncPath != NULL) {
794 free(ufoLastSysIncPath);
795 ufoLastSysIncPath = NULL;
800 //==========================================================================
802 // ufoErrorPrintFile
804 //==========================================================================
805 static void ufoErrorPrintFile (FILE *fo, const char *errwarn) {
806 if (ufoInFileName != NULL) {
807 fprintf(fo, "UFO %s at file %s, line %d: ", errwarn, ufoInFileName, ufoInFileLine);
808 } else {
809 fprintf(fo, "UFO %s somewhere in time: ", errwarn);
814 //==========================================================================
816 // ufoErrorMsgV
818 //==========================================================================
819 static void ufoErrorMsgV (const char *errwarn, const char *fmt, va_list ap) {
820 ufoFlushOutput();
821 if (!ufoLastEmitWasCR) { printf("\n"); ufoLastEmitWasCR = 1; }
822 ufoErrorPrintFile(stderr, errwarn);
823 vfprintf(stderr, fmt, ap);
824 va_end(ap);
825 fputc('\n', stderr);
826 ufoFlushOutput();
830 //==========================================================================
832 // ufoWarning
834 //==========================================================================
835 __attribute__((format(printf, 1, 2)))
836 void ufoWarning (const char *fmt, ...) {
837 va_list ap;
838 va_start(ap, fmt);
839 ufoErrorMsgV("WARNING", fmt, ap);
843 //==========================================================================
845 // ufoFatal
847 //==========================================================================
848 __attribute__((noreturn)) __attribute__((format(printf, 1, 2)))
849 void ufoFatal (const char *fmt, ...) {
850 va_list ap;
851 #ifndef WIN32
852 ufoDisableRaw();
853 #endif
854 va_start(ap, fmt);
855 ufoErrorMsgV("ERROR", fmt, ap);
856 if (!ufoInBacktrace) {
857 ufoInBacktrace = 1;
858 ufoBacktrace(ufoIP, 1);
859 ufoInBacktrace = 0;
860 } else {
861 fprintf(stderr, "DOUBLE FATAL: error in backtrace!\n");
862 abort();
864 #ifdef UFO_DEBUG_FATAL_ABORT
865 abort();
866 #endif
867 ufoFatalError();
871 // ////////////////////////////////////////////////////////////////////////// //
872 // working with the stacks
873 UFO_FORCE_INLINE void ufoPush (uint32_t v) { if (ufoSP >= UFO_DSTACK_SIZE) ufoFatal("data stack overflow"); ufoDStack[ufoSP++] = v; }
874 UFO_FORCE_INLINE void ufoDrop (void) { if (ufoSP == 0) ufoFatal("data stack underflow"); --ufoSP; }
875 UFO_FORCE_INLINE uint32_t ufoPop (void) { if (ufoSP == 0) { ufoFatal("data stack underflow"); } return ufoDStack[--ufoSP]; }
876 UFO_FORCE_INLINE uint32_t ufoPeek (void) { if (ufoSP == 0) ufoFatal("data stack underflow"); return ufoDStack[ufoSP-1u]; }
877 UFO_FORCE_INLINE void ufoDup (void) { if (ufoSP == 0) ufoFatal("data stack underflow"); ufoPush(ufoDStack[ufoSP-1u]); }
878 UFO_FORCE_INLINE void ufoOver (void) { if (ufoSP < 2u) ufoFatal("data stack underflow"); ufoPush(ufoDStack[ufoSP-2u]); }
879 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; }
880 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; }
881 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; }
883 UFO_FORCE_INLINE void ufo2Dup (void) { ufoOver(); ufoOver(); }
884 UFO_FORCE_INLINE void ufo2Drop (void) { ufoDrop(); ufoDrop(); }
885 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); }
886 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; }
888 UFO_FORCE_INLINE void ufoRPush (uint32_t v) { if (ufoRP >= UFO_RSTACK_SIZE) ufoFatal("return stack overflow"); ufoRStack[ufoRP++] = v; }
889 UFO_FORCE_INLINE void ufoRDrop (void) { if (ufoRP == 0 || ufoRP == ufoRPTop) ufoFatal("return stack underflow"); --ufoRP; }
890 UFO_FORCE_INLINE uint32_t ufoRPop (void) { if (ufoRP == 0 || ufoRP == ufoRPTop) ufoFatal("return stack underflow"); return ufoRStack[--ufoRP]; }
891 UFO_FORCE_INLINE uint32_t ufoRPeek (void) { if (ufoRP == 0 || ufoRP == ufoRPTop) ufoFatal("return stack underflow"); return ufoRStack[ufoRP-1u]; }
892 UFO_FORCE_INLINE void ufoRDup (void) { if (ufoRP == 0 || ufoRP == ufoRPTop) ufoFatal("return stack underflow"); ufoPush(ufoRStack[ufoRP-1u]); }
894 UFO_FORCE_INLINE void ufoPushBool (int v) { ufoPush(v ? ufoTrueValue : 0u); }
897 //==========================================================================
899 // ufoImgEnsureSize
901 //==========================================================================
902 static void ufoImgEnsureSize (uint32_t addr) {
903 if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) != 0) ufoFatal("ufoImgEnsureSize: internal error");
904 if (addr >= ufoImageSize) {
905 // 64MB should be enough for everyone!
906 if (addr >= 0x04000000U) {
907 ufoFatal("image grown too big (addr=0%08XH)", addr);
909 const const uint32_t osz = ufoImageSize;
910 // grow by 1MB steps
911 const uint32_t nsz = (addr|0x000fffffU) + 1U;
912 ufo_assert(nsz > addr);
913 uint32_t *nimg = realloc(ufoImage, nsz);
914 if (nimg == NULL) {
915 ufoFatal("out of memory for UFO image (%u -> %u MBs)",
916 ufoImageSize / 1024u / 1024u,
917 nsz / 1024u / 1024u);
919 ufoImage = nimg;
920 ufoImageSize = nsz;
921 memset((char *)ufoImage + osz, 0, (nsz - osz));
926 //==========================================================================
928 // ufoImgEnsureTemp
930 //==========================================================================
931 static void ufoImgEnsureTemp (uint32_t addr) {
932 if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) != 0) ufoFatal("ufoImgEnsureTemp: internal error");
933 if (addr >= ufoImageTempSize) {
934 if (addr >= 1024u * 1024u) {
935 ufoFatal("Forth segmentation fault at address 0x%08X", addr | UFO_ADDR_TEMP_BIT);
937 const uint32_t osz = ufoImageTempSize;
938 // grow by 8KB steps
939 const uint32_t nsz = (addr|0x00001fffU) + 1U;
940 uint32_t *nimg = realloc(ufoImageTemp, nsz);
941 if (nimg == NULL) {
942 ufoFatal("out of memory for temp UFO image (%u -> %u KBs)",
943 ufoImageTempSize / 1024u,
944 nsz / 1024u);
946 ufoImageTemp = nimg;
947 ufoImageTempSize = nsz;
948 memset((char *)ufoImageTemp + osz, 0, (nsz - osz));
953 #ifdef UFO_FAST_MEM_ACCESS
954 //==========================================================================
956 // ufoImgPutU8
958 // fast
960 //==========================================================================
961 UFO_FORCE_INLINE void ufoImgPutU8 (uint32_t addr, const uint32_t value) {
962 if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
963 if (addr >= ufoImageSize) ufoImgEnsureSize(addr);
964 *((uint8_t *)ufoImage + addr) = (uint8_t)value;
965 } else if (addr & UFO_ADDR_TEMP_BIT) {
966 addr &= UFO_ADDR_TEMP_MASK;
967 if (addr >= ufoImageTempSize) ufoImgEnsureTemp(addr);
968 *((uint8_t *)ufoImageTemp + addr) = (uint8_t)value;
969 } else {
970 ufoFatal("Forth segmentation fault at address 0x%08X", addr);
975 //==========================================================================
977 // ufoImgPutU16
979 // fast
981 //==========================================================================
982 UFO_FORCE_INLINE void ufoImgPutU16 (uint32_t addr, const uint32_t value) {
983 if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
984 if (addr + 1u >= ufoImageSize) ufoImgEnsureSize(addr + 1u);
985 *(uint16_t *)((uint8_t *)ufoImage + addr) = (uint16_t)value;
986 } else if (addr & UFO_ADDR_TEMP_BIT) {
987 addr &= UFO_ADDR_TEMP_MASK;
988 if (addr + 1u >= ufoImageTempSize) ufoImgEnsureTemp(addr + 1u);
989 *(uint16_t *)((uint8_t *)ufoImageTemp + addr) = (uint16_t)value;
990 } else {
991 ufoFatal("Forth segmentation fault at address 0x%08X", addr);
996 //==========================================================================
998 // ufoImgPutU32
1000 // fast
1002 //==========================================================================
1003 UFO_FORCE_INLINE void ufoImgPutU32 (uint32_t addr, const uint32_t value) {
1004 if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
1005 if (addr + 3u >= ufoImageSize) ufoImgEnsureSize(addr + 3u);
1006 *(uint32_t *)((uint8_t *)ufoImage + addr) = value;
1007 } else if (addr & UFO_ADDR_TEMP_BIT) {
1008 addr &= UFO_ADDR_TEMP_MASK;
1009 if (addr + 3u >= ufoImageTempSize) ufoImgEnsureTemp(addr + 3u);
1010 *(uint32_t *)((uint8_t *)ufoImageTemp + addr) = value;
1011 } else {
1012 ufoFatal("Forth segmentation fault at address 0x%08X", addr);
1017 //==========================================================================
1019 // ufoImgGetU8
1021 // false
1023 //==========================================================================
1024 UFO_FORCE_INLINE uint32_t ufoImgGetU8 (uint32_t addr) {
1025 if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
1026 if (addr >= ufoImageSize) {
1027 // accessing unallocated image area is segmentation fault
1028 ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr);
1030 return *((const uint8_t *)ufoImage + addr);
1031 } else if (addr & UFO_ADDR_TEMP_BIT) {
1032 addr &= UFO_ADDR_TEMP_MASK;
1033 if (addr >= ufoImageTempSize) {
1034 // accessing unallocated image area is segmentation fault
1035 ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr | UFO_ADDR_TEMP_BIT);
1037 return *((const uint8_t *)ufoImageTemp + addr);
1038 } else {
1039 ufoFatal("Forth segmentation fault at address 0x%08X", addr);
1044 //==========================================================================
1046 // ufoImgGetU16
1048 // fast
1050 //==========================================================================
1051 UFO_FORCE_INLINE uint32_t ufoImgGetU16 (uint32_t addr) {
1052 if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
1053 if (addr + 1u >= ufoImageSize) {
1054 // accessing unallocated image area is segmentation fault
1055 ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr);
1057 return *(const uint16_t *)((const uint8_t *)ufoImage + addr);
1058 } else if (addr & UFO_ADDR_TEMP_BIT) {
1059 addr &= UFO_ADDR_TEMP_MASK;
1060 if (addr + 1u >= ufoImageTempSize) {
1061 // accessing unallocated image area is segmentation fault
1062 ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr | UFO_ADDR_TEMP_BIT);
1064 return *(const uint16_t *)((const uint8_t *)ufoImageTemp + addr);
1065 } else {
1066 ufoFatal("Forth segmentation fault at address 0x%08X", addr);
1071 //==========================================================================
1073 // ufoImgGetU32
1075 // fast
1077 //==========================================================================
1078 UFO_FORCE_INLINE uint32_t ufoImgGetU32 (uint32_t addr) {
1079 if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
1080 if (addr + 3u >= ufoImageSize) {
1081 // accessing unallocated image area is segmentation fault
1082 ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr);
1084 return *(const uint32_t *)((const uint8_t *)ufoImage + addr);
1085 } else if (addr & UFO_ADDR_TEMP_BIT) {
1086 addr &= UFO_ADDR_TEMP_MASK;
1087 if (addr + 3u >= ufoImageTempSize) {
1088 // accessing unallocated image area is segmentation fault
1089 ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr | UFO_ADDR_TEMP_BIT);
1091 return *(const uint32_t *)((const uint8_t *)ufoImageTemp + addr);
1092 } else {
1093 ufoFatal("Forth segmentation fault at address 0x%08X", addr);
1097 #else
1099 //==========================================================================
1101 // ufoImgPutU8
1103 // general
1105 //==========================================================================
1106 UFO_FORCE_INLINE void ufoImgPutU8 (uint32_t addr, const uint32_t value) {
1107 uint32_t *imgptr;
1108 if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
1109 if (addr >= ufoImageSize) ufoImgEnsureSize(addr);
1110 imgptr = &ufoImage[addr/4u];
1111 } else if (addr & UFO_ADDR_TEMP_BIT) {
1112 addr &= UFO_ADDR_TEMP_MASK;
1113 if (addr >= ufoImageTempSize) ufoImgEnsureTemp(addr);
1114 imgptr = &ufoImageTemp[addr/4u];
1115 } else {
1116 ufoFatal("Forth segmentation fault at address 0x%08X", addr);
1118 const uint8_t val = (uint8_t)value;
1119 memcpy((uint8_t *)imgptr + (addr&3), &val, 1);
1123 //==========================================================================
1125 // ufoImgPutU16
1127 // general
1129 //==========================================================================
1130 UFO_FORCE_INLINE void ufoImgPutU16 (uint32_t addr, const uint32_t value) {
1131 ufoImgPutU8(addr, value&0xffU);
1132 ufoImgPutU8(addr + 1u, (value>>8)&0xffU);
1136 //==========================================================================
1138 // ufoImgPutU32
1140 // general
1142 //==========================================================================
1143 UFO_FORCE_INLINE void ufoImgPutU32 (uint32_t addr, const uint32_t value) {
1144 ufoImgPutU16(addr, value&0xffffU);
1145 ufoImgPutU16(addr + 2u, (value>>16)&0xffffU);
1149 //==========================================================================
1151 // ufoImgGetU8
1153 // general
1155 //==========================================================================
1156 UFO_FORCE_INLINE uint32_t ufoImgGetU8 (uint32_t addr) {
1157 uint32_t *imgptr;
1158 if ((addr & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
1159 if (addr >= ufoImageSize) return 0;
1160 imgptr = &ufoImage[addr/4u];
1161 } else if (addr & UFO_ADDR_TEMP_BIT) {
1162 addr &= UFO_ADDR_TEMP_MASK;
1163 if (addr >= ufoImageTempSize) return 0;
1164 imgptr = &ufoImageTemp[addr/4u];
1165 } else {
1166 ufoFatal("Forth segmentation fault at address 0x%08X", addr);
1168 uint8_t val;
1169 memcpy(&val, (uint8_t *)imgptr + (addr&3), 1);
1170 return (uint32_t)val;
1174 //==========================================================================
1176 // ufoImgGetU16
1178 // general
1180 //==========================================================================
1181 UFO_FORCE_INLINE uint32_t ufoImgGetU16 (uint32_t addr) {
1182 return ufoImgGetU8(addr) | (ufoImgGetU8(addr + 1u) << 8);
1186 //==========================================================================
1188 // ufoImgGetU32
1190 // general
1192 //==========================================================================
1193 UFO_FORCE_INLINE uint32_t ufoImgGetU32 (uint32_t addr) {
1194 return ufoImgGetU16(addr) | (ufoImgGetU16(addr + 2u) << 16);
1196 #endif
1199 //==========================================================================
1201 // ufoEnsureDebugSize
1203 //==========================================================================
1204 UFO_DISABLE_INLINE void ufoEnsureDebugSize (uint32_t sdelta) {
1205 ufo_assert(sdelta != 0);
1206 if (ufoDebugImageUsed != 0) {
1207 if (ufoDebugImageUsed + sdelta >= 0x40000000U) ufoFatal("debug info too big");
1208 if (ufoDebugImageUsed + sdelta > ufoDebugImageSize) {
1209 // grow by 32KB, this should be more than enough
1210 const uint32_t newsz = ((ufoDebugImageUsed + sdelta) | 0x7fffU) + 1u;
1211 uint8_t *ndb = realloc(ufoDebugImage, newsz);
1212 if (ndb == NULL) ufoFatal("out of memory for debug info");
1213 ufoDebugImage = ndb;
1214 ufoDebugImageSize = newsz;
1216 } else {
1217 // initial allocation: 32KB, quite a lot
1218 ufoDebugImageSize = 1024 * 32;
1219 ufoDebugImage = malloc(ufoDebugImageSize);
1220 if (ufoDebugImage == NULL) ufoFatal("out of memory for debug info");
1225 #define UFO_DBG_PUT_U4(val_) do { \
1226 const uint32_t vv_ = (val_); \
1227 *((uint32_t *)(ufoDebugImage + ufoDebugImageUsed)) = vv_; \
1228 ufoDebugImageUsed += 4u; \
1229 } while (0)
1233 debug info header:
1234 dd lastFileInfoOfs
1235 ...first line info header...
1236 line info header (or reset):
1237 db 0 ; zero line delta
1238 dw followFileInfoSize ; either it, or 0 if reused
1239 dd fileInfoOfs ; present only if reused
1240 lines:
1241 dv lineDelta
1242 dv pcBytes
1244 file info record:
1245 dd prevFileInfoOfs
1246 dd fileNameHash
1247 dd nameLen ; without terminating 0
1248 ...name... (0-terminated)
1250 we will never compare file names: length and hash should provide
1251 good enough unique identifier.
1253 static uint8_t *ufoDebugImage = NULL;
1254 static uint32_t ufoDebugImageUsed = 0; // in bytes
1255 static uint32_t ufoDebugImageSize = 0; // in bytes
1256 static uint32_t ufoDebugFileNameHash = 0; // current file name hash
1257 static uint32_t ufoDebugFileNameLen = 0; // current file name length
1258 static uint32_t ufoDebugCurrDP = 0;
1262 //==========================================================================
1264 // ufoSkipDebugVarInt
1266 //==========================================================================
1267 static __attribute__((unused)) uint32_t ufoSkipDebugVarInt (uint32_t ofs) {
1268 uint8_t byte;
1269 do {
1270 if (ofs >= ufoDebugImageUsed) ufoFatal("invalid debug data");
1271 byte = ufoDebugImage[ofs]; ofs += 1u;
1272 } while (byte >= 0x80);
1273 return ofs;
1277 //==========================================================================
1279 // ufoCalcDebugVarIntSize
1281 //==========================================================================
1282 UFO_FORCE_INLINE uint8_t ufoCalcDebugVarIntSize (uint32_t v) {
1283 uint8_t count = 0;
1284 do {
1285 count += 1u;
1286 v >>= 7;
1287 } while (v != 0);
1288 return count;
1292 //==========================================================================
1294 // ufoGetDebugVarInt
1296 //==========================================================================
1297 static __attribute__((unused)) uint32_t ufoGetDebugVarInt (uint32_t ofs) {
1298 uint32_t v = 0;
1299 uint8_t shift = 0;
1300 uint8_t byte;
1301 do {
1302 if (ofs >= ufoDebugImageUsed) ufoFatal("invalid debug data");
1303 byte = ufoDebugImage[ofs];
1304 v |= (uint32_t)(byte & 0x7f) << shift;
1305 if (byte >= 0x80) {
1306 shift += 7;
1307 ofs += 1u;
1309 } while (byte >= 0x80);
1310 return v;
1314 //==========================================================================
1316 // ufoPutDebugVarInt
1318 //==========================================================================
1319 UFO_FORCE_INLINE void ufoPutDebugVarInt (uint32_t v) {
1320 ufoEnsureDebugSize(5u); // maximum size
1321 do {
1322 if (v >= 0x80) {
1323 ufoDebugImage[ufoDebugImageUsed] = (uint8_t)(v | 0x80u);
1324 } else {
1325 ufoDebugImage[ufoDebugImageUsed] = (uint8_t)v;
1327 ufoDebugImageUsed += 1;
1328 v >>= 7;
1329 } while (v != 0);
1333 #ifdef UFO_DEBUG_DEBUG
1334 //==========================================================================
1336 // ufoDumpDebugInfo
1338 //==========================================================================
1339 static void ufoDumpDebugImage (void) {
1340 #if 0
1341 uint32_t dbgpos = 4u; // first line header info
1342 uint32_t lastline = 0;
1343 uint32_t lastdp = 0;
1344 while (dbgpos < ufoDebugImageUsed) {
1345 if (ufoDebugImage[dbgpos] == 0) {
1346 // new file info
1347 dbgpos += 1u; // skip flag
1348 const uint32_t fhdrSize = *(const uint16_t *)(ufoDebugImage + dbgpos); dbgpos += 2u;
1349 lastdp = ufoGetDebugVarInt(dbgpos);
1350 dbgpos = ufoSkipDebugVarInt(dbgpos);
1351 if (fhdrSize == 0) {
1352 // reused
1353 const uint32_t infoOfs = *(const uint32_t *)(ufoDebugImage + dbgpos); dbgpos += 4u;
1354 fprintf(stderr, "*** OLD FILE: %s\n", (const char *)(ufoDebugImage + infoOfs + 3u * 4u));
1355 fprintf(stderr, "FILE NAME LEN: %u\n", ((const uint32_t *)(ufoDebugImage + infoOfs))[2]);
1356 fprintf(stderr, "FILE NAME HASH: 0x%08x\n", ((const uint32_t *)(ufoDebugImage + infoOfs))[1]);
1357 } else {
1358 // new
1359 fprintf(stderr, "*** NEW FILE: %s\n", (const char *)(ufoDebugImage + dbgpos + 3u * 4u));
1360 fprintf(stderr, "FILE NAME LEN: %u\n", ((const uint32_t *)(ufoDebugImage + dbgpos))[2]);
1361 fprintf(stderr, "FILE NAME HASH: 0x%08x\n", ((const uint32_t *)(ufoDebugImage + dbgpos))[1]);
1363 dbgpos += fhdrSize;
1364 fprintf(stderr, "LINES-OFS: 0x%08x (hsz: %u -- 0x%08x)\n", dbgpos, fhdrSize, fhdrSize);
1365 lastline = ~(uint32_t)0;
1366 } else {
1367 const uint32_t ln = ufoGetDebugVarInt(dbgpos);
1368 dbgpos = ufoSkipDebugVarInt(dbgpos);
1369 ufo_assert(ln != 0);
1370 lastline += ln;
1371 const uint32_t edp = ufoGetDebugVarInt(dbgpos);
1372 dbgpos = ufoSkipDebugVarInt(dbgpos);
1373 lastdp += edp;
1374 fprintf(stderr, " line %6u: edp=%u\n", lastline, lastdp);
1377 #endif
1379 #endif
1382 //==========================================================================
1384 // ufoRecordDebugCheckFile
1386 // if we moved to the new file:
1387 // put "line info header"
1388 // put new file info (or reuse old)
1390 //==========================================================================
1391 UFO_FORCE_INLINE void ufoRecordDebugCheckFile (void) {
1392 if (ufoDebugImageUsed == 0 ||
1393 ufoDebugFileNameLen != ufoInFileNameLen ||
1394 ufoDebugFileNameHash != ufoInFileNameHash)
1396 // new file record (or reuse old one)
1397 const int initial = (ufoDebugImageUsed == 0);
1398 uint32_t fileRec = 0;
1399 // try to find and old one
1400 if (!initial) {
1401 fileRec = *(const uint32_t *)ufoDebugImage;
1402 #if 0
1403 fprintf(stderr, "*** NEW-FILE(%u): 0x%08x: <%s> (frec=0x%08x)\n", ufoInFileNameLen,
1404 ufoInFileNameHash, ufoInFileName, fileRec);
1405 #endif
1406 while (fileRec != 0 &&
1407 (ufoInFileNameLen != ((const uint32_t *)(ufoDebugImage + fileRec))[1] ||
1408 ufoInFileNameHash != ((const uint32_t *)(ufoDebugImage + fileRec))[2]))
1410 #if 0
1411 fprintf(stderr, "*** FRCHECK: 0x%08x\n", fileRec);
1412 fprintf(stderr, " FILE NAME: %s\n", (const char *)(ufoDebugImage + fileRec + 3u * 4u));
1413 fprintf(stderr, " FILE NAME LEN: %u\n", ((const uint32_t *)(ufoDebugImage + fileRec))[2]);
1414 fprintf(stderr, " FILE NAME HASH: 0x%08x\n", ((const uint32_t *)(ufoDebugImage + fileRec))[1]);
1415 fprintf(stderr, " FILE PREV: 0x%08x\n", *(const uint32_t *)(ufoDebugImage + fileRec));
1416 #endif
1417 fileRec = *(const uint32_t *)(ufoDebugImage + fileRec);
1419 #if 0
1420 fprintf(stderr, "*** FRCHECK-DONE: 0x%08x\n", fileRec);
1421 if (fileRec != 0) {
1422 fprintf(stderr, " FILE NAME: %s\n", (const char *)(ufoDebugImage + fileRec + 3u * 4u));
1423 fprintf(stderr, " FILE NAME LEN: %u\n", ((const uint32_t *)(ufoDebugImage + fileRec))[2]);
1424 fprintf(stderr, " FILE NAME HASH: 0x%08x\n", ((const uint32_t *)(ufoDebugImage + fileRec))[1]);
1425 fprintf(stderr, " FILE PREV: 0x%08x\n", *(const uint32_t *)(ufoDebugImage + fileRec));
1427 #endif
1428 } else {
1429 ufoEnsureDebugSize(8u);
1430 *(uint32_t *)ufoDebugImage = 0;
1432 // write "line info header"
1433 if (fileRec != 0) {
1434 ufoEnsureDebugSize(32u);
1435 ufoDebugImage[ufoDebugImageUsed] = 0; ufoDebugImageUsed += 1u; // header flag (0 delta)
1436 // file record size: 0 (reused)
1437 *((uint16_t *)(ufoDebugImage + ufoDebugImageUsed)) = 0; ufoDebugImageUsed += 2u;
1438 // put last DP
1439 ufoPutDebugVarInt(ufoDebugCurrDP);
1440 // file info offset
1441 UFO_DBG_PUT_U4(fileRec);
1442 } else {
1443 // name, trailing 0 byte, 3 dword fields
1444 const uint32_t finfoSize = ufoInFileNameLen + 1u + 3u * 4u;
1445 ufo_assert(finfoSize < 65536u);
1446 ufoEnsureDebugSize(finfoSize + 32u);
1447 if (initial) {
1448 *(uint32_t *)ufoDebugImage = 0;
1449 ufoDebugImageUsed = 4;
1451 ufoDebugImage[ufoDebugImageUsed] = 0; ufoDebugImageUsed += 1u; // header flag (0 delta)
1452 // file record size
1453 *((uint16_t *)(ufoDebugImage + ufoDebugImageUsed)) = (uint16_t)finfoSize; ufoDebugImageUsed += 2u;
1454 // put last DP
1455 ufoPutDebugVarInt(ufoDebugCurrDP);
1456 // file record follows
1457 // fix file info offsets
1458 uint32_t lastOfs = *(const uint32_t *)ufoDebugImage;
1459 *(uint32_t *)ufoDebugImage = ufoDebugImageUsed;
1460 UFO_DBG_PUT_U4(lastOfs);
1461 // save file info hash
1462 UFO_DBG_PUT_U4(ufoInFileNameHash);
1463 // save file info length
1464 UFO_DBG_PUT_U4(ufoInFileNameLen);
1465 // save file name
1466 if (ufoInFileNameLen != 0) {
1467 memcpy(ufoDebugImage + ufoDebugImageUsed, ufoInFileName, ufoInFileNameLen + 1u);
1468 ufoDebugImageUsed += ufoInFileNameLen + 1u;
1469 } else {
1470 ufoDebugImage[ufoDebugImageUsed] = 0; ufoDebugImageUsed += 1u;
1473 ufoDebugFileNameLen = ufoInFileNameLen;
1474 ufoDebugFileNameHash = ufoInFileNameHash;
1475 ufoDebugLastLine = ~(uint32_t)0;
1476 ufoDebugLastLinePCOfs = 0;
1477 ufoDebugLastLineDP = ufoDebugCurrDP;
1482 //==========================================================================
1484 // ufoRecordDebugRecordLine
1486 //==========================================================================
1487 UFO_FORCE_INLINE void ufoRecordDebugRecordLine (uint32_t line, uint32_t newhere) {
1488 if (line == ufoDebugLastLine) {
1489 ufo_assert(ufoDebugLastLinePCOfs != 0);
1490 ufoDebugImageUsed = ufoDebugLastLinePCOfs;
1491 } else {
1492 #if 0
1493 fprintf(stderr, "FL-NEW-LINE(0x%08x): <%s>; new line: %u (old: %u)\n",
1494 ufoDebugImageUsed,
1495 ufoInFileName, line, ufoDebugLastLine);
1496 #endif
1497 ufoPutDebugVarInt(line - ufoDebugLastLine);
1498 ufoDebugLastLinePCOfs = ufoDebugImageUsed;
1499 ufoDebugLastLine = line;
1500 ufoDebugLastLineDP = ufoDebugCurrDP;
1502 ufoPutDebugVarInt(newhere - ufoDebugLastLineDP);
1503 ufoDebugCurrDP = newhere;
1507 //==========================================================================
1509 // ufoRecordDebug
1511 //==========================================================================
1512 UFO_DISABLE_INLINE void ufoRecordDebug (uint32_t newhere) {
1513 if (newhere > ufoDebugCurrDP) {
1514 uint32_t ln = (uint32_t)ufoInFileLine;
1515 if (ln == ~(uint32_t)0) ln = 0;
1516 #if 0
1517 fprintf(stderr, "FL: <%s>; line: %d\n", ufoInFileName, ufoInFileLine);
1518 #endif
1519 ufoRecordDebugCheckFile();
1520 ufoRecordDebugRecordLine(ln, newhere);
1525 //==========================================================================
1527 // ufoGetWordEndAddrYFA
1529 //==========================================================================
1530 static uint32_t ufoGetWordEndAddrYFA (uint32_t yfa) {
1531 if (yfa > 8u) {
1532 const uint32_t oyfa = yfa;
1533 yfa = ufoImgGetU32(yfa);
1534 if (yfa == 0) {
1535 if ((oyfa & UFO_ADDR_TEMP_BIT) == 0) {
1536 yfa = UFO_GET_DP();
1537 if ((yfa & UFO_ADDR_TEMP_BIT) != 0) {
1538 yfa = UFO_CFA_TO_PFA(UFO_NFA_TO_CFA(UFO_YFA_TO_NFA(oyfa)));
1540 } else {
1541 yfa = UFO_CFA_TO_PFA(UFO_NFA_TO_CFA(UFO_YFA_TO_NFA(oyfa)));
1543 } else {
1544 yfa = UFO_YFA_TO_WST(yfa);
1546 } else {
1547 yfa = 0;
1549 return yfa;
1553 //==========================================================================
1555 // ufoGetWordEndAddr
1557 //==========================================================================
1558 static uint32_t ufoGetWordEndAddr (const uint32_t cfa) {
1559 if (cfa != 0) {
1560 return ufoGetWordEndAddrYFA(UFO_LFA_TO_YFA(UFO_CFA_TO_LFA(cfa)));
1561 } else {
1562 return 0;
1567 //==========================================================================
1569 // ufoFindWordForIP
1571 // return NFA or 0
1573 // WARNING: this is SLOW!
1575 //==========================================================================
1576 static uint32_t ufoFindWordForIP (const uint32_t ip) {
1577 uint32_t res = 0;
1578 if (ip != 0) {
1579 //fprintf(stderr, "ufoFindWordForIP:000: ip=0x%08x\n", ip);
1580 // iterate over all words
1581 uint32_t xfa = ufoImgGetU32(ufoAddrLastXFA);
1582 //fprintf(stderr, "ufoFindWordForIP:001: xfa=0x%08x\n", xfa);
1583 if (xfa != 0) {
1584 while (res == 0 && xfa != 0) {
1585 const uint32_t yfa = UFO_XFA_TO_YFA(xfa);
1586 const uint32_t wst = UFO_YFA_TO_WST(yfa);
1587 //fprintf(stderr, "ufoFindWordForIP:002: yfa=0x%08x; wst=0x%08x\n", yfa, wst);
1588 const uint32_t wend = ufoGetWordEndAddrYFA(yfa);
1589 if (ip >= wst && ip < wend) {
1590 res = UFO_YFA_TO_NFA(yfa);
1591 } else {
1592 xfa = ufoImgGetU32(xfa);
1597 return res;
1601 //==========================================================================
1603 // ufoFindFileForIP
1605 // return file name or `NULL`
1607 // WARNING: this is SLOW!
1609 //==========================================================================
1610 static const char *ufoFindFileForIP (uint32_t ip, uint32_t *line,
1611 uint32_t *nlen, uint32_t *nhash)
1613 if (ip != 0 && ufoDebugImageUsed != 0) {
1614 const char *filename = NULL;
1615 uint32_t dbgpos = 4u; // first line header info
1616 uint32_t lastline = 0;
1617 uint32_t lastdp = 0;
1618 uint32_t namelen = 0;
1619 uint32_t namehash = 0;
1620 while (dbgpos < ufoDebugImageUsed) {
1621 if (ufoDebugImage[dbgpos] == 0) {
1622 // new file info
1623 dbgpos += 1u; // skip flag
1624 const uint32_t fhdrSize = *(const uint16_t *)(ufoDebugImage + dbgpos); dbgpos += 2u;
1625 lastdp = ufoGetDebugVarInt(dbgpos);
1626 dbgpos = ufoSkipDebugVarInt(dbgpos);
1627 uint32_t infoOfs;
1628 if (fhdrSize == 0) {
1629 // reused
1630 infoOfs = *(const uint32_t *)(ufoDebugImage + dbgpos); dbgpos += 4u;
1631 } else {
1632 // new
1633 infoOfs = dbgpos;
1635 filename = (const char *)(ufoDebugImage + infoOfs + 3u * 4u);
1636 namelen = ((const uint32_t *)(ufoDebugImage + infoOfs))[2];
1637 namehash = ((const uint32_t *)(ufoDebugImage + infoOfs))[1];
1638 if (filename[0] == 0) filename = NULL;
1639 dbgpos += fhdrSize;
1640 lastline = ~(uint32_t)0;
1641 } else {
1642 const uint32_t ln = ufoGetDebugVarInt(dbgpos);
1643 dbgpos = ufoSkipDebugVarInt(dbgpos);
1644 ufo_assert(ln != 0);
1645 lastline += ln;
1646 const uint32_t edp = ufoGetDebugVarInt(dbgpos);
1647 dbgpos = ufoSkipDebugVarInt(dbgpos);
1648 if (ip >= lastdp && ip < lastdp + edp) {
1649 if (line) *line = lastline;
1650 if (nlen) *nlen = namelen;
1651 if (nhash) *nhash = namehash;
1652 return filename;
1654 lastdp += edp;
1658 if (line) *line = 0;
1659 if (nlen) *nlen = 0;
1660 if (nhash) *nlen = 0;
1661 return NULL;
1665 //==========================================================================
1667 // ufoBumpDP
1669 //==========================================================================
1670 UFO_FORCE_INLINE void ufoBumpDP (uint32_t delta) {
1671 uint32_t dp = ufoImgGetU32(ufoAddrDPTemp);
1672 if (dp == 0) {
1673 dp = ufoImgGetU32(ufoAddrDP);
1674 if ((dp & UFO_ADDR_SPECIAL_BITS_MASK) == 0) ufoRecordDebug(dp + delta);
1675 dp += delta;
1676 ufoImgPutU32(ufoAddrDP, dp);
1677 } else {
1678 dp = ufoImgGetU32(ufoAddrDPTemp);
1679 if ((dp & UFO_ADDR_SPECIAL_BITS_MASK) == 0) ufoRecordDebug(dp + delta);
1680 dp += delta;
1681 ufoImgPutU32(ufoAddrDPTemp, dp);
1686 //==========================================================================
1688 // ufoImgEmitU8
1690 //==========================================================================
1691 UFO_FORCE_INLINE void ufoImgEmitU8 (uint32_t value) {
1692 ufoImgPutU8(UFO_GET_DP(), value);
1693 ufoBumpDP(1);
1697 //==========================================================================
1699 // ufoImgEmitU32
1701 //==========================================================================
1702 UFO_FORCE_INLINE void ufoImgEmitU32 (uint32_t value) {
1703 ufoImgPutU32(UFO_GET_DP(), value);
1704 ufoBumpDP(4);
1708 #ifdef UFO_FAST_MEM_ACCESS
1710 //==========================================================================
1712 // ufoImgEmitU32_NoInline
1714 // false
1716 //==========================================================================
1717 UFO_FORCE_INLINE void ufoImgEmitU32_NoInline (uint32_t value) {
1718 ufoImgPutU32(UFO_GET_DP(), value);
1719 ufoBumpDP(4);
1722 #else
1724 //==========================================================================
1726 // ufoImgEmitU32_NoInline
1728 // general
1730 //==========================================================================
1731 UFO_DISABLE_INLINE void ufoImgEmitU32_NoInline (uint32_t value) {
1732 ufoImgPutU32(UFO_GET_DP(), value);
1733 ufoBumpDP(4);
1736 #endif
1739 //==========================================================================
1741 // ufoImgGetU8Ext
1743 // this understands handle addresses
1745 //==========================================================================
1746 UFO_FORCE_INLINE uint32_t ufoImgGetU8Ext (uint32_t addr) {
1747 if ((addr & UFO_ADDR_HANDLE_BIT) == 0) {
1748 return ufoImgGetU8(addr);
1749 } else {
1750 ufoPush(0);
1751 ufoPush(addr);
1752 UFCALL(PAR_HANDLE_LOAD_BYTE);
1753 return ufoPop();
1758 //==========================================================================
1760 // ufoImgPutU8Ext
1762 // this understands handle addresses
1764 //==========================================================================
1765 UFO_FORCE_INLINE void ufoImgPutU8Ext (uint32_t addr, uint32_t value) {
1766 if ((addr & UFO_ADDR_HANDLE_BIT) == 0) {
1767 ufoImgPutU8(addr, value);
1768 } else {
1769 ufoPush(value);
1770 ufoPush(0);
1771 ufoPush(addr);
1772 UFCALL(PAR_HANDLE_STORE_BYTE);
1777 //==========================================================================
1779 // ufoImgEmitAlign
1781 //==========================================================================
1782 UFO_FORCE_INLINE void ufoImgEmitAlign (void) {
1783 while ((UFO_GET_DP() & 3) != 0) ufoImgEmitU8(0);
1787 //==========================================================================
1789 // ufoResetTib
1791 //==========================================================================
1792 UFO_FORCE_INLINE void ufoResetTib (void) {
1793 uint32_t defTIB = ufoImgGetU32(ufoAddrDefTIB);
1794 //fprintf(stderr, "ufoResetTib(%p): defTIB=0x%08x\n", ufoCurrState, defTIB);
1795 if (defTIB == 0) {
1796 // create new TIB handle
1797 UfoHandle *tibh = ufoAllocHandle(0x69a029a6); // arbitrary number
1798 defTIB = tibh->ufoHandle;
1799 ufoImgPutU32(ufoAddrDefTIB, defTIB);
1801 if ((defTIB & UFO_ADDR_HANDLE_BIT) != 0) {
1802 UfoHandle *hh = ufoGetHandle(defTIB);
1803 if (hh == NULL) ufoFatal("default TIB is not allocated");
1804 if (hh->size == 0) {
1805 ufo_assert(hh->data == NULL);
1806 hh->data = calloc(1, UFO_ADDR_HANDLE_OFS_MASK + 1);
1807 if (hh->data == NULL) ufoFatal("out of memory for default TIB");
1808 hh->size = UFO_ADDR_HANDLE_OFS_MASK + 1;
1811 const uint32_t oldA = ufoRegA;
1812 ufoImgPutU32(ufoAddrTIBx, defTIB);
1813 ufoImgPutU32(ufoAddrINx, 0);
1814 ufoRegA = defTIB;
1815 ufoPush(0); // value
1816 ufoPush(0); // offset
1817 UFCALL(CPOKE_REGA_IDX);
1818 ufoRegA = oldA;
1822 //==========================================================================
1824 // ufoTibEnsureSize
1826 //==========================================================================
1827 UFO_DISABLE_INLINE void ufoTibEnsureSize (uint32_t size) {
1828 if (size > 1024u * 1024u * 256u) ufoFatal("TIB size too big");
1829 const uint32_t tib = ufoImgGetU32(ufoAddrTIBx);
1830 //fprintf(stderr, "ufoTibEnsureSize: TIB=0x%08x; size=%u\n", tib, size);
1831 if ((tib & UFO_ADDR_HANDLE_BIT) != 0) {
1832 UfoHandle *hh = ufoGetHandle(tib);
1833 if (hh == NULL) {
1834 ufoFatal("cannot resize TIB, TIB is not a handle");
1836 if (hh->size < size) {
1837 const uint32_t newsz = (size | 0xfffU) + 1u;
1838 uint8_t *nx = realloc(hh->data, newsz);
1839 if (nx == NULL) ufoFatal("out of memory for restored TIB");
1840 hh->data = nx;
1841 hh->size = newsz;
1844 #if 0
1845 else {
1846 ufoFatal("cannot resize TIB, TIB is not a handle (0x%08x)", tib);
1848 #endif
1852 //==========================================================================
1854 // ufoTibGetSize
1856 //==========================================================================
1858 UFO_DISABLE_INLINE uint32_t ufoTibGetSize (void) {
1859 const uint32_t tib = ufoImgGetU32(ufoAddrTIBx);
1860 if ((tib & UFO_ADDR_HANDLE_BIT) == 0) {
1861 ufoFatal("cannot query TIB, TIB is not a handle");
1863 UfoHandle *hh = ufoGetHandle(tib);
1864 if (hh == NULL) {
1865 ufoFatal("cannot query TIB, TIB is not a handle");
1867 return hh->size;
1872 //==========================================================================
1874 // ufoTibPeekCh
1876 //==========================================================================
1877 UFO_FORCE_INLINE uint8_t ufoTibPeekCh (void) {
1878 return (uint8_t)ufoImgGetU8Ext(ufoImgGetU32(ufoAddrTIBx) + ufoImgGetU32(ufoAddrINx));
1882 //==========================================================================
1884 // ufoTibPeekChOfs
1886 //==========================================================================
1887 UFO_FORCE_INLINE uint8_t ufoTibPeekChOfs (uint32_t ofs) {
1888 const uint32_t tib = ufoImgGetU32(ufoAddrTIBx);
1889 if (ofs <= UFO_ADDR_HANDLE_OFS_MASK || (tib & UFO_ADDR_HANDLE_BIT) == 0) {
1890 return (uint8_t)ufoImgGetU8Ext(tib + ufoImgGetU32(ufoAddrINx) + ofs);
1891 } else {
1892 return 0;
1897 //==========================================================================
1899 // ufoTibPokeChOfs
1901 //==========================================================================
1902 UFO_DISABLE_INLINE void ufoTibPokeChOfs (uint8_t ch, uint32_t ofs) {
1903 const uint32_t oldA = ufoRegA;
1904 ufoRegA = ufoImgGetU32(ufoAddrTIBx);
1905 ufoPush(ch);
1906 ufoPush(ufoImgGetU32(ufoAddrINx) + ofs);
1907 UFCALL(CPOKE_REGA_IDX);
1908 ufoRegA = oldA;
1912 //==========================================================================
1914 // ufoTibGetCh
1916 //==========================================================================
1917 UFO_FORCE_INLINE uint8_t ufoTibGetCh (void) {
1918 const uint8_t ch = ufoTibPeekCh();
1919 if (ch) ufoImgPutU32(ufoAddrINx, ufoImgGetU32(ufoAddrINx) + 1u);
1920 return ch;
1924 //==========================================================================
1926 // ufoTibSkipCh
1928 //==========================================================================
1929 UFO_FORCE_INLINE void ufoTibSkipCh (void) {
1930 (void)ufoTibGetCh();
1934 // ////////////////////////////////////////////////////////////////////////// //
1935 // native CFA implementations
1938 //==========================================================================
1940 // ufoDoForth
1942 //==========================================================================
1943 static void ufoDoForth (uint32_t pfa) {
1944 ufoRPush(ufoIP);
1945 ufoIP = pfa;
1949 //==========================================================================
1951 // ufoDoVariable
1953 //==========================================================================
1954 static void ufoDoVariable (uint32_t pfa) {
1955 ufoPush(pfa);
1959 //==========================================================================
1961 // ufoDoUserVariable
1963 //==========================================================================
1964 static void ufoDoUserVariable (uint32_t pfa) {
1965 ufoPush(ufoImgGetU32(pfa));
1969 //==========================================================================
1971 // ufoDoValue
1973 //==========================================================================
1974 static void ufoDoValue (uint32_t pfa) {
1975 ufoPush(ufoImgGetU32(pfa));
1979 //==========================================================================
1981 // ufoDoConst
1983 //==========================================================================
1984 static void ufoDoConst (uint32_t pfa) {
1985 ufoPush(ufoImgGetU32(pfa));
1989 //==========================================================================
1991 // ufoDoDefer
1993 //==========================================================================
1994 static void ufoDoDefer (uint32_t pfa) {
1995 const uint32_t cfa = ufoImgGetU32(pfa);
1996 if (cfa != 0) {
1997 ufoRPush(cfa);
1998 ufoVMRPopCFA = 1;
2003 //==========================================================================
2005 // ufoDoVoc
2007 //==========================================================================
2008 static void ufoDoVoc (uint32_t pfa) {
2009 ufoImgPutU32(ufoAddrContext, ufoImgGetU32(pfa));
2013 //==========================================================================
2015 // ufoDoCreate
2017 //==========================================================================
2018 static void ufoDoCreate (uint32_t pfa) {
2019 ufoPush(pfa);
2023 //==========================================================================
2025 // ufoPushInFile
2027 // this also increments last used file id
2029 //==========================================================================
2030 static void ufoPushInFile (void) {
2031 if (ufoFileStackPos >= UFO_MAX_NESTED_INCLUDES) ufoFatal("too many includes");
2032 UFOFileStackEntry *stk = &ufoFileStack[ufoFileStackPos];
2033 stk->fl = ufoInFile;
2034 stk->fname = ufoInFileName;
2035 stk->fline = ufoInFileLine;
2036 stk->id = ufoFileId;
2037 stk->incpath = (ufoLastIncPath ? strdup(ufoLastIncPath) : NULL);
2038 stk->sysincpath = (ufoLastSysIncPath ? strdup(ufoLastSysIncPath) : NULL);
2039 ufoFileStackPos += 1;
2040 ufoInFile = NULL;
2041 ufoInFileName = NULL; ufoInFileNameLen = 0; ufoInFileNameHash = 0;
2042 ufoInFileLine = 0;
2043 ufoLastUsedFileId += 1;
2044 ufo_assert(ufoLastUsedFileId != 0); // just in case ;-)
2045 //ufoLastIncPath = NULL;
2049 //==========================================================================
2051 // ufoWipeIncludeStack
2053 //==========================================================================
2054 static void ufoWipeIncludeStack (void) {
2055 if (ufoInFileName) { free(ufoInFileName); ufoInFileName = NULL; }
2056 if (ufoInFile) { fclose(ufoInFile); ufoInFile = NULL; }
2057 if (ufoLastIncPath) { free(ufoLastIncPath); ufoLastIncPath = NULL; }
2058 if (ufoLastSysIncPath) { free(ufoLastSysIncPath); ufoLastSysIncPath = NULL; }
2059 while (ufoFileStackPos != 0) {
2060 ufoFileStackPos -= 1;
2061 UFOFileStackEntry *stk = &ufoFileStack[ufoFileStackPos];
2062 if (stk->fl) fclose(stk->fl);
2063 if (stk->fname) free(stk->fname);
2064 if (stk->incpath) free(stk->incpath);
2069 //==========================================================================
2071 // ufoPopInFile
2073 //==========================================================================
2074 static void ufoPopInFile (void) {
2075 if (ufoFileStackPos == 0) ufoFatal("trying to pop include from empty stack");
2076 if (ufoInFileName) { free(ufoInFileName); ufoInFileName = NULL; }
2077 if (ufoInFile) { fclose(ufoInFile); ufoInFile = NULL; }
2078 if (ufoLastIncPath) { free(ufoLastIncPath); ufoLastIncPath = NULL; }
2079 if (ufoLastSysIncPath) { free(ufoLastSysIncPath); ufoLastSysIncPath = NULL; }
2080 ufoFileStackPos -= 1;
2081 UFOFileStackEntry *stk = &ufoFileStack[ufoFileStackPos];
2082 ufoInFile = stk->fl;
2083 ufoSetInFileNameReuse(stk->fname);
2084 ufoInFileLine = stk->fline;
2085 ufoLastIncPath = stk->incpath;
2086 ufoLastSysIncPath = stk->sysincpath;
2087 ufoFileId = stk->id;
2088 ufoResetTib();
2089 #ifdef UFO_DEBUG_INCLUDE
2090 if (ufoInFileName == NULL) {
2091 fprintf(stderr, "INC-POP: no more files.\n");
2092 } else {
2093 fprintf(stderr, "INC-POP: fname: %s\n", ufoInFileName);
2095 #endif
2099 //==========================================================================
2101 // ufoDeinit
2103 //==========================================================================
2104 void ufoDeinit (void) {
2105 #ifdef UFO_DEBUG_WRITE_MAIN_IMAGE
2107 FILE *fo = fopen("zufo_main.img", "w");
2108 uint32_t dpTemp = ufoImgGetU32(ufoAddrDPTemp);
2109 uint32_t dpMain = ufoImgGetU32(ufoAddrDP);
2110 if ((dpMain & UFO_ADDR_SPECIAL_BITS_MASK) != 0) dpMain = ufoImageSize;
2111 if (dpTemp != 0 && (dpTemp & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
2112 if (dpTemp > dpMain) dpMain = dpTemp;
2114 fwrite(ufoImage, dpMain, 1, fo);
2115 fclose(fo);
2117 #endif
2119 #ifdef UFO_DEBUG_WRITE_DEBUG_IMAGE
2121 FILE *fo = fopen("zufo_debug.img", "w");
2122 fwrite(ufoDebugImage, ufoDebugImageUsed, 1, fo);
2123 fclose(fo);
2125 #endif
2127 #ifdef UFO_DEBUG_DEBUG
2129 uint32_t dpTemp = ufoImgGetU32(ufoAddrDPTemp);
2130 uint32_t dpMain = ufoImgGetU32(ufoAddrDP);
2131 if ((dpMain & UFO_ADDR_SPECIAL_BITS_MASK) != 0) dpMain = ufoImageSize;
2132 if (dpTemp != 0 && (dpTemp & UFO_ADDR_SPECIAL_BITS_MASK) == 0) {
2133 if (dpTemp > dpMain) dpMain = dpTemp;
2135 fprintf(stderr, "UFO: image used: %u; size: %u\n",
2136 dpMain, ufoImageSize);
2137 fprintf(stderr, "UFO: debug image used: %u; size: %u\n",
2138 ufoDebugImageUsed, ufoDebugImageSize);
2139 ufoDumpDebugImage();
2141 #endif
2143 // free all states
2144 ufoCurrState = NULL;
2145 ufoYieldedState = NULL;
2146 ufoDebuggerState = NULL;
2147 for (uint32_t fidx = 0; fidx < (uint32_t)(UFO_MAX_STATES/32); fidx += 1u) {
2148 uint32_t bmp = ufoStateUsedBitmap[fidx];
2149 if (bmp != 0) {
2150 uint32_t stid = fidx * 32u;
2151 while (bmp != 0) {
2152 if ((bmp & 0x01) != 0) ufoFreeState(ufoStateMap[stid]);
2153 stid += 1u; bmp >>= 1;
2158 free(ufoDebugImage);
2159 ufoDebugImage = NULL;
2160 ufoDebugImageUsed = 0;
2161 ufoDebugImageSize = 0;
2162 ufoDebugFileNameHash = 0;
2163 ufoDebugFileNameLen = 0;
2164 ufoDebugLastLine = 0;
2165 ufoDebugLastLinePCOfs = 0;
2166 ufoDebugLastLineDP = 0;
2167 ufoDebugCurrDP = 0;
2169 ufoInBacktrace = 0;
2170 ufoClearCondDefines();
2171 ufoWipeIncludeStack();
2173 // release all includes
2174 ufoInFile = NULL;
2175 if (ufoInFileName) free(ufoInFileName);
2176 if (ufoLastIncPath) free(ufoLastIncPath);
2177 if (ufoLastSysIncPath) free(ufoLastSysIncPath);
2178 ufoInFileName = NULL; ufoLastIncPath = NULL; ufoLastSysIncPath = NULL;
2179 ufoInFileNameHash = 0; ufoInFileNameLen = 0;
2180 ufoInFileLine = 0;
2182 free(ufoForthCFAs);
2183 ufoForthCFAs = NULL;
2184 ufoCFAsUsed = 0;
2186 free(ufoImage);
2187 ufoImage = NULL;
2188 ufoImageSize = 0;
2190 ufoMode = UFO_MODE_NATIVE;
2191 ufoForthVocId = 0; ufoCompilerVocId = 0;
2192 ufoSingleStep = 0;
2194 // free all handles
2195 for (uint32_t f = 0; f < ufoHandlesUsed; f += 1) {
2196 UfoHandle *hh = ufoHandles[f];
2197 if (hh != NULL) {
2198 if (hh->data != NULL) free(hh->data);
2199 free(hh);
2202 if (ufoHandles != NULL) free(ufoHandles);
2203 ufoHandles = NULL; ufoHandlesUsed = 0; ufoHandlesAlloted = 0;
2204 ufoHandleFreeList = NULL;
2206 ufoLastEmitWasCR = 1;
2208 ufoClearCondDefines();
2212 //==========================================================================
2214 // ufoDumpWordHeader
2216 //==========================================================================
2217 __attribute__((unused)) static void ufoDumpWordHeader (const uint32_t lfa) {
2218 fprintf(stderr, "=== WORD: LFA: 0x%08x ===\n", lfa);
2219 if (lfa != 0) {
2220 fprintf(stderr, " (XFA): 0x%08x\n", ufoImgGetU32(UFO_LFA_TO_XFA(lfa)));
2221 fprintf(stderr, " (YFA): 0x%08x\n", ufoImgGetU32(UFO_LFA_TO_YFA(lfa)));
2222 fprintf(stderr, " (BFA): 0x%08x\n", ufoImgGetU32(UFO_LFA_TO_BFA(lfa)));
2223 fprintf(stderr, " (LFA): 0x%08x\n", ufoImgGetU32(lfa));
2224 fprintf(stderr, " (NHH): 0x%08x\n", ufoImgGetU32(UFO_LFA_TO_NHASH(lfa)));
2225 const uint32_t cfa = UFO_LFA_TO_CFA(lfa);
2226 fprintf(stderr, " CFA: 0x%08x\n", cfa);
2227 fprintf(stderr, " PFA: 0x%08x\n", UFO_CFA_TO_PFA(cfa));
2228 fprintf(stderr, " (CFA): 0x%08x\n", ufoImgGetU32(cfa));
2229 const uint32_t nfa = UFO_LFA_TO_NFA(lfa);
2230 const uint32_t nlen = ufoImgGetU8(nfa);
2231 fprintf(stderr, " NFA: 0x%08x (nlen: %u)\n", nfa, nlen);
2232 const uint32_t flags = ufoImgGetU32(nfa);
2233 fprintf(stderr, " FLAGS: 0x%08x\n", flags);
2234 if ((flags & 0xffff0000U) != 0) {
2235 fprintf(stderr, " FLAGS:");
2236 if (flags & UFW_FLAG_IMMEDIATE) fprintf(stderr, " IMM");
2237 if (flags & UFW_FLAG_SMUDGE) fprintf(stderr, " SMUDGE");
2238 if (flags & UFW_FLAG_NORETURN) fprintf(stderr, " NORET");
2239 if (flags & UFW_FLAG_HIDDEN) fprintf(stderr, " HIDDEN");
2240 if (flags & UFW_FLAG_CBLOCK) fprintf(stderr, " CBLOCK");
2241 if (flags & UFW_FLAG_VOCAB) fprintf(stderr, " VOCAB");
2242 if (flags & UFW_FLAG_SCOLON) fprintf(stderr, " SCOLON");
2243 if (flags & UFW_FLAG_PROTECTED) fprintf(stderr, " PROTECTED");
2244 fputc('\n', stderr);
2246 if ((flags & 0xff00U) != 0) {
2247 fprintf(stderr, " ARGS: ");
2248 switch (flags & UFW_WARG_MASK) {
2249 case UFW_WARG_NONE: fprintf(stderr, "NONE"); break;
2250 case UFW_WARG_BRANCH: fprintf(stderr, "BRANCH"); break;
2251 case UFW_WARG_LIT: fprintf(stderr, "LIT"); break;
2252 case UFW_WARG_C4STRZ: fprintf(stderr, "C4STRZ"); break;
2253 case UFW_WARG_CFA: fprintf(stderr, "CFA"); break;
2254 case UFW_WARG_CBLOCK: fprintf(stderr, "CBLOCK"); break;
2255 case UFW_WARG_VOCID: fprintf(stderr, "VOCID"); break;
2256 case UFW_WARG_C1STRZ: fprintf(stderr, "C1STRZ"); break;
2257 default: fprintf(stderr, "wtf?!"); break;
2259 fputc('\n', stderr);
2261 fprintf(stderr, " BACKLEN: %u (nfa at 0x%08x)\n", ufoImgGetU8(cfa - 1u), UFO_CFA_TO_NFA(cfa));
2262 fprintf(stderr, " NAME(%u): ", nlen);
2263 for (uint32_t f = 0; f < nlen; f += 1) {
2264 const uint8_t ch = ufoImgGetU8(nfa + 4u + f);
2265 if (ch <= 32 || ch >= 127) {
2266 fprintf(stderr, "\\x%02x", ch);
2267 } else {
2268 fprintf(stderr, "%c", (char)ch);
2271 fprintf(stderr, "\n");
2272 ufo_assert(UFO_CFA_TO_LFA(cfa) == lfa);
2277 //==========================================================================
2279 // ufoVocCheckName
2281 // return 0 or CFA
2283 //==========================================================================
2284 static uint32_t ufoVocCheckName (uint32_t lfa, const void *wname, uint32_t wnlen, uint32_t hash,
2285 int allowvochid)
2287 uint32_t res = 0;
2288 #ifdef UFO_DEBUG_FIND_WORD
2289 fprintf(stderr, "CHECK-NAME: %.*s; LFA: 0x%08x; hash: 0x%08x (wname: 0x%08x)\n",
2290 (unsigned) wnlen, (const char *)wname,
2291 lfa, (lfa != 0 ? ufoImgGetU32(UFO_LFA_TO_NHASH(lfa)) : 0), hash);
2292 ufoDumpWordHeader(lfa);
2293 #endif
2294 if (lfa != 0 && ufoImgGetU32(UFO_LFA_TO_NHASH(lfa)) == hash) {
2295 const uint32_t lenflags = ufoImgGetU32(UFO_LFA_TO_NFA(lfa));
2296 if ((lenflags & UFW_FLAG_SMUDGE) == 0 &&
2297 (allowvochid || (lenflags & UFW_FLAG_HIDDEN) == 0))
2299 const uint32_t nlen = lenflags&0xffU;
2300 if (nlen == wnlen) {
2301 uint32_t naddr = UFO_LFA_TO_NFA(lfa) + 4u;
2302 uint32_t pos = 0;
2303 while (pos < nlen) {
2304 uint8_t c0 = ((const unsigned char *)wname)[pos];
2305 if (c0 >= 'a' && c0 <= 'z') c0 = c0 - 'a' + 'A';
2306 uint8_t c1 = ufoImgGetU8(naddr + pos);
2307 if (c1 >= 'a' && c1 <= 'z') c1 = c1 - 'a' + 'A';
2308 if (c0 != c1) break;
2309 pos += 1u;
2311 if (pos == nlen) {
2312 // i found her!
2313 naddr += pos + 1u;
2314 res = UFO_ALIGN4(naddr);
2319 return res;
2323 //==========================================================================
2325 // ufoFindWordInVoc
2327 // return 0 or CFA
2329 //==========================================================================
2330 static uint32_t ufoFindWordInVoc (const void *wname, uint32_t wnlen, uint32_t hash,
2331 uint32_t vocid, int allowvochid)
2333 uint32_t res = 0;
2334 if (wname == NULL) ufo_assert(wnlen == 0);
2335 if (wnlen != 0 && vocid != 0) {
2336 if (hash == 0) hash = joaatHashBufCI(wname, wnlen);
2337 #if defined(UFO_DEBUG_FIND_WORD) || defined(UFO_DEBUG_FIND_WORD_IN_VOC)
2338 fprintf(stderr, "IN-VOC: %.*s; VOCID: 0x%08x; whash: 0x%08x; htbl[0]: 0x%08x\n",
2339 (unsigned) wnlen, (const char *)wname,
2340 vocid, hash, ufoImgGetU32(vocid + UFW_VOCAB_OFS_HTABLE));
2341 #endif
2342 const uint32_t htbl = vocid + UFW_VOCAB_OFS_HTABLE;
2343 if (ufoImgGetU32(htbl) != UFO_NO_HTABLE_FLAG) {
2344 // hash table present, use it
2345 uint32_t bfa = htbl + (hash % (uint32_t)UFO_HASHTABLE_SIZE) * 4u;
2346 bfa = ufoImgGetU32(bfa);
2347 while (res == 0 && bfa != 0) {
2348 #if defined(UFO_DEBUG_FIND_WORD) || defined(UFO_DEBUG_FIND_WORD_IN_VOC)
2349 fprintf(stderr, "IN-VOC: bfa: 0x%08x\n", bfa);
2350 #endif
2351 res = ufoVocCheckName(UFO_BFA_TO_LFA(bfa), wname, wnlen, hash, allowvochid);
2352 bfa = ufoImgGetU32(bfa);
2354 } else {
2355 // no hash table, use linear search
2356 uint32_t lfa = vocid + UFW_VOCAB_OFS_LATEST;
2357 lfa = ufoImgGetU32(lfa);
2358 while (res == 0 && lfa != 0) {
2359 res = ufoVocCheckName(lfa, wname, wnlen, hash, allowvochid);
2360 lfa = ufoImgGetU32(lfa);
2364 return res;
2368 //==========================================================================
2370 // ufoFindColon
2372 // return part after the colon, or `NULL`
2374 //==========================================================================
2375 static const void *ufoFindColon (const void *wname, uint32_t wnlen) {
2376 const void *res = NULL;
2377 if (wnlen != 0) {
2378 ufo_assert(wname != NULL);
2379 const char *str = (const char *)wname;
2380 while (wnlen != 0 && str[0] != ':') {
2381 str += 1; wnlen -= 1;
2383 if (wnlen != 0) {
2384 res = (const void *)(str + 1); // skip colon
2387 return res;
2391 //==========================================================================
2393 // ufoFindWordInVocAndParents
2395 //==========================================================================
2396 static uint32_t ufoFindWordInVocAndParents (const void *wname, uint32_t wnlen, uint32_t hash,
2397 uint32_t vocid, int allowvochid)
2399 uint32_t res = 0;
2400 if (hash == 0) hash = joaatHashBufCI(wname, wnlen);
2401 while (res == 0 && vocid != 0) {
2402 res = ufoFindWordInVoc(wname, wnlen, hash, vocid, allowvochid);
2403 vocid = ufoImgGetU32(vocid + UFW_VOCAB_OFS_PARENT);
2405 return res;
2409 //==========================================================================
2411 // ufoFindWordNameRes
2413 // find with name resolution
2415 // return 0 or CFA
2417 //==========================================================================
2418 static uint32_t ufoFindWordNameRes (const void *wname, uint32_t wnlen) {
2419 uint32_t res = 0;
2420 if (wnlen != 0 && *(const char *)wname != ':') {
2421 ufo_assert(wname != NULL);
2423 const void *stx = wname;
2424 wname = ufoFindColon(wname, wnlen);
2425 if (wname != NULL) {
2426 // look in all vocabs (excluding hidden ones)
2427 uint32_t xlen = (uint32_t)(ptrdiff_t)(wname - stx) - 1u;
2428 ufo_assert(xlen > 0 && xlen < 255);
2429 uint32_t xhash = joaatHashBufCI(stx, xlen);
2430 uint32_t voclink = ufoImgGetU32(ufoAddrVocLink);
2431 #ifdef UFO_DEBUG_FIND_WORD_COLON
2432 fprintf(stderr, "COLON-FIND: first voc: {%.*s}; xhash=0x%08x; voc-link: 0x%08x\n",
2433 (unsigned)xlen, (const char *)stx, xhash, voclink);
2434 #endif
2435 while (res == 0 && voclink != 0) {
2436 const uint32_t vhdraddr = voclink - UFW_VOCAB_OFS_VOCLINK + UFW_VOCAB_OFS_HEADER;
2437 const uint32_t vhdr = ufoImgGetU32(vhdraddr);
2438 if (vhdr != 0) {
2439 res = ufoVocCheckName(UFO_NFA_TO_LFA(vhdr), stx, xlen, xhash, 0);
2441 if (res == 0) voclink = ufoImgGetU32(voclink);
2443 if (res != 0) {
2444 uint32_t vocid = voclink - UFW_VOCAB_OFS_VOCLINK;
2445 ufo_assert(voclink != 0);
2446 wnlen -= xlen + 1;
2447 #ifdef UFO_DEBUG_FIND_WORD_COLON
2448 fprintf(stderr, "searching {%.*s}(%u) in {%.*s}\n",
2449 (unsigned)wnlen, wname, wnlen, (unsigned)xlen, stx);
2450 #endif
2451 while (res != 0 && wname != NULL) {
2452 // first, the whole rest
2453 res = ufoFindWordInVocAndParents(wname, wnlen, 0, vocid, 1);
2454 if (res != 0) {
2455 wname = NULL;
2456 } else {
2457 stx = wname;
2458 wname = ufoFindColon(wname, wnlen);
2459 if (wname == NULL) xlen = wnlen; else xlen = (uint32_t)(ptrdiff_t)(wname - stx) - 1u;
2460 ufo_assert(xlen > 0 && xlen < 255);
2461 res = ufoFindWordInVocAndParents(stx, xlen, 0, vocid, 1);
2462 if (res != 0) {
2463 wnlen -= xlen + 1;
2464 if (wname != NULL) {
2465 // it should be a vocabulary
2466 const uint32_t nfa = UFO_CFA_TO_NFA(res);
2467 if ((ufoImgGetU32(nfa) & UFW_FLAG_VOCAB) != 0) {
2468 vocid = ufoImgGetU32(UFO_CFA_TO_PFA(res)); // pfa points to vocabulary
2469 } else {
2470 res = 0;
2480 return res;
2484 //==========================================================================
2486 // ufoFindWord
2488 // doesn't look in CURRENT, does name resolution ("a:b" is word "b" in "a")
2490 // return 0 or CFA
2492 //==========================================================================
2493 static uint32_t ufoFindWord (const char *wname) {
2494 uint32_t res = 0;
2495 if (wname && wname[0] != 0) {
2496 const size_t wnlen = strlen(wname);
2497 ufo_assert(wnlen < 8192);
2498 uint32_t ctx = ufoImgGetU32(ufoAddrContext);
2499 const uint32_t hash = joaatHashBufCI(wname, (uint32_t)wnlen);
2501 //fprintf(stderr, "FIND-WORD: whash: 0x%08x; name:{%s}\n", hash, wname);
2503 // first search in context
2504 res = ufoFindWordInVocAndParents(wname, (uint32_t)wnlen, hash, ctx, (ctx == ufoImgGetU32(ufoAddrCurrent)));
2506 // now try vocabulary stack
2507 uint32_t vstp = ufoVSP;
2508 while (res == 0 && vstp != 0) {
2509 vstp -= 1;
2510 ctx = ufoVocStack[vstp];
2511 res = ufoFindWordInVocAndParents(wname, (uint32_t)wnlen, hash, ctx, (ctx == ufoImgGetU32(ufoAddrCurrent)));
2514 // if not found, try name resolution
2515 if (res == 0) res = ufoFindWordNameRes(wname, (uint32_t)wnlen);
2518 return res;
2522 //==========================================================================
2524 // ufoCreateWordHeader
2526 // create word header up to CFA, link to the current dictionary
2528 //==========================================================================
2529 static void ufoCreateWordHeader (const char *wname, uint32_t flags) {
2530 if (wname == NULL) wname = "";
2531 const size_t wnlen = strlen(wname);
2532 ufo_assert(wnlen < UFO_MAX_WORD_LENGTH);
2533 const uint32_t hash = joaatHashBufCI(wname, (uint32_t)wnlen);
2534 const uint32_t curr = ufoImgGetU32(ufoAddrCurrent);
2535 ufo_assert(curr != 0);
2536 // redefine check
2537 const uint32_t warn = ufoImgGetU32(ufoAddrRedefineWarning);
2538 if (wnlen != 0 && warn != UFO_REDEF_WARN_DONT_CARE) {
2539 uint32_t cfa;
2540 if (warn != UFO_REDEF_WARN_PARENTS) {
2541 cfa = ufoFindWordInVoc(wname, wnlen, hash, curr, 1);
2542 } else {
2543 cfa = ufoFindWordInVocAndParents(wname, wnlen, hash, curr, 1);
2545 if (cfa != 0) {
2546 const uint32_t nfa = UFO_CFA_TO_NFA(cfa);
2547 const uint32_t flags = ufoImgGetU32(nfa);
2548 if ((flags & UFW_FLAG_PROTECTED) != 0) {
2549 ufoFatal("trying to redefine protected word '%s'", wname);
2550 } else if (warn != UFO_REDEF_WARN_NONE) {
2551 ufoWarning("redefining word '%s'", wname);
2555 //fprintf(stderr, "000: HERE: 0x%08x\n", UFO_GET_DP());
2556 const uint32_t bkt = (hash % (uint32_t)UFO_HASHTABLE_SIZE) * 4u;
2557 const uint32_t htbl = curr + UFW_VOCAB_OFS_HTABLE;
2558 ufoImgEmitAlign();
2559 const uint32_t xfaAddr = UFO_GET_DP();
2560 if ((xfaAddr & UFO_ADDR_TEMP_BIT) == 0) {
2561 // link previous yfa here
2562 const uint32_t lastxfa = ufoImgGetU32(ufoAddrLastXFA);
2563 // fix YFA of the previous word
2564 if (lastxfa != 0) {
2565 ufoImgPutU32(UFO_XFA_TO_YFA(lastxfa), UFO_XFA_TO_YFA(xfaAddr));
2567 // our XFA points to the previous XFA
2568 ufoImgEmitU32(lastxfa); // xfa
2569 // update last XFA
2570 ufoImgPutU32(ufoAddrLastXFA, xfaAddr);
2571 } else {
2572 ufoImgEmitU32(0); // xfa
2574 ufoImgEmitU32(0); // yfa
2575 // bucket link (bfa)
2576 if (wnlen == 0 || ufoImgGetU32(htbl) == UFO_NO_HTABLE_FLAG) {
2577 ufoImgEmitU32(0);
2578 } else {
2579 #ifdef UFO_DEBUG_DUMP_NEW_HEADERS
2580 fprintf(stderr, "NEW HEADER: %s; curr: 0x%08x; htbl: 0x%08x; bkt: 0x%08x\n",
2581 wname, curr, htbl, bkt);
2582 fprintf(stderr, " [bkt]: 0x%08x; nbk: 0x%08x\n", ufoImgGetU32(htbl + bkt), UFO_GET_DP());
2583 #endif
2584 // bfa points to bfa
2585 const uint32_t bfa = UFO_GET_DP();
2586 ufoImgEmitU32(ufoImgGetU32(htbl + bkt));
2587 ufoImgPutU32(htbl + bkt, bfa);
2589 // lfa
2590 const uint32_t lfa = UFO_GET_DP();
2591 ufoImgEmitU32(ufoImgGetU32(curr + UFW_VOCAB_OFS_LATEST));
2592 // fix voc latest
2593 ufoImgPutU32(curr + UFW_VOCAB_OFS_LATEST, lfa);
2594 // name hash
2595 ufoImgEmitU32(hash);
2596 // name length
2597 const uint32_t nfa = UFO_GET_DP();
2598 ufoImgEmitU32(((uint32_t)wnlen&0xffU) | (flags & 0xffffff00U));
2599 const uint32_t nstart = UFO_GET_DP();
2600 // put name
2601 for (size_t f = 0; f < wnlen; f += 1) {
2602 ufoImgEmitU8(((const unsigned char *)wname)[f]);
2604 while ((UFO_GET_DP() & 3) != 3) ufoImgEmitU8(0);
2605 const uint32_t nend = UFO_GET_DP(); // length byte itself is not included
2606 // name length, again
2607 ufo_assert(nend - nstart <= 255);
2608 ufoImgEmitU8((uint8_t)(nend - nstart));
2609 ufo_assert((UFO_GET_DP() & 3) == 0);
2610 ufo_assert(UFO_CFA_TO_NFA(UFO_GET_DP()) == nfa);
2611 if ((nend & UFO_ADDR_SPECIAL_BITS_MASK) == 0) ufoRecordDebug(nend);
2612 #ifdef UFO_DEBUG_DUMP_NEW_HEADERS
2613 fprintf(stderr, "*** NEW HEADER ***\n");
2614 fprintf(stderr, "CFA: 0x%08x\n", UFO_GET_DP());
2615 fprintf(stderr, "NSTART: 0x%08x\n", nstart);
2616 fprintf(stderr, "NEND: 0x%08x\n", nend);
2617 fprintf(stderr, "NLEN: %u (%u)\n", nend - nstart, ufoImgGetU8(UFO_GET_DP() - 1u));
2618 ufoDumpWordHeader(lfa);
2619 #endif
2620 #if 0
2621 fprintf(stderr, "NEW WORD CFA 0x%08x: %s\n", UFO_GET_DP(), wname);
2622 #endif
2626 //==========================================================================
2628 // ufoDecompilePart
2630 //==========================================================================
2631 static void ufoDecompilePart (uint32_t addr, uint32_t eaddr, int indent) {
2632 uint32_t count;
2633 FILE *fo = stdout;
2634 while (addr < eaddr) {
2635 uint32_t cfa = ufoImgGetU32(addr);
2636 for (int n = 0; n < indent; n += 1) fputc(' ', fo);
2637 fprintf(fo, "%6u: 0x%08x: ", addr, cfa);
2638 uint32_t nfa = UFO_CFA_TO_NFA(cfa);
2639 uint32_t flags = ufoImgGetU32(nfa);
2640 //fprintf(fo, "[0x%08x] ", flags & UFW_WARG_MASK);
2641 uint32_t nlen = flags & 0xffU;
2642 for (uint32_t f = 0; f < nlen; f += 1) {
2643 const uint8_t ch = ufoImgGetU8(nfa + 4u + f);
2644 if (ch <= 32 || ch >= 127) {
2645 fprintf(fo, "\\x%02x", ch);
2646 } else {
2647 fprintf(fo, "%c", (char)ch);
2650 addr += 4u;
2651 switch (flags & UFW_WARG_MASK) {
2652 case UFW_WARG_NONE:
2653 break;
2654 case UFW_WARG_BRANCH:
2655 fprintf(fo, " @%u", ufoImgGetU32(addr)); addr += 4u;
2656 break;
2657 case UFW_WARG_LIT:
2658 fprintf(fo, " %u : %d : 0x%08x", ufoImgGetU32(addr),
2659 (int32_t)ufoImgGetU32(addr), ufoImgGetU32(addr)); addr += 4u;
2660 break;
2661 case UFW_WARG_C4STRZ:
2662 count = ufoImgGetU32(addr); addr += 4;
2663 print_str:
2664 fprintf(fo, " str:");
2665 for (int f = 0; f < count; f += 1) {
2666 const uint8_t ch = ufoImgGetU8(addr); addr += 1u;
2667 if (ch <= 32 || ch >= 127) {
2668 fprintf(fo, "\\x%02x", ch);
2669 } else {
2670 fprintf(fo, "%c", (char)ch);
2673 addr += 1u; // skip zero byte
2674 addr = UFO_ALIGN4(addr);
2675 break;
2676 case UFW_WARG_CFA:
2677 cfa = ufoImgGetU32(addr); addr += 4u;
2678 fprintf(fo, " CFA:%u: ", cfa);
2679 nfa = UFO_CFA_TO_NFA(cfa);
2680 nlen = ufoImgGetU8(nfa);
2681 for (uint32_t f = 0; f < nlen; f += 1) {
2682 const uint8_t ch = ufoImgGetU8(nfa + 4u + f);
2683 if (ch <= 32 || ch >= 127) {
2684 fprintf(fo, "\\x%02x", ch);
2685 } else {
2686 fprintf(fo, "%c", (char)ch);
2689 break;
2690 case UFW_WARG_CBLOCK:
2691 fprintf(fo, " CBLOCK:%u", ufoImgGetU32(addr)); addr += 4u;
2692 break;
2693 case UFW_WARG_VOCID:
2694 fprintf(fo, " VOCID:%u", ufoImgGetU32(addr)); addr += 4u;
2695 break;
2696 case UFW_WARG_C1STRZ:
2697 count = ufoImgGetU8(addr); addr += 1;
2698 goto print_str;
2700 case UFW_WARG_U8:
2701 fprintf(fo, " ubyte:%u", ufoImgGetU8(addr)); addr += 1u;
2702 break;
2703 case UFW_WARG_S8:
2704 fprintf(fo, " sbyte:%u", ufoImgGetU8(addr)); addr += 1u;
2705 break;
2706 case UFW_WARG_U16:
2707 fprintf(fo, " uword:%u", ufoImgGetU16(addr)); addr += 2u;
2708 break;
2709 case UFW_WARG_S16:
2710 fprintf(fo, " sword:%u", ufoImgGetU16(addr)); addr += 2u;
2711 break;
2713 default:
2714 fprintf(fo, " -- WTF?!\n");
2715 abort();
2717 fputc('\n', fo);
2722 //==========================================================================
2724 // ufoDecompileWord
2726 //==========================================================================
2727 static void ufoDecompileWord (const uint32_t cfa) {
2728 if (cfa != 0) {
2729 const uint32_t lfa = UFO_CFA_TO_LFA(cfa);
2730 fprintf(stdout, "#### DECOMPILING CFA %u ###\n", cfa);
2731 ufoDumpWordHeader(lfa);
2732 const uint32_t yfa = ufoGetWordEndAddr(cfa);
2733 if (ufoImgGetU32(cfa) == ufoDoForthCFA) {
2734 fprintf(stdout, "--- DECOMPILED CODE ---\n");
2735 ufoDecompilePart(UFO_CFA_TO_PFA(cfa), yfa, 0);
2736 fprintf(stdout, "=======================\n");
2742 //==========================================================================
2744 // ufoBTShowWordName
2746 //==========================================================================
2747 static void ufoBTShowWordName (uint32_t nfa) {
2748 if (nfa != 0) {
2749 uint32_t len = ufoImgGetU8(nfa); nfa += 4u;
2750 //fprintf(stderr, "(0x%08x)", ufoImgGetU32(nfa - 4u));
2751 while (len != 0) {
2752 uint8_t ch = ufoImgGetU8(nfa); nfa += 1u; len -= 1u;
2753 if (ch <= 32 || ch >= 127) {
2754 fprintf(stderr, "\\x%02x", ch);
2755 } else {
2756 fprintf(stderr, "%c", (char)ch);
2763 //==========================================================================
2765 // ufoBacktrace
2767 //==========================================================================
2768 static void ufoBacktrace (uint32_t ip, int showDataStack) {
2769 // dump data stack (top 16)
2770 ufoFlushOutput();
2771 if (!ufoLastEmitWasCR) { printf("\n"); ufoLastEmitWasCR = 1; }
2773 if (showDataStack) {
2774 fprintf(stderr, "***UFO STACK DEPTH: %u\n", ufoSP);
2775 uint32_t xsp = ufoSP;
2776 if (xsp > 16) xsp = 16;
2777 for (uint32_t sp = 0; sp < xsp; ++sp) {
2778 fprintf(stderr, " %2u: 0x%08x %d%s\n",
2779 sp, ufoDStack[xsp - sp - 1], (int32_t)ufoDStack[xsp - sp - 1],
2780 (sp == 0 ? " -- TOS" : ""));
2782 if (ufoSP > 16) fprintf(stderr, " ...more...\n");
2785 // dump return stack (top 32)
2786 uint32_t nfa;
2787 uint32_t fline;
2788 const char *fname;
2790 fprintf(stderr, "***UFO RETURN STACK DEPTH: %u\n", ufoRP);
2791 if (ip != 0) {
2792 nfa = ufoFindWordForIP(ip);
2793 if (nfa != 0) {
2794 fprintf(stderr, " **: %8u -- ", ip);
2795 ufoBTShowWordName(nfa);
2796 fname = ufoFindFileForIP(ip, &fline, NULL, NULL);
2797 if (fname != NULL) { fprintf(stderr, " (at %s:%u)", fname, fline); }
2798 fputc('\n', stderr);
2801 uint32_t rp = ufoRP;
2802 uint32_t rscount = 0;
2803 if (rp > UFO_RSTACK_SIZE) rp = UFO_RSTACK_SIZE;
2804 while (rscount != 32 && rp != 0) {
2805 rp -= 1;
2806 const uint32_t val = ufoRStack[rp];
2807 nfa = ufoFindWordForIP(val);
2808 if (nfa != 0) {
2809 fprintf(stderr, " %2u: %8u -- ", ufoRP - rp - 1u, val);
2810 ufoBTShowWordName(nfa);
2811 fname = ufoFindFileForIP(val - 4u, &fline, NULL, NULL);
2812 if (fname != NULL) { fprintf(stderr, " (at %s:%u)", fname, fline); }
2813 fputc('\n', stderr);
2814 } else {
2815 fprintf(stderr, " %2u: 0x%08x %d\n", ufoRP - rp - 1u, val, (int32_t)val);
2817 rscount += 1;
2819 if (ufoRP > 32) fprintf(stderr, " ...more...\n");
2821 ufoFlushOutput();
2825 //==========================================================================
2827 // ufoDumpVocab
2829 //==========================================================================
2831 static void ufoDumpVocab (uint32_t vocid) {
2832 if (vocid != 0) {
2833 fprintf(stderr, "*** VOCID: 0x%08x ***\n", vocid);
2834 uint32_t vochdr = vocid + UFW_VOCAB_OFS_HEADER;
2835 vochdr = ufoImgGetU32(vochdr);
2836 if (vochdr != 0) {
2837 fprintf(stderr, "--- HEADER ---\n");
2838 ufoDumpWordHeader(UFO_NFA_TO_LFA(vochdr));
2839 fprintf(stderr, "========\n");
2840 uint32_t htbl = vocid + UFW_VOCAB_OFS_HTABLE;
2841 if (ufoImgGetU32(htbl) != UFO_NO_HTABLE_FLAG) {
2842 fprintf(stderr, "--- HASH TABLE ---\n");
2843 for (int f = 0; f < UFO_HASHTABLE_SIZE; f += 1) {
2844 uint32_t bfa = ufoImgGetU32(htbl);
2845 if (bfa != 0) {
2846 fprintf(stderr, "**** %2d: 0x%08x\n", f, bfa);
2847 do {
2848 ufoDumpWordHeader(UFO_BFA_TO_LFA(bfa));
2849 bfa = ufoImgGetU32(bfa);
2850 } while (bfa != 0);
2852 htbl += 4u;
2861 // if set, this will be used when we are out of include files. intended for UrAsm.
2862 // return 0 if there is no more lines, otherwise the string should be copied
2863 // to buffer, `*fname` and `*fline` should be properly set.
2864 int (*ufoFileReadLine) (void *buf, size_t bufsize, const char **fname, int *fline) = NULL;
2867 //==========================================================================
2869 // ufoLoadNextUserLine
2871 //==========================================================================
2872 static int ufoLoadNextUserLine (void) {
2873 uint32_t tibPos = 0;
2874 const char *fname = NULL;
2875 int fline = 0;
2876 ufoResetTib();
2877 if (ufoFileReadLine != NULL && ufoFileReadLine(ufoCurrFileLine, 510, &fname, &fline) != 0) {
2878 ufoCurrFileLine[510] = 0;
2879 uint32_t slen = (uint32_t)strlen(ufoCurrFileLine);
2880 while (slen != 0 && (ufoCurrFileLine[slen - 1u] == 10 || ufoCurrFileLine[slen - 1u] == 13)) {
2881 slen -= 1u;
2883 if (tibPos + slen + 1u > UFO_ADDR_HANDLE_OFS_MASK) {
2884 ufoFatal("input text line too long (at least %u bytes)", tibPos + slen);
2886 ufoTibEnsureSize(tibPos + slen + 1u);
2887 for (uint32_t f = 0; f < slen; f += 1) {
2888 ufoTibPokeChOfs(((const unsigned char *)ufoCurrFileLine)[f], tibPos + f);
2890 ufoTibPokeChOfs(0, tibPos + slen);
2891 tibPos += slen;
2892 if (fname == NULL) fname = "<user>";
2893 ufoSetInFileName(fname);
2894 ufoInFileLine = fline;
2895 return 1;
2896 } else {
2897 return 0;
2902 //==========================================================================
2904 // ufoLoadNextLine_NativeMode
2906 // load next file line into TIB
2907 // always strips final '\n'
2909 // return 0 on EOF, 1 on success
2911 //==========================================================================
2912 static int ufoLoadNextLine (int crossInclude) {
2913 int done = 0;
2914 uint32_t tibPos = 0;
2915 ufoResetTib();
2917 if (ufoMode == UFO_MODE_MACRO) {
2918 //fprintf(stderr, "***MAC!\n");
2919 return 0;
2922 while (ufoInFile != NULL && !done) {
2923 if (fgets(ufoCurrFileLine, 510, ufoInFile) != NULL) {
2924 // check for a newline
2925 // if there is no newline char at the end, the string was truncated
2926 ufoCurrFileLine[510] = 0;
2927 const uint32_t slen = (uint32_t)strlen(ufoCurrFileLine);
2928 if (tibPos + slen + 1u > UFO_ADDR_HANDLE_OFS_MASK) {
2929 ufoFatal("input text line too long (at least %u bytes)", tibPos + slen);
2931 ufoTibEnsureSize(tibPos + slen + 1u);
2932 for (uint32_t f = 0; f < slen; f += 1) {
2933 ufoTibPokeChOfs(((const unsigned char *)ufoCurrFileLine)[f], tibPos + f);
2935 ufoTibPokeChOfs(0, tibPos + slen);
2936 tibPos += slen;
2937 if (slen != 0 && (ufoCurrFileLine[slen - 1u] == 13 || ufoCurrFileLine[slen - 1u] == 10)) {
2938 ++ufoInFileLine;
2939 done = 1;
2940 } else {
2941 // continuation, nothing to do
2943 } else {
2944 // if we read nothing, this is EOF
2945 if (tibPos == 0 && crossInclude) {
2946 // we read nothing, and allowed to cross include boundaries
2947 ufoPopInFile();
2948 } else {
2949 done = 1;
2954 if (tibPos == 0) {
2955 // eof, try user-supplied input
2956 if (ufoFileStackPos == 0) {
2957 return ufoLoadNextUserLine();
2958 } else {
2959 return 0;
2961 } else {
2962 // if we read at least something, this is not EOF
2963 return 1;
2968 // ////////////////////////////////////////////////////////////////////////// //
2969 // debug
2971 // DUMP-STACK
2972 // ( -- )
2973 UFWORD(DUMP_STACK) {
2974 if (!ufoLastEmitWasCR) { printf("\n"); ufoLastEmitWasCR = 1; }
2975 printf("***UFO STACK DEPTH: %u\n", ufoSP);
2976 uint32_t xsp = ufoSP;
2977 if (xsp > 16) xsp = 16;
2978 for (uint32_t sp = 0; sp < xsp; ++sp) {
2979 printf(" %2u: 0x%08x %d%s\n",
2980 sp, ufoDStack[xsp - sp - 1], (int32_t)ufoDStack[xsp - sp - 1],
2981 (sp == 0 ? " -- TOS" : ""));
2983 if (ufoSP > 16) printf(" ...more...\n");
2984 ufoLastEmitWasCR = 1;
2987 // BACKTRACE
2988 // ( -- )
2989 UFWORD(UFO_BACKTRACE) {
2990 ufoFlushOutput();
2991 if (!ufoLastEmitWasCR) { printf("\n"); ufoLastEmitWasCR = 1; }
2992 if (ufoInFile != NULL) {
2993 fprintf(stderr, "*** at file %s, line %d ***\n", ufoInFileName, ufoInFileLine);
2994 } else {
2995 fprintf(stderr, "*** somewhere in time ***\n");
2997 ufoBacktrace(ufoIP, 1);
3000 // DUMP-STACK-TASK
3001 // ( stid -- )
3002 UFWORD(DUMP_STACK_TASK) {
3003 UfoState *st = ufoFindState(ufoPop());
3004 if (st == NULL) ufoFatal("invalid state id");
3005 // temporarily switch the task
3006 UfoState *oldst = ufoCurrState; ufoCurrState = st;
3007 // dump
3008 if (!ufoLastEmitWasCR) { printf("\n"); ufoLastEmitWasCR = 1; }
3009 printf("***UFO STACK DEPTH: %u\n", ufoSP);
3010 uint32_t xsp = ufoSP;
3011 if (xsp > 16) xsp = 16;
3012 for (uint32_t sp = 0; sp < xsp; ++sp) {
3013 printf(" %2u: 0x%08x %d%s\n",
3014 sp, ufoDStack[xsp - sp - 1], (int32_t)ufoDStack[xsp - sp - 1],
3015 (sp == 0 ? " -- TOS" : ""));
3017 if (ufoSP > 16) printf(" ...more...\n");
3018 ufoLastEmitWasCR = 1;
3019 // restore state
3020 ufoCurrState = oldst;
3023 // DUMP-RSTACK-TASK
3024 // ( stid -- )
3025 UFWORD(DUMP_RSTACK_TASK) {
3026 UfoState *st = ufoFindState(ufoPop());
3027 if (st == NULL) ufoFatal("invalid state id");
3028 // temporarily switch the task
3029 UfoState *oldst = ufoCurrState; ufoCurrState = st;
3030 // dump
3031 ufoFlushOutput();
3032 if (!ufoLastEmitWasCR) { printf("\n"); ufoLastEmitWasCR = 1; }
3033 if (ufoInFile != NULL) {
3034 fprintf(stderr, "*** at file %s, line %d ***\n", ufoInFileName, ufoInFileLine);
3035 } else {
3036 fprintf(stderr, "*** somewhere in time ***\n");
3038 ufoBacktrace(ufoIP, 0);
3039 // restore state
3040 ufoCurrState = oldst;
3043 // BACKTRACE-TASK
3044 // ( stid -- )
3045 UFWORD(UFO_BACKTRACE_TASK) {
3046 UfoState *st = ufoFindState(ufoPop());
3047 if (st == NULL) ufoFatal("invalid state id");
3048 // temporarily switch the task
3049 UfoState *oldst = ufoCurrState; ufoCurrState = st;
3050 // dump
3051 ufoFlushOutput();
3052 if (!ufoLastEmitWasCR) { printf("\n"); ufoLastEmitWasCR = 1; }
3053 if (ufoInFile != NULL) {
3054 fprintf(stderr, "*** at file %s, line %d ***\n", ufoInFileName, ufoInFileLine);
3055 } else {
3056 fprintf(stderr, "*** somewhere in time ***\n");
3058 ufoBacktrace(ufoIP, 1);
3059 // restore state
3060 ufoCurrState = oldst;
3064 // ////////////////////////////////////////////////////////////////////////// //
3065 // some init words, and PAD
3068 // SP0!
3069 // ( -- )
3070 UFWORD(SP0_STORE) { ufoSP = 0; }
3072 // RP0!
3073 // ( -- )
3074 UFWORD(RP0_STORE) {
3075 if (ufoRP != ufoRPTop) {
3076 ufoRP = ufoRPTop;
3077 // we need to push a dummy value
3078 ufoRPush(0xdeadf00d);
3082 // PAD
3083 // ( -- pad )
3084 // PAD is at the beginning of temp area
3085 UFWORD(PAD) {
3086 ufoPush(UFO_PAD_ADDR);
3090 // ////////////////////////////////////////////////////////////////////////// //
3091 // peeks and pokes with address register
3094 // A>
3095 // ( -- regA )
3096 UFWORD(REGA_LOAD) {
3097 ufoPush(ufoRegA);
3100 // >A
3101 // ( regA -- )
3102 UFWORD(REGA_STORE) {
3103 ufoRegA = ufoPop();
3106 // A-SWAP
3107 // ( regA -- oldA )
3108 // swap TOS and A
3109 UFWORD(REGA_SWAP) {
3110 const uint32_t newa = ufoPop();
3111 ufoPush(ufoRegA);
3112 ufoRegA = newa;
3115 // +1>A
3116 // ( -- )
3117 UFWORD(REGA_INC) {
3118 ufoRegA += 1u;
3121 // +4>A
3122 // ( -- )
3123 UFWORD(REGA_INC_CELL) {
3124 ufoRegA += 4u;
3127 // A>R
3128 // ( -- | rega )
3129 UFWORD(REGA_TO_R) {
3130 ufoRPush(ufoRegA);
3133 // R>A
3134 // ( | rega -- )
3135 UFWORD(R_TO_REGA) {
3136 ufoRegA = ufoRPop();
3140 // ////////////////////////////////////////////////////////////////////////// //
3141 // useful to work with handles and normal addreses uniformly
3144 // C@A+
3145 // ( idx -- byte )
3146 UFWORD(CPEEK_REGA_IDX) {
3147 if ((ufoRegA & UFO_ADDR_HANDLE_BIT) == 0) {
3148 const uint32_t idx = ufoPop();
3149 const uint32_t newaddr = ufoRegA + idx;
3150 if ((ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == (newaddr & UFO_ADDR_SPECIAL_BITS_MASK)) {
3151 ufoPush(ufoImgGetU8Ext(newaddr));
3152 } else {
3153 ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
3154 ufoRegA, idx, newaddr);
3156 } else {
3157 ufoPush(ufoRegA);
3158 UFCALL(PAR_HANDLE_LOAD_BYTE);
3162 // W@A+
3163 // ( idx -- word )
3164 UFWORD(WPEEK_REGA_IDX) {
3165 if ((ufoRegA & UFO_ADDR_HANDLE_BIT) == 0) {
3166 const uint32_t idx = ufoPop();
3167 const uint32_t newaddr = ufoRegA + idx;
3168 if ((ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == (newaddr & UFO_ADDR_SPECIAL_BITS_MASK) &&
3169 (ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == ((newaddr + 1u) & UFO_ADDR_SPECIAL_BITS_MASK))
3171 ufoPush(ufoImgGetU16(newaddr));
3172 } else {
3173 ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
3174 ufoRegA, idx, newaddr);
3176 } else {
3177 ufoPush(ufoRegA);
3178 UFCALL(PAR_HANDLE_LOAD_WORD);
3182 // @A+
3183 // ( idx -- value )
3184 UFWORD(PEEK_REGA_IDX) {
3185 if ((ufoRegA & UFO_ADDR_HANDLE_BIT) == 0) {
3186 const uint32_t idx = ufoPop();
3187 const uint32_t newaddr = ufoRegA + idx;
3188 if ((ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == (newaddr & UFO_ADDR_SPECIAL_BITS_MASK) &&
3189 (ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == ((newaddr + 3u) & UFO_ADDR_SPECIAL_BITS_MASK))
3191 ufoPush(ufoImgGetU32(newaddr));
3192 } else {
3193 ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
3194 ufoRegA, idx, newaddr);
3196 } else {
3197 ufoPush(ufoRegA);
3198 UFCALL(PAR_HANDLE_LOAD_CELL);
3202 // C!A+
3203 // ( byte idx -- )
3204 UFWORD(CPOKE_REGA_IDX) {
3205 if ((ufoRegA & UFO_ADDR_HANDLE_BIT) == 0) {
3206 const uint32_t idx = ufoPop();
3207 const uint32_t newaddr = ufoRegA + idx;
3208 if ((ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == (newaddr & UFO_ADDR_SPECIAL_BITS_MASK)) {
3209 const uint32_t value = ufoPop();
3210 ufoImgPutU8(newaddr, value);
3211 } else {
3212 ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
3213 ufoRegA, idx, newaddr);
3215 } else {
3216 ufoPush(ufoRegA);
3217 UFCALL(PAR_HANDLE_STORE_BYTE);
3221 // W!A+
3222 // ( word idx -- )
3223 UFWORD(WPOKE_REGA_IDX) {
3224 if ((ufoRegA & UFO_ADDR_HANDLE_BIT) == 0) {
3225 const uint32_t idx = ufoPop();
3226 const uint32_t newaddr = ufoRegA + idx;
3227 if ((ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == (newaddr & UFO_ADDR_SPECIAL_BITS_MASK) &&
3228 (ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == ((newaddr + 1u) & UFO_ADDR_SPECIAL_BITS_MASK))
3230 const uint32_t value = ufoPop();
3231 ufoImgPutU16(newaddr, value);
3232 } else {
3233 ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
3234 ufoRegA, idx, newaddr);
3236 } else {
3237 ufoPush(ufoRegA);
3238 UFCALL(PAR_HANDLE_STORE_WORD);
3242 // !A+
3243 // ( value idx -- )
3244 UFWORD(POKE_REGA_IDX) {
3245 if ((ufoRegA & UFO_ADDR_HANDLE_BIT) == 0) {
3246 const uint32_t idx = ufoPop();
3247 const uint32_t newaddr = ufoRegA + idx;
3248 if ((ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == (newaddr & UFO_ADDR_SPECIAL_BITS_MASK) &&
3249 (ufoRegA & UFO_ADDR_SPECIAL_BITS_MASK) == ((newaddr + 3u) & UFO_ADDR_SPECIAL_BITS_MASK))
3251 const uint32_t value = ufoPop();
3252 ufoImgPutU32(newaddr, value);
3253 } else {
3254 ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
3255 ufoRegA, idx, newaddr);
3257 } else {
3258 ufoPush(ufoRegA);
3259 UFCALL(PAR_HANDLE_STORE_CELL);
3264 // ////////////////////////////////////////////////////////////////////////// //
3265 // peeks and pokes
3268 // C@
3269 // ( addr -- value8 )
3270 UFWORD(CPEEK) {
3271 ufoPush(ufoImgGetU8Ext(ufoPop()));
3274 // W@
3275 // ( addr -- value16 )
3276 UFWORD(WPEEK) {
3277 const uint32_t addr = ufoPop();
3278 if ((addr & UFO_ADDR_HANDLE_BIT) == 0) {
3279 ufoPush(ufoImgGetU16(addr));
3280 } else {
3281 ufoPush(0);
3282 ufoPush(addr);
3283 UFCALL(PAR_HANDLE_LOAD_WORD);
3287 // @
3288 // ( addr -- value32 )
3289 UFWORD(PEEK) {
3290 const uint32_t addr = ufoPop();
3291 if ((addr & UFO_ADDR_HANDLE_BIT) == 0) {
3292 ufoPush(ufoImgGetU32(addr));
3293 } else {
3294 ufoPush(0);
3295 ufoPush(addr);
3296 UFCALL(PAR_HANDLE_LOAD_CELL);
3300 // C!
3301 // ( val8 addr -- )
3302 UFWORD(CPOKE) {
3303 const uint32_t addr = ufoPop();
3304 const uint32_t val = ufoPop();
3305 ufoImgPutU8Ext(addr, val);
3308 // W!
3309 // ( val16 addr -- )
3310 UFWORD(WPOKE) {
3311 const uint32_t addr = ufoPop();
3312 const uint32_t val = ufoPop();
3313 if ((addr & UFO_ADDR_HANDLE_BIT) == 0) {
3314 ufoImgPutU16(addr, val);
3315 } else {
3316 ufoPush(val);
3317 ufoPush(0);
3318 ufoPush(addr);
3319 UFCALL(PAR_HANDLE_STORE_WORD);
3323 // !
3324 // ( val32 addr -- )
3325 UFWORD(POKE) {
3326 const uint32_t addr = ufoPop();
3327 const uint32_t val = ufoPop();
3328 if ((addr & UFO_ADDR_HANDLE_BIT) == 0) {
3329 ufoImgPutU32(addr, val);
3330 } else {
3331 ufoPush(val);
3332 ufoPush(0);
3333 ufoPush(addr);
3334 UFCALL(PAR_HANDLE_STORE_CELL);
3339 // ////////////////////////////////////////////////////////////////////////// //
3340 // dictionary emitters
3343 // C,
3344 // ( val8 -- )
3345 UFWORD(CCOMMA) { const uint32_t val = ufoPop(); ufoImgEmitU8(val); }
3347 // W,
3348 // ( val16 -- )
3349 UFWORD(WCOMMA) { const uint32_t val = ufoPop(); ufoImgEmitU8(val&0xffU); ufoImgEmitU8((val >> 8)&0xffU); }
3351 // ,
3352 // ( val -- )
3353 UFWORD(COMMA) { const uint32_t val = ufoPop(); ufoImgEmitU32(val); }
3356 // ////////////////////////////////////////////////////////////////////////// //
3357 // literal pushers
3360 // (LIT) ( -- n )
3361 UFWORD(PAR_LIT) {
3362 const uint32_t v = ufoImgGetU32(ufoIP); ufoIP += 4;
3363 ufoPush(v);
3366 // (LITCFA) ( -- n )
3367 UFWORD(PAR_LITCFA) {
3368 const uint32_t v = ufoImgGetU32(ufoIP); ufoIP += 4;
3369 ufoPush(v);
3372 // (LITVOCID) ( -- n )
3373 UFWORD(PAR_LITVOCID) {
3374 const uint32_t v = ufoImgGetU32(ufoIP); ufoIP += 4;
3375 ufoPush(v);
3378 // (LITSTR8)
3379 UFWORD(PAR_LITSTR8) {
3380 const uint32_t count = ufoImgGetU8(ufoIP); ufoIP += 1;
3381 ufoPush(ufoIP);
3382 ufoPush(count);
3383 ufoIP += count + 1; // 1 for terminating 0
3384 // align
3385 ufoIP = UFO_ALIGN4(ufoIP);
3389 // ////////////////////////////////////////////////////////////////////////// //
3390 // jumps, etc.
3393 // (BRANCH) ( -- )
3394 UFWORD(PAR_BRANCH) {
3395 ufoIP = ufoImgGetU32(ufoIP);
3398 // (TBRANCH) ( flag )
3399 UFWORD(PAR_TBRANCH) {
3400 if (ufoPop()) {
3401 ufoIP = ufoImgGetU32(ufoIP);
3402 } else {
3403 ufoIP += 4;
3407 // (0BRANCH) ( flag )
3408 UFWORD(PAR_0BRANCH) {
3409 if (!ufoPop()) {
3410 ufoIP = ufoImgGetU32(ufoIP);
3411 } else {
3412 ufoIP += 4;
3416 // (+0BRANCH) ( flag )
3417 UFWORD(PAR_P0BRANCH) {
3418 if ((ufoPop() & 0x80000000u) == 0) {
3419 ufoIP = ufoImgGetU32(ufoIP);
3420 } else {
3421 ufoIP += 4;
3425 // (+BRANCH) ( flag )
3426 UFWORD(PAR_PBRANCH) {
3427 const uint32_t v = ufoPop();
3428 if (v > 0 && v < 0x80000000u) {
3429 ufoIP = ufoImgGetU32(ufoIP);
3430 } else {
3431 ufoIP += 4;
3435 // (-0BRANCH) ( flag )
3436 UFWORD(PAR_M0BRANCH) {
3437 const uint32_t v = ufoPop();
3438 if (v == 0 || v >= 0x80000000u) {
3439 ufoIP = ufoImgGetU32(ufoIP);
3440 } else {
3441 ufoIP += 4;
3445 // (-BRANCH) ( flag )
3446 UFWORD(PAR_MBRANCH) {
3447 if ((ufoPop() & 0x80000000u) != 0) {
3448 ufoIP = ufoImgGetU32(ufoIP);
3449 } else {
3450 ufoIP += 4;
3455 // ////////////////////////////////////////////////////////////////////////// //
3456 // execute words by CFA
3459 // EXECUTE ( cfa )
3460 UFWORD(EXECUTE) {
3461 ufoRPush(ufoPop());
3462 ufoVMRPopCFA = 1;
3465 // EXECUTE-TAIL ( cfa )
3466 UFWORD(EXECUTE_TAIL) {
3467 ufoIP = ufoRPop();
3468 ufoRPush(ufoPop());
3469 ufoVMRPopCFA = 1;
3473 // ////////////////////////////////////////////////////////////////////////// //
3474 // word termination, locals support
3477 // (EXIT)
3478 UFWORD(PAR_EXIT) {
3479 ufoIP = ufoRPop();
3482 // (L-ENTER)
3483 // ( loccount -- )
3484 UFWORD(PAR_LENTER) {
3485 // low byte of loccount is total number of locals
3486 // high byte is the number of args
3487 uint32_t lcount = ufoImgGetU32(ufoIP); ufoIP += 4u;
3488 uint32_t acount = (lcount >> 8) & 0xff;
3489 lcount &= 0xff;
3490 if (lcount == 0 || lcount < acount) ufoFatal("invalid call to (L-ENTER)");
3491 if ((ufoLBP != 0 && ufoLBP >= ufoLP) || UFO_LSTACK_SIZE - ufoLP <= lcount + 2) {
3492 ufoFatal("out of locals stack");
3494 uint32_t newbp;
3495 if (ufoLP == 0) { ufoLP = 1; newbp = 1; } else newbp = ufoLP;
3496 //fprintf(stderr, "LP: %u; LBP: %u; locs: %u; word: %s\n", ufoLP, ufoLBP, fw->locs, fw->name);
3497 ufoLStack[ufoLP] = ufoLBP; ufoLP += 1;
3498 ufoLBP = newbp; ufoLP += lcount;
3499 // and copy args
3500 newbp += acount;
3501 while (newbp != ufoLBP) {
3502 ufoLStack[newbp] = ufoPop();
3503 newbp -= 1;
3507 // (L-LEAVE)
3508 UFWORD(PAR_LLEAVE) {
3509 if (ufoLBP == 0) ufoFatal("(L-LEAVE) with empty locals stack");
3510 if (ufoLBP >= ufoLP) ufoFatal("(L-LEAVE) broken locals stack");
3511 ufoLP = ufoLBP;
3512 ufoLBP = ufoLStack[ufoLBP];
3515 //==========================================================================
3517 // ufoLoadLocal
3519 //==========================================================================
3520 UFO_FORCE_INLINE void ufoLoadLocal (const uint32_t lidx) {
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 ufoPush(ufoLStack[ufoLBP + lidx]);
3526 //==========================================================================
3528 // ufoStoreLocal
3530 //==========================================================================
3531 UFO_FORCE_INLINE void ufoStoreLocal (const uint32_t lidx) {
3532 const uint32_t value = ufoPop();
3533 if (lidx == 0 || lidx >= UFO_LSTACK_SIZE) ufoFatal("invalid local index");
3534 if (ufoLBP == 0 || ufoLBP >= ufoLP || ufoLP - ufoLBP <= lidx) ufoFatal("invalid local index");
3535 ufoLStack[ufoLBP + lidx] = value;
3538 // (LOCAL@)
3539 // ( idx -- value )
3540 UFWORD(PAR_LOCAL_LOAD) { ufoLoadLocal(ufoPop()); }
3542 // (LOCAL!)
3543 // ( value idx -- )
3544 UFWORD(PAR_LOCAL_STORE) { ufoStoreLocal(ufoPop()); }
3547 // ////////////////////////////////////////////////////////////////////////// //
3548 // stack manipulation
3551 // DUP
3552 // ( n -- n n )
3553 UFWORD(DUP) { ufoDup(); }
3554 // ?DUP
3555 // ( n -- n n ) | ( 0 -- 0 )
3556 UFWORD(QDUP) { if (ufoPeek()) ufoDup(); }
3557 // 2DUP
3558 // ( n0 n1 -- n0 n1 n0 n1 )
3559 UFWORD(DDUP) { ufo2Dup(); }
3560 // DROP
3561 // ( n -- )
3562 UFWORD(DROP) { ufoDrop(); }
3563 // 2DROP
3564 // ( n0 n1 -- )
3565 UFWORD(DDROP) { ufo2Drop(); }
3566 // SWAP
3567 // ( n0 n1 -- n1 n0 )
3568 UFWORD(SWAP) { ufoSwap(); }
3569 // 2SWAP
3570 // ( n0 n1 -- n1 n0 )
3571 UFWORD(DSWAP) { ufo2Swap(); }
3572 // OVER
3573 // ( n0 n1 -- n0 n1 n0 )
3574 UFWORD(OVER) { ufoOver(); }
3575 // 2OVER
3576 // ( n0 n1 -- n0 n1 n0 )
3577 UFWORD(DOVER) { ufo2Over(); }
3578 // ROT
3579 // ( n0 n1 n2 -- n1 n2 n0 )
3580 UFWORD(ROT) { ufoRot(); }
3581 // NROT
3582 // ( n0 n1 n2 -- n2 n0 n1 )
3583 UFWORD(NROT) { ufoNRot(); }
3585 // RDUP
3586 // ( n -- n n )
3587 UFWORD(RDUP) { ufoRDup(); }
3588 // RDROP
3589 // ( n -- )
3590 UFWORD(RDROP) { ufoRDrop(); }
3592 // >R
3593 // ( n -- | n )
3594 UFWORD(DTOR) { ufoRPush(ufoPop()); }
3595 // R>
3596 // ( | n -- n )
3597 UFWORD(RTOD) { ufoPush(ufoRPop()); }
3598 // R@
3599 // ( | n -- n | n)
3600 UFWORD(RPEEK) { ufoPush(ufoRPeek()); }
3602 // PICK
3603 // ( idx -- n )
3604 UFWORD(PICK) {
3605 const uint32_t n = ufoPop();
3606 if (n >= ufoSP) ufoFatal("invalid PICK index %u", n);
3607 ufoPush(ufoDStack[ufoSP - n - 1u]);
3610 // RPICK
3611 // ( idx -- n )
3612 UFWORD(RPICK) {
3613 const uint32_t n = ufoPop();
3614 if (n >= ufoRP - ufoRPTop) ufoFatal("invalid RPICK index %u", n);
3615 const uint32_t rp = ufoRP - n - 1u;
3616 ufoPush(ufoRStack[rp]);
3619 // ROLL
3620 // ( idx -- n )
3621 UFWORD(ROLL) {
3622 const uint32_t n = ufoPop();
3623 if (n >= ufoSP) ufoFatal("invalid ROLL index %u", n);
3624 switch (n) {
3625 case 0: break; // do nothing
3626 case 1: ufoSwap(); break;
3627 case 2: ufoRot(); break;
3628 default:
3630 const uint32_t val = ufoDStack[ufoSP - n - 1u];
3631 for (uint32_t f = ufoSP - n; f < ufoSP; f += 1) ufoDStack[f - 1] = ufoDStack[f];
3632 ufoDStack[ufoSP - 1u] = val;
3634 break;
3638 // RROLL
3639 // ( idx -- n )
3640 UFWORD(RROLL) {
3641 const uint32_t n = ufoPop();
3642 if (n >= ufoRP - ufoRPTop) ufoFatal("invalid RROLL index %u", n);
3643 if (n != 0) {
3644 const uint32_t rp = ufoRP - n - 1u;
3645 const uint32_t val = ufoRStack[rp];
3646 for (uint32_t f = rp + 1u; f < ufoRP; f += 1u) ufoRStack[f - 1u] = ufoRStack[f];
3647 ufoRStack[ufoRP - 1u] = val;
3651 // RSWAP
3652 // ( | a b -- | b a )
3653 UFWORD(RSWAP) {
3654 const uint32_t b = ufoRPop();
3655 const uint32_t a = ufoRPop();
3656 ufoRPush(b); ufoRPush(a);
3659 // ROVER
3660 // ( | a b -- | a b a )
3661 UFWORD(ROVER) {
3662 const uint32_t b = ufoRPop();
3663 const uint32_t a = ufoRPop();
3664 ufoRPush(a); ufoRPush(b); ufoRPush(a);
3667 // RROT
3668 // ( | a b c -- | b c a )
3669 UFWORD(RROT) {
3670 const uint32_t c = ufoRPop();
3671 const uint32_t b = ufoRPop();
3672 const uint32_t a = ufoRPop();
3673 ufoRPush(b); ufoRPush(c); ufoRPush(a);
3676 // RNROT
3677 // ( | a b c -- | c a b )
3678 UFWORD(RNROT) {
3679 const uint32_t c = ufoRPop();
3680 const uint32_t b = ufoRPop();
3681 const uint32_t a = ufoRPop();
3682 ufoRPush(c); ufoRPush(a); ufoRPush(b);
3686 // ////////////////////////////////////////////////////////////////////////// //
3687 // TIB API
3690 // REFILL
3691 // ( -- eofflag )
3692 UFWORD(REFILL) {
3693 ufoPushBool(ufoLoadNextLine(1));
3696 // REFILL-NOCROSS
3697 // ( -- eofflag )
3698 UFWORD(REFILL_NOCROSS) {
3699 ufoPushBool(ufoLoadNextLine(0));
3702 // (TIB-IN)
3703 // ( -- addr )
3704 UFWORD(TIB_IN) {
3705 ufoPush(ufoImgGetU32(ufoAddrTIBx) + ufoImgGetU32(ufoAddrINx));
3708 // TIB-PEEKCH
3709 // ( -- char )
3710 UFWORD(TIB_PEEKCH) {
3711 ufoPush(ufoTibPeekCh());
3714 // TIB-PEEKCH-OFS
3715 // ( ofs -- char )
3716 UFWORD(TIB_PEEKCH_OFS) {
3717 const uint32_t ofs = ufoPop();
3718 ufoPush(ufoTibPeekChOfs(ofs));
3721 // TIB-GETCH
3722 // ( -- char )
3723 UFWORD(TIB_GETCH) {
3724 ufoPush(ufoTibGetCh());
3727 // TIB-SKIPCH
3728 // ( -- )
3729 UFWORD(TIB_SKIPCH) {
3730 ufoTibSkipCh();
3734 // ////////////////////////////////////////////////////////////////////////// //
3735 // TIB parsing
3738 //==========================================================================
3740 // ufoIsDelim
3742 //==========================================================================
3743 UFO_FORCE_INLINE int ufoIsDelim (uint8_t ch, uint8_t delim) {
3744 return (delim == 32 ? (ch <= 32) : (ch == delim));
3747 // (PARSE)
3748 // ( delim skip-leading-delim? -- addr count TRUE / FALSE )
3749 // does base TIB parsing; never copies anything.
3750 // as our reader is line-based, returns FALSE on EOL.
3751 // EOL is detected after skipping leading delimiters.
3752 // passing -1 as delimiter skips the whole line, and always returns FALSE.
3753 // trailing delimiter is always skipped.
3754 UFWORD(PAR_PARSE) {
3755 const uint32_t skipDelim = ufoPop();
3756 const uint32_t delim = ufoPop();
3757 uint8_t ch;
3759 if (delim == 0 || delim > 0xffU) {
3760 // skip everything
3761 while (ufoTibGetCh() != 0) {}
3762 ufoPushBool(0);
3763 } else {
3764 ch = ufoTibPeekCh();
3765 // skip initial delimiters
3766 if (skipDelim) {
3767 while (ch != 0 && ufoIsDelim(ch, delim)) {
3768 ufoTibSkipCh();
3769 ch = ufoTibPeekCh();
3772 if (ch == 0) {
3773 ufoPushBool(0);
3774 } else {
3775 // parse
3776 const uint32_t staddr = ufoImgGetU32(ufoAddrTIBx) + ufoImgGetU32(ufoAddrINx);
3777 uint32_t count = 0;
3778 while (ch != 0 && !ufoIsDelim(ch, delim)) {
3779 count += 1u;
3780 ufoTibSkipCh();
3781 ch = ufoTibPeekCh();
3783 // skip delimiter
3784 if (ch != 0) ufoTibSkipCh();
3785 ufoPush(staddr);
3786 ufoPush(count);
3787 ufoPushBool(1);
3792 // PARSE-SKIP-BLANKS
3793 // ( -- )
3794 UFWORD(PARSE_SKIP_BLANKS) {
3795 uint8_t ch = ufoTibPeekCh();
3796 while (ch != 0 && ch <= 32) {
3797 ufoTibSkipCh();
3798 ch = ufoTibPeekCh();
3802 //==========================================================================
3804 // ufoParseMLComment
3806 // initial two chars are skipped
3808 //==========================================================================
3809 static void ufoParseMLComment (uint32_t allowMulti, int nested) {
3810 uint32_t level = 1;
3811 uint8_t ch, ch1;
3812 while (level != 0) {
3813 ch = ufoTibGetCh();
3814 if (ch == 0) {
3815 if (allowMulti) {
3816 UFCALL(REFILL_NOCROSS);
3817 if (ufoPop() == 0) ufoFatal("unexpected end of file in comment");
3818 } else {
3819 ufoFatal("unexpected end of line in comment");
3821 } else {
3822 ch1 = ufoTibPeekCh();
3823 if (nested && ch == '(' && ch1 == '(') { ufoTibSkipCh(); level += 1; }
3824 else if (nested && ch == ')' && ch1 == ')') { ufoTibSkipCh(); level -= 1; }
3825 else if (!nested && ch == '*' && ch1 == ')') { ufo_assert(level == 1); ufoTibSkipCh(); level = 0; }
3830 // (PARSE-SKIP-COMMENTS)
3831 // ( allow-multiline? -- )
3832 // skip all blanks and comments
3833 UFWORD(PAR_PARSE_SKIP_COMMENTS) {
3834 const uint32_t allowMulti = ufoPop();
3835 uint8_t ch, ch1;
3836 ch = ufoTibPeekCh();
3837 #if 0
3838 fprintf(stderr, "(PARSE-SKIP-COMMENTS): first-ch:'%c'\n", (char)ch);
3839 #endif
3840 while (ch != 0) {
3841 if (ch <= 32) {
3842 ufoTibSkipCh();
3843 ch = ufoTibPeekCh();
3844 #if 0
3845 fprintf(stderr, "(PARSE-SKIP-COMMENTS): blank-ch:'%c'\n", (char)ch);
3846 #endif
3847 } else if (ch == '(') {
3848 #if 0
3849 fprintf(stderr, "(PARSE-SKIP-COMMENTS): ch:'%c'; ch1:'%c' ('%c')\n", (char)ch, (char)ch1,
3850 ufoTibPeekChOfs(0));
3851 #endif
3852 ch1 = ufoTibPeekChOfs(1);
3853 if (ch1 <= 32) {
3854 // single-line comment
3855 do { ch = ufoTibGetCh(); } while (ch != 0 && ch != ')');
3856 ch = ufoTibPeekCh();
3857 } else if ((ch1 == '*' || ch1 == '(') && ufoTibPeekChOfs(2) <= 32) {
3858 // possibly multiline
3859 ufoTibSkipCh(); ufoTibSkipCh(); // skip opening
3860 ufoParseMLComment(allowMulti, (ch1 == '('));
3861 ch = ufoTibPeekCh();
3862 } else {
3863 ch = 0;
3865 } else if (ch == '\\' && ufoTibPeekChOfs(1) <= 32) {
3866 // single-line comment
3867 while (ch != 0) ch = ufoTibGetCh();
3868 } else if ((ch == ';' || ch == '-' || ch == '/') && (ufoTibPeekChOfs(1) == ch)) {
3869 // skip to EOL
3870 while (ch != 0) ch = ufoTibGetCh();
3871 } else {
3872 ch = 0;
3875 #if 0
3876 fprintf(stderr, "(PARSE-SKIP-COMMENTS): end-ch:'%c'\n", ufoTibPeekCh());
3877 #endif
3880 // PARSE-SKIP-LINE
3881 // ( -- )
3882 UFWORD(PARSE_SKIP_LINE) {
3883 ufoPush(0); ufoPushBool(0); UFCALL(PAR_PARSE);
3884 if (ufoPop() != 0) {
3885 ufo2Drop();
3889 // PARSE-NAME
3890 // ( -- addr count )
3891 // parse with leading blanks skipping. doesn't copy anything.
3892 // return empty string on EOL.
3893 UFWORD(PARSE_NAME) {
3894 ufoPush(32); ufoPushBool(1); UFCALL(PAR_PARSE);
3895 if (ufoPop() == 0) {
3896 ufoPush(0);
3897 ufoPush(0);
3901 // PARSE
3902 // ( delim -- addr count TRUE / FALSE )
3903 // parse without skipping delimiters; never copies anything.
3904 // as our reader is line-based, returns FALSE on EOL.
3905 // passing 0 as delimiter skips the whole line, and always returns FALSE.
3906 // trailing delimiter is always skipped.
3907 UFWORD(PARSE) {
3908 ufoPushBool(0); UFCALL(PAR_PARSE);
3912 // ////////////////////////////////////////////////////////////////////////// //
3913 // char output
3916 // (NORM-EMIT-CHAR)
3917 // ( ch -- )
3918 UFWORD(PAR_NORM_EMIT_CHAR) {
3919 uint32_t ch = ufoPop()&0xffU;
3920 if (ch < 32 || ch == 127) {
3921 if (ch != 9 && ch != 10 && ch != 13) ch = '?';
3923 ufoPush(ch);
3926 // (NORM-XEMIT-CHAR)
3927 // ( ch -- )
3928 UFWORD(PAR_NORM_XEMIT_CHAR) {
3929 uint32_t ch = ufoPop()&0xffU;
3930 if (ch < 32 || ch == 127) ch = '?';
3931 ufoPush(ch);
3934 // (EMIT)
3935 // ( n -- )
3936 UFWORD(PAR_EMIT) {
3937 uint32_t ch = ufoPop()&0xffU;
3938 ufoLastEmitWasCR = (ch == 10);
3939 putchar((char)ch);
3942 // LASTCR?
3943 // ( -- bool )
3944 UFWORD(LASTCRQ) {
3945 ufoPushBool(ufoLastEmitWasCR);
3948 // LASTCR!
3949 // ( bool -- )
3950 UFWORD(LASTCRSET) {
3951 ufoLastEmitWasCR = !!ufoPop();
3954 // FLUSH-EMIT
3955 // ( -- )
3956 UFWORD(FLUSH_EMIT) {
3957 ufoFlushOutput();
3961 // ////////////////////////////////////////////////////////////////////////// //
3962 // simple math
3965 #define UF_UMATH(name_,op_) \
3966 UFWORD(name_) { \
3967 const uint32_t a = ufoPop(); \
3968 ufoPush(op_); \
3971 #define UF_BMATH(name_,op_) \
3972 UFWORD(name_) { \
3973 const uint32_t b = ufoPop(); \
3974 const uint32_t a = ufoPop(); \
3975 ufoPush(op_); \
3978 #define UF_BDIV(name_,op_) \
3979 UFWORD(name_) { \
3980 const uint32_t b = ufoPop(); \
3981 const uint32_t a = ufoPop(); \
3982 if (b == 0) ufoFatal("division by zero"); \
3983 ufoPush(op_); \
3986 #define UFO_POP_U64() ({ \
3987 const uint32_t hi_ = ufoPop(); \
3988 const uint32_t lo_ = ufoPop(); \
3989 (((uint64_t)hi_ << 32) | lo_); \
3992 // this is UB by the idiotic C standard. i don't care.
3993 #define UFO_POP_I64() ((int64_t)UFO_POP_U64())
3995 #define UFO_PUSH_U64(vn_) do { \
3996 ufoPush((uint32_t)(vn_)); \
3997 ufoPush((uint32_t)((vn_) >> 32)); \
3998 } while (0)
4000 // this is UB by the idiotic C standard. i don't care.
4001 #define UFO_PUSH_I64(vn_) UFO_PUSH_U64((uint64_t)(vn_))
4003 // +
4004 // ( a b -- a+b )
4005 UF_BMATH(PLUS, a + b);
4007 // -
4008 // ( a b -- a-b )
4009 UF_BMATH(MINUS, a - b);
4011 // *
4012 // ( a b -- a*b )
4013 UF_BMATH(MUL, (uint32_t)((int32_t)a * (int32_t)b));
4015 // U*
4016 // ( a b -- a*b )
4017 UF_BMATH(UMUL, a * b);
4019 // /
4020 // ( a b -- a/b )
4021 UF_BDIV(DIV, (uint32_t)((int32_t)a / (int32_t)b));
4023 // U/
4024 // ( a b -- a/b )
4025 UF_BDIV(UDIV, a / b);
4027 // MOD
4028 // ( a b -- a%b )
4029 UF_BDIV(MOD, (uint32_t)((int32_t)a % (int32_t)b));
4031 // UMOD
4032 // ( a b -- a%b )
4033 UF_BDIV(UMOD, a % b);
4035 // /MOD
4036 // ( a b -- a/b, a%b )
4037 UFWORD(DIVMOD) {
4038 const int32_t b = (int32_t)ufoPop();
4039 const int32_t a = (int32_t)ufoPop();
4040 if (b == 0) ufoFatal("division by zero");
4041 ufoPush((uint32_t)(a/b));
4042 ufoPush((uint32_t)(a%b));
4045 // U/MOD
4046 // ( a b -- a/b, a%b )
4047 UFWORD(UDIVMOD) {
4048 const uint32_t b = ufoPop();
4049 const uint32_t a = ufoPop();
4050 if (b == 0) ufoFatal("division by zero");
4051 ufoPush((uint32_t)(a/b));
4052 ufoPush((uint32_t)(a%b));
4055 // */
4056 // ( a b c -- a*b/c )
4057 // this uses 64-bit intermediate value
4058 UFWORD(MULDIV) {
4059 const int32_t c = (int32_t)ufoPop();
4060 const int32_t b = (int32_t)ufoPop();
4061 const int32_t a = (int32_t)ufoPop();
4062 if (c == 0) ufoFatal("division by zero");
4063 int64_t xval = a; xval *= b; xval /= c;
4064 ufoPush((uint32_t)(int32_t)xval);
4067 // U*/
4068 // ( a b c -- a*b/c )
4069 // this uses 64-bit intermediate value
4070 UFWORD(UMULDIV) {
4071 const uint32_t c = ufoPop();
4072 const uint32_t b = ufoPop();
4073 const uint32_t a = ufoPop();
4074 if (c == 0) ufoFatal("division by zero");
4075 uint64_t xval = a; xval *= b; xval /= c;
4076 ufoPush((uint32_t)xval);
4079 // */MOD
4080 // ( a b c -- a*b/c a*b%c )
4081 // this uses 64-bit intermediate value
4082 UFWORD(MULDIVMOD) {
4083 const int32_t c = (int32_t)ufoPop();
4084 const int32_t b = (int32_t)ufoPop();
4085 const int32_t a = (int32_t)ufoPop();
4086 if (c == 0) ufoFatal("division by zero");
4087 int64_t xval = a; xval *= b;
4088 ufoPush((uint32_t)(int32_t)(xval / c));
4089 ufoPush((uint32_t)(int32_t)(xval % c));
4092 // U*/
4093 // ( a b c -- a*b/c )
4094 // this uses 64-bit intermediate value
4095 UFWORD(UMULDIVMOD) {
4096 const uint32_t c = ufoPop();
4097 const uint32_t b = ufoPop();
4098 const uint32_t a = ufoPop();
4099 if (c == 0) ufoFatal("division by zero");
4100 uint64_t xval = a; xval *= b;
4101 ufoPush((uint32_t)(xval / c));
4102 ufoPush((uint32_t)(xval % c));
4105 // M*
4106 // ( a b -- lo(a*b) hi(a*b) )
4107 // this leaves 64-bit result
4108 UFWORD(MMUL) {
4109 const int32_t b = (int32_t)ufoPop();
4110 const int32_t a = (int32_t)ufoPop();
4111 int64_t xval = a; xval *= b;
4112 UFO_PUSH_I64(xval);
4115 // UM*
4116 // ( a b -- lo(a*b) hi(a*b) )
4117 // this leaves 64-bit result
4118 UFWORD(UMMUL) {
4119 const uint32_t b = ufoPop();
4120 const uint32_t a = ufoPop();
4121 uint64_t xval = a; xval *= b;
4122 UFO_PUSH_U64(xval);
4125 // M/MOD
4126 // ( alo ahi b -- a/b a%b )
4127 UFWORD(MDIVMOD) {
4128 const int32_t b = (int32_t)ufoPop();
4129 if (b == 0) ufoFatal("division by zero");
4130 int64_t a = UFO_POP_I64();
4131 int32_t adiv = (int32_t)(a / b);
4132 int32_t amod = (int32_t)(a % b);
4133 ufoPush((uint32_t)adiv);
4134 ufoPush((uint32_t)amod);
4137 // UM/MOD
4138 // ( alo ahi b -- a/b a%b )
4139 UFWORD(UMDIVMOD) {
4140 const uint32_t b = ufoPop();
4141 if (b == 0) ufoFatal("division by zero");
4142 uint64_t a = UFO_POP_U64();
4143 uint32_t adiv = (uint32_t)(a / b);
4144 uint32_t amod = (uint32_t)(a % b);
4145 ufoPush(adiv);
4146 ufoPush(amod);
4149 // UDS*
4150 // ( alo ahi u -- lo hi )
4151 UFWORD(UDSMUL) {
4152 const uint32_t b = ufoPop();
4153 uint64_t a = UFO_POP_U64();
4154 a *= b;
4155 UFO_PUSH_U64(a);
4158 // D-
4159 // ( lo0 hi0 lo1 hi1 -- lo hi )
4160 UFWORD(DMINUS) {
4161 uint64_t n1 = UFO_POP_U64();
4162 uint64_t n0 = UFO_POP_U64();
4163 n0 -= n1;
4164 UFO_PUSH_U64(n0);
4167 // D+
4168 // ( lo0 hi0 lo1 hi1 -- lo hi )
4169 UFWORD(DPLUS) {
4170 uint64_t n1 = UFO_POP_U64();
4171 uint64_t n0 = UFO_POP_U64();
4172 n0 += n1;
4173 UFO_PUSH_U64(n0);
4176 // D=
4177 // ( lo0 hi0 lo1 hi1 -- bool )
4178 UFWORD(DEQU) {
4179 uint64_t n1 = UFO_POP_U64();
4180 uint64_t n0 = UFO_POP_U64();
4181 ufoPushBool(n0 == n1);
4184 // D<
4185 // ( lo0 hi0 lo1 hi1 -- bool )
4186 UFWORD(DLESS) {
4187 int64_t n1 = UFO_POP_I64();
4188 int64_t n0 = UFO_POP_I64();
4189 ufoPushBool(n0 < n1);
4192 // D<=
4193 // ( lo0 hi0 lo1 hi1 -- bool )
4194 UFWORD(DLESSEQU) {
4195 int64_t n1 = UFO_POP_I64();
4196 int64_t n0 = UFO_POP_I64();
4197 ufoPushBool(n0 <= n1);
4200 // DU<
4201 // ( lo0 hi0 lo1 hi1 -- bool )
4202 UFWORD(DULESS) {
4203 uint64_t n1 = UFO_POP_U64();
4204 uint64_t n0 = UFO_POP_U64();
4205 ufoPushBool(n0 < n1);
4208 // DU<=
4209 // ( lo0 hi0 lo1 hi1 -- bool )
4210 UFWORD(DULESSEQU) {
4211 uint64_t n1 = UFO_POP_U64();
4212 uint64_t n0 = UFO_POP_U64();
4213 ufoPushBool(n0 <= n1);
4216 // SM/REM
4217 // ( dlo dhi n -- nmod ndiv )
4218 // rounds toward zero
4219 UFWORD(SMREM) {
4220 const int32_t n = (int32_t)ufoPop();
4221 if (n == 0) ufoFatal("division by zero");
4222 int64_t d = UFO_POP_I64();
4223 int32_t ndiv = (int32_t)(d / n);
4224 int32_t nmod = (int32_t)(d % n);
4225 ufoPush(nmod);
4226 ufoPush(ndiv);
4229 // FM/MOD
4230 // ( dlo dhi n -- nmod ndiv )
4231 // rounds toward negative infinity
4232 UFWORD(FMMOD) {
4233 const int32_t n = (int32_t)ufoPop();
4234 if (n == 0) ufoFatal("division by zero");
4235 int64_t d = UFO_POP_I64();
4236 int32_t ndiv = (int32_t)(d / n);
4237 int32_t nmod = (int32_t)(d % n);
4238 if (nmod != 0 && ((uint32_t)n ^ (uint32_t)(d >> 32)) >= 0x80000000u) {
4239 ndiv -= 1;
4240 nmod += n;
4242 ufoPush(nmod);
4243 ufoPush(ndiv);
4247 // ////////////////////////////////////////////////////////////////////////// //
4248 // simple logic and bit manipulation
4251 #define UF_CMP(name_,op_) \
4252 UFWORD(name_) { \
4253 const uint32_t b = ufoPop(); \
4254 const uint32_t a = ufoPop(); \
4255 ufoPushBool(op_); \
4258 // <
4259 // ( a b -- a<b )
4260 UF_CMP(LESS, (int32_t)a < (int32_t)b);
4262 // U<
4263 // ( a b -- a<b )
4264 UF_CMP(ULESS, a < b);
4266 // >
4267 // ( a b -- a>b )
4268 UF_CMP(GREAT, (int32_t)a > (int32_t)b);
4270 // U>
4271 // ( a b -- a>b )
4272 UF_CMP(UGREAT, a > b);
4274 // <=
4275 // ( a b -- a<=b )
4276 UF_CMP(LESSEQU, (int32_t)a <= (int32_t)b);
4278 // U<=
4279 // ( a b -- a<=b )
4280 UF_CMP(ULESSEQU, a <= b);
4282 // >=
4283 // ( a b -- a>=b )
4284 UF_CMP(GREATEQU, (int32_t)a >= (int32_t)b);
4286 // U>=
4287 // ( a b -- a>=b )
4288 UF_CMP(UGREATEQU, a >= b);
4290 // =
4291 // ( a b -- a=b )
4292 UF_CMP(EQU, a == b);
4294 // <>
4295 // ( a b -- a<>b )
4296 UF_CMP(NOTEQU, a != b);
4298 // 0=
4299 // ( a -- a==0 )
4300 UFWORD(ZERO_EQU) {
4301 const uint32_t a = ufoPop();
4302 ufoPushBool(a == 0);
4305 // 0<>
4306 // ( a -- a<>0 )
4307 UFWORD(ZERO_NOTEQU) {
4308 const uint32_t a = ufoPop();
4309 ufoPushBool(a != 0);
4312 // LAND
4313 // ( a b -- a&&b )
4314 UF_CMP(LOGAND, a && b);
4316 // LOR
4317 // ( a b -- a||b )
4318 UF_CMP(LOGOR, a || b);
4320 // AND
4321 // ( a b -- a&b )
4322 UFWORD(AND) {
4323 const uint32_t b = ufoPop();
4324 const uint32_t a = ufoPop();
4325 ufoPush(a&b);
4328 // OR
4329 // ( a b -- a|b )
4330 UFWORD(OR) {
4331 const uint32_t b = ufoPop();
4332 const uint32_t a = ufoPop();
4333 ufoPush(a|b);
4336 // XOR
4337 // ( a b -- a^b )
4338 UFWORD(XOR) {
4339 const uint32_t b = ufoPop();
4340 const uint32_t a = ufoPop();
4341 ufoPush(a^b);
4344 // BITNOT
4345 // ( a -- ~a )
4346 UFWORD(BITNOT) {
4347 const uint32_t a = ufoPop();
4348 ufoPush(~a);
4351 // ASH
4352 // ( n count -- )
4353 // arithmetic shift; positive `n` shifts to the left
4354 UFWORD(ASH) {
4355 int32_t c = (int32_t)ufoPop();
4356 if (c < 0) {
4357 // right
4358 int32_t n = (int32_t)ufoPop();
4359 if (c < -30) {
4360 if (n < 0) n = -1; else n = 0;
4361 } else {
4362 n >>= (uint8_t)(-c);
4364 ufoPush((uint32_t)n);
4365 } else if (c > 0) {
4366 // left
4367 uint32_t u = ufoPop();
4368 if (c > 31) {
4369 u = 0;
4370 } else {
4371 u <<= (uint8_t)c;
4373 ufoPush(u);
4377 // LSH
4378 // ( n count -- )
4379 // logical shift; positive `n` shifts to the left
4380 UFWORD(LSH) {
4381 int32_t c = (int32_t) ufoPop();
4382 uint32_t u = ufoPop();
4383 if (c < 0) {
4384 // right
4385 if (c < -31) {
4386 u = 0;
4387 } else {
4388 u >>= (uint8_t)(-c);
4390 } else if (c > 0) {
4391 // left
4392 if (c > 31) {
4393 u = 0;
4394 } else {
4395 u <<= (uint8_t)c;
4398 ufoPush(u);
4402 // ////////////////////////////////////////////////////////////////////////// //
4403 // string unescaping
4406 // (UNESCAPE)
4407 // ( addr count -- addr count )
4408 UFWORD(PAR_UNESCAPE) {
4409 const uint32_t count = ufoPop();
4410 const uint32_t addr = ufoPeek();
4411 if ((count & ((uint32_t)1<<31)) == 0) {
4412 const uint32_t eaddr = addr + count;
4413 uint32_t caddr = addr;
4414 uint32_t daddr = addr;
4415 while (caddr != eaddr) {
4416 uint8_t ch = ufoImgGetU8Ext(caddr); caddr += 1u;
4417 if (ch == '\\' && caddr != eaddr) {
4418 ch = ufoImgGetU8Ext(caddr); caddr += 1u;
4419 switch (ch) {
4420 case 'r': ch = '\r'; break;
4421 case 'n': ch = '\n'; break;
4422 case 't': ch = '\t'; break;
4423 case 'e': ch = '\x1b'; break;
4424 case '`': ch = '"'; break; // special escape to insert double-quote
4425 case '"': ch = '"'; break;
4426 case '\\': ch = '\\'; break;
4427 case 'x': case 'X':
4428 if (eaddr - daddr >= 1) {
4429 const int dg0 = digitInBase((char)(ufoImgGetU8Ext(caddr)), 16);
4430 if (dg0 < 0) ufoFatal("invalid hex string escape");
4431 if (eaddr - daddr >= 2) {
4432 const int dg1 = digitInBase((char)(ufoImgGetU8Ext(caddr + 1u)), 16);
4433 if (dg1 < 0) ufoFatal("invalid hex string escape");
4434 ch = (uint8_t)(dg0 * 16 + dg1);
4435 caddr += 2u;
4436 } else {
4437 ch = (uint8_t)dg0;
4438 caddr += 1u;
4440 } else {
4441 ufoFatal("invalid hex string escape");
4443 break;
4444 default: ufoFatal("invalid string escape");
4447 ufoImgPutU8Ext(daddr, ch); daddr += 1u;
4449 ufoPush(daddr - addr);
4450 } else {
4451 ufoPush(count);
4456 // ////////////////////////////////////////////////////////////////////////// //
4457 // numeric conversions
4460 // (BASED-NUMBER) ( addr count allowsign? base -- num TRUE / FALSE )
4461 UFWORD(PAR_BASED_NUMBER) {
4462 const uint32_t xbase = ufoPop();
4463 const uint32_t allowSign = ufoPop();
4464 int32_t count = (int32_t)ufoPop();
4465 uint32_t addr = ufoPop();
4466 uint32_t n = 0;
4467 int base = 0;
4468 int neg = 0;
4469 uint8_t ch;
4471 if (allowSign && count > 1) {
4472 ch = ufoImgGetU8Ext(addr);
4473 if (ch == '-') { neg = 1; addr += 1u; count -= 1; }
4474 else if (ch == '+') { neg = 0; addr += 1u; count -= 1; }
4477 // special-based numbers
4478 if (count >= 3 && ufoImgGetU8Ext(addr) == '0') {
4479 switch (ufoImgGetU8Ext(addr + 1u)) {
4480 case 'x': case 'X': base = 16; break;
4481 case 'o': case 'O': base = 8; break;
4482 case 'b': case 'B': base = 2; break;
4483 case 'd': case 'D': base = 10; break;
4484 default: break;
4486 if (base) { addr += 2; count -= 2; }
4487 } else if (count >= 2 && ufoImgGetU8Ext(addr) == '$') {
4488 base = 16;
4489 addr += 1; count -= 1;
4490 } else if (count >= 2 && ufoImgGetU8Ext(addr) == '#') {
4491 base = 16;
4492 addr += 1; count -= 1;
4493 } else if (count >= 2 && ufoImgGetU8Ext(addr) == '%') {
4494 base = 2;
4495 addr += 1; count -= 1;
4496 } else if (count >= 3 && ufoImgGetU8Ext(addr) == '&') {
4497 switch (ufoImgGetU8Ext(addr + 1u)) {
4498 case 'h': case 'H': base = 16; break;
4499 case 'o': case 'O': base = 8; break;
4500 case 'b': case 'B': base = 2; break;
4501 case 'd': case 'D': base = 10; break;
4502 default: break;
4504 if (base) { addr += 2; count -= 2; }
4505 } else if (xbase < 12 && count > 2 && toUpperU8(ufoImgGetU8Ext(addr + (uint32_t)count - 1u)) == 'B') {
4506 base = 2;
4507 count -= 1;
4508 } else if (xbase < 18 && count > 2 && toUpperU8(ufoImgGetU8Ext(addr + (uint32_t)count - 1u)) == 'H') {
4509 base = 16;
4510 count -= 1;
4511 } else if (xbase < 25 && count > 2 && toUpperU8(ufoImgGetU8Ext(addr + (uint32_t)count - 1u)) == 'O') {
4512 base = 8;
4513 count -= 1;
4516 // in current base?
4517 if (!base && xbase < 255) base = xbase;
4519 if (count <= 0 || base < 1 || base > 36) {
4520 ufoPushBool(0);
4521 } else {
4522 uint32_t nc;
4523 int wasDig = 0, wasUnder = 1, error = 0, dig;
4524 while (!error && count != 0) {
4525 ch = ufoImgGetU8Ext(addr); addr += 1u; count -= 1;
4526 if (ch != '_') {
4527 error = 1; wasUnder = 0; wasDig = 1;
4528 dig = digitInBase((char)ch, (int)base);
4529 if (dig >= 0) {
4530 nc = n * (uint32_t)base;
4531 if (nc >= n) {
4532 nc += (uint32_t)dig;
4533 if (nc >= n) {
4534 n = nc;
4535 error = 0;
4539 } else {
4540 error = wasUnder;
4541 wasUnder = 1;
4545 if (!error && wasDig && !wasUnder) {
4546 if (allowSign && neg) n = ~n + 1u;
4547 ufoPush(n);
4548 ufoPushBool(1);
4549 } else {
4550 ufoPushBool(0);
4556 // ////////////////////////////////////////////////////////////////////////// //
4557 // compiler-related, dictionary-related
4560 static char ufoWNameBuf[256];
4562 // (CREATE-WORD-HEADER)
4563 // ( addr count word-flags -- )
4564 UFWORD(PAR_CREATE_WORD_HEADER) {
4565 const uint32_t flags = ufoPop();
4566 const uint32_t wlen = ufoPop();
4567 const uint32_t waddr = ufoPop();
4568 if (wlen == 0) ufoFatal("word name expected");
4569 if (wlen >= UFO_MAX_WORD_LENGTH) ufoFatal("word name too long");
4570 // copy to separate buffer
4571 for (uint32_t f = 0; f < wlen; f += 1) {
4572 ufoWNameBuf[f] = (char)ufoImgGetU8Ext(waddr + f);
4574 ufoWNameBuf[wlen] = 0;
4575 ufoCreateWordHeader(ufoWNameBuf, flags);
4578 // (CREATE-NAMELESS-WORD-HEADER)
4579 // ( word-flags -- )
4580 UFWORD(PAR_CREATE_NAMELESS_WORD_HEADER) {
4581 const uint32_t flags = ufoPop();
4582 ufoCreateWordHeader("", flags);
4585 // FIND-WORD
4586 // ( addr count -- cfa TRUE / FALSE)
4587 UFWORD(FIND_WORD) {
4588 const uint32_t wlen = ufoPop();
4589 const uint32_t waddr = ufoPop();
4590 if (wlen > 0 && wlen < UFO_MAX_WORD_LENGTH) {
4591 // copy to separate buffer
4592 for (uint32_t f = 0; f < wlen; f += 1) {
4593 ufoWNameBuf[f] = (char)ufoImgGetU8Ext(waddr + f);
4595 ufoWNameBuf[wlen] = 0;
4596 const uint32_t cfa = ufoFindWord(ufoWNameBuf);
4597 if (cfa != 0) {
4598 ufoPush(cfa);
4599 ufoPushBool(1);
4600 } else {
4601 ufoPushBool(0);
4603 } else {
4604 ufoPushBool(0);
4608 // (FIND-WORD-IN-VOC)
4609 // ( addr count vocid allowhidden -- cfa TRUE / FALSE)
4610 // find only in the given voc; no name resolution
4611 UFWORD(FIND_WORD_IN_VOC) {
4612 const uint32_t allowHidden = ufoPop();
4613 const uint32_t vocid = ufoPop();
4614 const uint32_t wlen = ufoPop();
4615 const uint32_t waddr = ufoPop();
4616 if (wlen > 0 && wlen < UFO_MAX_WORD_LENGTH) {
4617 // copy to separate buffer
4618 for (uint32_t f = 0; f < wlen; f += 1) {
4619 ufoWNameBuf[f] = (char)ufoImgGetU8Ext(waddr + f);
4621 ufoWNameBuf[wlen] = 0;
4622 const uint32_t cfa = ufoFindWordInVoc(ufoWNameBuf, wlen, 0, vocid, (allowHidden ? 1 : 0));
4623 if (cfa != 0) {
4624 ufoPush(cfa);
4625 ufoPushBool(1);
4626 } else {
4627 ufoPushBool(0);
4629 } else {
4630 ufoPushBool(0);
4634 // (FIND-WORD-IN-VOC-AND-PARENTS)
4635 // ( addr count vocid allowhidden -- cfa TRUE / FALSE)
4636 // find only in the given voc; no name resolution
4637 UFWORD(FIND_WORD_IN_VOC_AND_PARENTS) {
4638 const uint32_t allowHidden = ufoPop();
4639 const uint32_t vocid = ufoPop();
4640 const uint32_t wlen = ufoPop();
4641 const uint32_t waddr = ufoPop();
4642 if (wlen > 0 && wlen < UFO_MAX_WORD_LENGTH) {
4643 // copy to separate buffer
4644 for (uint32_t f = 0; f < wlen; f += 1) {
4645 ufoWNameBuf[f] = (char)ufoImgGetU8Ext(waddr + f);
4647 ufoWNameBuf[wlen] = 0;
4648 const uint32_t cfa = ufoFindWordInVocAndParents(ufoWNameBuf, wlen, 0, vocid, (allowHidden ? 1 : 0));
4649 if (cfa != 0) {
4650 ufoPush(cfa);
4651 ufoPushBool(1);
4652 } else {
4653 ufoPushBool(0);
4655 } else {
4656 ufoPushBool(0);
4661 // ////////////////////////////////////////////////////////////////////////// //
4662 // more compiler words
4665 // ////////////////////////////////////////////////////////////////////////// //
4666 // vocabulary and wordlist utilities
4669 // (VSP@)
4670 // ( -- vsp )
4671 UFWORD(PAR_GET_VSP) {
4672 ufoPush(ufoVSP);
4675 // (VSP!)
4676 // ( vsp -- )
4677 UFWORD(PAR_SET_VSP) {
4678 const uint32_t vsp = ufoPop();
4679 if (vsp >= UFO_VOCSTACK_SIZE) ufoFatal("VSP %u out of range (%u)", vsp, UFO_VOCSTACK_SIZE);
4680 ufoVSP = vsp;
4683 // (VSP-AT@)
4684 // ( idx -- value )
4685 UFWORD(PAR_VSP_LOAD) {
4686 const uint32_t vsp = ufoPop();
4687 if (vsp >= UFO_VOCSTACK_SIZE) ufoFatal("VSP %u out of range (%u)", vsp, UFO_VOCSTACK_SIZE);
4688 ufoPush(ufoVocStack[vsp]);
4691 // (VSP-AT!)
4692 // ( value idx -- )
4693 UFWORD(PAR_VSP_STORE) {
4694 const uint32_t vsp = ufoPop();
4695 const uint32_t value = ufoPop();
4696 if (vsp > UFO_VOCSTACK_SIZE) ufoFatal("VSP %u out of range (%u)", vsp, UFO_VOCSTACK_SIZE);
4697 ufoVocStack[vsp] = value;
4701 // ////////////////////////////////////////////////////////////////////////// //
4702 // word field address conversion
4705 // CFA->PFA
4706 // ( cfa -- pfa )
4707 UFWORD(CFA2PFA) {
4708 const uint32_t cfa = ufoPop();
4709 ufoPush(UFO_CFA_TO_PFA(cfa));
4712 // CFA->NFA
4713 // ( cfa -- nfa )
4714 UFWORD(CFA2NFA) {
4715 const uint32_t cfa = ufoPop();
4716 ufoPush(UFO_CFA_TO_NFA(cfa));
4719 // CFA->LFA
4720 // ( cfa -- lfa )
4721 UFWORD(CFA2LFA) {
4722 const uint32_t cfa = ufoPop();
4723 ufoPush(UFO_CFA_TO_LFA(cfa));
4726 // CFA->WEND
4727 // ( cfa -- wend-addr )
4728 UFWORD(CFA2WEND) {
4729 const uint32_t cfa = ufoPop();
4730 ufoPush(ufoGetWordEndAddr(cfa));
4733 // PFA->CFA
4734 // ( pfa -- cfa )
4735 UFWORD(PFA2CFA) {
4736 const uint32_t pfa = ufoPop();
4737 ufoPush(UFO_PFA_TO_CFA(pfa));
4740 // PFA->NFA
4741 // ( pfa -- nfa )
4742 UFWORD(PFA2NFA) {
4743 const uint32_t pfa = ufoPop();
4744 const uint32_t cfa = UFO_PFA_TO_CFA(pfa);
4745 ufoPush(UFO_CFA_TO_NFA(cfa));
4748 // NFA->CFA
4749 // ( nfa -- cfa )
4750 UFWORD(NFA2CFA) {
4751 const uint32_t nfa = ufoPop();
4752 ufoPush(UFO_NFA_TO_CFA(nfa));
4755 // NFA->PFA
4756 // ( nfa -- pfa )
4757 UFWORD(NFA2PFA) {
4758 const uint32_t nfa = ufoPop();
4759 const uint32_t cfa = UFO_NFA_TO_CFA(nfa);
4760 ufoPush(UFO_CFA_TO_PFA(cfa));
4763 // NFA->LFA
4764 // ( nfa -- lfa )
4765 UFWORD(NFA2LFA) {
4766 const uint32_t nfa = ufoPop();
4767 ufoPush(UFO_NFA_TO_LFA(nfa));
4770 // LFA->CFA
4771 // ( lfa -- cfa )
4772 UFWORD(LFA2CFA) {
4773 const uint32_t lfa = ufoPop();
4774 ufoPush(UFO_LFA_TO_CFA(lfa));
4777 // LFA->PFA
4778 // ( lfa -- pfa )
4779 UFWORD(LFA2PFA) {
4780 const uint32_t lfa = ufoPop();
4781 const uint32_t cfa = UFO_LFA_TO_CFA(lfa);
4782 ufoPush(UFO_CFA_TO_PFA(cfa));
4785 // LFA->BFA
4786 // ( lfa -- bfa )
4787 UFWORD(LFA2BFA) {
4788 const uint32_t lfa = ufoPop();
4789 ufoPush(UFO_LFA_TO_BFA(lfa));
4792 // LFA->XFA
4793 // ( lfa -- xfa )
4794 UFWORD(LFA2XFA) {
4795 const uint32_t lfa = ufoPop();
4796 ufoPush(UFO_LFA_TO_XFA(lfa));
4799 // LFA->YFA
4800 // ( lfa -- yfa )
4801 UFWORD(LFA2YFA) {
4802 const uint32_t lfa = ufoPop();
4803 ufoPush(UFO_LFA_TO_YFA(lfa));
4806 // LFA->NFA
4807 // ( lfa -- nfa )
4808 UFWORD(LFA2NFA) {
4809 const uint32_t lfa = ufoPop();
4810 ufoPush(UFO_LFA_TO_NFA(lfa));
4813 // IP->NFA
4814 // ( ip -- nfa / 0 )
4815 UFWORD(IP2NFA) {
4816 const uint32_t ip = ufoPop();
4817 ufoPush(ufoFindWordForIP(ip));
4820 // IP->FILE/LINE
4821 // ( ip -- addr count line TRUE / FALSE )
4822 // name is at PAD; it is safe to use PAD, because each task has its own temp image
4823 UFWORD(IP2FILELINE) {
4824 const uint32_t ip = ufoPop();
4825 uint32_t fline;
4826 const char *fname = ufoFindFileForIP(ip, &fline, NULL, NULL);
4827 if (fname != NULL) {
4828 UFCALL(PAD);
4829 uint32_t addr = ufoPeek();
4830 uint32_t count = 0;
4831 while (*fname != 0) {
4832 ufoImgPutU8(addr, *(const unsigned char *)fname);
4833 fname += 1u; addr += 1u; count += 1u;
4835 ufoImgPutU8(addr, 0); // just in case
4836 ufoPush(count);
4837 ufoPush(fline);
4838 ufoPushBool(1);
4839 } else {
4840 ufoPushBool(0);
4845 // IP->FILE-HASH/LINE
4846 // ( ip -- len hash line TRUE / FALSE )
4847 UFWORD(IP2FILEHASHLINE) {
4848 const uint32_t ip = ufoPop();
4849 uint32_t fline, fhash, flen;
4850 const char *fname = ufoFindFileForIP(ip, &fline, &flen, &fhash);
4851 if (fname != NULL) {
4852 ufoPush(flen);
4853 ufoPush(fhash);
4854 ufoPush(fline);
4855 ufoPushBool(1);
4856 } else {
4857 ufoPushBool(0);
4862 // ////////////////////////////////////////////////////////////////////////// //
4863 // string operations
4866 UFO_FORCE_INLINE uint32_t ufoHashBuf (uint32_t addr, uint32_t size, uint8_t orbyte) {
4867 uint32_t hash = 0x29a;
4868 if ((size & ((uint32_t)1<<31)) == 0) {
4869 while (size != 0) {
4870 hash += ufoImgGetU8Ext(addr) | orbyte;
4871 hash += hash<<10;
4872 hash ^= hash>>6;
4873 addr += 1u; size -= 1u;
4876 // finalize
4877 hash += hash<<3;
4878 hash ^= hash>>11;
4879 hash += hash<<15;
4880 return hash;
4883 //==========================================================================
4885 // ufoBufEqu
4887 //==========================================================================
4888 UFO_FORCE_INLINE int ufoBufEqu (uint32_t addr0, uint32_t addr1, uint32_t count) {
4889 int res;
4890 if ((count & ((uint32_t)1<<31)) == 0) {
4891 res = 1;
4892 while (res != 0 && count != 0) {
4893 res = (toUpperU8(ufoImgGetU8Ext(addr0)) == toUpperU8(ufoImgGetU8Ext(addr1)));
4894 addr0 += 1u; addr1 += 1u; count -= 1u;
4896 } else {
4897 res = 0;
4899 return res;
4902 // STRING:=
4903 // ( a0 c0 a1 c1 -- bool )
4904 UFWORD(STREQU) {
4905 int32_t c1 = (int32_t)ufoPop();
4906 uint32_t a1 = ufoPop();
4907 int32_t c0 = (int32_t)ufoPop();
4908 uint32_t a0 = ufoPop();
4909 if (c0 < 0) c0 = 0;
4910 if (c1 < 0) c1 = 0;
4911 if (c0 == c1) {
4912 int res = 1;
4913 while (res != 0 && c0 != 0) {
4914 res = (ufoImgGetU8Ext(a0) == ufoImgGetU8Ext(a1));
4915 a0 += 1; a1 += 1; c0 -= 1;
4917 ufoPushBool(res);
4918 } else {
4919 ufoPushBool(0);
4923 // STRING:=CI
4924 // ( a0 c0 a1 c1 -- bool )
4925 UFWORD(STREQUCI) {
4926 int32_t c1 = (int32_t)ufoPop();
4927 uint32_t a1 = ufoPop();
4928 int32_t c0 = (int32_t)ufoPop();
4929 uint32_t a0 = ufoPop();
4930 if (c0 < 0) c0 = 0;
4931 if (c1 < 0) c1 = 0;
4932 if (c0 == c1) {
4933 int res = 1;
4934 while (res != 0 && c0 != 0) {
4935 res = (toUpperU8(ufoImgGetU8Ext(a0)) == toUpperU8(ufoImgGetU8Ext(a1)));
4936 a0 += 1; a1 += 1; c0 -= 1;
4938 ufoPushBool(res);
4939 } else {
4940 ufoPushBool(0);
4944 // search the string specified by c-addr1 u1 for the string specified by c-addr2 u2.
4945 // if flag is true, a match was found at c-addr3 with u3 characters remaining.
4946 // if flag is false there was no match and c-addr3 is c-addr1 and u3 is u1.
4947 // ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 flag )
4948 UFWORD(SEARCH) {
4949 const uint32_t pcount = ufoPop();
4950 const uint32_t paddr = ufoPop();
4951 const uint32_t tcount = ufoPop();
4952 const uint32_t taddr = ufoPop();
4953 if ((pcount & ((uint32_t)1 << 31)) == 0 && (tcount & ((uint32_t)1 << 31)) == 0) {
4954 for (uint32_t f = 0; tcount - f >= pcount; f += 1) {
4955 if (ufoBufEqu(taddr + f, paddr, pcount)) {
4956 ufoPush(taddr + f);
4957 ufoPush(tcount - f);
4958 ufoPushBool(1);
4959 return;
4963 ufoPush(taddr);
4964 ufoPush(tcount);
4965 ufoPushBool(0);
4968 // STRING:HASH
4969 // ( addr count -- hash )
4970 UFWORD(STRHASH) {
4971 uint32_t count = ufoPop();
4972 uint32_t addr = ufoPop();
4973 ufoPush(ufoHashBuf(addr, count, 0));
4976 // STRING:HASH-CI
4977 // ( addr count -- hash )
4978 UFWORD(STRHASHCI) {
4979 uint32_t count = ufoPop();
4980 uint32_t addr = ufoPop();
4981 ufoPush(ufoHashBuf(addr, count, 0x20));
4985 // ////////////////////////////////////////////////////////////////////////// //
4986 // conditional defines
4989 typedef struct UForthCondDefine_t UForthCondDefine;
4990 struct UForthCondDefine_t {
4991 char *name;
4992 uint32_t namelen;
4993 uint32_t hash;
4994 UForthCondDefine *next;
4997 static UForthCondDefine *ufoCondDefines = NULL;
4998 static char ufoErrMsgBuf[4096];
5001 //==========================================================================
5003 // ufoStrEquCI
5005 //==========================================================================
5006 UFO_DISABLE_INLINE int ufoStrEquCI (const void *str0, const void *str1) {
5007 const unsigned char *s0 = (const unsigned char *)str0;
5008 const unsigned char *s1 = (const unsigned char *)str1;
5009 while (*s0 && *s1) {
5010 if (toUpperU8(*s0) != toUpperU8(*s1)) return 0;
5011 s0 += 1; s1 += 1;
5013 return (*s0 == 0 && *s1 == 0);
5017 //==========================================================================
5019 // ufoBufEquCI
5021 //==========================================================================
5022 UFO_FORCE_INLINE int ufoBufEquCI (uint32_t addr, uint32_t count, const void *buf) {
5023 int res;
5024 if ((count & ((uint32_t)1<<31)) == 0) {
5025 const unsigned char *src = (const unsigned char *)buf;
5026 res = 1;
5027 while (res != 0 && count != 0) {
5028 res = (toUpperU8(*src) == toUpperU8(ufoImgGetU8Ext(addr)));
5029 src += 1; addr += 1u; count -= 1u;
5031 } else {
5032 res = 0;
5034 return res;
5038 //==========================================================================
5040 // ufoClearCondDefines
5042 //==========================================================================
5043 static void ufoClearCondDefines (void) {
5044 while (ufoCondDefines) {
5045 UForthCondDefine *df = ufoCondDefines;
5046 ufoCondDefines = df->next;
5047 if (df->name) free(df->name);
5048 free(df);
5053 //==========================================================================
5055 // ufoHasCondDefine
5057 //==========================================================================
5058 int ufoHasCondDefine (const char *name) {
5059 int res = 0;
5060 if (name != NULL && name[0] != 0) {
5061 const size_t nlen = strlen(name);
5062 if (nlen <= 255) {
5063 const uint32_t hash = joaatHashBufCI(name, nlen);
5064 UForthCondDefine *dd = ufoCondDefines;
5065 while (res == 0 && dd != NULL) {
5066 if (dd->hash == hash && dd->namelen == (uint32_t)nlen) {
5067 res = ufoStrEquCI(name, dd->name);
5069 dd = dd->next;
5073 return res;
5077 //==========================================================================
5079 // ufoCondDefine
5081 //==========================================================================
5082 void ufoCondDefine (const char *name) {
5083 if (name != NULL && name[0] != 0) {
5084 const size_t nlen = strlen(name);
5085 if (nlen > 255) ufoFatal("conditional define name too long");
5086 const uint32_t hash = joaatHashBufCI(name, nlen);
5087 UForthCondDefine *dd = ufoCondDefines;
5088 int res = 0;
5089 while (res == 0 && dd != NULL) {
5090 if (dd->hash == hash && dd->namelen == (uint32_t)nlen) {
5091 res = ufoStrEquCI(name, dd->name);
5093 dd = dd->next;
5095 if (res == 0) {
5096 // new define
5097 dd = calloc(1, sizeof(UForthCondDefine));
5098 if (dd == NULL) ufoFatal("out of memory for defines");
5099 dd->name = strdup(name);
5100 if (dd->name == NULL) { free(dd); ufoFatal("out of memory for defines"); }
5101 dd->namelen = (uint32_t)nlen;
5102 dd->hash = hash;
5103 dd->next = ufoCondDefines;
5104 ufoCondDefines = dd;
5110 //==========================================================================
5112 // ufoCondUndef
5114 //==========================================================================
5115 void ufoCondUndef (const char *name) {
5116 if (name != NULL && name[0] != 0) {
5117 const size_t nlen = strlen(name);
5118 if (nlen <= 255) {
5119 const uint32_t hash = joaatHashBufCI(name, nlen);
5120 UForthCondDefine *dd = ufoCondDefines;
5121 UForthCondDefine *prev = NULL;
5122 while (dd != NULL) {
5123 if (dd->hash == hash && dd->namelen == (uint32_t)nlen) {
5124 if (ufoStrEquCI(name, dd->name)) {
5125 if (prev != NULL) prev->next = dd->next; else ufoCondDefines = dd->next;
5126 free(dd->name);
5127 free(dd);
5128 dd = NULL;
5131 if (dd != NULL) { prev = dd; dd = dd->next; }
5138 // ($DEFINE)
5139 // ( addr count -- )
5140 UFWORD(PAR_DLR_DEFINE) {
5141 uint32_t count = ufoPop();
5142 uint32_t addr = ufoPop();
5143 if (count == 0) ufoFatal("empty define");
5144 if (count >= UFO_MAX_WORD_LENGTH) ufoFatal("define too long");
5145 const uint32_t hash = ufoHashBuf(addr, count, 0x20);
5146 UForthCondDefine *dd;
5147 for (dd = ufoCondDefines; dd != NULL; dd = dd->next) {
5148 if (dd->hash == hash && dd->namelen == count) {
5149 if (ufoBufEquCI(addr, count, dd->name)) return;
5152 // new define
5153 dd = calloc(1, sizeof(UForthCondDefine));
5154 if (dd == NULL) ufoFatal("out of memory for defines");
5155 dd->name = calloc(1, count + 1u);
5156 if (dd->name == NULL) { free(dd); ufoFatal("out of memory for defines"); }
5157 for (uint32_t f = 0; f < count; f += 1) {
5158 ((unsigned char *)dd->name)[f] = ufoImgGetU8Ext(addr + f);
5160 dd->namelen = count;
5161 dd->hash = hash;
5162 dd->next = ufoCondDefines;
5163 ufoCondDefines = dd;
5166 // ($UNDEF)
5167 // ( addr count -- )
5168 UFWORD(PAR_DLR_UNDEF) {
5169 uint32_t count = ufoPop();
5170 uint32_t addr = ufoPop();
5171 if (count == 0) ufoFatal("empty define");
5172 if (count >= UFO_MAX_WORD_LENGTH) ufoFatal("define too long");
5173 const uint32_t hash = ufoHashBuf(addr, count, 0x20);
5174 UForthCondDefine *prev = NULL;
5175 UForthCondDefine *dd;
5176 for (dd = ufoCondDefines; dd != NULL; prev = dd, dd = dd->next) {
5177 if (dd->hash == hash && dd->namelen == count) {
5178 if (ufoBufEquCI(addr, count, dd->name)) {
5179 if (prev == NULL) ufoCondDefines = dd->next; else prev->next = dd->next;
5180 free(dd->name);
5181 free(dd);
5182 return;
5188 // ($DEFINED?)
5189 // ( addr count -- bool )
5190 UFWORD(PAR_DLR_DEFINEDQ) {
5191 uint32_t count = ufoPop();
5192 uint32_t addr = ufoPop();
5193 if (count == 0) ufoFatal("empty define");
5194 if (count >= UFO_MAX_WORD_LENGTH) ufoFatal("define too long");
5195 const uint32_t hash = ufoHashBuf(addr, count, 0x20);
5196 int found = 0;
5197 UForthCondDefine *dd = ufoCondDefines;
5198 while (!found && dd != NULL) {
5199 if (dd->hash == hash && dd->namelen == count) {
5200 found = ufoBufEquCI(addr, count, dd->name);
5202 dd = dd->next;
5204 ufoPushBool(found);
5208 // ////////////////////////////////////////////////////////////////////////// //
5209 // error reporting
5212 // ERROR
5213 // ( addr count -- )
5214 UFWORD(ERROR) {
5215 uint32_t count = ufoPop();
5216 uint32_t addr = ufoPop();
5217 if (count & (1u<<31)) ufoFatal("invalid error message");
5218 if (count == 0) ufoFatal("some error");
5219 if (count > (uint32_t)sizeof(ufoErrMsgBuf) - 1u) count = (uint32_t)sizeof(ufoErrMsgBuf) - 1u;
5220 for (uint32_t f = 0; f < count; f += 1) {
5221 ufoErrMsgBuf[f] = (char)ufoImgGetU8Ext(addr + f);
5223 ufoErrMsgBuf[count] = 0;
5224 ufoFatal("%s", ufoErrMsgBuf);
5227 // ////////////////////////////////////////////////////////////////////////// //
5228 // includes
5231 static char ufoFNameBuf[4096];
5234 //==========================================================================
5236 // ufoScanIncludeFileName
5238 // `*psys` and `*psoft` must be initialised!
5240 //==========================================================================
5241 static void ufoScanIncludeFileName (uint32_t addr, uint32_t count, char *dest, size_t destsz,
5242 uint32_t *psys, uint32_t *psoft)
5244 uint8_t ch;
5245 uint32_t dpos;
5246 ufo_assert(dest != NULL);
5247 ufo_assert(destsz > 0);
5249 while (count != 0) {
5250 ch = ufoImgGetU8Ext(addr);
5251 if (ch == '!') {
5252 //if (system) ufoFatal("invalid file name (duplicate system mark)");
5253 *psys = 1;
5254 } else if (ch == '?') {
5255 //if (softinclude) ufoFatal("invalid file name (duplicate soft mark)");
5256 *psoft = 1;
5257 } else {
5258 break;
5260 do {
5261 addr += 1; count -= 1;
5262 ch = ufoImgGetU8Ext(addr);
5263 } while (ch <= 32 && count != 0);
5266 if (count == 0) ufoFatal("empty include file name");
5267 if (count >= destsz) ufoFatal("include file name too long");
5269 dpos = 0;
5270 while (count != 0) {
5271 dest[dpos] = (char)ufoImgGetU8Ext(addr); dpos += 1;
5272 addr += 1; count -= 1;
5274 dest[dpos] = 0;
5278 // (INCLUDE-DEPTH)
5279 // ( -- depth )
5280 // return number of items in include stack
5281 UFWORD(PAR_INCLUDE_DEPTH) {
5282 ufoPush(ufoFileStackPos);
5285 // (INCLUDE-FILE-ID)
5286 // ( isp -- id ) -- isp 0 is current, then 1, etc.
5287 // each include file has unique non-zero id.
5288 UFWORD(PAR_INCLUDE_FILE_ID) {
5289 const uint32_t isp = ufoPop();
5290 if (isp == 0) {
5291 ufoPush(ufoFileId);
5292 } else if (isp <= ufoFileStackPos) {
5293 UFOFileStackEntry *stk = &ufoFileStack[ufoFileStackPos - isp];
5294 ufoPush(stk->id);
5295 } else {
5296 ufoFatal("invalid include stack index");
5300 // (INCLUDE-FILE-LINE)
5301 // ( isp -- line )
5302 UFWORD(PAR_INCLUDE_FILE_LINE) {
5303 const uint32_t isp = ufoPop();
5304 if (isp == 0) {
5305 ufoPush(ufoInFileLine);
5306 } else if (isp <= ufoFileStackPos) {
5307 UFOFileStackEntry *stk = &ufoFileStack[ufoFileStackPos - isp];
5308 ufoPush(stk->fline);
5309 } else {
5310 ufoFatal("invalid include stack index");
5312 ufoPush(ufoInFileLine);
5315 // (INCLUDE-FILE-NAME)
5316 // ( isp -- addr count )
5317 // current file name; at PAD
5318 UFWORD(PAR_INCLUDE_FILE_NAME) {
5319 const uint32_t isp = ufoPop();
5320 const char *fname = NULL;
5321 if (isp == 0) {
5322 fname = ufoInFileName;
5323 } else if (isp <= ufoFileStackPos) {
5324 UFOFileStackEntry *stk = &ufoFileStack[ufoFileStackPos - isp];
5325 fname = stk->fname;
5326 } else {
5327 ufoFatal("invalid include stack index");
5329 UFCALL(PAD);
5330 uint32_t addr = ufoPop();
5331 uint32_t count = 0;
5332 while (fname[count] != 0) {
5333 ufoImgPutU8Ext(addr + count, ((const unsigned char *)fname)[count]);
5334 count += 1;
5336 ufoImgPutU8Ext(addr + count, 0);
5337 ufoPush(addr);
5338 ufoPush(count);
5341 // (INCLUDE)
5342 // ( addr count soft? system? -- )
5343 UFWORD(PAR_INCLUDE) {
5344 uint32_t system = ufoPop();
5345 uint32_t softinclude = ufoPop();
5346 uint32_t count = ufoPop();
5347 uint32_t addr = ufoPop();
5349 if (ufoMode == UFO_MODE_MACRO) ufoFatal("macros cannot include files");
5351 if ((count & ((uint32_t)1<<31)) != 0) ufoFatal("invalid include name");
5353 ufoScanIncludeFileName(addr, count, ufoFNameBuf, sizeof(ufoFNameBuf),
5354 &system, &softinclude);
5356 char *ffn = ufoCreateIncludeName(ufoFNameBuf, system, (system ? ufoLastSysIncPath : ufoLastIncPath));
5357 #ifdef WIN32
5358 FILE *fl = fopen(ffn, "rb");
5359 #else
5360 FILE *fl = fopen(ffn, "r");
5361 #endif
5362 if (!fl) {
5363 if (softinclude) { free(ffn); return; }
5364 ufoFatal("include file '%s' not found", ffn);
5366 #ifdef UFO_DEBUG_INCLUDE
5367 fprintf(stderr, "INC-PUSH: new fname: %s\n", ffn);
5368 #endif
5369 ufoPushInFile();
5370 ufoInFile = fl;
5371 ufoInFileLine = 0;
5372 ufoSetInFileNameReuse(ffn);
5373 ufoFileId = ufoLastUsedFileId;
5374 setLastIncPath(ufoInFileName, system);
5375 // trigger next line loading
5376 UFCALL(REFILL);
5377 if (!ufoPop()) ufoFatal("(INCLUDE) internal error");
5380 // $INCLUDE "str"
5381 UFWORD(DLR_INCLUDE_IMM) {
5382 int soft = 0, system = 0;
5383 // parse include filename
5384 //UFCALL(PARSE_SKIP_BLANKS);
5385 ufoPushBool(0); UFCALL(PAR_PARSE_SKIP_COMMENTS);
5386 uint8_t ch = ufoTibPeekCh();
5387 if (ch == '"') {
5388 ufoTibSkipCh(); // skip quote
5389 ufoPush(34);
5390 } else if (ch == '<') {
5391 ufoTibSkipCh(); // skip quote
5392 ufoPush(62);
5393 system = 1;
5394 } else {
5395 ufoFatal("expected quoted string");
5397 UFCALL(PARSE);
5398 if (!ufoPop()) ufoFatal("file name expected");
5399 ufoPushBool(0); UFCALL(PAR_PARSE_SKIP_COMMENTS);
5400 if (ufoTibPeekCh() != 0) {
5401 ufoFatal("$INCLUDE doesn't accept extra args yet");
5403 // ( addr count soft? system? -- )
5404 ufoPushBool(soft); ufoPushBool(system); UFCALL(PAR_INCLUDE);
5408 //==========================================================================
5410 // ufoCreateFileGuard
5412 //==========================================================================
5413 static const char *ufoCreateFileGuard (const char *fname) {
5414 if (fname == NULL || fname[0] == 0) return NULL;
5415 char *rp = ufoRealPath(fname);
5416 if (rp == NULL) return NULL;
5417 #ifdef WIN32
5418 for (char *s = rp; *s; s += 1) if (*s == '\\') *s = '/';
5419 #endif
5420 // hash the buffer; extract file name; create string with path len, file name, and hash
5421 const size_t orgplen = strlen(rp);
5422 const uint32_t phash = joaatHashBuf(rp, orgplen, 0);
5423 size_t plen = orgplen;
5424 while (plen != 0 && rp[plen - 1u] != '/') plen -= 1;
5425 snprintf(ufoRealPathHashBuf, sizeof(ufoRealPathHashBuf),
5426 "__INCLUDE_GUARD_%08X_%08X_%s__", phash, (uint32_t)orgplen, rp + plen);
5427 return ufoRealPathHashBuf;
5431 // $INCLUDE-ONCE "str"
5432 // includes file only once; unreliable on shitdoze, i believe
5433 UFWORD(DLR_INCLUDE_ONCE_IMM) {
5434 uint32_t softinclude = 0, system = 0;
5435 // parse include filename
5436 //UFCALL(PARSE_SKIP_BLANKS);
5437 ufoPushBool(0); UFCALL(PAR_PARSE_SKIP_COMMENTS);
5438 uint8_t ch = ufoTibPeekCh();
5439 if (ch == '"') {
5440 ufoTibSkipCh(); // skip quote
5441 ufoPush(34);
5442 } else if (ch == '<') {
5443 ufoTibSkipCh(); // skip quote
5444 ufoPush(62);
5445 system = 1;
5446 } else {
5447 ufoFatal("expected quoted string");
5449 UFCALL(PARSE);
5450 if (!ufoPop()) ufoFatal("file name expected");
5451 const uint32_t count = ufoPop();
5452 const uint32_t addr = ufoPop();
5453 ufoPushBool(0); UFCALL(PAR_PARSE_SKIP_COMMENTS);
5454 if (ufoTibPeekCh() != 0) {
5455 ufoFatal("$REQUIRE doesn't accept extra args yet");
5457 ufoScanIncludeFileName(addr, count, ufoRealPathHashBuf, sizeof(ufoRealPathHashBuf),
5458 &system, &softinclude);
5459 char *incfname = ufoCreateIncludeName(ufoRealPathHashBuf, system, (system ? ufoLastSysIncPath : ufoLastIncPath));
5460 if (incfname == NULL) ufoFatal("cannot resolve include file '%s'", ufoRealPathHashBuf);
5461 //fprintf(stderr, "?:%d;!:%d;%s|%s\n", softinclude, system, ufoRealPathHashBuf, incfname);
5462 // this will overwrite `ufoRealPathHashBuf`
5463 const char *guard = ufoCreateFileGuard(incfname);
5464 free(incfname);
5465 if (guard == NULL) {
5466 if (!softinclude) ufoFatal("cannot include file '%s'", ufoRealPathHashBuf);
5467 return;
5469 #if 0
5470 fprintf(stderr, "GUARD: <%s>\n", guard);
5471 #endif
5472 // now check for the guard
5473 const uint32_t glen = (uint32_t)strlen(guard);
5474 const uint32_t ghash = joaatHashBuf(guard, glen, 0);
5475 UForthCondDefine *dd;
5476 for (dd = ufoCondDefines; dd != NULL; dd = dd->next) {
5477 if (dd->hash == ghash && dd->namelen == glen && strcmp(guard, dd->name) == 0) {
5478 // nothing to do: already included
5479 return;
5482 // add guard
5483 dd = calloc(1, sizeof(UForthCondDefine));
5484 if (dd == NULL) ufoFatal("out of memory for defines");
5485 dd->name = calloc(1, glen + 1u);
5486 if (dd->name == NULL) { free(dd); ufoFatal("out of memory for defines"); }
5487 strcpy(dd->name, guard);
5488 dd->namelen = glen;
5489 dd->hash = ghash;
5490 dd->next = ufoCondDefines;
5491 ufoCondDefines = dd;
5492 // ( addr count soft? system? -- )
5493 ufoPush(addr); ufoPush(count); ufoPushBool(softinclude); ufoPushBool(system);
5494 UFCALL(PAR_INCLUDE);
5498 // ////////////////////////////////////////////////////////////////////////// //
5499 // handles
5502 // HANDLE:NEW
5503 // ( typeid -- hx )
5504 UFWORD(PAR_NEW_HANDLE) {
5505 const uint32_t typeid = ufoPop();
5506 if (typeid == UFO_HANDLE_FREE) ufoFatal("invalid handle typeid");
5507 UfoHandle *hh = ufoAllocHandle(typeid);
5508 ufoPush(hh->ufoHandle);
5511 // HANDLE:FREE
5512 // ( hx -- )
5513 UFWORD(PAR_FREE_HANDLE) {
5514 const uint32_t hx = ufoPop();
5515 if (hx != 0) {
5516 if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("trying to free something that is not a handle");
5517 UfoHandle *hh = ufoGetHandle(hx);
5518 if (hh == NULL) ufoFatal("trying to free invalid handle");
5519 ufoFreeHandle(hh);
5523 // HANDLE:TYPEID@
5524 // ( hx -- typeid )
5525 UFWORD(PAR_HANDLE_GET_TYPEID) {
5526 const uint32_t hx = ufoPop();
5527 if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle");
5528 UfoHandle *hh = ufoGetHandle(hx);
5529 if (hh == NULL) ufoFatal("invalid handle");
5530 ufoPush(hh->typeid);
5533 // HANDLE:TYPEID!
5534 // ( typeid hx -- )
5535 UFWORD(PAR_HANDLE_SET_TYPEID) {
5536 const uint32_t hx = ufoPop();
5537 const uint32_t typeid = ufoPop();
5538 if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle");
5539 if (typeid == UFO_HANDLE_FREE) ufoFatal("invalid handle typeid");
5540 UfoHandle *hh = ufoGetHandle(hx);
5541 if (hh == NULL) ufoFatal("invalid handle");
5542 hh->typeid = typeid;
5545 // HANDLE:SIZE@
5546 // ( hx -- size )
5547 UFWORD(PAR_HANDLE_GET_SIZE) {
5548 const uint32_t hx = ufoPop();
5549 if (hx != 0) {
5550 if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle");
5551 UfoHandle *hh = ufoGetHandle(hx);
5552 if (hh == NULL) ufoFatal("invalid handle");
5553 ufoPush(hh->size);
5554 } else {
5555 ufoPush(0);
5559 // HANDLE:SIZE!
5560 // ( size hx -- )
5561 UFWORD(PAR_HANDLE_SET_SIZE) {
5562 const uint32_t hx = ufoPop();
5563 const uint32_t size = ufoPop();
5564 if (size > 0x04000000) ufoFatal("invalid handle size");
5565 if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle");
5566 UfoHandle *hh = ufoGetHandle(hx);
5567 if (hh == NULL) ufoFatal("invalid handle");
5568 if (hh->size != size) {
5569 if (size == 0) {
5570 free(hh->data);
5571 hh->data = NULL;
5572 } else {
5573 uint8_t *nx = realloc(hh->data, size * sizeof(hh->data[0]));
5574 if (nx == NULL) ufoFatal("out of memory for handle of size %u", size);
5575 hh->data = nx;
5576 if (size > hh->size) memset(hh->data, 0, size - hh->size);
5578 hh->size = size;
5579 if (hh->used > size) hh->used = size;
5583 // HANDLE:USED@
5584 // ( hx -- used )
5585 UFWORD(PAR_HANDLE_GET_USED) {
5586 const uint32_t hx = ufoPop();
5587 if (hx != 0) {
5588 if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle");
5589 UfoHandle *hh = ufoGetHandle(hx);
5590 if (hh == NULL) ufoFatal("invalid handle");
5591 ufoPush(hh->used);
5592 } else {
5593 ufoPush(0);
5597 // HANDLE:USED!
5598 // ( size hx -- )
5599 UFWORD(PAR_HANDLE_SET_USED) {
5600 const uint32_t hx = ufoPop();
5601 const uint32_t used = ufoPop();
5602 if (used > 0x04000000) ufoFatal("invalid handle used");
5603 if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle");
5604 UfoHandle *hh = ufoGetHandle(hx);
5605 if (hh == NULL) ufoFatal("invalid handle");
5606 if (used > hh->size) ufoFatal("handle used %u out of range (%u)", used, hh->size);
5607 hh->used = used;
5610 #define POP_PREPARE_HANDLE() \
5611 const uint32_t hx = ufoPop(); \
5612 uint32_t idx = ufoPop(); \
5613 if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle"); \
5614 if (idx > 0x1fffffffU - UFO_ADDR_HANDLE_OFS_MASK) ufoFatal("handle index %u out of range", idx); \
5615 idx += (hx & UFO_ADDR_HANDLE_OFS_MASK); \
5616 UfoHandle *hh = ufoGetHandle(hx); \
5617 if (hh == NULL) ufoFatal("invalid handle")
5619 // HANDLE:C@
5620 // ( idx hx -- value )
5621 UFWORD(PAR_HANDLE_LOAD_BYTE) {
5622 POP_PREPARE_HANDLE();
5623 if (idx >= hh->size) ufoFatal("handle index %u out of range (%u)", idx, hh->size);
5624 ufoPush(hh->data[idx]);
5627 // HANDLE:W@
5628 // ( idx hx -- value )
5629 UFWORD(PAR_HANDLE_LOAD_WORD) {
5630 POP_PREPARE_HANDLE();
5631 if (idx >= hh->size || hh->size - idx < 2u) {
5632 ufoFatal("handle index %u out of range (%u)", idx, hh->size);
5634 #ifdef UFO_FAST_MEM_ACCESS
5635 ufoPush(*(const uint16_t *)(hh->data + idx));
5636 #else
5637 uint32_t res = hh->data[idx];
5638 res |= hh->data[idx + 1u] << 8;
5639 ufoPush(res);
5640 #endif
5643 // HANDLE:@
5644 // ( idx hx -- value )
5645 UFWORD(PAR_HANDLE_LOAD_CELL) {
5646 POP_PREPARE_HANDLE();
5647 if (idx >= hh->size || hh->size - idx < 4u) {
5648 ufoFatal("handle index %u out of range (%u)", idx, hh->size);
5650 #ifdef UFO_FAST_MEM_ACCESS
5651 ufoPush(*(const uint32_t *)(hh->data + idx));
5652 #else
5653 uint32_t res = hh->data[idx];
5654 res |= hh->data[idx + 1u] << 8;
5655 res |= hh->data[idx + 2u] << 16;
5656 res |= hh->data[idx + 3u] << 24;
5657 ufoPush(res);
5658 #endif
5661 // HANDLE:C!
5662 // ( value idx hx -- value )
5663 UFWORD(PAR_HANDLE_STORE_BYTE) {
5664 POP_PREPARE_HANDLE();
5665 const uint32_t value = ufoPop();
5666 if (idx >= hh->size) ufoFatal("handle index %u out of range (%u)", idx, hh->size);
5667 hh->data[idx] = value;
5670 // HANDLE:W!
5671 // ( value idx hx -- )
5672 UFWORD(PAR_HANDLE_STORE_WORD) {
5673 POP_PREPARE_HANDLE();
5674 const uint32_t value = ufoPop();
5675 if (idx >= hh->size || hh->size - idx < 2u) {
5676 ufoFatal("handle index %u out of range (%u)", idx, hh->size);
5678 #ifdef UFO_FAST_MEM_ACCESS
5679 *(uint16_t *)(hh->data + idx) = (uint16_t)value;
5680 #else
5681 hh->data[idx] = (uint8_t)value;
5682 hh->data[idx + 1u] = (uint8_t)(value >> 8);
5683 #endif
5686 // HANDLE:!
5687 // ( value idx hx -- )
5688 UFWORD(PAR_HANDLE_STORE_CELL) {
5689 POP_PREPARE_HANDLE();
5690 const uint32_t value = ufoPop();
5691 if (idx >= hh->size || hh->size - idx < 4u) {
5692 ufoFatal("handle index %u out of range (%u)", idx, hh->size);
5694 #ifdef UFO_FAST_MEM_ACCESS
5695 *(uint32_t *)(hh->data + idx) = value;
5696 #else
5697 hh->data[idx] = (uint8_t)value;
5698 hh->data[idx + 1u] = (uint8_t)(value >> 8);
5699 hh->data[idx + 2u] = (uint8_t)(value >> 16);
5700 hh->data[idx + 3u] = (uint8_t)(value >> 24);
5701 #endif
5705 // HANDLE:LOAD-FILE
5706 // ( addr count -- stx / FALSE )
5707 UFWORD(PAR_HANDLE_LOAD_FILE) {
5708 uint32_t count = ufoPop();
5709 uint32_t addr = ufoPop();
5711 if ((count & ((uint32_t)1<<31)) != 0) ufoFatal("invalid file name");
5713 uint8_t *dest = (uint8_t *)ufoFNameBuf;
5714 while (count != 0 && dest < (uint8_t *)ufoFNameBuf + sizeof(ufoFNameBuf)) {
5715 uint8_t ch = ufoImgGetU8Ext(addr);
5716 *dest = ch;
5717 dest += 1u; addr += 1u; count -= 1u;
5719 if (dest == (uint8_t *)ufoFNameBuf + sizeof(ufoFNameBuf)) ufoFatal("file name too long");
5720 *dest = 0;
5722 if (*ufoFNameBuf == 0) ufoFatal("empty file name");
5724 char *ffn = ufoCreateIncludeName(ufoFNameBuf, 0/*system*/, ufoLastIncPath);
5725 #ifdef WIN32
5726 FILE *fl = fopen(ffn, "rb");
5727 #else
5728 FILE *fl = fopen(ffn, "r");
5729 #endif
5730 if (!fl) {
5731 free(ffn);
5732 ufoPush(0);
5733 return;
5736 if (fseek(fl, 0, SEEK_END) != 0) {
5737 fclose(fl);
5738 ufoFatal("seek error in file '%s'", ffn);
5741 long sz = ftell(fl);
5742 if (sz < 0 || sz >= 1024 * 1024 * 64) {
5743 fclose(fl);
5744 ufoFatal("tell error in file '%s' (or too big)", ffn);
5747 if (fseek(fl, 0, SEEK_SET) != 0) {
5748 fclose(fl);
5749 ufoFatal("seek error in file '%s'", ffn);
5752 UfoHandle *hh = ufoAllocHandle(0);
5753 if (sz != 0) {
5754 hh->data = malloc((uint32_t)sz);
5755 if (hh->data == NULL) {
5756 fclose(fl);
5757 ufoFatal("out of memory for file '%s'", ffn);
5759 hh->size = (uint32_t)sz;
5760 if (fread(hh->data, (uint32_t)sz, 1, fl) != 1) {
5761 fclose(fl);
5762 ufoFatal("error reading file '%s'", ffn);
5764 fclose(fl);
5767 free(ffn);
5768 ufoPush(hh->ufoHandle);
5772 // ////////////////////////////////////////////////////////////////////////// //
5773 // utils
5776 // DEBUG:(DECOMPILE-CFA)
5777 // ( cfa -- )
5778 UFWORD(DEBUG_DECOMPILE_CFA) {
5779 const uint32_t cfa = ufoPop();
5780 ufoFlushOutput();
5781 ufoDecompileWord(cfa);
5784 // DEBUG:(DECOMPILE-MEM)
5785 // ( addr-start addr-end -- )
5786 UFWORD(DEBUG_DECOMPILE_MEM) {
5787 const uint32_t end = ufoPop();
5788 const uint32_t start = ufoPop();
5789 ufoFlushOutput();
5790 ufoDecompilePart(start, end, 0);
5793 // GET-MSECS
5794 // ( -- u32 )
5795 UFWORD(GET_MSECS) {
5796 ufoPush((uint32_t)ufo_get_msecs());
5799 // this is called by INTERPRET when it is out of input stream
5800 UFWORD(UFO_INTERPRET_FINISHED_ACTION) {
5801 ufoVMStop = 1;
5804 // MTASK:NEW-STATE
5805 // ( cfa -- stid )
5806 UFWORD(MT_NEW_STATE) {
5807 UfoState *st = ufoNewState();
5808 ufoInitStateUserVars(st, ufoPop());
5809 ufoPush(st->id);
5812 // MTASK:FREE-STATE
5813 // ( stid -- )
5814 UFWORD(MT_FREE_STATE) {
5815 UfoState *st = ufoFindState(ufoPop());
5816 if (st == NULL) ufoFatal("cannot free unknown state");
5817 if (st == ufoCurrState) ufoFatal("cannot free current state");
5818 ufoFreeState(st);
5821 // MTASK:STATE-NAME@
5822 // ( stid -- addr count )
5823 // to PAD
5824 UFWORD(MT_GET_STATE_NAME) {
5825 UfoState *st = ufoFindState(ufoPop());
5826 if (st == NULL) ufoFatal("unknown state");
5827 UFCALL(PAD);
5828 uint32_t addr = ufoPop();
5829 uint32_t count = 0;
5830 while (st->name[count] != 0) {
5831 ufoImgPutU8Ext(addr + count, ((const unsigned char *)st->name)[count]);
5832 count += 1u;
5834 ufoImgPutU8Ext(addr + count, 0);
5835 ufoPush(addr);
5836 ufoPush(count);
5839 // MTASK:STATE-NAME!
5840 // ( addr count stid -- )
5841 UFWORD(MT_SET_STATE_NAME) {
5842 UfoState *st = ufoFindState(ufoPop());
5843 if (st == NULL) ufoFatal("unknown state");
5844 uint32_t count = ufoPop();
5845 uint32_t addr = ufoPop();
5846 if ((count & ((uint32_t)1 << 31)) == 0) {
5847 if (count > UFO_MAX_TASK_NAME) ufoFatal("task name too long");
5848 for (uint32_t f = 0; f < count; f += 1u) {
5849 ((unsigned char *)st->name)[f] = ufoImgGetU8Ext(addr + f);
5851 st->name[count] = 0;
5855 // MTASK:STATE-FIRST
5856 // ( -- stid )
5857 UFWORD(MT_STATE_FIRST) {
5858 uint32_t fidx = 0;
5859 while (fidx != (uint32_t)(UFO_MAX_STATES/32) && ufoStateUsedBitmap[fidx] == 0) fidx += 1u;
5860 // there should be at least one allocated state
5861 ufo_assert(fidx != (uint32_t)(UFO_MAX_STATES/32));
5862 uint32_t bmp = ufoStateUsedBitmap[fidx];
5863 fidx *= 32u;
5864 while ((bmp & 0x01) == 0) { fidx += 1u; bmp >>= 1; }
5865 ufoPush(fidx + 1u);
5868 // MTASK:STATE-NEXT
5869 // ( stid -- stid / 0 )
5870 UFWORD(MT_STATE_NEXT) {
5871 uint32_t stid = ufoPop();
5872 if (stid != 0 && stid < (uint32_t)(UFO_MAX_STATES/32)) {
5873 // it is already incremented for us, yay!
5874 uint32_t fidx = stid / 32u;
5875 uint8_t fofs = stid & 0x1f;
5876 while (fidx < (uint32_t)(UFO_MAX_STATES/32)) {
5877 const uint32_t bmp = ufoStateUsedBitmap[fidx];
5878 if (bmp != 0) {
5879 while (fofs != 32u) {
5880 if ((bmp & ((uint32_t)1 << (fofs & 0x1f))) == 0) fofs += 1u;
5882 if (fofs != 32u) {
5883 ufoPush(fidx * 32u + fofs + 1u);
5884 return; // sorry!
5887 fidx += 1u; fofs = 0;
5890 ufoPush(0);
5894 // MTASK:YIELD-TO
5895 // ( ... argc stid -- )
5896 UFWORD(MT_YIELD_TO) {
5897 UfoState *st = ufoFindState(ufoPop());
5898 if (st == NULL) ufoFatal("cannot yield to unknown state");
5899 //if (st == ufoDebuggerState) ufoFatal("cannot yield to debugger"); // why not?
5900 const uint32_t argc = ufoPop();
5901 if (argc > 256) ufoFatal("too many YIELD-TO arguments");
5902 UfoState *curst = ufoCurrState;
5903 if (st != ufoCurrState) {
5904 for (uint32_t f = 0; f < argc; f += 1) {
5905 ufoCurrState = curst;
5906 const uint32_t n = ufoPop();
5907 ufoCurrState = st;
5908 ufoPush(n);
5910 ufoCurrState = curst; // we need to use API call to switch states
5912 ufoSwitchToState(st); // always use API call for this!
5913 ufoPush(argc);
5914 ufoPush(curst->id);
5917 // MTASK:SET-SELF-AS-DEBUGGER
5918 // ( -- )
5919 UFWORD(MT_SET_SELF_AS_DEBUGGER) {
5920 ufoDebuggerState = ufoCurrState;
5923 // DEBUG:(BP)
5924 // ( -- )
5925 // debugger task receives debugge stid on the data stack, and -1 as argc.
5926 // i.e. debugger stask is: ( -1 old-stid )
5927 UFWORD(MT_DEBUGGER_BP) {
5928 if (ufoDebuggerState != NULL && ufoCurrState != ufoDebuggerState && ufoIsGoodTTY()) {
5929 UfoState *st = ufoCurrState;
5930 ufoSwitchToState(ufoDebuggerState); // always use API call for this!
5931 ufoPush(-1);
5932 ufoPush(st->id);
5933 ufoSingleStep = 0;
5934 } else {
5935 UFCALL(UFO_BACKTRACE);
5939 // MTASK:DEBUGGER-RESUME
5940 // ( stid -- )
5941 UFWORD(MT_RESUME_DEBUGEE) {
5942 if (ufoCurrState != ufoDebuggerState) ufoFatal("cannot resume from non-debugger");
5943 UfoState *st = ufoFindState(ufoPop());
5944 if (st == NULL) ufoFatal("cannot yield to unknown state");
5945 if (st == ufoCurrState) ufoFatal("cannot resume into debugger itself");
5946 ufoSwitchToState(st); // always use API call for this!
5947 ufoSingleStep = 0;
5950 // MTASK:DEBUGGER-SINGLE-STEP
5951 // ( stid -- )
5952 UFWORD(MT_SINGLE_STEP_DEBUGEE) {
5953 if (ufoCurrState != ufoDebuggerState) ufoFatal("cannot resume from non-debugger");
5954 UfoState *st = ufoFindState(ufoPop());
5955 if (st == NULL) ufoFatal("cannot yield to unknown state");
5956 if (st == ufoCurrState) ufoFatal("cannot resume into debugger itself");
5957 ufoSwitchToState(st); // always use API call for this!
5958 ufoSingleStep = 2; // it will be decremented after returning from this word
5961 // MTASK:STATE-IP@
5962 // ( stid -- ip )
5963 UFWORD(MT_STATE_IP_GET) {
5964 UfoState *st = ufoFindState(ufoPop());
5965 if (st == NULL) ufoFatal("unknown state");
5966 ufoPush(st->IP);
5969 // MTASK:STATE-IP!
5970 // ( ip stid -- )
5971 UFWORD(MT_STATE_IP_SET) {
5972 UfoState *st = ufoFindState(ufoPop());
5973 if (st == NULL) ufoFatal("unknown state");
5974 st->IP = ufoPop();
5977 // MTASK:STATE-A>
5978 // ( stid -- ip )
5979 UFWORD(MT_STATE_REGA_GET) {
5980 UfoState *st = ufoFindState(ufoPop());
5981 if (st == NULL) ufoFatal("unknown state");
5982 ufoPush(st->regA);
5985 // MTASK:STATE->A
5986 // ( ip stid -- )
5987 UFWORD(MT_STATE_REGA_SET) {
5988 UfoState *st = ufoFindState(ufoPop());
5989 if (st == NULL) ufoFatal("unknown state");
5990 st->regA = ufoPop();
5993 // MTASK:STATE-USER@
5994 // ( addr stid -- value )
5995 UFWORD(MT_STATE_USER_GET) {
5996 UfoState *st = ufoFindState(ufoPop());
5997 if (st == NULL) ufoFatal("unknown state");
5998 const uint32_t addr = ufoPop();
5999 if ((addr & UFO_ADDR_TEMP_BIT) != 0 && (addr & UFO_ADDR_TEMP_MASK) + 3u < st->imageTempSize) {
6000 uint32_t v = *(const uint32_t *)((const uint8_t *)st->imageTemp + (addr & UFO_ADDR_TEMP_MASK));
6001 ufoPush(v);
6002 } else {
6003 ufoFatal("invalid user area address");
6007 // MTASK:STATE-USER!
6008 // ( value addr stid -- )
6009 UFWORD(MT_STATE_USER_SET) {
6010 UfoState *st = ufoFindState(ufoPop());
6011 if (st == NULL) ufoFatal("unknown state");
6012 const uint32_t addr = ufoPop();
6013 const uint32_t value = ufoPop();
6014 if ((addr & UFO_ADDR_TEMP_BIT) != 0 && (addr & UFO_ADDR_TEMP_MASK) + 3u < st->imageTempSize) {
6015 *(uint32_t *)((const uint8_t *)st->imageTemp + (addr & UFO_ADDR_TEMP_MASK)) = value;
6016 } else {
6017 ufoFatal("invalid user area address");
6021 // MTASK:STATE-RPOPCFA@
6022 // ( -- flag )
6023 UFWORD(MT_STATE_RPOPCFA_GET) {
6024 UfoState *st = ufoFindState(ufoPop());
6025 if (st == NULL) ufoFatal("unknown state");
6026 ufoPush(st->vmRPopCFA);
6029 // MTASK:STATE-RPOPCFA!
6030 // ( flag -- )
6031 UFWORD(MT_STATE_RPOPCFA_SET) {
6032 UfoState *st = ufoFindState(ufoPop());
6033 if (st == NULL) ufoFatal("unknown state");
6034 st->vmRPopCFA = ufoPop();
6037 // MTASK:ACTIVE-STATE
6038 // ( -- stid )
6039 UFWORD(MT_ACTIVE_STATE) {
6040 ufoPush(ufoCurrState->id);
6043 // MTASK:YIELDED-FROM
6044 // ( -- stid / 0 )
6045 UFWORD(MT_YIELDED_FROM) {
6046 if (ufoYieldedState != NULL) {
6047 ufoPush(ufoYieldedState->id);
6048 } else {
6049 ufoPush(0);
6053 // MTASK:STATE-SP@
6054 // ( stid -- depth )
6055 UFWORD(MT_DSTACK_DEPTH_GET) {
6056 UfoState *st = ufoFindState(ufoPop());
6057 if (st == NULL) ufoFatal("unknown state");
6058 ufoPush(st->SP);
6061 // MTASK:STATE-RP@
6062 // ( stid -- depth )
6063 UFWORD(MT_RSTACK_DEPTH_GET) {
6064 UfoState *st = ufoFindState(ufoPop());
6065 if (st == NULL) ufoFatal("unknown state");
6066 ufoPush(st->RP - st->RPTop);
6069 // MTASK:STATE-LP@
6070 // ( stid -- lp )
6071 UFWORD(MT_LP_GET) {
6072 UfoState *st = ufoFindState(ufoPop());
6073 if (st == NULL) ufoFatal("unknown state");
6074 ufoPush(st->LP);
6077 // MTASK:STATE-LBP@
6078 // ( stid -- lbp )
6079 UFWORD(MT_LBP_GET) {
6080 UfoState *st = ufoFindState(ufoPop());
6081 if (st == NULL) ufoFatal("unknown state");
6082 ufoPush(st->LBP);
6085 // MTASK:STATE-SP!
6086 // ( depth stid -- )
6087 UFWORD(MT_DSTACK_DEPTH_SET) {
6088 UfoState *st = ufoFindState(ufoPop());
6089 if (st == NULL) ufoFatal("unknown state");
6090 const uint32_t idx = ufoPop();
6091 if (idx >= UFO_DSTACK_SIZE) ufoFatal("invalid stack index %u (%u)", idx, UFO_DSTACK_SIZE);
6092 st->SP = idx;
6095 // MTASK:STATE-RP!
6096 // ( depth stid -- )
6097 UFWORD(MT_RSTACK_DEPTH_SET) {
6098 UfoState *st = ufoFindState(ufoPop());
6099 if (st == NULL) ufoFatal("unknown state");
6100 const uint32_t idx = ufoPop();
6101 const uint32_t left = UFO_RSTACK_SIZE - st->RPTop;
6102 if (idx >= left) ufoFatal("invalid rstack index %u (%u)", idx, left);
6103 st->RP = st->RPTop + idx;
6106 // MTASK:STATE-LP!
6107 // ( lp stid -- )
6108 UFWORD(MT_LP_SET) {
6109 UfoState *st = ufoFindState(ufoPop());
6110 if (st == NULL) ufoFatal("unknown state");
6111 st->LP = ufoPop();
6114 // MTASK:STATE-LBP!
6115 // ( lbp stid -- )
6116 UFWORD(MT_LBP_SET) {
6117 UfoState *st = ufoFindState(ufoPop());
6118 if (st == NULL) ufoFatal("unknown state");
6119 st->LBP = ufoPop();
6122 // MTASK:STATE-DS@
6123 // ( idx stid -- value )
6124 UFWORD(MT_DSTACK_LOAD) {
6125 UfoState *st = ufoFindState(ufoPop());
6126 if (st == NULL) ufoFatal("unknown state");
6127 const uint32_t idx = ufoPop();
6128 if (idx >= st->SP) ufoFatal("invalid stack index %u (%u)", idx, st->SP);
6129 ufoPush(st->dStack[st->SP - idx - 1u]);
6132 // MTASK:STATE-RS@
6133 // ( idx stid -- value )
6134 UFWORD(MT_RSTACK_LOAD) {
6135 UfoState *st = ufoFindState(ufoPop());
6136 if (st == NULL) ufoFatal("unknown state");
6137 const uint32_t idx = ufoPop();
6138 if (idx >= st->RP - st->RPTop) ufoFatal("invalid stack index %u (%u)", idx, st->RP - st->RPTop);
6139 ufoPush(st->dStack[st->RP - idx - 1u]);
6142 // MTASK:STATE-LS@
6143 // ( idx stid -- value )
6144 UFWORD(MT_LSTACK_LOAD) {
6145 UfoState *st = ufoFindState(ufoPop());
6146 if (st == NULL) ufoFatal("unknown state");
6147 const uint32_t idx = ufoPop();
6148 if (idx >= st->LP) ufoFatal("invalid lstack index %u (%u)", idx, st->LP);
6149 ufoPush(st->lStack[st->LP - idx - 1u]);
6152 // MTASK:STATE-DS!
6153 // ( value idx stid -- )
6154 UFWORD(MT_DSTACK_STORE) {
6155 UfoState *st = ufoFindState(ufoPop());
6156 if (st == NULL) ufoFatal("unknown state");
6157 const uint32_t idx = ufoPop();
6158 const uint32_t value = ufoPop();
6159 if (idx >= st->SP) ufoFatal("invalid stack index %u (%u)", idx, st->SP);
6160 st->dStack[st->SP - idx - 1u] = value;
6163 // MTASK:STATE-RS!
6164 // ( value idx stid -- )
6165 UFWORD(MT_RSTACK_STORE) {
6166 UfoState *st = ufoFindState(ufoPop());
6167 if (st == NULL) ufoFatal("unknown state");
6168 const uint32_t idx = ufoPop();
6169 const uint32_t value = ufoPop();
6170 if (idx >= st->RP - st->RPTop) ufoFatal("invalid stack index %u (%u)", idx, st->RP - st->RPTop);
6171 st->dStack[st->RP - idx - 1u] = value;
6174 // MTASK:STATE-LS!
6175 // ( value idx stid -- )
6176 UFWORD(MT_LSTACK_STORE) {
6177 UfoState *st = ufoFindState(ufoPop());
6178 if (st == NULL) ufoFatal("unknown state");
6179 const uint32_t idx = ufoPop();
6180 const uint32_t value = ufoPop();
6181 if (idx >= st->LP) ufoFatal("invalid stack index %u (%u)", idx, st->LP);
6182 st->dStack[st->LP - idx - 1u] = value;
6186 #include "urforth_tty.c"
6189 // ////////////////////////////////////////////////////////////////////////// //
6190 // states
6193 //==========================================================================
6195 // ufoNewState
6197 // create a new state, its execution will start from the given CFA.
6198 // state is not automatically activated.
6200 //==========================================================================
6201 static UfoState *ufoNewState (void) {
6202 // find free state id
6203 uint32_t fidx = 0;
6204 uint32_t bmp = ufoStateUsedBitmap[0];
6205 while (fidx != (uint32_t)(UFO_MAX_STATES/32) && bmp == ~(uint32_t)0) {
6206 fidx += 1u;
6207 bmp = ufoStateUsedBitmap[fidx];
6209 if (fidx == (uint32_t)(UFO_MAX_STATES/32)) ufoFatal("too many execution states");
6210 //fprintf(stderr, "NST:000: fidx=%u; bmp=0x%08x\n", fidx, bmp);
6211 fidx *= 32u;
6212 while ((bmp & 0x01) != 0) { fidx += 1u; bmp >>= 1; }
6213 ufo_assert(fidx < UFO_MAX_STATES);
6214 ufo_assert((ufoStateUsedBitmap[fidx / 32u] & ((uint32_t)1 << (fidx & 0x1f))) == 0);
6215 ufo_assert(ufoStateMap[fidx] == NULL);
6216 UfoState *st = calloc(1, sizeof(UfoState));
6217 if (st == NULL) ufoFatal("out of memory for states");
6218 st->id = fidx + 1u;
6219 ufoStateMap[fidx] = st;
6220 ufoStateUsedBitmap[fidx / 32u] |= ((uint32_t)1 << (fidx & 0x1f));
6221 //fprintf(stderr, "NST: fidx=%u; 0x%08x\n", fidx, ufoStateUsedBitmap[fidx / 32u]);
6222 return st;
6226 //==========================================================================
6228 // ufoFreeState
6230 // free all memory used for the state, remove it from state list.
6231 // WARNING! never free current state!
6233 //==========================================================================
6234 static void ufoFreeState (UfoState *st) {
6235 if (st != NULL) {
6236 if (st == ufoCurrState) ufoFatal("cannot free active state");
6237 if (ufoYieldedState == st) ufoYieldedState = NULL;
6238 if (ufoDebuggerState == st) ufoDebuggerState = NULL;
6239 const uint32_t fidx = st->id - 1u;
6240 //fprintf(stderr, "FST: fidx=%u; 0x%08x\n", fidx, ufoStateUsedBitmap[fidx / 32u]);
6241 ufo_assert(fidx < UFO_MAX_STATES);
6242 ufo_assert((ufoStateUsedBitmap[fidx / 32u] & (1u << (fidx & 0x1f))) != 0);
6243 ufo_assert(ufoStateMap[fidx] == st);
6244 // free default TIB handle
6245 UfoState *oldst = ufoCurrState;
6246 ufoCurrState = st;
6247 const uint32_t tib = ufoImgGetU32(ufoAddrDefTIB);
6248 if ((tib & UFO_ADDR_TEMP_BIT) != 0) {
6249 UfoHandle *tibh = ufoGetHandle(tib);
6250 if (tibh != NULL) ufoFreeHandle(tibh);
6252 ufoCurrState = oldst;
6253 // free temp buffer
6254 if (st->imageTemp != NULL) free(st->imageTemp);
6255 free(st);
6256 ufoStateMap[fidx] = NULL;
6257 ufoStateUsedBitmap[fidx / 32u] &= ~((uint32_t)1 << (fidx & 0x1f));
6262 //==========================================================================
6264 // ufoFindState
6266 //==========================================================================
6267 static UfoState *ufoFindState (uint32_t stid) {
6268 UfoState *res = NULL;
6269 if (stid >= 0 && stid <= UFO_MAX_STATES) {
6270 if (stid == 0) {
6271 // current
6272 ufo_assert(ufoCurrState != NULL);
6273 stid = ufoCurrState->id - 1u;
6274 } else {
6275 stid -= 1u;
6277 res = ufoStateMap[stid];
6278 if (res != NULL) {
6279 ufo_assert((ufoStateUsedBitmap[stid / 32u] & (1u << (stid & 0x1f))) != 0);
6280 ufo_assert(res->id == stid + 1u);
6281 } else {
6282 ufo_assert((ufoStateUsedBitmap[stid / 32u] & (1u << (stid & 0x1f))) == 0);
6285 return res;
6289 //==========================================================================
6291 // ufoSwitchToState
6293 //==========================================================================
6294 static void ufoSwitchToState (UfoState *newst) {
6295 ufo_assert(newst != NULL);
6296 if (newst != ufoCurrState) {
6297 ufoCurrState = newst;
6303 // ////////////////////////////////////////////////////////////////////////// //
6304 // initial dictionary definitions
6307 #undef UFWORD
6309 #define UFWORD(name_) do { \
6310 const uint32_t xcfa_ = ufoCFAsUsed; \
6311 ufo_assert(xcfa_ < UFO_MAX_NATIVE_CFAS); \
6312 ufoForthCFAs[xcfa_] = &ufoWord_##name_; \
6313 ufoCFAsUsed += 1; \
6314 ufoDefineNative(""#name_, xcfa_, 0); \
6315 } while (0)
6317 #define UFWORDX(strname_,name_) do { \
6318 const uint32_t xcfa_ = ufoCFAsUsed; \
6319 ufo_assert(xcfa_ < UFO_MAX_NATIVE_CFAS); \
6320 ufoForthCFAs[xcfa_] = &ufoWord_##name_; \
6321 ufoCFAsUsed += 1; \
6322 ufoDefineNative(strname_, xcfa_, 0); \
6323 } while (0)
6325 #define UFWORD_IMM(name_) do { \
6326 const uint32_t xcfa_ = ufoCFAsUsed; \
6327 ufo_assert(xcfa_ < UFO_MAX_NATIVE_CFAS); \
6328 ufoForthCFAs[xcfa_] = &ufoWord_##name_; \
6329 ufoCFAsUsed += 1; \
6330 ufoDefineNative(""#name_, xcfa_, 1); \
6331 } while (0)
6333 #define UFWORDX_IMM(strname_,name_) do { \
6334 const uint32_t xcfa_ = ufoCFAsUsed; \
6335 ufo_assert(xcfa_ < UFO_MAX_NATIVE_CFAS); \
6336 ufoForthCFAs[xcfa_] = &ufoWord_##name_; \
6337 ufoCFAsUsed += 1; \
6338 ufoDefineNative(strname_, xcfa_, 1); \
6339 } while (0)
6341 #define UFC(name_) ufoImgEmitU32_NoInline(ufoFindWordChecked(name_))
6344 //==========================================================================
6346 // ufoFindWordChecked
6348 //==========================================================================
6349 UFO_DISABLE_INLINE uint32_t ufoFindWordChecked (const char *wname) {
6350 const uint32_t cfa = ufoFindWord(wname);
6351 if (cfa == 0) ufoFatal("word '%s' not found", wname);
6352 return cfa;
6356 //==========================================================================
6358 // ufoGetForthVocId
6360 // get "FORTH" vocid
6362 //==========================================================================
6363 uint32_t ufoGetForthVocId (void) {
6364 return ufoForthVocId;
6368 //==========================================================================
6370 // ufoVocSetOnlyDefs
6372 //==========================================================================
6373 void ufoVocSetOnlyDefs (uint32_t vocid) {
6374 ufoImgPutU32(ufoAddrCurrent, vocid);
6375 ufoImgPutU32(ufoAddrContext, vocid);
6379 //==========================================================================
6381 // ufoCreateVoc
6383 // return voc PFA (vocid)
6385 //==========================================================================
6386 uint32_t ufoCreateVoc (const char *wname, uint32_t parentvocid, uint32_t flags) {
6387 // create wordlist struct
6388 // typeid, used by Forth code (structs and such)
6389 ufoImgEmitU32(0); // typeid
6390 // vocid points here, to "LATEST-LFA"
6391 const uint32_t vocid = UFO_GET_DP();
6392 //fprintf(stderr, "NEW VOCID (%s): 0x%08x\n", wname, vocid);
6393 ufoImgEmitU32(0); // latest
6394 const uint32_t vlink = UFO_GET_DP();
6395 if ((vocid & UFO_ADDR_TEMP_BIT) == 0) {
6396 ufoImgEmitU32(ufoImgGetU32(ufoAddrVocLink)); // voclink
6397 ufoImgPutU32(ufoAddrVocLink, vlink); // update voclink
6398 } else {
6399 abort();
6400 ufoImgEmitU32(0);
6402 ufoImgEmitU32(parentvocid); // parent
6403 const uint32_t hdraddr = UFO_GET_DP();
6404 ufoImgEmitU32(0); // word header
6405 // create empty hash table
6406 for (int f = 0; f < UFO_HASHTABLE_SIZE; f += 1) ufoImgEmitU32(0);
6407 // update CONTEXT and CURRENT if this is the first wordlist ever
6408 if (ufoImgGetU32(ufoAddrContext) == 0) {
6409 ufoImgPutU32(ufoAddrContext, vocid);
6411 if (ufoImgGetU32(ufoAddrCurrent) == 0) {
6412 ufoImgPutU32(ufoAddrCurrent, vocid);
6414 // create word header
6415 if (wname != NULL && wname[0] != 0) {
6417 uint32_t flags = ufoImgGetU32(ufoAddrNewWordFlags);
6418 flags &=
6419 //UFW_FLAG_IMMEDIATE|
6420 //UFW_FLAG_SMUDGE|
6421 //UFW_FLAG_NORETURN|
6422 UFW_FLAG_HIDDEN|
6423 //UFW_FLAG_CBLOCK|
6424 //UFW_FLAG_VOCAB|
6425 //UFW_FLAG_SCOLON|
6426 UFW_FLAG_PROTECTED;
6427 flags |= UFW_FLAG_VOCAB;
6429 flags &= 0xffffff00u;
6430 flags |= UFW_FLAG_VOCAB;
6431 ufoCreateWordHeader(wname, flags);
6432 const uint32_t cfa = UFO_GET_DP();
6433 ufoImgEmitU32(ufoDoVocCFA); // cfa
6434 ufoImgEmitU32(vocid); // pfa
6435 // update vocab header pointer
6436 const uint32_t lfa = UFO_CFA_TO_LFA(cfa);
6437 ufoImgPutU32(hdraddr, UFO_LFA_TO_NFA(lfa));
6438 #ifdef UFO_DEBUG_DUMP_NEW_HEADERS
6439 ufoDumpWordHeader(lfa);
6440 #endif
6442 return vocid;
6446 //==========================================================================
6448 // ufoSetLatestArgs
6450 //==========================================================================
6451 static void ufoSetLatestArgs (uint32_t warg) {
6452 const uint32_t curr = ufoImgGetU32(ufoAddrCurrent);
6453 const uint32_t lfa = ufoImgGetU32(curr);
6454 const uint32_t nfa = UFO_LFA_TO_NFA(lfa);
6455 uint32_t flags = ufoImgGetU32(nfa);
6456 //fprintf(stderr, "OLD FLAGS: 0x%08x\n", flags);
6457 flags &= ~UFW_WARG_MASK;
6458 flags |= warg & UFW_WARG_MASK;
6459 //fprintf(stderr, "NEW FLAGS: 0x%08x\n", flags);
6460 ufoImgPutU32(nfa, flags);
6461 #ifdef UFO_DEBUG_DUMP_NEW_HEADERS
6462 ufoDumpWordHeader(lfa);
6463 #endif
6467 //==========================================================================
6469 // ufoDefine
6471 //==========================================================================
6472 static void ufoDefineNative (const char *wname, uint32_t cfaidx, int immed) {
6473 cfaidx |= UFO_ADDR_CFA_BIT;
6474 uint32_t flags = ufoImgGetU32(ufoAddrNewWordFlags);
6475 flags &=
6476 //UFW_FLAG_IMMEDIATE|
6477 //UFW_FLAG_SMUDGE|
6478 //UFW_FLAG_NORETURN|
6479 UFW_FLAG_HIDDEN|
6480 //UFW_FLAG_CBLOCK|
6481 //UFW_FLAG_VOCAB|
6482 //UFW_FLAG_SCOLON|
6483 UFW_FLAG_PROTECTED;
6484 if (immed) flags |= UFW_FLAG_IMMEDIATE;
6485 ufoCreateWordHeader(wname, flags);
6486 ufoImgEmitU32(cfaidx);
6490 //==========================================================================
6492 // ufoDefineConstant
6494 //==========================================================================
6495 static void ufoDefineConstant (const char *name, uint32_t value) {
6496 ufoDefineNative(name, ufoDoConstCFA, 0);
6497 ufoImgEmitU32(value);
6501 //==========================================================================
6503 // ufoDefineUserVar
6505 //==========================================================================
6506 static void ufoDefineUserVar (const char *name, uint32_t addr) {
6507 ufoDefineNative(name, ufoDoUserVariableCFA, 0);
6508 ufoImgEmitU32(addr);
6512 //==========================================================================
6514 // ufoDefineVar
6516 //==========================================================================
6518 static void ufoDefineVar (const char *name, uint32_t value) {
6519 ufoDefineNative(name, ufoDoVarCFA, 0);
6520 ufoImgEmitU32(value);
6525 //==========================================================================
6527 // ufoDefineDefer
6529 //==========================================================================
6531 static void ufoDefineDefer (const char *name, uint32_t value) {
6532 ufoDefineNative(name, ufoDoDeferCFA, 0);
6533 ufoImgEmitU32(value);
6538 //==========================================================================
6540 // ufoHiddenWords
6542 //==========================================================================
6543 static void ufoHiddenWords (void) {
6544 const uint32_t flags = ufoImgGetU32(ufoAddrNewWordFlags);
6545 ufoImgPutU32(ufoAddrNewWordFlags, flags | UFW_FLAG_HIDDEN);
6549 //==========================================================================
6551 // ufoPublicWords
6553 //==========================================================================
6554 static void ufoPublicWords (void) {
6555 const uint32_t flags = ufoImgGetU32(ufoAddrNewWordFlags);
6556 ufoImgPutU32(ufoAddrNewWordFlags, flags & ~UFW_FLAG_HIDDEN);
6560 //==========================================================================
6562 // ufoDefineForth
6564 //==========================================================================
6566 static void ufoDefineForth (const char *name) {
6567 ufoDefineNative(name, ufoDoForthCFA, 0);
6572 //==========================================================================
6574 // ufoDefineForthImm
6576 //==========================================================================
6578 static void ufoDefineForthImm (const char *name) {
6579 ufoDefineNative(name, ufoDoForthCFA, 1);
6584 //==========================================================================
6586 // ufoDefineForthHidden
6588 //==========================================================================
6590 static void ufoDefineForthHidden (const char *name) {
6591 const uint32_t flags = ufoImgGetU32(ufoAddrNewWordFlags);
6592 ufoImgPutU32(ufoAddrNewWordFlags, flags | UFW_FLAG_HIDDEN);
6593 ufoDefineNative(name, ufoDoForthCFA, 0);
6594 ufoImgPutU32(ufoAddrNewWordFlags, flags);
6599 //==========================================================================
6601 // ufoDefineSColonForth
6603 // create word suitable for scattered colon extension
6605 //==========================================================================
6606 static void ufoDefineSColonForth (const char *name) {
6607 ufoDefineNative(name, ufoDoForthCFA, 0);
6608 // placeholder for scattered colon
6609 // it will compile two branches:
6610 // the first branch will jump to the first "..:" word (or over the two branches)
6611 // the second branch is never taken, and works as a pointer to the latest branch addr in the list
6612 // this way, each extension word will simply fix the last branch address, and update list tail
6613 // at the creation time, second branch points to the first branch
6614 UFC("FORTH:(BRANCH)");
6615 const uint32_t xjmp = UFO_GET_DP();
6616 ufoImgEmitU32(0);
6617 UFC("FORTH:(BRANCH)"); ufoImgEmitU32(xjmp);
6618 ufoImgPutU32(xjmp, UFO_GET_DP());
6622 //==========================================================================
6624 // ufoDoneForth
6626 //==========================================================================
6627 UFO_FORCE_INLINE void ufoDoneForth (void) {
6628 UFC("FORTH:(EXIT)");
6632 //==========================================================================
6634 // ufoCompileStrLit
6636 // compile string literal, the same as QUOTE_IMM
6638 //==========================================================================
6639 static void ufoCompileStrLitEx (const char *str, const uint32_t slen) {
6640 if (str == NULL) str = "";
6641 if (slen > 255) ufoFatal("string literal too long");
6642 UFC("FORTH:(LITSTR8)");
6643 ufoImgEmitU8((uint8_t)slen);
6644 for (size_t f = 0; f < slen; f += 1) {
6645 ufoImgEmitU8(((const unsigned char *)str)[f]);
6647 ufoImgEmitU8(0);
6648 ufoImgEmitAlign();
6652 //==========================================================================
6654 // ufoCompileStrLit
6656 //==========================================================================
6658 static void ufoCompileStrLit (const char *str) {
6659 ufoCompileStrLitEx(str, (uint32_t)strlen(str));
6664 //==========================================================================
6666 // ufoCompileLit
6668 //==========================================================================
6669 static void ufoCompileLit (uint32_t value) {
6670 UFC("FORTH:(LIT)");
6671 ufoImgEmitU32(value);
6675 //==========================================================================
6677 // ufoCompileCFALit
6679 //==========================================================================
6681 static void ufoCompileCFALit (const char *wname) {
6682 UFC("FORTH:(LITCFA)");
6683 const uint32_t cfa = ufoFindWordChecked(wname);
6684 ufoImgEmitU32(cfa);
6689 //==========================================================================
6691 // ufoXStrEquCI
6693 //==========================================================================
6694 static int ufoXStrEquCI (const char *word, const char *text, uint32_t tlen) {
6695 while (tlen != 0 && *word) {
6696 if (toUpper(*word) != toUpper(*text)) return 0;
6697 word += 1u; text += 1u; tlen -= 1u;
6699 return (tlen == 0 && *word == 0);
6703 #define UFO_MAX_LABEL_NAME (63)
6704 typedef struct UfoLabel_t {
6705 uint32_t hash;
6706 uint32_t namelen;
6707 char name[UFO_MAX_LABEL_NAME];
6708 uint32_t addr; // jump chain tail, or address
6709 uint32_t defined;
6710 uint32_t word; // is this a forward word definition?
6711 struct UfoLabel_t *next;
6712 } UfoLabel;
6714 static UfoLabel *ufoLabels = NULL;
6717 //==========================================================================
6719 // ufoFindAddLabelEx
6721 //==========================================================================
6722 static UfoLabel *ufoFindAddLabelEx (const char *name, uint32_t namelen, int allowAdd) {
6723 if (namelen == 0 || namelen > UFO_MAX_LABEL_NAME) ufoFatal("invalid label name");
6724 const uint32_t hash = joaatHashBufCI(name, namelen);
6725 UfoLabel *lbl = ufoLabels;
6726 while (lbl != NULL) {
6727 if (lbl->hash == hash && lbl->namelen == namelen) {
6728 int ok = 1;
6729 uint32_t sidx = 0;
6730 while (ok && sidx != namelen) {
6731 ok = (toUpper(name[sidx]) == toUpper(lbl->name[sidx]));
6732 sidx += 1;
6734 if (ok) return lbl;
6736 lbl = lbl->next;
6738 if (allowAdd) {
6739 // create new label
6740 lbl = calloc(1, sizeof(UfoLabel));
6741 lbl->hash = hash;
6742 lbl->namelen = namelen;
6743 memcpy(lbl->name, name, namelen);
6744 lbl->name[namelen] = 0;
6745 lbl->next = ufoLabels;
6746 ufoLabels = lbl;
6747 return lbl;
6748 } else {
6749 return NULL;
6754 //==========================================================================
6756 // ufoFindAddLabel
6758 //==========================================================================
6759 static UfoLabel *ufoFindAddLabel (const char *name, uint32_t namelen) {
6760 return ufoFindAddLabelEx(name, namelen, 1);
6764 //==========================================================================
6766 // ufoFindLabel
6768 //==========================================================================
6769 static UfoLabel *ufoFindLabel (const char *name, uint32_t namelen) {
6770 return ufoFindAddLabelEx(name, namelen, 0);
6774 //==========================================================================
6776 // ufoTrySimpleNumber
6778 // only decimal and C-like hexes; with an optional sign
6780 //==========================================================================
6781 static int ufoTrySimpleNumber (const char *text, uint32_t tlen, uint32_t *num) {
6782 int neg = 0;
6784 if (tlen != 0 && *text == '+') { text += 1u; tlen -= 1u; }
6785 else if (tlen != 0 && *text == '-') { neg = 1; text += 1u; tlen -= 1u; }
6787 int base = 10; // default base
6788 if (tlen > 2 && text[0] == '0' && toUpper(text[1]) == 'X') {
6789 // hex
6790 base = 16;
6791 text += 2u; tlen -= 2u;
6794 if (tlen == 0 || digitInBase(*text, base) < 0) return 0;
6796 int wasDigit = 0;
6797 uint32_t n = 0;
6798 int dig;
6799 while (tlen != 0) {
6800 if (*text == '_') {
6801 if (!wasDigit) return 0;
6802 wasDigit = 0;
6803 } else {
6804 dig = digitInBase(*text, base);
6805 if (dig < 0) return 0;
6806 wasDigit = 1;
6807 n = n * (uint32_t)base + (uint32_t)dig;
6809 text += 1u; tlen -= 1u;
6812 if (!wasDigit) return 0;
6813 if (neg) n = ~n + 1u;
6814 *num = n;
6815 return 1;
6819 //==========================================================================
6821 // ufoEmitLabelChain
6823 //==========================================================================
6824 static void ufoEmitLabelChain (UfoLabel *lbl) {
6825 ufo_assert(lbl != NULL);
6826 ufo_assert(lbl->defined == 0);
6827 const uint32_t here = UFO_GET_DP();
6828 ufoImgEmitU32(lbl->addr);
6829 lbl->addr = here;
6833 //==========================================================================
6835 // ufoFixLabelChainHere
6837 //==========================================================================
6838 static void ufoFixLabelChainHere (UfoLabel *lbl) {
6839 ufo_assert(lbl != NULL);
6840 ufo_assert(lbl->defined == 0);
6841 const uint32_t here = UFO_GET_DP();
6842 while (lbl->addr != 0) {
6843 const uint32_t aprev = ufoImgGetU32(lbl->addr);
6844 ufoImgPutU32(lbl->addr, here);
6845 lbl->addr = aprev;
6847 lbl->addr = here;
6848 lbl->defined = 1;
6852 #define UFO_MII_WORD_COMPILE_IMM (-4)
6853 #define UFO_MII_WORD_CFA_LIT (-3)
6854 #define UFO_MII_WORD_COMPILE (-2)
6855 #define UFO_MII_IN_WORD (-1)
6856 #define UFO_MII_NO_WORD (0)
6857 #define UFO_MII_WORD_NAME (1)
6858 #define UFO_MII_WORD_NAME_IMM (2)
6859 #define UFO_MII_WORD_NAME_HIDDEN (3)
6861 static int ufoMinInterpState = UFO_MII_NO_WORD;
6864 //==========================================================================
6866 // ufoFinalLabelCheck
6868 //==========================================================================
6869 static void ufoFinalLabelCheck (void) {
6870 int errorCount = 0;
6871 if (ufoMinInterpState != UFO_MII_NO_WORD) {
6872 ufoFatal("missing semicolon");
6874 while (ufoLabels != NULL) {
6875 UfoLabel *lbl = ufoLabels; ufoLabels = lbl->next;
6876 if (!lbl->defined) {
6877 fprintf(stderr, "UFO ERROR: label '%s' is not defined!\n", lbl->name);
6878 errorCount += 1;
6880 free(lbl);
6882 if (errorCount != 0) {
6883 ufoFatal("%d undefined label%s", errorCount, (errorCount != 1 ? "s" : ""));
6888 //==========================================================================
6890 // ufoInterpretLine
6892 // this is so i could write Forth definitions more easily
6894 // labels:
6895 // $name -- reference
6896 // $name: -- definition
6898 //==========================================================================
6899 UFO_DISABLE_INLINE void ufoInterpretLine (const char *line) {
6900 char wname[UFO_MAX_WORD_LENGTH];
6901 uint32_t wlen, num, cfa;
6902 UfoLabel *lbl;
6903 while (*line) {
6904 if (*(const unsigned char *)line <= 32) {
6905 line += 1;
6906 } else if (ufoMinInterpState == UFO_MII_WORD_CFA_LIT ||
6907 ufoMinInterpState == UFO_MII_WORD_COMPILE ||
6908 ufoMinInterpState == UFO_MII_WORD_COMPILE_IMM)
6910 // "[']"/"COMPILE"/"[COMPILE]" argument
6911 wlen = 1;
6912 while (((const unsigned char *)line)[wlen] > 32) wlen += 1;
6913 if (wlen >= UFO_MAX_WORD_LENGTH) ufoFatal("word name too long");
6914 memcpy(wname, line, wlen);
6915 wname[wlen] = 0;
6916 switch (ufoMinInterpState) {
6917 case UFO_MII_WORD_CFA_LIT: UFC("FORTH:(LITCFA)"); break;
6918 case UFO_MII_WORD_COMPILE: UFC("FORTH:(LITCFA)"); break;
6919 case UFO_MII_WORD_COMPILE_IMM: break;
6920 default: ufo_assert(0);
6922 cfa = ufoFindWord(wname);
6923 if (cfa != 0) {
6924 ufoImgEmitU32(cfa);
6925 } else {
6926 // forward reference
6927 lbl = ufoFindAddLabel(line, wlen);
6928 if (lbl->defined || (lbl->word == 0 && lbl->addr)) {
6929 ufoFatal("unknown word: '%s'", wname);
6931 lbl->word = 1;
6932 ufoEmitLabelChain(lbl);
6934 switch (ufoMinInterpState) {
6935 case UFO_MII_WORD_CFA_LIT: break;
6936 case UFO_MII_WORD_COMPILE: UFC("FORTH:COMPILE,"); break;
6937 case UFO_MII_WORD_COMPILE_IMM: break;
6938 default: ufo_assert(0);
6940 ufoMinInterpState = UFO_MII_IN_WORD;
6941 line += wlen;
6942 } else if (ufoMinInterpState > UFO_MII_NO_WORD) {
6943 // new word
6944 wlen = 1;
6945 while (((const unsigned char *)line)[wlen] > 32) wlen += 1;
6946 if (wlen >= UFO_MAX_WORD_LENGTH) ufoFatal("word name too long");
6947 if (wlen > 2 && line[0] == ':' && line[wlen - 1u] == ':') ufoFatal("invalid word name");
6948 memcpy(wname, line, wlen);
6949 wname[wlen] = 0;
6950 const uint32_t oldFlags = ufoImgGetU32(ufoAddrNewWordFlags);
6951 if (ufoMinInterpState == UFO_MII_WORD_NAME_HIDDEN) {
6952 ufoImgPutU32(ufoAddrNewWordFlags, oldFlags | UFW_FLAG_HIDDEN);
6954 ufoDefineNative(wname, ufoDoForthCFA, (ufoMinInterpState == UFO_MII_WORD_NAME_IMM));
6955 ufoImgPutU32(ufoAddrNewWordFlags, oldFlags);
6956 ufoMinInterpState = UFO_MII_IN_WORD;
6957 // check for forward references
6958 lbl = ufoFindLabel(line, wlen);
6959 if (lbl != NULL) {
6960 if (lbl->defined || !lbl->word) {
6961 ufoFatal("label/word conflict for '%.*s'", (unsigned)wlen, line);
6963 ufoFixLabelChainHere(lbl);
6965 line += wlen;
6966 } else if ((line[0] == ';' && line[1] == ';') ||
6967 (line[0] == '-' && line[1] == '-') ||
6968 (line[0] == '/' && line[1] == '/') ||
6969 (line[0] == '\\' && ((const unsigned char *)line)[1] <= 32))
6971 ufoFatal("do not use single-line comments");
6972 } else if (line[0] == '(' && ((const unsigned char *)line)[1] <= 32) {
6973 while (*line && *line != ')') line += 1;
6974 if (*line == ')') line += 1;
6975 } else {
6976 // word
6977 wlen = 1;
6978 while (((const unsigned char *)line)[wlen] > 32) wlen += 1;
6979 if (wlen == 1 && (line[0] == '"' || line[0] == '`')) {
6980 // string literal
6981 const char qch = line[0];
6982 if (!line[1]) ufoFatal("unterminated string literal");
6983 // skip quote and space
6984 if (((const unsigned char *)line)[1] <= 32) line += 2u; else line += 1u;
6985 wlen = 0;
6986 while (line[wlen] && line[wlen] != qch) wlen += 1u;
6987 if (line[wlen] != qch) ufoFatal("unterminated string literal");
6988 ufoCompileStrLitEx(line, wlen);
6989 line += wlen + 1u; // skip final quote
6990 } else if (wlen == 1 && line[0] == ':') {
6991 // new word
6992 if (ufoMinInterpState != UFO_MII_NO_WORD) ufoFatal("unexpected colon");
6993 ufoMinInterpState = UFO_MII_WORD_NAME;
6994 line += wlen;
6995 } else if (wlen == 1 && line[0] == ';') {
6996 // end word
6997 if (ufoMinInterpState != UFO_MII_IN_WORD) ufoFatal("unexpected semicolon");
6998 ufoImgEmitU32(ufoFindWordChecked("FORTH:(EXIT)"));
6999 ufoMinInterpState = UFO_MII_NO_WORD;
7000 line += wlen;
7001 } else if (wlen == 2 && line[0] == '!' && line[1] == ':') {
7002 // new immediate word
7003 if (ufoMinInterpState != UFO_MII_NO_WORD) ufoFatal("unexpected colon");
7004 ufoMinInterpState = UFO_MII_WORD_NAME_IMM;
7005 line += wlen;
7006 } else if (wlen == 2 && line[0] == '*' && line[1] == ':') {
7007 // new hidden word
7008 if (ufoMinInterpState != UFO_MII_NO_WORD) ufoFatal("unexpected colon");
7009 ufoMinInterpState = UFO_MII_WORD_NAME_HIDDEN;
7010 line += wlen;
7011 } else if (wlen == 3 && memcmp(line, "[']", 3) == 0) {
7012 // cfa literal
7013 if (ufoMinInterpState != UFO_MII_IN_WORD) ufoFatal("unexpected immediate tick");
7014 ufoMinInterpState = UFO_MII_WORD_CFA_LIT;
7015 line += wlen;
7016 } else if (wlen == 7 && ufoXStrEquCI("COMPILE", line, wlen)) {
7017 // "COMPILE"
7018 if (ufoMinInterpState != UFO_MII_IN_WORD) ufoFatal("unexpected immediate tick");
7019 ufoMinInterpState = UFO_MII_WORD_COMPILE;
7020 line += wlen;
7021 } else if (wlen == 9 && ufoXStrEquCI("[COMPILE]", line, wlen)) {
7022 // "[COMPILE]"
7023 if (ufoMinInterpState != UFO_MII_IN_WORD) ufoFatal("unexpected immediate tick");
7024 ufoMinInterpState = UFO_MII_WORD_COMPILE_IMM;
7025 line += wlen;
7026 } else {
7027 // look for a word
7028 if (wlen >= UFO_MAX_WORD_LENGTH) ufoFatal("word name too long");
7029 memcpy(wname, line, wlen);
7030 wname[wlen] = 0;
7031 cfa = ufoFindWord(wname);
7032 if (cfa != 0) {
7033 // compile word
7034 ufoImgEmitU32(cfa);
7035 } else if (ufoTrySimpleNumber(line, wlen, &num)) {
7036 // compile numeric literal
7037 ufoCompileLit(num);
7038 } else {
7039 // unknown word, this may be a forward reference, or a label definition
7040 // label defintion starts with "$"
7041 // (there are no words starting with "$" in the initial image)
7042 if (line[0] == '$') {
7043 if (wlen == 1) ufoFatal("dollar what?");
7044 if (wlen > 2 && line[wlen - 1u] == ':') {
7045 // label definition
7046 lbl = ufoFindAddLabel(line, wlen - 1u);
7047 if (lbl->defined) ufoFatal("double label '%s' definition", lbl->name);
7048 ufoFixLabelChainHere(lbl);
7049 } else {
7050 // label reference
7051 lbl = ufoFindAddLabel(line, wlen);
7052 if (lbl->defined) {
7053 ufoImgEmitU32(lbl->addr);
7054 } else {
7055 ufoEmitLabelChain(lbl);
7058 } else {
7059 // forward reference
7060 lbl = ufoFindAddLabel(line, wlen);
7061 if (lbl->defined || (lbl->word == 0 && lbl->addr)) {
7062 ufoFatal("unknown word: '%s'", wname);
7064 lbl->word = 1;
7065 ufoEmitLabelChain(lbl);
7068 line += wlen;
7075 //==========================================================================
7077 // ufoReset
7079 //==========================================================================
7080 UFO_DISABLE_INLINE void ufoReset (void) {
7081 if (ufoCurrState == NULL) ufoFatal("no active execution state");
7083 ufoSP = 0; ufoRP = 0;
7084 ufoLP = 0; ufoLBP = 0;
7086 ufoInRunWord = 0;
7087 ufoVMStop = 0; ufoVMAbort = 0;
7089 ufoInBacktrace = 0;
7091 // save TIB
7092 const uint32_t tib = ufoImgGetU32(ufoAddrTIBx);
7093 const uint32_t tibDef = ufoImgGetU32(ufoAddrDefTIB);
7094 ufoInitStateUserVars(ufoCurrState, 0);
7095 // restore TIB
7096 ufoImgPutU32(ufoAddrTIBx, tib);
7097 ufoImgPutU32(ufoAddrDefTIB, tibDef);
7098 ufoImgPutU32(ufoAddrRedefineWarning, UFO_REDEF_WARN_NORMAL);
7099 ufoResetTib();
7101 ufoImgPutU32(ufoAddrDPTemp, 0);
7103 ufoImgPutU32(ufoAddrNewWordFlags, 0);
7104 ufoVocSetOnlyDefs(ufoForthVocId);
7108 //==========================================================================
7110 // ufoDefineEmitType
7112 //==========================================================================
7113 UFO_DISABLE_INLINE void ufoDefineEmitType (void) {
7114 // EMIT
7115 // ( ch -- )
7116 ufoInterpretLine(": EMIT ( ch -- ) (NORM-EMIT-CHAR) (EMIT) ;");
7118 // XEMIT
7119 // ( ch -- )
7120 ufoInterpretLine(": XEMIT ( ch -- ) (NORM-XEMIT-CHAR) (EMIT) ;");
7122 // CR
7123 // ( -- )
7124 ufoInterpretLine(": CR ( -- ) NL (EMIT) ;");
7126 // ENDCR
7127 // ( -- )
7128 ufoInterpretLine(
7129 ": ENDCR ( -- ) "
7130 " LASTCR? FORTH:(TBRANCH) $endcr-exit CR "
7131 "$endcr-exit: "
7132 ";");
7133 //ufoDecompileWord(ufoFindWordChecked("ENDCR"));
7135 // SPACE
7136 // ( -- )
7137 ufoInterpretLine(": SPACE ( -- ) BL (EMIT) ;");
7139 // SPACES
7140 // ( count -- )
7141 ufoInterpretLine(
7142 ": SPACES ( count -- ) "
7143 "$spaces-again: "
7144 " DUP 0> FORTH:(0BRANCH) $spaces-exit "
7145 " SPACE 1- "
7146 " FORTH:(BRANCH) $spaces-again "
7147 "$spaces-exit: "
7148 " DROP "
7149 ";");
7151 // TYPE
7152 // ( addr count -- )
7153 ufoInterpretLine(
7154 ": TYPE ( addr count -- ) "
7155 " A>R SWAP >A "
7156 "$type-again: "
7157 " DUP 0> FORTH:(0BRANCH) $type-exit "
7158 " C@A EMIT +1>A "
7159 " 1- "
7160 " FORTH:(BRANCH) $type-again "
7161 "$type-exit: "
7162 " DROP R>A "
7163 ";");
7165 // XTYPE
7166 // ( addr count -- )
7167 ufoInterpretLine(
7168 ": XTYPE ( addr count -- ) "
7169 " A>R SWAP >A "
7170 "$xtype-again: "
7171 " DUP 0> FORTH:(0BRANCH) $xtype-exit "
7172 " C@A XEMIT +1>A "
7173 " 1- "
7174 " FORTH:(BRANCH) $xtype-again "
7175 "$xtype-exit: "
7176 " DROP R>A "
7177 ";");
7179 // HERE
7180 // ( -- here )
7181 ufoInterpretLine(
7182 ": HERE ( -- here ) "
7183 " FORTH:(DP-TEMP) @ ?DUP "
7184 " FORTH:(TBRANCH) $here-exit "
7185 " FORTH:(DP) @ "
7186 "$here-exit: "
7187 ";");
7189 // ALIGN-HERE
7190 // ( -- )
7191 ufoInterpretLine(
7192 ": ALIGN-HERE ( -- ) "
7193 "$align-here-loop: "
7194 " HERE 3 AND "
7195 " FORTH:(0BRANCH) $align-here-exit "
7196 " 0 C, "
7197 " FORTH:(BRANCH) $align-here-loop "
7198 "$align-here-exit: "
7199 ";");
7201 // STRLITERAL
7202 // ( C:addr count -- ) ( E: -- addr count )
7203 ufoInterpretLine(
7204 ": STRLITERAL ( C:addr count -- ) ( E: -- addr count ) "
7205 " DUP 255 U> ` string literal too long` ?ERROR "
7206 " STATE @ FORTH:(0BRANCH) $strlit-exit "
7207 " ( addr count ) "
7208 " ['] FORTH:(LITSTR8) COMPILE, "
7209 " A>R SWAP >A "
7210 " ( compile length ) "
7211 " DUP C, "
7212 " ( compile chars ) "
7213 "$strlit-loop: "
7214 " DUP 0<> FORTH:(0BRANCH) $strlit-loop-exit "
7215 " C@A C, +1>A 1- "
7216 " FORTH:(BRANCH) $strlit-loop "
7217 "$strlit-loop-exit: "
7218 " R>A "
7219 " ( final 0: our counter is 0 here, so use it ) "
7220 " C, ALIGN-HERE "
7221 "$strlit-exit: "
7222 ";");
7224 // quote
7225 // ( -- addr count )
7226 ufoInterpretLine(
7227 "!: \" ( -- addr count ) "
7228 " 34 PARSE ` string literal expected` ?NOT-ERROR "
7229 " COMPILER:(UNESCAPE) STRLITERAL "
7230 ";");
7234 //==========================================================================
7236 // ufoDefineInterpret
7238 // define "INTERPRET" in Forth
7240 //==========================================================================
7241 UFO_DISABLE_INLINE void ufoDefineInterpret (void) {
7242 UFWORDX("(UFO-INTERPRET-FINISHED-ACTION)", UFO_INTERPRET_FINISHED_ACTION);
7244 // return "stop flag"
7245 ufoInterpretLine(
7246 "*: (UFO-INTERPRET-NEXT-LINE) ( -- continue? ) "
7247 " STATE @ FORTH:(TBRANCH) $ipn_incomp "
7248 " ( interpreter allowed to cross include boundary ) "
7249 " REFILL FORTH:(BRANCH) $ipn_done "
7250 "$ipn_incomp: "
7251 " ( compiler is not allowed to cross include boundary ) "
7252 " REFILL-NOCROSS ` compiler cannot cross file boundaries` ?NOT-ERROR "
7253 " TRUE "
7254 "$ipn_done: "
7255 ";");
7257 ufoInterpNextLineCFA = ufoFindWordChecked("FORTH:(UFO-INTERPRET-NEXT-LINE)");
7258 ufoInterpretLine("*: (INTERPRET-NEXT-LINE) (USER-INTERPRET-NEXT-LINE) @ EXECUTE-TAIL ;");
7260 // skip comments, parse name, refilling lines if necessary
7261 // returning FALSE as counter means: "no addr, exit INTERPRET"
7262 ufoInterpretLine(
7263 "*: (INTERPRET-PARSE-NAME) ( -- addr count / FALSE ) "
7264 "$label_ipn_again: "
7265 " TRUE (PARSE-SKIP-COMMENTS) PARSE-NAME "
7266 " DUP FORTH:(TBRANCH) $label_ipn_exit_fwd "
7267 " 2DROP (INTERPRET-NEXT-LINE) "
7268 " FORTH:(TBRANCH) $label_ipn_again "
7269 " FALSE "
7270 "$label_ipn_exit_fwd: "
7271 ";");
7272 //ufoDecompileWord(ufoFindWordChecked("(INTERPRET-PARSE-NAME)"));
7274 ufoInterpretLine(
7275 ": INTERPRET "
7276 "$interp-again: "
7277 " FORTH:(INTERPRET-PARSE-NAME) ( addr count / FALSE )"
7278 " ?DUP FORTH:(0BRANCH) $interp-done "
7279 " ( try defered checker ) "
7280 " ( addr count FALSE -- addr count FALSE / TRUE ) "
7281 " FALSE (INTERPRET-CHECK-WORD) FORTH:(TBRANCH) $interp-again "
7282 " 2DUP FIND-WORD ( addr count cfa TRUE / addr count FALSE ) "
7283 " FORTH:(0BRANCH) $interp-try-number "
7284 " ( word found ) "
7285 " NROT 2DROP ( drop word string ) "
7286 " STATE @ FORTH:(0BRANCH) $interp-exec "
7287 " ( compiling; check immediate bit ) "
7288 " DUP CFA->NFA @ COMPILER:(WFLAG-IMMEDIATE) AND FORTH:(TBRANCH) $interp-exec "
7289 " ( compile it ) "
7290 " FORTH:COMPILE, FORTH:(BRANCH) $interp-again "
7291 " ( execute it ) "
7292 "$interp-exec: "
7293 " EXECUTE FORTH:(BRANCH) $interp-again "
7294 " ( not a word, try a number ) "
7295 "$interp-try-number: "
7296 " 2DUP TRUE BASE @ (BASED-NUMBER) ( addr count allowsign? base -- num TRUE / FALSE ) "
7297 " FORTH:(0BRANCH) $interp-number-error "
7298 " ( number ) "
7299 " NROT 2DROP ( drop word string ) "
7300 " ( do we need to compile it? ) "
7301 " STATE @ FORTH:(0BRANCH) $interp-again "
7302 " COMPILE FORTH:(LIT) FORTH:, "
7303 " FORTH:(BRANCH) $interp-again "
7304 " ( error ) "
7305 "$interp-number-error: "
7306 " ( addr count FALSE -- addr count FALSE / TRUE ) "
7307 " FALSE (INTERPRET-WORD-NOT-FOUND) FORTH:(TBRANCH) $interp-again "
7308 " ENDCR SPACE XTYPE ` -- wut?` TYPE CR "
7309 " ` unknown word` ERROR "
7310 "$interp-done: "
7311 ";");
7312 //ufoDecompileWord(ufoFindWordChecked("INTERPRET"));
7316 //==========================================================================
7318 // ufoInitBaseDict
7320 //==========================================================================
7321 UFO_DISABLE_INLINE void ufoInitBaseDict (void) {
7322 uint32_t imgAddr = 0;
7324 // reserve 32 bytes for nothing
7325 for (uint32_t f = 0; f < 32; f += 1) {
7326 ufoImgPutU8(imgAddr, 0);
7327 imgAddr += 1;
7329 // align
7330 while ((imgAddr & 3) != 0) {
7331 ufoImgPutU8(imgAddr, 0);
7332 imgAddr += 1;
7335 // DP
7336 ufoAddrDP = imgAddr;
7337 ufoImgPutU32(imgAddr, 0); imgAddr += 4u;
7339 // DP-TEMP
7340 ufoAddrDPTemp = imgAddr;
7341 ufoImgPutU32(imgAddr, 0); imgAddr += 4u;
7343 // (LATEST-XFA)
7344 ufoAddrLastXFA = imgAddr;
7345 ufoImgPutU32(imgAddr, 0); imgAddr += 4u;
7347 // (VOC-LINK)
7348 ufoAddrVocLink = imgAddr;
7349 ufoImgPutU32(imgAddr, 0); imgAddr += 4u;
7351 // (NEW-WORD-FLAGS)
7352 ufoAddrNewWordFlags = imgAddr;
7353 ufoImgPutU32(imgAddr, UFW_FLAG_PROTECTED); imgAddr += 4u;
7355 // WORD-REDEFINE-WARN-MODE
7356 ufoAddrRedefineWarning = imgAddr;
7357 ufoImgPutU32(imgAddr, UFO_REDEF_WARN_NORMAL); imgAddr += 4u;
7359 // setup (DP) and (DP-TEMP)
7360 ufoImgPutU32(ufoAddrDP, imgAddr);
7361 ufoImgPutU32(ufoAddrDPTemp, 0);
7363 #if 0
7364 fprintf(stderr, "INITIAL HERE: 0x%08x (0x%08x)\n", imgAddr, UFO_GET_DP());
7365 #endif
7369 //==========================================================================
7371 // ufoInitStateUserVars
7373 //==========================================================================
7374 static void ufoInitStateUserVars (UfoState *st, uint32_t cfa) {
7375 ufo_assert(st != NULL);
7376 if (st->imageTempSize < 8192u) {
7377 uint32_t *itmp = realloc(st->imageTemp, 8192);
7378 if (itmp == NULL) ufoFatal("out of memory for state user area");
7379 st->imageTemp = itmp;
7380 memset((uint8_t *)st->imageTemp + st->imageTempSize, 0, 8192u - st->imageTempSize);
7381 st->imageTempSize = 8192;
7383 st->imageTemp[(ufoAddrBASE & UFO_ADDR_TEMP_MASK) / 4u] = 10;
7384 st->imageTemp[(ufoAddrSTATE & UFO_ADDR_TEMP_MASK) / 4u] = 0;
7385 st->imageTemp[(ufoAddrUserVarUsed & UFO_ADDR_TEMP_MASK) / 4u] = ufoAddrUserVarUsed;
7386 st->imageTemp[(ufoAddrDefTIB & UFO_ADDR_TEMP_MASK) / 4u] = UFO_DEF_TIB_ADDR;
7387 st->imageTemp[(ufoAddrTIBx & UFO_ADDR_TEMP_MASK) / 4u] = UFO_DEF_TIB_ADDR;
7388 st->imageTemp[(ufoAddrINx & UFO_ADDR_TEMP_MASK) / 4u] = 0;
7389 st->imageTemp[(ufoAddrContext & UFO_ADDR_TEMP_MASK) / 4u] = ufoForthVocId;
7390 st->imageTemp[(ufoAddrCurrent & UFO_ADDR_TEMP_MASK) / 4u] = ufoForthVocId;
7391 st->imageTemp[(ufoAddrSelf & UFO_ADDR_TEMP_MASK) / 4u] = 0;
7392 st->imageTemp[(ufoAddrInterNextLine & UFO_ADDR_TEMP_MASK) / 4u] = ufoInterpNextLineCFA;
7393 st->imageTemp[(ufoAddrEP & UFO_ADDR_TEMP_MASK) / 4u] = 0;
7394 // init other things, because this procedure is used in `ufoReset()` too
7395 st->SP = 0; st->RP = 0; st->RPTop = 0; st->regA = 0;
7396 st->LP = 0; st->LBP = 0; st->vmRPopCFA = 0;
7397 st->VSP = 0;
7398 // init it
7399 if (cfa != 0) {
7400 st->vmRPopCFA = 1;
7401 st->rStack[0] = 0xdeadf00d; // dummy value
7402 st->rStack[1] = cfa;
7403 st->RP = 2;
7408 //==========================================================================
7410 // ufoInitBasicWords
7412 //==========================================================================
7413 UFO_DISABLE_INLINE void ufoInitBasicWords (void) {
7414 ufoDefineConstant("FALSE", 0);
7415 ufoDefineConstant("TRUE", ufoTrueValue);
7417 ufoDefineConstant("BL", 32);
7418 ufoDefineConstant("NL", 10);
7420 // user variables
7421 ufoDefineUserVar("BASE", ufoAddrBASE);
7422 ufoDefineUserVar("TIB", ufoAddrTIBx);
7423 ufoDefineUserVar(">IN", ufoAddrINx);
7424 ufoDefineUserVar("(STD-TIB-ADDR)", ufoAddrDefTIB);
7425 ufoDefineUserVar("(USER-VAR-USED)", ufoAddrUserVarUsed);
7426 ufoDefineConstant("(USER-VAR-ADDR)", UFO_ADDR_TEMP_BIT);
7427 ufoDefineConstant("(USER-VAR-SIZE)", UFO_USER_AREA_SIZE);
7428 ufoDefineConstant("(USER-TIB)", UFO_DEF_TIB_ADDR);
7429 ufoDefineConstant("(USER-TIB-SIZE)", UFO_ADDR_HANDLE_OFS_MASK);
7431 ufoDefineUserVar("STATE", ufoAddrSTATE);
7432 ufoDefineConstant("CONTEXT", ufoAddrContext);
7433 ufoDefineConstant("CURRENT", ufoAddrCurrent);
7434 ufoDefineConstant("(SELF)", ufoAddrSelf); // used in OOP implementations
7435 ufoDefineConstant("(USER-INTERPRET-NEXT-LINE)", ufoAddrInterNextLine);
7436 ufoDefineConstant("(EXC-FRAME-PTR)", ufoAddrEP);
7438 ufoHiddenWords();
7439 ufoDefineConstant("(LATEST-XFA)", ufoAddrLastXFA);
7440 ufoDefineConstant("(VOC-LINK)", ufoAddrVocLink);
7441 ufoDefineConstant("(NEW-WORD-FLAGS)", ufoAddrNewWordFlags);
7442 ufoDefineConstant("(ADDR-TEMP-BIT)", UFO_ADDR_TEMP_BIT);
7443 ufoDefineConstant("(ADDR-CFA-BIT)", UFO_ADDR_CFA_BIT);
7444 ufoDefineConstant("(ADDR-HANDLE-BIT)", UFO_ADDR_HANDLE_BIT);
7445 ufoDefineConstant("(MAX-HANDLE-OFS)", UFO_ADDR_HANDLE_OFS_MASK);
7447 ufoDefineConstant("(PAD-ADDR)", UFO_PAD_ADDR);
7448 ufoDefineConstant("(#BUF)", UFO_NBUF_ADDR + 4u); // reserve room for counter
7449 ufoDefineConstant("(#BUF-SIZE)", UFO_NBUF_SIZE - 8u);
7451 ufoDefineConstant("(DP)", ufoAddrDP);
7452 ufoDefineConstant("(DP-TEMP)", ufoAddrDPTemp);
7453 ufoPublicWords();
7455 //UFWORDX("(UFO-BUCKET-STATS)", PAR_UFO_BUCKET_STATS);
7456 UFWORDX("SP0!", SP0_STORE);
7457 UFWORDX("RP0!", RP0_STORE);
7459 UFWORDX("PAD", PAD);
7461 UFWORDX("@", PEEK);
7462 UFWORDX("C@", CPEEK);
7463 UFWORDX("W@", WPEEK);
7465 UFWORDX("!", POKE);
7466 UFWORDX("C!", CPOKE);
7467 UFWORDX("W!", WPOKE);
7469 UFWORDX(",", COMMA);
7470 UFWORDX("C,", CCOMMA);
7471 UFWORDX("W,", WCOMMA);
7473 UFWORDX("A>", REGA_LOAD);
7474 UFWORDX(">A", REGA_STORE);
7475 UFWORDX("A-SWAP", REGA_SWAP);
7476 UFWORDX("+1>A", REGA_INC);
7477 UFWORDX("+4>A", REGA_INC_CELL);
7478 UFWORDX("A>R", REGA_TO_R);
7479 UFWORDX("R>A", R_TO_REGA);
7481 UFWORDX("@A+", PEEK_REGA_IDX);
7482 UFWORDX("C@A+", CPEEK_REGA_IDX);
7483 UFWORDX("W@A+", WPEEK_REGA_IDX);
7485 UFWORDX("!A+", POKE_REGA_IDX);
7486 UFWORDX("C!A+", CPOKE_REGA_IDX);
7487 UFWORDX("W!A+", WPOKE_REGA_IDX);
7489 ufoHiddenWords();
7490 UFWORDX("(LIT)", PAR_LIT); ufoSetLatestArgs(UFW_WARG_LIT);
7491 UFWORDX("(LITCFA)", PAR_LITCFA); ufoSetLatestArgs(UFW_WARG_CFA);
7492 UFWORDX("(LITVOCID)", PAR_LITVOCID); ufoSetLatestArgs(UFW_WARG_VOCID);
7493 UFWORDX("(LITSTR8)", PAR_LITSTR8); ufoSetLatestArgs(UFW_WARG_C1STRZ);
7494 UFWORDX("(EXIT)", PAR_EXIT);
7496 ufoLitStr8CFA = ufoFindWordChecked("FORTH:(LITSTR8)");
7498 UFWORDX("(L-ENTER)", PAR_LENTER); ufoSetLatestArgs(UFW_WARG_LIT);
7499 UFWORDX("(L-LEAVE)", PAR_LLEAVE);
7500 UFWORDX("(LOCAL@)", PAR_LOCAL_LOAD);
7501 UFWORDX("(LOCAL!)", PAR_LOCAL_STORE);
7503 UFWORDX("(BRANCH)", PAR_BRANCH); ufoSetLatestArgs(UFW_WARG_BRANCH);
7504 UFWORDX("(TBRANCH)", PAR_TBRANCH); ufoSetLatestArgs(UFW_WARG_BRANCH);
7505 UFWORDX("(0BRANCH)", PAR_0BRANCH); ufoSetLatestArgs(UFW_WARG_BRANCH);
7506 UFWORDX("(+0BRANCH)", PAR_P0BRANCH); ufoSetLatestArgs(UFW_WARG_BRANCH);
7507 UFWORDX("(+BRANCH)", PAR_PBRANCH); ufoSetLatestArgs(UFW_WARG_BRANCH);
7508 UFWORDX("(-0BRANCH)", PAR_M0BRANCH); ufoSetLatestArgs(UFW_WARG_BRANCH);
7509 UFWORDX("(-BRANCH)", PAR_MBRANCH); ufoSetLatestArgs(UFW_WARG_BRANCH);
7510 ufoPublicWords();
7514 //==========================================================================
7516 // ufoInitBasicCompilerWords
7518 //==========================================================================
7519 UFO_DISABLE_INLINE void ufoInitBasicCompilerWords (void) {
7520 // create "COMPILER" vocabulary
7521 ufoCompilerVocId = ufoCreateVoc("COMPILER", 0, UFW_FLAG_PROTECTED);
7522 ufoVocSetOnlyDefs(ufoCompilerVocId);
7524 ufoDefineConstant("(CFAIDX-DO-FORTH)", ufoDoForthCFA);
7525 ufoDefineConstant("(CFAIDX-DO-VAR)", ufoDoVariableCFA);
7526 ufoDefineConstant("(CFAIDX-DO-VALUE)", ufoDoValueCFA);
7527 ufoDefineConstant("(CFAIDX-DO-CONST)", ufoDoConstCFA);
7528 ufoDefineConstant("(CFAIDX-DO-DEFER)", ufoDoDeferCFA);
7529 ufoDefineConstant("(CFAIDX-DO-VOC)", ufoDoVocCFA);
7530 ufoDefineConstant("(CFAIDX-DO-CREATE)", ufoDoCreateCFA);
7531 ufoDefineConstant("(CFAIDX-DO-USER-VAR)", ufoDoUserVariableCFA);
7533 ufoDefineConstant("(WFLAG-IMMEDIATE)", UFW_FLAG_IMMEDIATE);
7534 ufoDefineConstant("(WFLAG-SMUDGE)", UFW_FLAG_SMUDGE);
7535 ufoDefineConstant("(WFLAG-NORETURN)", UFW_FLAG_NORETURN);
7536 ufoDefineConstant("(WFLAG-HIDDEN)", UFW_FLAG_HIDDEN);
7537 ufoDefineConstant("(WFLAG-CBLOCK)", UFW_FLAG_CBLOCK);
7538 ufoDefineConstant("(WFLAG-VOCAB)", UFW_FLAG_VOCAB);
7539 ufoDefineConstant("(WFLAG-SCOLON)", UFW_FLAG_SCOLON);
7540 ufoDefineConstant("(WFLAG-PROTECTED)", UFW_FLAG_PROTECTED);
7542 ufoDefineConstant("(WARG-MASK)", UFW_WARG_MASK);
7543 ufoDefineConstant("(WARG-NONE)", UFW_WARG_NONE);
7544 ufoDefineConstant("(WARG-BRANCH)", UFW_WARG_BRANCH);
7545 ufoDefineConstant("(WARG-LIT)", UFW_WARG_LIT);
7546 ufoDefineConstant("(WARG-C4STRZ)", UFW_WARG_C4STRZ);
7547 ufoDefineConstant("(WARG-CFA)", UFW_WARG_CFA);
7548 ufoDefineConstant("(WARG-CBLOCK)", UFW_WARG_CBLOCK);
7549 ufoDefineConstant("(WARG-VOCID)", UFW_WARG_VOCID);
7550 ufoDefineConstant("(WARG-C1STRZ)", UFW_WARG_C1STRZ);
7552 ufoDefineConstant("(VOCOFS-LATEST)", UFW_VOCAB_OFS_LATEST);
7553 ufoDefineConstant("(VOCOFS-VOCLINK)", UFW_VOCAB_OFS_VOCLINK);
7554 ufoDefineConstant("(VOCOFS-PARENT)", UFW_VOCAB_OFS_PARENT);
7555 ufoDefineConstant("(VOCOFS-HEADER)", UFW_VOCAB_OFS_HEADER);
7556 ufoDefineConstant("(VOCOFS-HTABLE)", UFW_VOCAB_OFS_HTABLE);
7557 ufoDefineConstant("(VOC-HTABLE-SIZE)", UFO_HASHTABLE_SIZE);
7558 ufoDefineConstant("(VOC-HTABLE-NOFLAG)", UFO_NO_HTABLE_FLAG);
7560 ufoDefineConstant("(REDEFINE-WARN-DON'T-CARE)", UFO_REDEF_WARN_DONT_CARE);
7561 ufoDefineConstant("(REDEFINE-WARN-NONE)", UFO_REDEF_WARN_NONE);
7562 ufoDefineConstant("(REDEFINE-WARN-NORMAL)", UFO_REDEF_WARN_NORMAL);
7563 ufoDefineConstant("(REDEFINE-WARN-PARENTS)", UFO_REDEF_WARN_PARENTS);
7565 ufoDefineConstant("WORD-REDEFINE-WARN-MODE", ufoAddrRedefineWarning);
7567 UFWORDX("(UNESCAPE)", PAR_UNESCAPE);
7569 ufoInterpretLine(
7570 ": ?EXEC ( -- ) "
7571 " FORTH:STATE FORTH:@ ` expecting interpretation mode` FORTH:?ERROR "
7572 ";");
7574 ufoInterpretLine(
7575 ": ?COMP ( -- ) "
7576 " FORTH:STATE FORTH:@ ` expecting compilation mode` FORTH:?NOT-ERROR "
7577 ";");
7579 UFWORDX("(CREATE-WORD-HEADER)", PAR_CREATE_WORD_HEADER);
7580 UFWORDX("(CREATE-NAMELESS-WORD-HEADER)", PAR_CREATE_NAMELESS_WORD_HEADER);
7582 ufoVocSetOnlyDefs(ufoForthVocId);
7584 // [
7585 ufoInterpretLine("!: [ COMPILER:?COMP 0 STATE ! ;");
7586 // ]
7587 ufoInterpretLine(": ] COMPILER:?EXEC 1 STATE ! ;");
7591 //==========================================================================
7593 // ufoInitMoreWords
7595 //==========================================================================
7596 UFO_DISABLE_INLINE void ufoInitMoreWords (void) {
7597 UFWORDX("COMPILE,", COMMA); // just an alias, for clarity
7599 UFWORDX("CFA->PFA", CFA2PFA);
7600 UFWORDX("CFA->NFA", CFA2NFA);
7601 UFWORDX("CFA->LFA", CFA2LFA);
7602 UFWORDX("CFA->WEND", CFA2WEND);
7604 UFWORDX("PFA->CFA", PFA2CFA);
7605 UFWORDX("PFA->NFA", PFA2NFA);
7607 UFWORDX("NFA->CFA", NFA2CFA);
7608 UFWORDX("NFA->PFA", NFA2PFA);
7609 UFWORDX("NFA->LFA", NFA2LFA);
7611 UFWORDX("LFA->CFA", LFA2CFA);
7612 UFWORDX("LFA->PFA", LFA2PFA);
7613 UFWORDX("LFA->BFA", LFA2BFA);
7614 UFWORDX("LFA->XFA", LFA2XFA);
7615 UFWORDX("LFA->YFA", LFA2YFA);
7616 UFWORDX("LFA->NFA", LFA2NFA);
7618 UFWORDX("(BASED-NUMBER)", PAR_BASED_NUMBER);
7619 UFWORDX("FIND-WORD", FIND_WORD);
7620 UFWORDX("(FIND-WORD-IN-VOC)", FIND_WORD_IN_VOC);
7621 UFWORDX("(FIND-WORD-IN-VOC-AND-PARENTS)", FIND_WORD_IN_VOC_AND_PARENTS);
7623 UFWORD(EXECUTE);
7624 UFWORDX("EXECUTE-TAIL", EXECUTE_TAIL);
7626 UFWORD(DUP);
7627 UFWORDX("?DUP", QDUP);
7628 UFWORDX("2DUP", DDUP);
7629 UFWORD(DROP);
7630 UFWORDX("2DROP", DDROP);
7631 UFWORD(SWAP);
7632 UFWORDX("2SWAP", DSWAP);
7633 UFWORD(OVER);
7634 UFWORDX("2OVER", DOVER);
7635 UFWORD(ROT);
7636 UFWORD(NROT);
7637 UFWORDX("PICK", PICK);
7638 UFWORDX("ROLL", ROLL);
7640 UFWORD(RDUP);
7641 UFWORD(RDROP);
7642 UFWORDX(">R", DTOR);
7643 UFWORDX("R>", RTOD);
7644 UFWORDX("R@", RPEEK);
7645 UFWORDX("RPICK", RPICK);
7646 UFWORDX("RROLL", RROLL);
7647 UFWORDX("RSWAP", RSWAP);
7648 UFWORDX("ROVER", ROVER);
7649 UFWORDX("RROT", RROT);
7650 UFWORDX("RNROT", RNROT);
7652 UFWORDX("FLUSH-EMIT", FLUSH_EMIT);
7653 UFWORDX("(EMIT)", PAR_EMIT);
7654 UFWORDX("(NORM-EMIT-CHAR)", PAR_NORM_EMIT_CHAR);
7655 UFWORDX("(NORM-XEMIT-CHAR)", PAR_NORM_XEMIT_CHAR);
7656 UFWORDX("LASTCR?", LASTCRQ);
7657 UFWORDX("LASTCR!", LASTCRSET);
7659 // simple math
7660 UFWORDX("+", PLUS);
7661 UFWORDX("-", MINUS);
7662 UFWORDX("*", MUL);
7663 UFWORDX("U*", UMUL);
7664 UFWORDX("/", DIV);
7665 UFWORDX("U/", UDIV);
7666 UFWORDX("MOD", MOD);
7667 UFWORDX("UMOD", UMOD);
7668 UFWORDX("/MOD", DIVMOD);
7669 UFWORDX("U/MOD", UDIVMOD);
7670 UFWORDX("*/", MULDIV);
7671 UFWORDX("U*/", UMULDIV);
7672 UFWORDX("*/MOD", MULDIVMOD);
7673 UFWORDX("U*/MOD", UMULDIVMOD);
7674 UFWORDX("M*", MMUL);
7675 UFWORDX("UM*", UMMUL);
7676 UFWORDX("M/MOD", MDIVMOD);
7677 UFWORDX("UM/MOD", UMDIVMOD);
7678 UFWORDX("UDS*", UDSMUL);
7680 UFWORDX("SM/REM", SMREM);
7681 UFWORDX("FM/MOD", FMMOD);
7683 UFWORDX("D-", DMINUS);
7684 UFWORDX("D+", DPLUS);
7685 UFWORDX("D=", DEQU);
7686 UFWORDX("D<", DLESS);
7687 UFWORDX("D<=", DLESSEQU);
7688 UFWORDX("DU<", DULESS);
7689 UFWORDX("DU<=", DULESSEQU);
7691 UFWORD(ASH);
7692 UFWORD(LSH);
7694 // logic
7695 UFWORDX("<", LESS);
7696 UFWORDX(">", GREAT);
7697 UFWORDX("<=", LESSEQU);
7698 UFWORDX(">=", GREATEQU);
7699 UFWORDX("U<", ULESS);
7700 UFWORDX("U>", UGREAT);
7701 UFWORDX("U<=", ULESSEQU);
7702 UFWORDX("U>=", UGREATEQU);
7703 UFWORDX("=", EQU);
7704 UFWORDX("<>", NOTEQU);
7706 UFWORDX("0=", ZERO_EQU);
7707 UFWORDX("0<>", ZERO_NOTEQU);
7709 UFWORDX("NOT", ZERO_EQU);
7710 UFWORDX("NOTNOT", ZERO_NOTEQU);
7712 UFWORD(BITNOT);
7713 UFWORD(AND);
7714 UFWORD(OR);
7715 UFWORD(XOR);
7716 UFWORDX("LOGAND", LOGAND);
7717 UFWORDX("LOGOR", LOGOR);
7719 // TIB and parser
7720 UFWORDX("(TIB-IN)", TIB_IN);
7721 UFWORDX("TIB-PEEKCH", TIB_PEEKCH);
7722 UFWORDX("TIB-PEEKCH-OFS", TIB_PEEKCH_OFS);
7723 UFWORDX("TIB-GETCH", TIB_GETCH);
7724 UFWORDX("TIB-SKIPCH", TIB_SKIPCH);
7726 UFWORDX("REFILL", REFILL);
7727 UFWORDX("REFILL-NOCROSS", REFILL_NOCROSS);
7729 ufoHiddenWords();
7730 UFWORDX("(PARSE)", PAR_PARSE);
7731 UFWORDX("(PARSE-SKIP-COMMENTS)", PAR_PARSE_SKIP_COMMENTS);
7732 ufoPublicWords();
7733 UFWORDX("PARSE-SKIP-BLANKS", PARSE_SKIP_BLANKS);
7734 UFWORDX("PARSE-NAME", PARSE_NAME);
7735 UFWORDX("PARSE-SKIP-LINE", PARSE_SKIP_LINE);
7736 UFWORDX("PARSE", PARSE);
7738 ufoHiddenWords();
7739 UFWORDX("(VSP@)", PAR_GET_VSP);
7740 UFWORDX("(VSP!)", PAR_SET_VSP);
7741 UFWORDX("(VSP-AT@)", PAR_VSP_LOAD);
7742 UFWORDX("(VSP-AT!)", PAR_VSP_STORE);
7743 ufoDefineConstant("(VSP-SIZE)", UFO_VOCSTACK_SIZE);
7745 ufoDefineConstant("(SP-SIZE)", UFO_DSTACK_SIZE);
7746 ufoDefineConstant("(RP-SIZE)", UFO_RSTACK_SIZE);
7747 ufoDefineConstant("(LP-SIZE)", UFO_LSTACK_SIZE);
7748 ufoPublicWords();
7750 UFWORDX("ERROR", ERROR);
7751 UFWORDX("FATAL-ERROR", ERROR);
7753 ufoInterpretLine(": 1+ ( n -- n+1 ) 1 + ;");
7754 ufoInterpretLine(": 1- ( n -- n-1 ) 1 - ;");
7755 ufoInterpretLine(": 2+ ( n -- n+2 ) 2 + ;");
7756 ufoInterpretLine(": 2- ( n -- n-2 ) 2 - ;");
7757 ufoInterpretLine(": 4+ ( n -- n+4 ) 4 + ;");
7758 ufoInterpretLine(": 4- ( n -- n-4 ) 4 - ;");
7760 ufoInterpretLine(": 2* ( n -- n*2 ) 1 ASH ;");
7761 ufoInterpretLine(": 2/ ( n -- n/2 ) -1 ASH ;");
7762 ufoInterpretLine(": 4* ( n -- n*4 ) 2 ASH ;");
7763 ufoInterpretLine(": 4/ ( n -- n/4 ) -2 ASH ;");
7765 ufoInterpretLine(": 2U* ( u -- u*2 ) 1 LSH ;");
7766 ufoInterpretLine(": 2U/ ( u -- u/2 ) -1 LSH ;");
7767 ufoInterpretLine(": 4U* ( u -- u*4 ) 2 LSH ;");
7768 ufoInterpretLine(": 4U/ ( u -- u/4 ) -2 LSH ;");
7770 ufoInterpretLine(": 0< ( n -- n<0 ) 0 < ;");
7771 ufoInterpretLine(": 0> ( n -- n>0 ) 0 > ;");
7772 ufoInterpretLine(": 0<= ( n -- n<0 ) 0 <= ;");
7773 ufoInterpretLine(": 0>= ( n -- n>0 ) 0 >= ;");
7775 ufoInterpretLine(": @A ( idx -- v ) 0 @A+ ;");
7776 ufoInterpretLine(": C@A ( idx -- v ) 0 C@A+ ;");
7777 ufoInterpretLine(": W@A ( idx -- v ) 0 W@A+ ;");
7779 ufoInterpretLine(": !A ( idx -- v ) 0 !A+ ;");
7780 ufoInterpretLine(": C!A ( idx -- v ) 0 C!A+ ;");
7781 ufoInterpretLine(": W!A ( idx -- v ) 0 W!A+ ;");
7783 // ABORT
7784 // ( -- )
7785 ufoInterpretLine(": ABORT ` \"ABORT\" called` ERROR ;");
7787 // ?ERROR
7788 // ( errflag addr count -- )
7789 ufoInterpretLine(
7790 ": ?ERROR ( errflag addr count -- ) "
7791 " ROT FORTH:(0BRANCH) $qerr_skip ERROR "
7792 "$qerr_skip: "
7793 " 2DROP "
7794 ";");
7796 // ?NOT-ERROR
7797 // ( errflag addr count -- )
7798 ufoInterpretLine(
7799 ": ?NOT-ERROR ( errflag addr count -- ) "
7800 " ROT FORTH:(TBRANCH) $qnoterr_skip ERROR "
7801 "$qnoterr_skip: "
7802 " 2DROP "
7803 ";");
7805 ufoInterpretLine(
7806 ": FIND-WORD-IN-VOC ( vocid addr count -- cfa TRUE / FALSE ) "
7807 " 0 (FIND-WORD-IN-VOC) ;");
7809 ufoInterpretLine(
7810 ": FIND-WORD-IN-VOC-AND-PARENTS ( vocid addr count -- cfa TRUE / FALSE ) "
7811 " 0 (FIND-WORD-IN-VOC-AND-PARENTS) ;");
7813 UFWORDX("GET-MSECS", GET_MSECS);
7817 //==========================================================================
7819 // ufoInitHandleWords
7821 //==========================================================================
7822 UFO_DISABLE_INLINE void ufoInitHandleWords (void) {
7823 // create "HANDLE" vocabulary
7824 const uint32_t handleVocId = ufoCreateVoc("HANDLE", 0, UFW_FLAG_PROTECTED);
7825 ufoVocSetOnlyDefs(handleVocId);
7826 UFWORDX("NEW", PAR_NEW_HANDLE);
7827 UFWORDX("FREE", PAR_FREE_HANDLE);
7828 UFWORDX("TYPEID@", PAR_HANDLE_GET_TYPEID);
7829 UFWORDX("TYPEID!", PAR_HANDLE_SET_TYPEID);
7830 UFWORDX("SIZE@", PAR_HANDLE_GET_SIZE);
7831 UFWORDX("SIZE!", PAR_HANDLE_SET_SIZE);
7832 UFWORDX("USED@", PAR_HANDLE_GET_USED);
7833 UFWORDX("USED!", PAR_HANDLE_SET_USED);
7834 UFWORDX("C@", PAR_HANDLE_LOAD_BYTE);
7835 UFWORDX("W@", PAR_HANDLE_LOAD_WORD);
7836 UFWORDX("@", PAR_HANDLE_LOAD_CELL);
7837 UFWORDX("C!", PAR_HANDLE_STORE_BYTE);
7838 UFWORDX("W!", PAR_HANDLE_STORE_WORD);
7839 UFWORDX("!", PAR_HANDLE_STORE_CELL);
7840 UFWORDX("LOAD-FILE", PAR_HANDLE_LOAD_FILE);
7841 ufoVocSetOnlyDefs(ufoForthVocId);
7845 //==========================================================================
7847 // ufoInitHigherWords
7849 //==========================================================================
7850 UFO_DISABLE_INLINE void ufoInitHigherWords (void) {
7851 UFWORDX("(INCLUDE)", PAR_INCLUDE);
7853 UFWORDX("(INCLUDE-DEPTH)", PAR_INCLUDE_DEPTH);
7854 UFWORDX("(INCLUDE-FILE-ID)", PAR_INCLUDE_FILE_ID);
7855 UFWORDX("(INCLUDE-FILE-LINE)", PAR_INCLUDE_FILE_LINE);
7856 UFWORDX("(INCLUDE-FILE-NAME)", PAR_INCLUDE_FILE_NAME);
7858 UFWORDX("($DEFINED?)", PAR_DLR_DEFINEDQ);
7859 UFWORDX("($DEFINE)", PAR_DLR_DEFINE);
7860 UFWORDX("($UNDEF)", PAR_DLR_UNDEF);
7862 UFWORDX_IMM("$INCLUDE", DLR_INCLUDE_IMM);
7863 UFWORDX_IMM("$INCLUDE-ONCE", DLR_INCLUDE_ONCE_IMM);
7867 //==========================================================================
7869 // ufoInitStringWords
7871 //==========================================================================
7872 UFO_DISABLE_INLINE void ufoInitStringWords (void) {
7873 // create "STRING" vocabulary
7874 const uint32_t stringVocId = ufoCreateVoc("STRING", 0, UFW_FLAG_PROTECTED);
7875 ufoVocSetOnlyDefs(stringVocId);
7876 UFWORDX("=", STREQU);
7877 UFWORDX("=CI", STREQUCI);
7878 UFWORDX("SEARCH", SEARCH);
7879 UFWORDX("HASH", STRHASH);
7880 UFWORDX("HASH-CI", STRHASHCI);
7881 ufoVocSetOnlyDefs(ufoForthVocId);
7885 //==========================================================================
7887 // ufoInitDebugWords
7889 //==========================================================================
7890 UFO_DISABLE_INLINE void ufoInitDebugWords (void) {
7891 // create "DEBUG" vocabulary
7892 const uint32_t debugVocId = ufoCreateVoc("DEBUG", 0, UFW_FLAG_PROTECTED);
7893 ufoVocSetOnlyDefs(debugVocId);
7894 UFWORDX("(DECOMPILE-CFA)", DEBUG_DECOMPILE_CFA);
7895 UFWORDX("(DECOMPILE-MEM)", DEBUG_DECOMPILE_MEM);
7896 UFWORDX("BACKTRACE", UFO_BACKTRACE);
7897 UFWORDX("DUMP-STACK", DUMP_STACK);
7898 UFWORDX("BACKTRACE-TASK", UFO_BACKTRACE_TASK);
7899 UFWORDX("DUMP-STACK-TASK", DUMP_STACK_TASK);
7900 UFWORDX("DUMP-RSTACK-TASK", DUMP_RSTACK_TASK);
7901 UFWORDX("(BP)", MT_DEBUGGER_BP);
7902 UFWORDX("IP->NFA", IP2NFA);
7903 UFWORDX("IP->FILE/LINE", IP2FILELINE);
7904 UFWORDX("IP->FILE-HASH/LINE", IP2FILEHASHLINE);
7905 ufoVocSetOnlyDefs(ufoForthVocId);
7909 //==========================================================================
7911 // ufoInitMTWords
7913 //==========================================================================
7914 UFO_DISABLE_INLINE void ufoInitMTWords (void) {
7915 // create "MTASK" vocabulary
7916 const uint32_t mtVocId = ufoCreateVoc("MTASK", 0, UFW_FLAG_PROTECTED);
7917 ufoVocSetOnlyDefs(mtVocId);
7918 UFWORDX("NEW-STATE", MT_NEW_STATE);
7919 UFWORDX("FREE-STATE", MT_FREE_STATE);
7920 UFWORDX("STATE-NAME@", MT_GET_STATE_NAME);
7921 UFWORDX("STATE-NAME!", MT_SET_STATE_NAME);
7922 UFWORDX("STATE-FIRST", MT_STATE_FIRST);
7923 UFWORDX("STATE-NEXT", MT_STATE_NEXT);
7924 UFWORDX("YIELD-TO", MT_YIELD_TO);
7925 UFWORDX("SET-SELF-AS-DEBUGGER", MT_SET_SELF_AS_DEBUGGER);
7926 UFWORDX("DEBUGGER-RESUME", MT_RESUME_DEBUGEE);
7927 UFWORDX("DEBUGGER-SINGLE-STEP", MT_SINGLE_STEP_DEBUGEE);
7928 UFWORDX("ACTIVE-STATE", MT_ACTIVE_STATE);
7929 UFWORDX("STATE-IP@", MT_STATE_IP_GET);
7930 UFWORDX("STATE-IP!", MT_STATE_IP_SET);
7931 UFWORDX("STATE-A>", MT_STATE_REGA_GET);
7932 UFWORDX("STATE->A", MT_STATE_REGA_SET);
7933 UFWORDX("STATE-USER@", MT_STATE_USER_GET);
7934 UFWORDX("STATE-USER!", MT_STATE_USER_SET);
7935 UFWORDX("STATE-RPOPCFA@", MT_STATE_RPOPCFA_GET);
7936 UFWORDX("STATE-RPOPCFA!", MT_STATE_RPOPCFA_SET);
7937 UFWORDX("YIELDED-FROM", MT_YIELDED_FROM);
7938 UFWORDX("STATE-SP@", MT_DSTACK_DEPTH_GET);
7939 UFWORDX("STATE-RP@", MT_RSTACK_DEPTH_GET);
7940 UFWORDX("STATE-LP@", MT_LP_GET);
7941 UFWORDX("STATE-LBP@", MT_LBP_GET);
7942 UFWORDX("STATE-SP!", MT_DSTACK_DEPTH_SET);
7943 UFWORDX("STATE-RP!", MT_RSTACK_DEPTH_SET);
7944 UFWORDX("STATE-LP!", MT_LP_SET);
7945 UFWORDX("STATE-LBP!", MT_LBP_SET);
7946 UFWORDX("STATE-DS@", MT_DSTACK_LOAD);
7947 UFWORDX("STATE-RS@", MT_RSTACK_LOAD);
7948 UFWORDX("STATE-LS@", MT_LSTACK_LOAD);
7949 UFWORDX("STATE-DS!", MT_DSTACK_STORE);
7950 UFWORDX("STATE-RS!", MT_RSTACK_STORE);
7951 UFWORDX("STATE-LS!", MT_LSTACK_STORE);
7952 ufoVocSetOnlyDefs(ufoForthVocId);
7956 //==========================================================================
7958 // ufoInitTTYWords
7960 //==========================================================================
7961 UFO_DISABLE_INLINE void ufoInitTTYWords (void) {
7962 // create "TTY" vocabulary
7963 const uint32_t ttyVocId = ufoCreateVoc("TTY", 0, UFW_FLAG_PROTECTED);
7964 ufoVocSetOnlyDefs(ttyVocId);
7965 UFWORDX("TTY?", TTY_TTYQ);
7966 UFWORDX("RAW?", TTY_RAWQ);
7967 UFWORDX("SIZE", TTY_SIZE);
7968 UFWORDX("SET-RAW", TTY_SET_RAW);
7969 UFWORDX("SET-COOKED", TTY_SET_COOKED);
7970 UFWORDX("RAW-EMIT", TTY_RAW_EMIT);
7971 UFWORDX("RAW-TYPE", TTY_RAW_TYPE);
7972 UFWORDX("RAW-FLUSH", TTY_RAW_FLUSH);
7973 UFWORDX("RAW-READCH", TTY_RAW_READCH);
7974 UFWORDX("RAW-READY?", TTY_RAW_READYQ);
7975 ufoVocSetOnlyDefs(ufoForthVocId);
7979 //==========================================================================
7981 // ufoInitVeryVeryHighWords
7983 //==========================================================================
7984 UFO_DISABLE_INLINE void ufoInitVeryVeryHighWords (void) {
7985 // interpret defer
7986 //ufoDefineDefer("INTERPRET", idumbCFA);
7988 ufoDefineEmitType();
7990 // ( addr count FALSE -- addr count FALSE / TRUE )
7991 ufoDefineSColonForth("(INTERPRET-CHECK-WORD)");
7992 ufoDoneForth();
7993 // ( addr count FALSE -- addr count FALSE / TRUE )
7994 ufoDefineSColonForth("(INTERPRET-WORD-NOT-FOUND)");
7995 ufoDoneForth();
7996 // ( -- ) -- called in "EXIT", before compiling "FORTH:(EXIT)"
7997 ufoDefineSColonForth("(EXIT-EXTENDER)");
7998 ufoDoneForth();
8000 // EXIT ( -- )
8001 ufoInterpretLine("!: EXIT ( -- ) COMPILER:?COMP (EXIT-EXTENDER) COMPILE FORTH:(EXIT) ;");
8003 ufoDefineInterpret();
8005 //ufoDumpVocab(ufoCompilerVocId);
8007 ufoInterpretLine(
8008 ": RUN-INTERPRET-LOOP "
8009 "$run-interp-loop-again: "
8010 " RP0! INTERPRET (UFO-INTERPRET-FINISHED-ACTION) "
8011 " FORTH:(BRANCH) $run-interp-loop-again "
8012 ";");
8015 #define UFO_ADD_DO_CFA(cfx_) do { \
8016 ufoDo##cfx_##CFA = ufoCFAsUsed | UFO_ADDR_CFA_BIT; \
8017 ufoForthCFAs[ufoCFAsUsed] = &ufoDo##cfx_; \
8018 ufoCFAsUsed += 1; \
8019 } while (0)
8022 //==========================================================================
8024 // ufoInitCommon
8026 //==========================================================================
8027 UFO_DISABLE_INLINE void ufoInitCommon (void) {
8028 ufoVSP = 0;
8029 ufoForthVocId = 0; ufoCompilerVocId = 0;
8031 ufoForthCFAs = calloc(UFO_MAX_NATIVE_CFAS, sizeof(ufoForthCFAs[0]));
8033 // allocate default TIB handle
8034 //UfoHandle *tibh = ufoAllocHandle(0x69a029a6); // arbitrary number
8035 //ufoDefTIB = tibh->ufoHandle;
8037 ufoForthCFAs[0] = NULL; ufoCFAsUsed = 1u;
8038 UFO_ADD_DO_CFA(Forth);
8039 UFO_ADD_DO_CFA(Variable);
8040 UFO_ADD_DO_CFA(Value);
8041 UFO_ADD_DO_CFA(Const);
8042 UFO_ADD_DO_CFA(Defer);
8043 UFO_ADD_DO_CFA(Voc);
8044 UFO_ADD_DO_CFA(Create);
8045 UFO_ADD_DO_CFA(UserVariable);
8047 //fprintf(stderr, "DO-FORTH-CFA: 0x%08x\n", ufoDoForthCFA);
8049 ufoInitBaseDict();
8051 // create "FORTH" vocabulary (it should be the first one)
8052 ufoForthVocId = ufoCreateVoc("FORTH", 0, UFW_FLAG_PROTECTED);
8053 ufoVocSetOnlyDefs(ufoForthVocId);
8055 // base low-level interpreter words
8056 ufoInitBasicWords();
8058 // more FORTH words
8059 ufoInitMoreWords();
8061 // some COMPILER words
8062 ufoInitBasicCompilerWords();
8064 // STRING vocabulary
8065 ufoInitStringWords();
8067 // DEBUG vocabulary
8068 ufoInitDebugWords();
8070 // MTASK vocabulary
8071 ufoInitMTWords();
8073 // HANDLE vocabulary
8074 ufoInitHandleWords();
8076 // TTY vocabulary
8077 ufoInitTTYWords();
8079 // some higher-level FORTH words (includes, etc.)
8080 ufoInitHigherWords();
8082 // very-very high-level FORTH words
8083 ufoInitVeryVeryHighWords();
8085 ufoFinalLabelCheck();
8087 #if 0
8088 ufoDecompileWord(ufoFindWordChecked("RUN-INTERPRET-LOOP"));
8089 #endif
8091 ufoReset();
8094 #undef UFC
8097 // ////////////////////////////////////////////////////////////////////////// //
8098 // virtual machine executor
8102 //==========================================================================
8104 // ufoRunVM
8106 // address interpreter
8108 //==========================================================================
8109 static void ufoRunVMCFA (uint32_t cfa) {
8110 const uint32_t oldRPTop = ufoRPTop;
8111 ufoRPTop = ufoRP;
8112 #ifdef UFO_TRACE_VM_RUN
8113 fprintf(stderr, "**VM-INITIAL**: cfa=%u\n", cfa);
8114 UFCALL(DUMP_STACK);
8115 #endif
8116 ufoRPush(cfa);
8117 ufoVMRPopCFA = 1;
8118 ufoVMStop = 0;
8119 // VM execution loop
8120 do {
8121 if (ufoVMAbort) ufoFatal("user abort");
8122 if (ufoVMStop) { ufoRP = oldRPTop; break; }
8123 if (ufoCurrState == NULL) ufoFatal("execution state is lost");
8124 if (ufoVMRPopCFA == 0) {
8125 // check IP
8126 if (ufoIP == 0) ufoFatal("IP is NULL");
8127 if (ufoIP & UFO_ADDR_HANDLE_BIT) ufoFatal("IP is a handle");
8128 cfa = ufoImgGetU32(ufoIP); ufoIP += 4u;
8129 } else {
8130 cfa = ufoRPop(); ufoVMRPopCFA = 0;
8132 // check CFA sanity
8133 if (cfa == 0) ufoFatal("EXECUTE: NULL CFA");
8134 if (cfa & UFO_ADDR_HANDLE_BIT) ufoFatal("cannot execute handle");
8135 // get next word CFAIDX, and check it
8136 uint32_t cfaidx = ufoImgGetU32(cfa);
8137 if (cfaidx & UFO_ADDR_HANDLE_BIT) ufoFatal("cannot execute CFAIDX-handle");
8138 #ifdef UFO_TRACE_VM_RUN
8139 fprintf(stderr, "**VM**: IP=%u; cfa=%u; cfaidx=0x%08x\n", ufoIP - 4u, cfa, cfaidx);
8140 UFCALL(DUMP_STACK);
8141 ufoDumpWordHeader(UFO_CFA_TO_LFA(cfa));
8142 fprintf(stderr, "######################################\n");
8143 #endif
8144 if (cfaidx & UFO_ADDR_CFA_BIT) {
8145 cfaidx &= UFO_ADDR_CFA_MASK;
8146 if (cfaidx >= ufoCFAsUsed || ufoForthCFAs[cfaidx] == NULL) {
8147 ufoFatal("tried to execute an unknown word: %u (max is %u); IP=%u",
8148 cfaidx, ufoCFAsUsed, ufoIP - 4u);
8150 #ifdef UFO_TRACE_VM_RUN
8151 fprintf(stderr, "**VM-NATIVE**: cfaidx=%u (doForth=%u)\n", cfaidx,
8152 (ufoDoForthCFA & UFO_ADDR_CFA_MASK));
8153 #endif
8154 ufoForthCFAs[cfaidx](UFO_CFA_TO_PFA(cfa));
8155 } else {
8156 // if CFA points somewhere inside a dict, this is "DOES>" word
8157 // IP points to PFA we need to push
8158 // CFA points to Forth word we need to jump to
8159 #ifdef UFO_TRACE_VM_DOER
8160 fprintf(stderr, "*** DOER! IP=%u; cfa=%u; cfaidx=%u ***\n", ufoIP, cfa, cfaidx);
8161 UFCALL(UFO_BACKTRACE);
8162 #endif
8163 ufoPush(UFO_CFA_TO_PFA(cfa)); // push PFA
8164 ufoRPush(ufoIP); // push IP
8165 ufoIP = cfaidx; // fix IP
8167 // that's all we need to activate the debugger
8168 if (ufoSingleStep) {
8169 ufoSingleStep -= 1;
8170 if (ufoSingleStep == 0 && ufoDebuggerState != NULL) {
8171 if (ufoCurrState == ufoDebuggerState) ufoFatal("debugger cannot debug itself");
8172 UfoState *ost = ufoCurrState;
8173 ufoSwitchToState(ufoDebuggerState); // always use API call for this!
8174 ufoPush(-2);
8175 ufoPush(ost->id);
8178 } while (ufoRP != oldRPTop);
8179 //ufoVMStop = 0;
8183 // ////////////////////////////////////////////////////////////////////////// //
8184 // high-level API
8187 //==========================================================================
8189 // ufoRegisterWord
8191 // register new word
8193 //==========================================================================
8194 uint32_t ufoRegisterWord (const char *wname, ufoNativeCFA cfa, uint32_t flags) {
8195 ufo_assert(cfa != NULL);
8196 ufo_assert(wname != NULL && wname[0] != 0);
8197 uint32_t cfaidx = ufoCFAsUsed;
8198 if (cfaidx >= UFO_MAX_NATIVE_CFAS) ufoFatal("too many native words");
8199 ufoForthCFAs[cfaidx] = cfa;
8200 ufoCFAsUsed += 1;
8201 //ufoDefineNative(wname, xcfa, 0);
8202 cfaidx |= UFO_ADDR_CFA_BIT;
8203 flags &= 0xffffff00u;
8204 ufoCreateWordHeader(wname, flags);
8205 const uint32_t res = UFO_GET_DP();
8206 ufoImgEmitU32(cfaidx);
8207 return res;
8211 //==========================================================================
8213 // ufoRegisterDataWord
8215 //==========================================================================
8216 static uint32_t ufoRegisterDataWord (const char *wname, uint32_t cfaidx, uint32_t value,
8217 uint32_t flags)
8219 ufo_assert(wname != NULL && wname[0] != 0);
8220 flags &= 0xffffff00u;
8221 ufoCreateWordHeader(wname, flags);
8222 ufoImgEmitU32(cfaidx);
8223 const uint32_t res = UFO_GET_DP();
8224 ufoImgEmitU32(value);
8225 return res;
8229 //==========================================================================
8231 // ufoRegisterConstant
8233 //==========================================================================
8234 void ufoRegisterConstant (const char *wname, uint32_t value, uint32_t flags) {
8235 (void)ufoRegisterDataWord(wname, ufoDoConstCFA, value, flags);
8239 //==========================================================================
8241 // ufoRegisterVariable
8243 //==========================================================================
8244 uint32_t ufoRegisterVariable (const char *wname, uint32_t value, uint32_t flags) {
8245 return ufoRegisterDataWord(wname, ufoDoVariableCFA, value, flags);
8249 //==========================================================================
8251 // ufoRegisterValue
8253 //==========================================================================
8254 uint32_t ufoRegisterValue (const char *wname, uint32_t value, uint32_t flags) {
8255 return ufoRegisterDataWord(wname, ufoDoValueCFA, value, flags);
8259 //==========================================================================
8261 // ufoRegisterDefer
8263 //==========================================================================
8264 uint32_t ufoRegisterDefer (const char *wname, uint32_t value, uint32_t flags) {
8265 return ufoRegisterDataWord(wname, ufoDoDeferCFA, value, flags);
8269 //==========================================================================
8271 // ufoFindWordInVocabulary
8273 // check if we have the corresponding word.
8274 // return CFA suitable for executing, or 0.
8276 //==========================================================================
8277 uint32_t ufoFindWordInVocabulary (const char *wname, uint32_t vocid) {
8278 if (wname == NULL || wname[0] == 0) return 0;
8279 size_t wlen = strlen(wname);
8280 if (wlen >= UFO_MAX_WORD_LENGTH) return 0;
8281 return ufoFindWordInVocAndParents(wname, (uint32_t)wlen, 0, vocid, 0);
8285 //==========================================================================
8287 // ufoGetIP
8289 //==========================================================================
8290 uint32_t ufoGetIP (void) {
8291 return ufoIP;
8295 //==========================================================================
8297 // ufoSetIP
8299 //==========================================================================
8300 void ufoSetIP (uint32_t newip) {
8301 ufoIP = newip;
8305 //==========================================================================
8307 // ufoIsExecuting
8309 //==========================================================================
8310 int ufoIsExecuting (void) {
8311 return (ufoImgGetU32(ufoAddrSTATE) == 0);
8315 //==========================================================================
8317 // ufoIsCompiling
8319 //==========================================================================
8320 int ufoIsCompiling (void) {
8321 return (ufoImgGetU32(ufoAddrSTATE) != 0);
8325 //==========================================================================
8327 // ufoSetExecuting
8329 //==========================================================================
8330 void ufoSetExecuting (void) {
8331 ufoImgPutU32(ufoAddrSTATE, 0);
8335 //==========================================================================
8337 // ufoSetCompiling
8339 //==========================================================================
8340 void ufoSetCompiling (void) {
8341 ufoImgPutU32(ufoAddrSTATE, 1);
8345 //==========================================================================
8347 // ufoGetHere
8349 //==========================================================================
8350 uint32_t ufoGetHere () {
8351 return UFO_GET_DP();
8355 //==========================================================================
8357 // ufoGetPad
8359 //==========================================================================
8360 uint32_t ufoGetPad () {
8361 UFCALL(PAD);
8362 return ufoPop();
8366 //==========================================================================
8368 // ufoTIBPeekCh
8370 //==========================================================================
8371 uint8_t ufoTIBPeekCh (uint32_t ofs) {
8372 return ufoTibPeekChOfs(ofs);
8376 //==========================================================================
8378 // ufoTIBGetCh
8380 //==========================================================================
8381 uint8_t ufoTIBGetCh (void) {
8382 return ufoTibGetCh();
8386 //==========================================================================
8388 // ufoTIBSkipCh
8390 //==========================================================================
8391 void ufoTIBSkipCh (void) {
8392 ufoTibSkipCh();
8396 //==========================================================================
8398 // ufoTIBSRefill
8400 // returns 0 on EOF
8402 //==========================================================================
8403 int ufoTIBSRefill (int allowCrossIncludes) {
8404 return ufoLoadNextLine(allowCrossIncludes);
8408 //==========================================================================
8410 // ufoPeekData
8412 //==========================================================================
8413 uint32_t ufoPeekData (void) {
8414 return ufoPeek();
8418 //==========================================================================
8420 // ufoPopData
8422 //==========================================================================
8423 uint32_t ufoPopData (void) {
8424 return ufoPop();
8428 //==========================================================================
8430 // ufoPushData
8432 //==========================================================================
8433 void ufoPushData (uint32_t value) {
8434 return ufoPush(value);
8438 //==========================================================================
8440 // ufoPushBoolData
8442 //==========================================================================
8443 void ufoPushBoolData (int val) {
8444 ufoPushBool(val);
8448 //==========================================================================
8450 // ufoPeekRet
8452 //==========================================================================
8453 uint32_t ufoPeekRet (void) {
8454 return ufoRPeek();
8458 //==========================================================================
8460 // ufoPopRet
8462 //==========================================================================
8463 uint32_t ufoPopRet (void) {
8464 return ufoRPop();
8468 //==========================================================================
8470 // ufoPushRet
8472 //==========================================================================
8473 void ufoPushRet (uint32_t value) {
8474 return ufoRPush(value);
8478 //==========================================================================
8480 // ufoPushBoolRet
8482 //==========================================================================
8483 void ufoPushBoolRet (int val) {
8484 ufoRPush(val ? ufoTrueValue : 0);
8488 //==========================================================================
8490 // ufoPeekByte
8492 //==========================================================================
8493 uint8_t ufoPeekByte (uint32_t addr) {
8494 return ufoImgGetU8Ext(addr);
8498 //==========================================================================
8500 // ufoPeekWord
8502 //==========================================================================
8503 uint16_t ufoPeekWord (uint32_t addr) {
8504 ufoPush(addr);
8505 UFCALL(WPEEK);
8506 return ufoPop();
8510 //==========================================================================
8512 // ufoPeekCell
8514 //==========================================================================
8515 uint32_t ufoPeekCell (uint32_t addr) {
8516 ufoPush(addr);
8517 UFCALL(PEEK);
8518 return ufoPop();
8522 //==========================================================================
8524 // ufoPokeByte
8526 //==========================================================================
8527 void ufoPokeByte (uint32_t addr, uint32_t value) {
8528 ufoImgPutU8(addr, value);
8532 //==========================================================================
8534 // ufoPokeWord
8536 //==========================================================================
8537 void ufoPokeWord (uint32_t addr, uint32_t value) {
8538 ufoPush(value);
8539 ufoPush(addr);
8540 UFCALL(WPOKE);
8544 //==========================================================================
8546 // ufoPokeCell
8548 //==========================================================================
8549 void ufoPokeCell (uint32_t addr, uint32_t value) {
8550 ufoPush(value);
8551 ufoPush(addr);
8552 UFCALL(POKE);
8556 //==========================================================================
8558 // ufoEmitByte
8560 //==========================================================================
8561 void ufoEmitByte (uint32_t value) {
8562 ufoImgEmitU8(value);
8566 //==========================================================================
8568 // ufoEmitWord
8570 //==========================================================================
8571 void ufoEmitWord (uint32_t value) {
8572 ufoImgEmitU8(value & 0xff);
8573 ufoImgEmitU8((value >> 8) & 0xff);
8577 //==========================================================================
8579 // ufoEmitCell
8581 //==========================================================================
8582 void ufoEmitCell (uint32_t value) {
8583 ufoImgEmitU32(value);
8587 //==========================================================================
8589 // ufoIsInited
8591 //==========================================================================
8592 int ufoIsInited (void) {
8593 return (ufoMode != UFO_MODE_NONE);
8597 static void (*ufoUserPostInitCB) (void);
8600 //==========================================================================
8602 // ufoSetUserPostInit
8604 // called after main initialisation
8606 //==========================================================================
8607 void ufoSetUserPostInit (void (*cb) (void)) {
8608 ufoUserPostInitCB = cb;
8612 //==========================================================================
8614 // ufoInit
8616 //==========================================================================
8617 void ufoInit (void) {
8618 if (ufoMode != UFO_MODE_NONE) return;
8619 ufoMode = UFO_MODE_NATIVE;
8621 ufoInFileLine = 0;
8622 ufoInFileName = NULL; ufoInFileNameLen = 0; ufoInFileNameHash = 0;
8623 ufoInFile = NULL;
8624 ufoLastIncPath = NULL; ufoLastSysIncPath = NULL;
8626 for (uint32_t f = 0; f < UFO_MAX_STATES; f += 1u) ufoStateMap[f] = NULL;
8627 memset(ufoStateUsedBitmap, 0, sizeof(ufoStateUsedBitmap));
8629 ufoCurrState = ufoNewState();
8630 strcpy(ufoCurrState->name, "MAIN");
8631 ufoInitStateUserVars(ufoCurrState, 0);
8632 ufoImgPutU32(ufoAddrDefTIB, 0); // create TIB handle
8633 ufoImgPutU32(ufoAddrTIBx, 0); // create TIB handle
8635 ufoYieldedState = NULL;
8636 ufoDebuggerState = NULL;
8637 ufoSingleStep = 0;
8639 #ifdef UFO_DEBUG_STARTUP_TIMES
8640 uint32_t stt = ufo_get_msecs();
8641 ufoCondDefine("UFO-DEBUG-STARTUP-TIMES");
8642 #endif
8643 ufoInitCommon();
8644 #ifdef UFO_DEBUG_STARTUP_TIMES
8645 uint32_t ett = ufo_get_msecs();
8646 fprintf(stderr, "UrForth init time: %u msecs\n", (unsigned)(ett - stt));
8647 #endif
8649 ufoReset();
8651 if (ufoUserPostInitCB) {
8652 ufoUserPostInitCB();
8653 ufoReset();
8656 // load ufo modules
8657 char *ufmname = ufoCreateIncludeName("init", 1, NULL);
8658 #ifdef WIN32
8659 FILE *ufl = fopen(ufmname, "rb");
8660 #else
8661 FILE *ufl = fopen(ufmname, "r");
8662 #endif
8663 if (ufl) {
8664 ufoPushInFile();
8665 ufoSetInFileNameReuse(ufmname);
8666 ufoInFile = ufl;
8667 ufoFileId = ufoLastUsedFileId;
8668 setLastIncPath(ufoInFileName, 1);
8669 } else {
8670 free(ufmname);
8671 ufoFatal("cannot load init code");
8674 if (ufoInFile != NULL) {
8675 ufoRunInterpretLoop();
8680 //==========================================================================
8682 // ufoFinishVM
8684 //==========================================================================
8685 void ufoFinishVM (void) {
8686 ufoVMStop = 1;
8690 //==========================================================================
8692 // ufoWasVMFinished
8694 // check if VM was exited due to `ufoFinishVM()`
8696 //==========================================================================
8697 int ufoWasVMFinished (void) {
8698 return (ufoVMStop != 0);
8702 //==========================================================================
8704 // ufoCallParseIntr
8706 // ( -- addr count TRUE / FALSE )
8707 // does base TIB parsing; never copies anything.
8708 // as our reader is line-based, returns FALSE on EOL.
8709 // EOL is detected after skipping leading delimiters.
8710 // passing -1 as delimiter skips the whole line, and always returns FALSE.
8711 // trailing delimiter is always skipped.
8712 // result is on the data stack.
8714 //==========================================================================
8715 void ufoCallParseIntr (uint32_t delim, int skipLeading) {
8716 ufoPush(delim); ufoPushBool(skipLeading);
8717 UFCALL(PAR_PARSE);
8720 //==========================================================================
8722 // ufoCallParseName
8724 // ( -- addr count )
8725 // parse with leading blanks skipping. doesn't copy anything.
8726 // return empty string on EOL.
8728 //==========================================================================
8729 void ufoCallParseName (void) {
8730 UFCALL(PARSE_NAME);
8734 //==========================================================================
8736 // ufoCallParse
8738 // ( -- addr count TRUE / FALSE )
8739 // parse without skipping delimiters; never copies anything.
8740 // as our reader is line-based, returns FALSE on EOL.
8741 // passing 0 as delimiter skips the whole line, and always returns FALSE.
8742 // trailing delimiter is always skipped.
8744 //==========================================================================
8745 void ufoCallParse (uint32_t delim) {
8746 ufoPush(delim);
8747 UFCALL(PARSE);
8751 //==========================================================================
8753 // ufoCallParseSkipBlanks
8755 //==========================================================================
8756 void ufoCallParseSkipBlanks (void) {
8757 UFCALL(PARSE_SKIP_BLANKS);
8761 //==========================================================================
8763 // ufoCallParseSkipComments
8765 //==========================================================================
8766 void ufoCallParseSkipComments (void) {
8767 ufoPushBool(1); UFCALL(PAR_PARSE_SKIP_COMMENTS);
8771 //==========================================================================
8773 // ufoCallParseSkipLineComments
8775 //==========================================================================
8776 void ufoCallParseSkipLineComments (void) {
8777 ufoPushBool(0); UFCALL(PAR_PARSE_SKIP_COMMENTS);
8781 //==========================================================================
8783 // ufoCallParseSkipLine
8785 // to the end of line; doesn't refill
8787 //==========================================================================
8788 void ufoCallParseSkipLine (void) {
8789 UFCALL(PARSE_SKIP_LINE);
8793 //==========================================================================
8795 // ufoCallBasedNumber
8797 // convert number from addrl+1
8798 // returns address of the first inconvertible char
8799 // (BASED-NUMBER) ( addr count allowsign? base -- num TRUE / FALSE )
8801 //==========================================================================
8802 void ufoCallBasedNumber (uint32_t addr, uint32_t count, int allowSign, int base) {
8803 ufoPush(addr); ufoPush(count); ufoPushBool(allowSign);
8804 if (base < 0) ufoPush(0); else ufoPush((uint32_t)base);
8805 UFCALL(PAR_BASED_NUMBER);
8809 //==========================================================================
8811 // ufoRunWord
8813 //==========================================================================
8814 void ufoRunWord (uint32_t cfa) {
8815 if (cfa != 0) {
8816 if (ufoMode == UFO_MODE_NONE) ufoFatal("UrForth is not properly inited");
8817 if (ufoInRunWord) ufoFatal("`ufoRunWord` cannot be called recursively");
8818 ufoMode = UFO_MODE_NATIVE;
8819 ufoInRunWord = 1;
8820 ufoRunVMCFA(cfa);
8821 ufoInRunWord = 0;
8826 //==========================================================================
8828 // ufoRunMacroWord
8830 //==========================================================================
8831 void ufoRunMacroWord (uint32_t cfa) {
8832 if (cfa != 0) {
8833 if (ufoMode == UFO_MODE_NONE) ufoFatal("UrForth is not properly inited");
8834 if (ufoInRunWord) ufoFatal("`ufoRunWord` cannot be called recursively");
8835 ufoMode = UFO_MODE_MACRO;
8836 const uint32_t oisp = ufoFileStackPos;
8837 ufoPushInFile();
8838 ufoFileId = 0;
8839 (void)ufoLoadNextUserLine();
8840 ufoInRunWord = 1;
8841 ufoRunVMCFA(cfa);
8842 ufoInRunWord = 0;
8843 ufoPopInFile();
8844 ufo_assert(ufoFileStackPos == oisp); // sanity check
8849 //==========================================================================
8851 // ufoIsInMacroMode
8853 // check if we are currently in "MACRO" mode.
8854 // should be called from registered words.
8856 //==========================================================================
8857 int ufoIsInMacroMode (void) {
8858 return (ufoMode == UFO_MODE_MACRO);
8862 //==========================================================================
8864 // ufoRunInterpretLoop
8866 // run default interpret loop.
8868 //==========================================================================
8869 void ufoRunInterpretLoop (void) {
8870 if (ufoMode == UFO_MODE_NONE) {
8871 ufoInit();
8873 const uint32_t cfa = ufoFindWord("RUN-INTERPRET-LOOP");
8874 if (cfa == 0) ufoFatal("'RUN-INTERPRET-LOOP' word not found");
8875 ufoReset();
8876 ufoMode = UFO_MODE_NATIVE;
8877 ufoInRunWord = 1;
8878 ufoRunVMCFA(cfa);
8879 ufoInRunWord = 0;
8880 while (ufoFileStackPos != 0) ufoPopInFile();
8884 //==========================================================================
8886 // ufoRunFile
8888 //==========================================================================
8889 void ufoRunFile (const char *fname) {
8890 if (ufoMode == UFO_MODE_NONE) {
8891 ufoInit();
8893 if (ufoInRunWord) ufoFatal("`ufoRunFile` cannot be called recursively");
8894 ufoMode = UFO_MODE_NATIVE;
8896 ufoReset();
8897 char *ufmname = ufoCreateIncludeName(fname, 0, ".");
8898 #ifdef WIN32
8899 FILE *ufl = fopen(ufmname, "rb");
8900 #else
8901 FILE *ufl = fopen(ufmname, "r");
8902 #endif
8903 if (ufl) {
8904 ufoPushInFile();
8905 ufoSetInFileNameReuse(ufmname);
8906 ufoInFile = ufl;
8907 ufoFileId = ufoLastUsedFileId;
8908 setLastIncPath(ufoInFileName, 0);
8909 } else {
8910 free(ufmname);
8911 ufoFatal("cannot load source file '%s'", fname);
8913 ufoRunInterpretLoop();