1 // and now for something completely different...
2 // UrAsm built-in Forth Engine!
16 #include <sys/types.h>
21 # define realpath(shit,fuck) _fullpath(fuck, shit, 32768)
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
43 # define UFO_FORCE_INLINE static inline __attribute__((always_inline))
45 # define UFO_FORCE_INLINE static __attribute__((noinline)) /*__attribute__((unused))*/
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
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
) {
67 if (*t
== '/' || *t
== '\\') fname
= t
+1;
69 if (*t
== '/') fname
= t
+1;
73 fprintf(stderr
, "\n%s:%d: Assertion in `%s` failed: %s\n", fname
, fline
, func
, cond
);
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 //==========================================================================
89 //==========================================================================
90 static char *ufoRealPath (const char *fname
) {
92 if (fname
!= NULL
&& fname
[0] != 0) {
93 res
= realpath(fname
, NULL
);
95 const size_t slen
= strlen(res
);
97 strcpy(ufoRealPathBuf
, res
);
113 static time_t secstart
= 0;
118 //==========================================================================
122 //==========================================================================
123 static uint64_t ufo_get_msecs (void) {
125 return GetTickCount();
128 #ifdef CLOCK_MONOTONIC
129 ufo_assert(clock_gettime(CLOCK_MONOTONIC
, &ts
) == 0);
131 // this should be available everywhere
132 ufo_assert(clock_gettime(CLOCK_REALTIME
, &ts
) == 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;
141 //return (uint64_t)(ts.tv_sec-secstart+2)*1000000000U+(uint32_t)ts.tv_nsec;
146 //==========================================================================
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
;
155 hash
+= (*s
++)|orbyte
;
167 // this converts ASCII capitals to locase (and destroys other, but who cares)
168 #define joaatHashBufCI(buf_,len_) joaatHashBuf((buf_), (len_), 0x20)
171 //==========================================================================
175 //==========================================================================
176 UFO_FORCE_INLINE
char toUpper (char ch
) {
177 return (ch
>= 'a' && ch
<= 'z' ? ch
-'a'+'A' : ch
);
181 //==========================================================================
185 //==========================================================================
186 UFO_FORCE_INLINE
uint8_t toUpperU8 (uint8_t ch
) {
187 return (ch
>= 'a' && ch
<= 'z' ? ch
-'a'+'A' : ch
);
191 //==========================================================================
195 //==========================================================================
196 UFO_FORCE_INLINE
int digitInBase (char ch
, int base
) {
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
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
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
229 ;; dd cfaidx ; our internal CFA index, or image address for DOES>
233 ;; first word cell contains combined name length (low byte), argtype and flags (other bytes)
238 ;; i.e. we have 16 bits for flags, and 256 possible argument types. why not.
247 ;; bit 6: *UNUSED* main scattered colon word (with "...")
250 ;; argtype is the type of the argument that this word reads from the threaded code.
251 ;; possible argument types:
254 ;; 2: cell-size numeric literal
255 ;; 3: cell-counted string with terminating zero (not counted)
256 ;; 4: cfa of another word
259 ;; 7: byte-counted string with terminating zero (not counted)
260 ;; 8: data skip: the arg is amout of bytes to skip (not including the counter itself)
263 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
264 ;; wordlist structure (at PFA)
265 ;; -4: wordlist type id (used by structs, for example)
267 ;; dd voclink (voclink always points here)
268 ;; dd parent (if not zero, all parent words are visible)
269 ;; dd header-nfa (can be 0 for anonymous wordlists)
270 ;; hashtable (if enabled), or ~0U if no hash table
274 // ////////////////////////////////////////////////////////////////////////// //
275 #define UFO_BFA_TO_LFA(bfa_) ((bfa_) + 1u * 4u)
276 #define UFO_LFA_TO_XFA(lfa_) ((lfa_) - 3u * 4u)
277 #define UFO_LFA_TO_YFA(lfa_) ((lfa_) - 2u * 4u)
278 #define UFO_LFA_TO_BFA(lfa_) ((lfa_) - 1u * 4u)
279 #define UFO_LFA_TO_NFA(lfa_) ((lfa_) + 2u * 4u)
280 #define UFO_LFA_TO_CFA(lfa_) UFO_ALIGN4((lfa_) + 3u * 4u + 1u + ufoImgGetU8((lfa_) + 2u * 4u))
281 #define UFO_LFA_TO_NHASH(lfa_) ((lfa_) + 1u * 4u)
282 #define UFO_CFA_TO_NFA(cfa_) ((cfa_) - 1u - 4u - ufoImgGetU8((cfa_) - 1u))
283 #define UFO_CFA_TO_LFA(cfa_) ((cfa_) - 1u - 4u * 3u - ufoImgGetU8((cfa_) - 1u))
284 #define UFO_CFA_TO_PFA(cfa_) ((cfa_) + 1u * 4u)
285 #define UFO_PFA_TO_CFA(pfa_) ((pfa_) - 1u * 4u)
286 #define UFO_NFA_TO_CFA(nfa_) UFO_ALIGN4((nfa_) + 4u + 1u + ufoImgGetU8((nfa_)))
287 #define UFO_NFA_TO_LFA(nfa_) ((nfa_) - 2u * 4u)
288 #define UFO_XFA_TO_YFA(xfa_) ((xfa_) + 4u)
289 #define UFO_YFA_TO_XFA(yfa_) ((xfa_) - 4u)
290 #define UFO_XFA_TO_WST(xfa_) ((xfa_) - 4u)
291 #define UFO_YFA_TO_WST(yfa_) ((yfa_) - 2u * 4u)
292 #define UFO_YFA_TO_NFA(yfa_) ((yfa_) + 4u * 4u)
295 // ////////////////////////////////////////////////////////////////////////// //
296 #define UFW_VOCAB_OFS_LATEST (0u * 4u)
297 #define UFW_VOCAB_OFS_VOCLINK (1u * 4u)
298 #define UFW_VOCAB_OFS_PARENT (2u * 4u)
299 #define UFW_VOCAB_OFS_HEADER (3u * 4u)
300 #define UFW_VOCAB_OFS_HTABLE (4u * 4u)
302 #define UFO_HASHTABLE_SIZE (256)
304 #define UFO_NO_HTABLE_FLAG (~(uint32_t)0)
306 #define UFO_MAX_NATIVE_CFAS (1024u)
307 static ufoNativeCFA
*ufoForthCFAs
= NULL
;
308 static uint32_t ufoCFAsUsed
= 0;
310 static uint32_t ufoDoForthCFA
;
311 static uint32_t ufoDoVariableCFA
;
312 static uint32_t ufoDoValueCFA
;
313 static uint32_t ufoDoConstCFA
;
314 static uint32_t ufoDoDeferCFA
;
315 static uint32_t ufoDoVocCFA
;
316 static uint32_t ufoDoCreateCFA
;
317 static uint32_t ufoDoUserVariableCFA
;
319 static uint32_t ufoLitStr8CFA
;
321 // special address types:
322 #define UFO_ADDR_CFA_BIT ((uint32_t)1<<31)
323 #define UFO_ADDR_CFA_MASK (UFO_ADDR_CFA_BIT-1u)
325 // handles are somewhat special: first 12 bits can be used as offset for "@", and are ignored
326 #define UFO_ADDR_HANDLE_BIT ((uint32_t)1<<30)
327 #define UFO_ADDR_HANDLE_MASK ((UFO_ADDR_HANDLE_BIT-1u)&~((uint32_t)0xfff))
328 #define UFO_ADDR_HANDLE_SHIFT (12)
329 #define UFO_ADDR_HANDLE_OFS_MASK ((uint32_t)((1 << UFO_ADDR_HANDLE_SHIFT) - 1))
331 // temporary area is 1MB buffer out of the main image
332 #define UFO_ADDR_TEMP_BIT ((uint32_t)1<<29)
333 #define UFO_ADDR_TEMP_MASK (UFO_ADDR_TEMP_BIT-1u)
335 #define UFO_ADDR_SPECIAL_BITS_MASK (UFO_ADDR_CFA_BIT|UFO_ADDR_HANDLE_BIT|UFO_ADDR_TEMP_BIT)
338 static uint32_t *ufoImage
= NULL
;
339 static uint32_t ufoImageSize
= 0;
341 static uint8_t *ufoDebugImage
= NULL
;
342 static uint32_t ufoDebugImageUsed
= 0; // in bytes
343 static uint32_t ufoDebugImageSize
= 0; // in bytes
344 static uint32_t ufoDebugFileNameHash
= 0; // current file name hash
345 static uint32_t ufoDebugFileNameLen
= 0; // current file name length
346 static uint32_t ufoDebugLastLine
= 0;
347 static uint32_t ufoDebugLastLinePCOfs
= 0;
348 static uint32_t ufoDebugLastLineDP
= 0;
349 static uint32_t ufoDebugCurrDP
= 0;
351 static uint32_t ufoInRunWord
= 0;
353 static volatile int ufoVMAbort
= 0;
354 static volatile int ufoVMStop
= 0;
356 #define ufoTrueValue (~(uint32_t)0)
360 UFO_MODE_NATIVE
= 0, // executing forth code
361 UFO_MODE_MACRO
= 1, // executing forth asm macro
363 static uint32_t ufoMode
= UFO_MODE_NONE
;
365 #define UFO_DSTACK_SIZE (8192)
366 #define UFO_RSTACK_SIZE (4096)
367 #define UFO_LSTACK_SIZE (4096)
368 #define UFO_MAX_TASK_NAME (127)
369 #define UFO_VOCSTACK_SIZE (16u)
371 // to support multitasking (required for the debugger),
372 // our virtual machine state is encapsulated in a struct.
373 typedef struct UfoState_t
{
375 uint32_t dStack
[UFO_DSTACK_SIZE
];
376 uint32_t rStack
[UFO_RSTACK_SIZE
];
377 uint32_t lStack
[UFO_LSTACK_SIZE
];
378 uint32_t IP
; // in image
379 uint32_t SP
; // points AFTER the last value pushed
380 uint32_t RP
; // points AFTER the last value pushed
381 uint32_t RPTop
; // stop when RP is this
389 uint32_t vocStack
[UFO_VOCSTACK_SIZE
]; // cfas
393 uint32_t imageTempSize
;
394 // linked list of all allocated states (tasks)
395 char name
[UFO_MAX_TASK_NAME
+ 1];
399 #define UFO_MAX_STATES (8192)
401 // this is indexed by id
402 static UfoState
*ufoStateMap
[UFO_MAX_STATES
] = {NULL
};
403 static uint32_t ufoStateUsedBitmap
[UFO_MAX_STATES
/32] = {0};
405 // currently active execution state
406 static UfoState
*ufoCurrState
= NULL
;
407 // state we're yielded from
408 static UfoState
*ufoYieldedState
= NULL
;
409 // if debug state is not NULL, VM will switch to it
410 // after executing one instruction from the current state.
411 // it will store current state in `ufoDebugeeState`.
412 static UfoState
*ufoDebuggerState
= NULL
;
413 static uint32_t ufoSingleStep
= 0;
415 #define ufoDStack (ufoCurrState->dStack)
416 #define ufoRStack (ufoCurrState->rStack)
417 #define ufoLStack (ufoCurrState->lStack)
418 #define ufoIP (ufoCurrState->IP)
419 #define ufoSP (ufoCurrState->SP)
420 #define ufoRP (ufoCurrState->RP)
421 #define ufoRPTop (ufoCurrState->RPTop)
422 #define ufoLP (ufoCurrState->LP)
423 #define ufoLBP (ufoCurrState->LBP)
424 #define ufoRegA (ufoCurrState->regA)
425 #define ufoImageTemp (ufoCurrState->imageTemp)
426 #define ufoImageTempSize (ufoCurrState->imageTempSize)
427 #define ufoVMRPopCFA (ufoCurrState->vmRPopCFA)
428 #define ufoVocStack (ufoCurrState->vocStack)
429 #define ufoVSP (ufoCurrState->VSP)
431 // 256 bytes for user variables
432 #define UFO_USER_AREA_ADDR UFO_ADDR_TEMP_BIT
433 #define UFO_USER_AREA_SIZE (256u)
434 #define UFO_NBUF_ADDR UFO_USER_AREA_ADDR + UFO_USER_AREA_SIZE
435 #define UFO_NBUF_SIZE (256u)
436 #define UFO_PAD_ADDR (UFO_NBUF_ADDR + UFO_NBUF_SIZE)
437 #define UFO_DEF_TIB_ADDR (UFO_PAD_ADDR + 2048u)
439 // dynamically allocated text input buffer
440 // always ends with zero (this is word name too)
441 static const uint32_t ufoAddrTIBx
= UFO_ADDR_TEMP_BIT
+ 0u * 4u; // TIB
442 static const uint32_t ufoAddrINx
= UFO_ADDR_TEMP_BIT
+ 1u * 4u; // >IN
443 static const uint32_t ufoAddrDefTIB
= UFO_ADDR_TEMP_BIT
+ 2u * 4u; // default TIB (handle); user cannot change it
444 static const uint32_t ufoAddrBASE
= UFO_ADDR_TEMP_BIT
+ 3u * 4u;
445 static const uint32_t ufoAddrSTATE
= UFO_ADDR_TEMP_BIT
+ 4u * 4u;
446 static const uint32_t ufoAddrContext
= UFO_ADDR_TEMP_BIT
+ 5u * 4u; // CONTEXT
447 static const uint32_t ufoAddrCurrent
= UFO_ADDR_TEMP_BIT
+ 6u * 4u; // CURRENT (definitions will go there)
448 static const uint32_t ufoAddrSelf
= UFO_ADDR_TEMP_BIT
+ 7u * 4u; // CURRENT (definitions will go there)
449 static const uint32_t ufoAddrInterNextLine
= UFO_ADDR_TEMP_BIT
+ 8u * 4u; // (INTERPRET-NEXT-LINE)
450 static const uint32_t ufoAddrEP
= UFO_ADDR_TEMP_BIT
+ 9u * 4u; // (EP) -- exception frame pointer
451 static const uint32_t ufoAddrUserVarUsed
= UFO_ADDR_TEMP_BIT
+ 10u * 4u;
453 static uint32_t ufoAddrVocLink
;
454 static uint32_t ufoAddrDP
;
455 static uint32_t ufoAddrDPTemp
;
456 static uint32_t ufoAddrNewWordFlags
;
457 static uint32_t ufoAddrRedefineWarning
;
458 static uint32_t ufoAddrLastXFA
;
460 static uint32_t ufoForthVocId
;
461 static uint32_t ufoCompilerVocId
;
462 static uint32_t ufoInterpNextLineCFA
;
464 // allows to redefine even protected words
465 #define UFO_REDEF_WARN_DONT_CARE (~(uint32_t)0)
466 // do not warn about ordinary words, allow others
467 #define UFO_REDEF_WARN_NONE (0)
468 // do warn (or fail on protected)
469 #define UFO_REDEF_WARN_NORMAL (1)
470 // do warn (or fail on protected) for parent dicts too
471 #define UFO_REDEF_WARN_PARENTS (2)
473 #define UFO_GET_DP() (ufoImgGetU32(ufoAddrDPTemp) ?: ufoImgGetU32(ufoAddrDP))
474 //#define UFO_SET_DP(val_) ufoImgPutU32(ufoAddrDP, (val_))
476 #define UFO_MAX_NESTED_INCLUDES (32)
483 uint32_t id
; // non-zero unique id
486 static UFOFileStackEntry ufoFileStack
[UFO_MAX_NESTED_INCLUDES
];
487 static uint32_t ufoFileStackPos
; // after the last used item
489 static FILE *ufoInFile
= NULL
;
490 static uint32_t ufoInFileNameLen
= 0;
491 static uint32_t ufoInFileNameHash
= 0;
492 static char *ufoInFileName
= NULL
;
493 static char *ufoLastIncPath
= NULL
;
494 static char *ufoLastSysIncPath
= NULL
;
495 static int ufoInFileLine
= 0;
496 static uint32_t ufoFileId
= 0;
497 static uint32_t ufoLastUsedFileId
= 0;
498 static int ufoLastEmitWasCR
= 1;
500 // dynamic memory handles
501 typedef struct UHandleInfo_t
{
508 struct UHandleInfo_t
*next
;
511 static UfoHandle
*ufoHandleFreeList
= NULL
;
512 static UfoHandle
**ufoHandles
= NULL
;
513 static uint32_t ufoHandlesUsed
= 0;
514 static uint32_t ufoHandlesAlloted
= 0;
516 #define UFO_HANDLE_FREE (~(uint32_t)0)
518 static char ufoCurrFileLine
[520];
521 static uint32_t ufoInBacktrace
= 0;
524 // ////////////////////////////////////////////////////////////////////////// //
525 static void ufoClearCondDefines (void);
527 static void ufoRunVMCFA (uint32_t cfa
);
529 static void ufoBacktrace (uint32_t ip
, int showDataStack
);
531 static void ufoClearCondDefines (void);
533 static UfoState
*ufoNewState (void);
534 static void ufoInitStateUserVars (UfoState
*st
, uint32_t cfa
);
535 static void ufoFreeState (UfoState
*st
);
536 static UfoState
*ufoFindState (uint32_t stid
);
537 static void ufoSwitchToState (UfoState
*newst
);
539 __attribute__((unused
)) static void ufoDumpWordHeader (const uint32_t lfa
);
542 static void ufoDisableRaw (void);
543 static void ufoTTYRawFlush (void);
545 static int ufoIsGoodTTY (void);
547 #ifdef UFO_DEBUG_DEBUG
548 static void ufoDumpDebugImage (void);
552 // ////////////////////////////////////////////////////////////////////////// //
553 #define UFWORD(name_) \
554 static void ufoWord_##name_ (uint32_t mypfa)
556 #define UFCALL(name_) ufoWord_##name_(0)
557 #define UFCFA(name_) (&ufoWord_##name_)
560 UFWORD(CPEEK_REGA_IDX
);
561 UFWORD(CPOKE_REGA_IDX
);
564 UFWORD(PAR_HANDLE_LOAD_BYTE
);
565 UFWORD(PAR_HANDLE_LOAD_WORD
);
566 UFWORD(PAR_HANDLE_LOAD_CELL
);
567 UFWORD(PAR_HANDLE_STORE_BYTE
);
568 UFWORD(PAR_HANDLE_STORE_WORD
);
569 UFWORD(PAR_HANDLE_STORE_CELL
);
572 //==========================================================================
576 //==========================================================================
577 static void ufoFlushOutput (void) {
585 //==========================================================================
589 // if `reuse` is not 0, reuse/free `fname`
591 //==========================================================================
592 static void ufoSetInFileNameEx (const char *fname
, int reuse
) {
593 ufo_assert(fname
== NULL
|| (fname
!= ufoInFileName
));
594 if (fname
== NULL
|| fname
[0] == 0) {
595 if (ufoInFileName
) { free(ufoInFileName
); ufoInFileName
= NULL
; }
596 ufoInFileNameLen
= 0;
597 ufoInFileNameHash
= 0;
598 if (reuse
&& fname
!= NULL
) free((void *)fname
);
600 const uint32_t fnlen
= (uint32_t)strlen(fname
);
601 const uint32_t fnhash
= joaatHashBuf(fname
, fnlen
, 0);
602 if (ufoInFileNameLen
!= fnlen
|| ufoInFileNameHash
!= fnhash
) {
603 if (ufoInFileName
) { free(ufoInFileName
); ufoInFileName
= NULL
; }
605 ufoInFileName
= (char *)fname
;
607 ufoInFileName
= strdup(fname
);
608 if (ufoInFileName
== NULL
) ufoFatal("out of memory for filename info");
610 ufoInFileNameLen
= fnlen
;
611 ufoInFileNameHash
= fnhash
;
613 if (reuse
&& fname
!= NULL
) free((void *)fname
);
619 //==========================================================================
623 //==========================================================================
624 UFO_FORCE_INLINE
void ufoSetInFileName (const char *fname
) {
625 ufoSetInFileNameEx(fname
, 0);
629 //==========================================================================
631 // ufoSetInFileNameReuse
633 //==========================================================================
634 UFO_FORCE_INLINE
void ufoSetInFileNameReuse (const char *fname
) {
635 ufoSetInFileNameEx(fname
, 1);
639 //==========================================================================
643 //==========================================================================
644 void ufoSetUserAbort (void) {
649 //==========================================================================
653 //==========================================================================
654 static UfoHandle
*ufoAllocHandle (uint32_t typeid) {
655 ufo_assert(typeid != UFO_HANDLE_FREE
);
656 UfoHandle
*newh
= ufoHandleFreeList
;
658 if (ufoHandlesUsed
== ufoHandlesAlloted
) {
659 uint32_t newsz
= ufoHandlesAlloted
+ 16384;
660 // due to offsets, this is the maximum number of handles we can have
661 if (newsz
> 0x1ffffU
) {
662 if (ufoHandlesAlloted
> 0x1ffffU
) ufoFatal("too many dynamic handles");
663 newsz
= 0x1ffffU
+ 1U;
664 ufo_assert(newsz
> ufoHandlesAlloted
);
666 UfoHandle
**nh
= realloc(ufoHandles
, sizeof(ufoHandles
[0]) * newsz
);
667 if (nh
== NULL
) ufoFatal("out of memory for handle table");
669 ufoHandlesAlloted
= newsz
;
671 newh
= calloc(1, sizeof(UfoHandle
));
672 if (newh
== NULL
) ufoFatal("out of memory for handle info");
673 ufoHandles
[ufoHandlesUsed
] = newh
;
674 // setup new handle info
675 newh
->ufoHandle
= (ufoHandlesUsed
<< UFO_ADDR_HANDLE_SHIFT
) | UFO_ADDR_HANDLE_BIT
;
678 ufo_assert(newh
->typeid == UFO_HANDLE_FREE
);
679 ufoHandleFreeList
= newh
->next
;
681 // setup new handle info
682 newh
->typeid = typeid;
691 //==========================================================================
695 //==========================================================================
696 static void ufoFreeHandle (UfoHandle
*hh
) {
698 ufo_assert(hh
->typeid != UFO_HANDLE_FREE
);
699 if (hh
->data
) free(hh
->data
);
700 hh
->typeid = UFO_HANDLE_FREE
;
704 hh
->next
= ufoHandleFreeList
;
705 ufoHandleFreeList
= hh
;
710 //==========================================================================
714 //==========================================================================
715 static UfoHandle
*ufoGetHandle (uint32_t hh
) {
717 if (hh
!= 0 && (hh
& UFO_ADDR_HANDLE_BIT
) != 0) {
718 hh
= (hh
& UFO_ADDR_HANDLE_MASK
) >> UFO_ADDR_HANDLE_SHIFT
;
719 if (hh
< ufoHandlesUsed
) {
720 res
= ufoHandles
[hh
];
721 if (res
->typeid == UFO_HANDLE_FREE
) res
= NULL
;
732 //==========================================================================
736 //==========================================================================
737 static void setLastIncPath (const char *fname
, int system
) {
738 if (fname
== NULL
|| fname
[0] == 0) {
740 if (ufoLastSysIncPath
) free(ufoLastIncPath
);
741 ufoLastSysIncPath
= NULL
;
743 if (ufoLastIncPath
) free(ufoLastIncPath
);
744 ufoLastIncPath
= strdup(".");
750 if (ufoLastSysIncPath
) free(ufoLastSysIncPath
);
751 ufoLastSysIncPath
= strdup(fname
);
752 lslash
= ufoLastSysIncPath
;
753 cpos
= ufoLastSysIncPath
;
755 if (ufoLastIncPath
) free(ufoLastIncPath
);
756 ufoLastIncPath
= strdup(fname
);
757 lslash
= ufoLastIncPath
;
758 cpos
= ufoLastIncPath
;
762 if (*cpos
== '/' || *cpos
== '\\') lslash
= cpos
;
764 if (*cpos
== '/') lslash
= cpos
;
773 //==========================================================================
775 // ufoClearIncludePath
777 // required for UrAsm
779 //==========================================================================
780 void ufoClearIncludePath (void) {
781 if (ufoLastIncPath
!= NULL
) {
782 free(ufoLastIncPath
);
783 ufoLastIncPath
= NULL
;
785 if (ufoLastSysIncPath
!= NULL
) {
786 free(ufoLastSysIncPath
);
787 ufoLastSysIncPath
= NULL
;
792 //==========================================================================
796 //==========================================================================
797 static void ufoErrorPrintFile (FILE *fo
, const char *errwarn
) {
798 if (ufoInFileName
!= NULL
) {
799 fprintf(fo
, "UFO %s at file %s, line %d: ", errwarn
, ufoInFileName
, ufoInFileLine
);
801 fprintf(fo
, "UFO %s somewhere in time: ", errwarn
);
806 //==========================================================================
810 //==========================================================================
811 static void ufoErrorMsgV (const char *errwarn
, const char *fmt
, va_list ap
) {
813 if (!ufoLastEmitWasCR
) { printf("\n"); ufoLastEmitWasCR
= 1; }
814 ufoErrorPrintFile(stderr
, errwarn
);
815 vfprintf(stderr
, fmt
, ap
);
822 //==========================================================================
826 //==========================================================================
827 __attribute__((format(printf
, 1, 2)))
828 void ufoWarning (const char *fmt
, ...) {
831 ufoErrorMsgV("WARNING", fmt
, ap
);
835 //==========================================================================
839 //==========================================================================
840 __attribute__((noreturn
)) __attribute__((format(printf
, 1, 2)))
841 void ufoFatal (const char *fmt
, ...) {
847 ufoErrorMsgV("ERROR", fmt
, ap
);
848 if (!ufoInBacktrace
) {
850 ufoBacktrace(ufoIP
, 1);
853 fprintf(stderr
, "DOUBLE FATAL: error in backtrace!\n");
856 #ifdef UFO_DEBUG_FATAL_ABORT
863 // ////////////////////////////////////////////////////////////////////////// //
864 // working with the stacks
865 UFO_FORCE_INLINE
void ufoPush (uint32_t v
) { if (ufoSP
>= UFO_DSTACK_SIZE
) ufoFatal("data stack overflow"); ufoDStack
[ufoSP
++] = v
; }
866 UFO_FORCE_INLINE
void ufoDrop (void) { if (ufoSP
== 0) ufoFatal("data stack underflow"); --ufoSP
; }
867 UFO_FORCE_INLINE
uint32_t ufoPop (void) { if (ufoSP
== 0) { ufoFatal("data stack underflow"); } return ufoDStack
[--ufoSP
]; }
868 UFO_FORCE_INLINE
uint32_t ufoPeek (void) { if (ufoSP
== 0) ufoFatal("data stack underflow"); return ufoDStack
[ufoSP
-1u]; }
869 UFO_FORCE_INLINE
void ufoDup (void) { if (ufoSP
== 0) ufoFatal("data stack underflow"); ufoPush(ufoDStack
[ufoSP
-1u]); }
870 UFO_FORCE_INLINE
void ufoOver (void) { if (ufoSP
< 2u) ufoFatal("data stack underflow"); ufoPush(ufoDStack
[ufoSP
-2u]); }
871 UFO_FORCE_INLINE
void ufoSwap (void) { if (ufoSP
< 2u) ufoFatal("data stack underflow"); const uint32_t t
= ufoDStack
[ufoSP
-1u]; ufoDStack
[ufoSP
-1u] = ufoDStack
[ufoSP
-2u]; ufoDStack
[ufoSP
-2u] = t
; }
872 UFO_FORCE_INLINE
void ufoRot (void) { if (ufoSP
< 3u) ufoFatal("data stack underflow"); const uint32_t t
= ufoDStack
[ufoSP
-3u]; ufoDStack
[ufoSP
-3u] = ufoDStack
[ufoSP
-2u]; ufoDStack
[ufoSP
-2u] = ufoDStack
[ufoSP
-1u]; ufoDStack
[ufoSP
-1u] = t
; }
873 UFO_FORCE_INLINE
void ufoNRot (void) { if (ufoSP
< 3u) ufoFatal("data stack underflow"); const uint32_t t
= ufoDStack
[ufoSP
-1u]; ufoDStack
[ufoSP
-1u] = ufoDStack
[ufoSP
-2u]; ufoDStack
[ufoSP
-2u] = ufoDStack
[ufoSP
-3u]; ufoDStack
[ufoSP
-3u] = t
; }
875 UFO_FORCE_INLINE
void ufo2Dup (void) { ufoOver(); ufoOver(); }
876 UFO_FORCE_INLINE
void ufo2Drop (void) { ufoDrop(); ufoDrop(); }
877 UFO_FORCE_INLINE
void ufo2Over (void) { if (ufoSP
< 4u) ufoFatal("data stack underflow"); const uint32_t n0
= ufoDStack
[ufoSP
-4u]; const uint32_t n1
= ufoDStack
[ufoSP
-3u]; ufoPush(n0
); ufoPush(n1
); }
878 UFO_FORCE_INLINE
void ufo2Swap (void) { if (ufoSP
< 4u) ufoFatal("data stack underflow"); const uint32_t n0
= ufoDStack
[ufoSP
-4u]; const uint32_t n1
= ufoDStack
[ufoSP
-3u]; ufoDStack
[ufoSP
-4u] = ufoDStack
[ufoSP
-2u]; ufoDStack
[ufoSP
-3u] = ufoDStack
[ufoSP
-1u]; ufoDStack
[ufoSP
-2u] = n0
; ufoDStack
[ufoSP
-1u] = n1
; }
880 UFO_FORCE_INLINE
void ufoRPush (uint32_t v
) { if (ufoRP
>= UFO_RSTACK_SIZE
) ufoFatal("return stack overflow"); ufoRStack
[ufoRP
++] = v
; }
881 UFO_FORCE_INLINE
void ufoRDrop (void) { if (ufoRP
== 0 || ufoRP
== ufoRPTop
) ufoFatal("return stack underflow"); --ufoRP
; }
882 UFO_FORCE_INLINE
uint32_t ufoRPop (void) { if (ufoRP
== 0 || ufoRP
== ufoRPTop
) ufoFatal("return stack underflow"); return ufoRStack
[--ufoRP
]; }
883 UFO_FORCE_INLINE
uint32_t ufoRPeek (void) { if (ufoRP
== 0 || ufoRP
== ufoRPTop
) ufoFatal("return stack underflow"); return ufoRStack
[ufoRP
-1u]; }
884 UFO_FORCE_INLINE
void ufoRDup (void) { if (ufoRP
== 0 || ufoRP
== ufoRPTop
) ufoFatal("return stack underflow"); ufoPush(ufoRStack
[ufoRP
-1u]); }
886 UFO_FORCE_INLINE
void ufoPushBool (int v
) { ufoPush(v
? ufoTrueValue
: 0u); }
889 //==========================================================================
893 //==========================================================================
894 static void ufoImgEnsureSize (uint32_t addr
) {
895 if ((addr
& UFO_ADDR_SPECIAL_BITS_MASK
) != 0) ufoFatal("ufoImgEnsureSize: internal error");
896 if (addr
>= ufoImageSize
) {
897 // 64MB should be enough for everyone!
898 if (addr
>= 0x04000000U
) {
899 ufoFatal("image grown too big (addr=0%08XH)", addr
);
901 const const uint32_t osz
= ufoImageSize
;
903 const uint32_t nsz
= (addr
|0x000fffffU
) + 1U;
904 ufo_assert(nsz
> addr
);
905 uint32_t *nimg
= realloc(ufoImage
, nsz
);
907 ufoFatal("out of memory for UFO image (%u -> %u MBs)",
908 ufoImageSize
/ 1024u / 1024u,
909 nsz
/ 1024u / 1024u);
913 memset((char *)ufoImage
+ osz
, 0, (nsz
- osz
));
918 //==========================================================================
922 //==========================================================================
923 static void ufoImgEnsureTemp (uint32_t addr
) {
924 if ((addr
& UFO_ADDR_SPECIAL_BITS_MASK
) != 0) ufoFatal("ufoImgEnsureTemp: internal error");
925 if (addr
>= ufoImageTempSize
) {
926 if (addr
>= 1024u * 1024u) {
927 ufoFatal("Forth segmentation fault at address 0x%08X", addr
| UFO_ADDR_TEMP_BIT
);
929 const uint32_t osz
= ufoImageTempSize
;
931 const uint32_t nsz
= (addr
|0x00001fffU
) + 1U;
932 uint32_t *nimg
= realloc(ufoImageTemp
, nsz
);
934 ufoFatal("out of memory for temp UFO image (%u -> %u KBs)",
935 ufoImageTempSize
/ 1024u,
939 ufoImageTempSize
= nsz
;
940 memset((char *)ufoImageTemp
+ osz
, 0, (nsz
- osz
));
945 #ifdef UFO_FAST_MEM_ACCESS
946 //==========================================================================
952 //==========================================================================
953 UFO_FORCE_INLINE
void ufoImgPutU8 (uint32_t addr
, const uint32_t value
) {
954 if ((addr
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) {
955 if (addr
>= ufoImageSize
) ufoImgEnsureSize(addr
);
956 *((uint8_t *)ufoImage
+ addr
) = (uint8_t)value
;
957 } else if (addr
& UFO_ADDR_TEMP_BIT
) {
958 addr
&= UFO_ADDR_TEMP_MASK
;
959 if (addr
>= ufoImageTempSize
) ufoImgEnsureTemp(addr
);
960 *((uint8_t *)ufoImageTemp
+ addr
) = (uint8_t)value
;
962 ufoFatal("Forth segmentation fault at address 0x%08X", addr
);
967 //==========================================================================
973 //==========================================================================
974 UFO_FORCE_INLINE
void ufoImgPutU16 (uint32_t addr
, const uint32_t value
) {
975 if ((addr
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) {
976 if (addr
+ 1u >= ufoImageSize
) ufoImgEnsureSize(addr
+ 1u);
977 *(uint16_t *)((uint8_t *)ufoImage
+ addr
) = (uint16_t)value
;
978 } else if (addr
& UFO_ADDR_TEMP_BIT
) {
979 addr
&= UFO_ADDR_TEMP_MASK
;
980 if (addr
+ 1u >= ufoImageTempSize
) ufoImgEnsureTemp(addr
+ 1u);
981 *(uint16_t *)((uint8_t *)ufoImageTemp
+ addr
) = (uint16_t)value
;
983 ufoFatal("Forth segmentation fault at address 0x%08X", addr
);
988 //==========================================================================
994 //==========================================================================
995 UFO_FORCE_INLINE
void ufoImgPutU32 (uint32_t addr
, const uint32_t value
) {
996 if ((addr
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) {
997 if (addr
+ 3u >= ufoImageSize
) ufoImgEnsureSize(addr
+ 3u);
998 *(uint32_t *)((uint8_t *)ufoImage
+ addr
) = value
;
999 } else if (addr
& UFO_ADDR_TEMP_BIT
) {
1000 addr
&= UFO_ADDR_TEMP_MASK
;
1001 if (addr
+ 3u >= ufoImageTempSize
) ufoImgEnsureTemp(addr
+ 3u);
1002 *(uint32_t *)((uint8_t *)ufoImageTemp
+ addr
) = value
;
1004 ufoFatal("Forth segmentation fault at address 0x%08X", addr
);
1009 //==========================================================================
1015 //==========================================================================
1016 UFO_FORCE_INLINE
uint32_t ufoImgGetU8 (uint32_t addr
) {
1017 if ((addr
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) {
1018 if (addr
>= ufoImageSize
) {
1019 // accessing unallocated image area is segmentation fault
1020 ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr
);
1022 return *((const uint8_t *)ufoImage
+ addr
);
1023 } else if (addr
& UFO_ADDR_TEMP_BIT
) {
1024 addr
&= UFO_ADDR_TEMP_MASK
;
1025 if (addr
>= ufoImageTempSize
) {
1026 // accessing unallocated image area is segmentation fault
1027 ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr
| UFO_ADDR_TEMP_BIT
);
1029 return *((const uint8_t *)ufoImageTemp
+ addr
);
1031 ufoFatal("Forth segmentation fault at address 0x%08X", addr
);
1036 //==========================================================================
1042 //==========================================================================
1043 UFO_FORCE_INLINE
uint32_t ufoImgGetU16 (uint32_t addr
) {
1044 if ((addr
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) {
1045 if (addr
+ 1u >= ufoImageSize
) {
1046 // accessing unallocated image area is segmentation fault
1047 ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr
);
1049 return *(const uint16_t *)((const uint8_t *)ufoImage
+ addr
);
1050 } else if (addr
& UFO_ADDR_TEMP_BIT
) {
1051 addr
&= UFO_ADDR_TEMP_MASK
;
1052 if (addr
+ 1u >= ufoImageTempSize
) {
1053 // accessing unallocated image area is segmentation fault
1054 ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr
| UFO_ADDR_TEMP_BIT
);
1056 return *(const uint16_t *)((const uint8_t *)ufoImageTemp
+ addr
);
1058 ufoFatal("Forth segmentation fault at address 0x%08X", addr
);
1063 //==========================================================================
1069 //==========================================================================
1070 UFO_FORCE_INLINE
uint32_t ufoImgGetU32 (uint32_t addr
) {
1071 if ((addr
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) {
1072 if (addr
+ 3u >= ufoImageSize
) {
1073 // accessing unallocated image area is segmentation fault
1074 ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr
);
1076 return *(const uint32_t *)((const uint8_t *)ufoImage
+ addr
);
1077 } else if (addr
& UFO_ADDR_TEMP_BIT
) {
1078 addr
&= UFO_ADDR_TEMP_MASK
;
1079 if (addr
+ 3u >= ufoImageTempSize
) {
1080 // accessing unallocated image area is segmentation fault
1081 ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr
| UFO_ADDR_TEMP_BIT
);
1083 return *(const uint32_t *)((const uint8_t *)ufoImageTemp
+ addr
);
1085 ufoFatal("Forth segmentation fault at address 0x%08X", addr
);
1091 //==========================================================================
1097 //==========================================================================
1098 UFO_FORCE_INLINE
void ufoImgPutU8 (uint32_t addr
, const uint32_t value
) {
1100 if ((addr
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) {
1101 if (addr
>= ufoImageSize
) ufoImgEnsureSize(addr
);
1102 imgptr
= &ufoImage
[addr
/4u];
1103 } else if (addr
& UFO_ADDR_TEMP_BIT
) {
1104 addr
&= UFO_ADDR_TEMP_MASK
;
1105 if (addr
>= ufoImageTempSize
) ufoImgEnsureTemp(addr
);
1106 imgptr
= &ufoImageTemp
[addr
/4u];
1108 ufoFatal("Forth segmentation fault at address 0x%08X", addr
);
1110 const uint8_t val
= (uint8_t)value
;
1111 memcpy((uint8_t *)imgptr
+ (addr
&3), &val
, 1);
1115 //==========================================================================
1121 //==========================================================================
1122 UFO_FORCE_INLINE
void ufoImgPutU16 (uint32_t addr
, const uint32_t value
) {
1123 ufoImgPutU8(addr
, value
&0xffU
);
1124 ufoImgPutU8(addr
+ 1u, (value
>>8)&0xffU
);
1128 //==========================================================================
1134 //==========================================================================
1135 UFO_FORCE_INLINE
void ufoImgPutU32 (uint32_t addr
, const uint32_t value
) {
1136 ufoImgPutU16(addr
, value
&0xffffU
);
1137 ufoImgPutU16(addr
+ 2u, (value
>>16)&0xffffU
);
1141 //==========================================================================
1147 //==========================================================================
1148 UFO_FORCE_INLINE
uint32_t ufoImgGetU8 (uint32_t addr
) {
1150 if ((addr
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) {
1151 if (addr
>= ufoImageSize
) return 0;
1152 imgptr
= &ufoImage
[addr
/4u];
1153 } else if (addr
& UFO_ADDR_TEMP_BIT
) {
1154 addr
&= UFO_ADDR_TEMP_MASK
;
1155 if (addr
>= ufoImageTempSize
) return 0;
1156 imgptr
= &ufoImageTemp
[addr
/4u];
1158 ufoFatal("Forth segmentation fault at address 0x%08X", addr
);
1161 memcpy(&val
, (uint8_t *)imgptr
+ (addr
&3), 1);
1162 return (uint32_t)val
;
1166 //==========================================================================
1172 //==========================================================================
1173 UFO_FORCE_INLINE
uint32_t ufoImgGetU16 (uint32_t addr
) {
1174 return ufoImgGetU8(addr
) | (ufoImgGetU8(addr
+ 1u) << 8);
1178 //==========================================================================
1184 //==========================================================================
1185 UFO_FORCE_INLINE
uint32_t ufoImgGetU32 (uint32_t addr
) {
1186 return ufoImgGetU16(addr
) | (ufoImgGetU16(addr
+ 2u) << 16);
1191 //==========================================================================
1193 // ufoEnsureDebugSize
1195 //==========================================================================
1196 UFO_DISABLE_INLINE
void ufoEnsureDebugSize (uint32_t sdelta
) {
1197 ufo_assert(sdelta
!= 0);
1198 if (ufoDebugImageUsed
!= 0) {
1199 if (ufoDebugImageUsed
+ sdelta
>= 0x40000000U
) ufoFatal("debug info too big");
1200 if (ufoDebugImageUsed
+ sdelta
> ufoDebugImageSize
) {
1201 // grow by 32KB, this should be more than enough
1202 const uint32_t newsz
= ((ufoDebugImageUsed
+ sdelta
) | 0x7fffU
) + 1u;
1203 uint8_t *ndb
= realloc(ufoDebugImage
, newsz
);
1204 if (ndb
== NULL
) ufoFatal("out of memory for debug info");
1205 ufoDebugImage
= ndb
;
1206 ufoDebugImageSize
= newsz
;
1209 // initial allocation: 32KB, quite a lot
1210 ufoDebugImageSize
= 1024 * 32;
1211 ufoDebugImage
= malloc(ufoDebugImageSize
);
1212 if (ufoDebugImage
== NULL
) ufoFatal("out of memory for debug info");
1217 #define UFO_DBG_PUT_U4(val_) do { \
1218 const uint32_t vv_ = (val_); \
1219 *((uint32_t *)(ufoDebugImage + ufoDebugImageUsed)) = vv_; \
1220 ufoDebugImageUsed += 4u; \
1227 ...first line info header...
1228 line info header (or reset):
1229 db 0 ; zero line delta
1230 dw followFileInfoSize ; either it, or 0 if reused
1231 dd fileInfoOfs ; present only if reused
1239 dd nameLen ; without terminating 0
1240 ...name... (0-terminated)
1242 we will never compare file names: length and hash should provide
1243 good enough unique identifier.
1245 static uint8_t *ufoDebugImage = NULL;
1246 static uint32_t ufoDebugImageUsed = 0; // in bytes
1247 static uint32_t ufoDebugImageSize = 0; // in bytes
1248 static uint32_t ufoDebugFileNameHash = 0; // current file name hash
1249 static uint32_t ufoDebugFileNameLen = 0; // current file name length
1250 static uint32_t ufoDebugCurrDP = 0;
1254 //==========================================================================
1256 // ufoSkipDebugVarInt
1258 //==========================================================================
1259 static __attribute__((unused
)) uint32_t ufoSkipDebugVarInt (uint32_t ofs
) {
1262 if (ofs
>= ufoDebugImageUsed
) ufoFatal("invalid debug data");
1263 byte
= ufoDebugImage
[ofs
]; ofs
+= 1u;
1264 } while (byte
>= 0x80);
1269 //==========================================================================
1271 // ufoCalcDebugVarIntSize
1273 //==========================================================================
1274 UFO_FORCE_INLINE
uint8_t ufoCalcDebugVarIntSize (uint32_t v
) {
1284 //==========================================================================
1286 // ufoGetDebugVarInt
1288 //==========================================================================
1289 static __attribute__((unused
)) uint32_t ufoGetDebugVarInt (uint32_t ofs
) {
1294 if (ofs
>= ufoDebugImageUsed
) ufoFatal("invalid debug data");
1295 byte
= ufoDebugImage
[ofs
];
1296 v
|= (uint32_t)(byte
& 0x7f) << shift
;
1301 } while (byte
>= 0x80);
1306 //==========================================================================
1308 // ufoPutDebugVarInt
1310 //==========================================================================
1311 UFO_FORCE_INLINE
void ufoPutDebugVarInt (uint32_t v
) {
1312 ufoEnsureDebugSize(5u); // maximum size
1315 ufoDebugImage
[ufoDebugImageUsed
] = (uint8_t)(v
| 0x80u
);
1317 ufoDebugImage
[ufoDebugImageUsed
] = (uint8_t)v
;
1319 ufoDebugImageUsed
+= 1;
1325 #ifdef UFO_DEBUG_DEBUG
1326 //==========================================================================
1330 //==========================================================================
1331 static void ufoDumpDebugImage (void) {
1333 uint32_t dbgpos
= 4u; // first line header info
1334 uint32_t lastline
= 0;
1335 uint32_t lastdp
= 0;
1336 while (dbgpos
< ufoDebugImageUsed
) {
1337 if (ufoDebugImage
[dbgpos
] == 0) {
1339 dbgpos
+= 1u; // skip flag
1340 const uint32_t fhdrSize
= *(const uint16_t *)(ufoDebugImage
+ dbgpos
); dbgpos
+= 2u;
1341 lastdp
= ufoGetDebugVarInt(dbgpos
);
1342 dbgpos
= ufoSkipDebugVarInt(dbgpos
);
1343 if (fhdrSize
== 0) {
1345 const uint32_t infoOfs
= *(const uint32_t *)(ufoDebugImage
+ dbgpos
); dbgpos
+= 4u;
1346 fprintf(stderr
, "*** OLD FILE: %s\n", (const char *)(ufoDebugImage
+ infoOfs
+ 3u * 4u));
1347 fprintf(stderr
, "FILE NAME LEN: %u\n", ((const uint32_t *)(ufoDebugImage
+ infoOfs
))[2]);
1348 fprintf(stderr
, "FILE NAME HASH: 0x%08x\n", ((const uint32_t *)(ufoDebugImage
+ infoOfs
))[1]);
1351 fprintf(stderr
, "*** NEW FILE: %s\n", (const char *)(ufoDebugImage
+ dbgpos
+ 3u * 4u));
1352 fprintf(stderr
, "FILE NAME LEN: %u\n", ((const uint32_t *)(ufoDebugImage
+ dbgpos
))[2]);
1353 fprintf(stderr
, "FILE NAME HASH: 0x%08x\n", ((const uint32_t *)(ufoDebugImage
+ dbgpos
))[1]);
1356 fprintf(stderr
, "LINES-OFS: 0x%08x (hsz: %u -- 0x%08x)\n", dbgpos
, fhdrSize
, fhdrSize
);
1357 lastline
= ~(uint32_t)0;
1359 const uint32_t ln
= ufoGetDebugVarInt(dbgpos
);
1360 dbgpos
= ufoSkipDebugVarInt(dbgpos
);
1361 ufo_assert(ln
!= 0);
1363 const uint32_t edp
= ufoGetDebugVarInt(dbgpos
);
1364 dbgpos
= ufoSkipDebugVarInt(dbgpos
);
1366 fprintf(stderr
, " line %6u: edp=%u\n", lastline
, lastdp
);
1374 //==========================================================================
1376 // ufoRecordDebugCheckFile
1378 // if we moved to the new file:
1379 // put "line info header"
1380 // put new file info (or reuse old)
1382 //==========================================================================
1383 UFO_FORCE_INLINE
void ufoRecordDebugCheckFile (void) {
1384 if (ufoDebugImageUsed
== 0 ||
1385 ufoDebugFileNameLen
!= ufoInFileNameLen
||
1386 ufoDebugFileNameHash
!= ufoInFileNameHash
)
1388 // new file record (or reuse old one)
1389 const int initial
= (ufoDebugImageUsed
== 0);
1390 uint32_t fileRec
= 0;
1391 // try to find and old one
1393 fileRec
= *(const uint32_t *)ufoDebugImage
;
1395 fprintf(stderr
, "*** NEW-FILE(%u): 0x%08x: <%s> (frec=0x%08x)\n", ufoInFileNameLen
,
1396 ufoInFileNameHash
, ufoInFileName
, fileRec
);
1398 while (fileRec
!= 0 &&
1399 (ufoInFileNameLen
!= ((const uint32_t *)(ufoDebugImage
+ fileRec
))[1] ||
1400 ufoInFileNameHash
!= ((const uint32_t *)(ufoDebugImage
+ fileRec
))[2]))
1403 fprintf(stderr
, "*** FRCHECK: 0x%08x\n", fileRec
);
1404 fprintf(stderr
, " FILE NAME: %s\n", (const char *)(ufoDebugImage
+ fileRec
+ 3u * 4u));
1405 fprintf(stderr
, " FILE NAME LEN: %u\n", ((const uint32_t *)(ufoDebugImage
+ fileRec
))[2]);
1406 fprintf(stderr
, " FILE NAME HASH: 0x%08x\n", ((const uint32_t *)(ufoDebugImage
+ fileRec
))[1]);
1407 fprintf(stderr
, " FILE PREV: 0x%08x\n", *(const uint32_t *)(ufoDebugImage
+ fileRec
));
1409 fileRec
= *(const uint32_t *)(ufoDebugImage
+ fileRec
);
1412 fprintf(stderr
, "*** FRCHECK-DONE: 0x%08x\n", fileRec
);
1414 fprintf(stderr
, " FILE NAME: %s\n", (const char *)(ufoDebugImage
+ fileRec
+ 3u * 4u));
1415 fprintf(stderr
, " FILE NAME LEN: %u\n", ((const uint32_t *)(ufoDebugImage
+ fileRec
))[2]);
1416 fprintf(stderr
, " FILE NAME HASH: 0x%08x\n", ((const uint32_t *)(ufoDebugImage
+ fileRec
))[1]);
1417 fprintf(stderr
, " FILE PREV: 0x%08x\n", *(const uint32_t *)(ufoDebugImage
+ fileRec
));
1421 ufoEnsureDebugSize(8u);
1422 *(uint32_t *)ufoDebugImage
= 0;
1424 // write "line info header"
1426 ufoEnsureDebugSize(32u);
1427 ufoDebugImage
[ufoDebugImageUsed
] = 0; ufoDebugImageUsed
+= 1u; // header flag (0 delta)
1428 // file record size: 0 (reused)
1429 *((uint16_t *)(ufoDebugImage
+ ufoDebugImageUsed
)) = 0; ufoDebugImageUsed
+= 2u;
1431 ufoPutDebugVarInt(ufoDebugCurrDP
);
1433 UFO_DBG_PUT_U4(fileRec
);
1435 // name, trailing 0 byte, 3 dword fields
1436 const uint32_t finfoSize
= ufoInFileNameLen
+ 1u + 3u * 4u;
1437 ufo_assert(finfoSize
< 65536u);
1438 ufoEnsureDebugSize(finfoSize
+ 32u);
1440 *(uint32_t *)ufoDebugImage
= 0;
1441 ufoDebugImageUsed
= 4;
1443 ufoDebugImage
[ufoDebugImageUsed
] = 0; ufoDebugImageUsed
+= 1u; // header flag (0 delta)
1445 *((uint16_t *)(ufoDebugImage
+ ufoDebugImageUsed
)) = (uint16_t)finfoSize
; ufoDebugImageUsed
+= 2u;
1447 ufoPutDebugVarInt(ufoDebugCurrDP
);
1448 // file record follows
1449 // fix file info offsets
1450 uint32_t lastOfs
= *(const uint32_t *)ufoDebugImage
;
1451 *(uint32_t *)ufoDebugImage
= ufoDebugImageUsed
;
1452 UFO_DBG_PUT_U4(lastOfs
);
1453 // save file info hash
1454 UFO_DBG_PUT_U4(ufoInFileNameHash
);
1455 // save file info length
1456 UFO_DBG_PUT_U4(ufoInFileNameLen
);
1458 if (ufoInFileNameLen
!= 0) {
1459 memcpy(ufoDebugImage
+ ufoDebugImageUsed
, ufoInFileName
, ufoInFileNameLen
+ 1u);
1460 ufoDebugImageUsed
+= ufoInFileNameLen
+ 1u;
1462 ufoDebugImage
[ufoDebugImageUsed
] = 0; ufoDebugImageUsed
+= 1u;
1465 ufoDebugFileNameLen
= ufoInFileNameLen
;
1466 ufoDebugFileNameHash
= ufoInFileNameHash
;
1467 ufoDebugLastLine
= ~(uint32_t)0;
1468 ufoDebugLastLinePCOfs
= 0;
1469 ufoDebugLastLineDP
= ufoDebugCurrDP
;
1474 //==========================================================================
1476 // ufoRecordDebugRecordLine
1478 //==========================================================================
1479 UFO_FORCE_INLINE
void ufoRecordDebugRecordLine (uint32_t line
, uint32_t newhere
) {
1480 if (line
== ufoDebugLastLine
) {
1481 ufo_assert(ufoDebugLastLinePCOfs
!= 0);
1482 ufoDebugImageUsed
= ufoDebugLastLinePCOfs
;
1485 fprintf(stderr
, "FL-NEW-LINE(0x%08x): <%s>; new line: %u (old: %u)\n",
1487 ufoInFileName
, line
, ufoDebugLastLine
);
1489 ufoPutDebugVarInt(line
- ufoDebugLastLine
);
1490 ufoDebugLastLinePCOfs
= ufoDebugImageUsed
;
1491 ufoDebugLastLine
= line
;
1492 ufoDebugLastLineDP
= ufoDebugCurrDP
;
1494 ufoPutDebugVarInt(newhere
- ufoDebugLastLineDP
);
1495 ufoDebugCurrDP
= newhere
;
1499 //==========================================================================
1503 //==========================================================================
1504 UFO_DISABLE_INLINE
void ufoRecordDebug (uint32_t newhere
) {
1505 if (newhere
> ufoDebugCurrDP
) {
1506 uint32_t ln
= (uint32_t)ufoInFileLine
;
1507 if (ln
== ~(uint32_t)0) ln
= 0;
1509 fprintf(stderr
, "FL: <%s>; line: %d\n", ufoInFileName
, ufoInFileLine
);
1511 ufoRecordDebugCheckFile();
1512 ufoRecordDebugRecordLine(ln
, newhere
);
1517 //==========================================================================
1519 // ufoGetWordEndAddrYFA
1521 //==========================================================================
1522 static uint32_t ufoGetWordEndAddrYFA (uint32_t yfa
) {
1524 const uint32_t oyfa
= yfa
;
1525 yfa
= ufoImgGetU32(yfa
);
1527 if ((oyfa
& UFO_ADDR_TEMP_BIT
) == 0) {
1529 if ((yfa
& UFO_ADDR_TEMP_BIT
) != 0) {
1530 yfa
= UFO_CFA_TO_PFA(UFO_NFA_TO_CFA(UFO_YFA_TO_NFA(oyfa
)));
1533 yfa
= UFO_CFA_TO_PFA(UFO_NFA_TO_CFA(UFO_YFA_TO_NFA(oyfa
)));
1536 yfa
= UFO_YFA_TO_WST(yfa
);
1545 //==========================================================================
1547 // ufoGetWordEndAddr
1549 //==========================================================================
1550 static uint32_t ufoGetWordEndAddr (const uint32_t cfa
) {
1552 return ufoGetWordEndAddrYFA(UFO_LFA_TO_YFA(UFO_CFA_TO_LFA(cfa
)));
1559 //==========================================================================
1565 // WARNING: this is SLOW!
1567 //==========================================================================
1568 static uint32_t ufoFindWordForIP (const uint32_t ip
) {
1571 //fprintf(stderr, "ufoFindWordForIP:000: ip=0x%08x\n", ip);
1572 // iterate over all words
1573 uint32_t xfa
= ufoImgGetU32(ufoAddrLastXFA
);
1574 //fprintf(stderr, "ufoFindWordForIP:001: xfa=0x%08x\n", xfa);
1576 while (res
== 0 && xfa
!= 0) {
1577 const uint32_t yfa
= UFO_XFA_TO_YFA(xfa
);
1578 const uint32_t wst
= UFO_YFA_TO_WST(yfa
);
1579 //fprintf(stderr, "ufoFindWordForIP:002: yfa=0x%08x; wst=0x%08x\n", yfa, wst);
1580 const uint32_t wend
= ufoGetWordEndAddrYFA(yfa
);
1581 if (ip
>= wst
&& ip
< wend
) {
1582 res
= UFO_YFA_TO_NFA(yfa
);
1584 xfa
= ufoImgGetU32(xfa
);
1593 //==========================================================================
1597 // return file name or `NULL`
1599 // WARNING: this is SLOW!
1601 //==========================================================================
1602 static const char *ufoFindFileForIP (uint32_t ip
, uint32_t *line
,
1603 uint32_t *nlen
, uint32_t *nhash
)
1605 if (ip
!= 0 && ufoDebugImageUsed
!= 0) {
1606 const char *filename
= NULL
;
1607 uint32_t dbgpos
= 4u; // first line header info
1608 uint32_t lastline
= 0;
1609 uint32_t lastdp
= 0;
1610 uint32_t namelen
= 0;
1611 uint32_t namehash
= 0;
1612 while (dbgpos
< ufoDebugImageUsed
) {
1613 if (ufoDebugImage
[dbgpos
] == 0) {
1615 dbgpos
+= 1u; // skip flag
1616 const uint32_t fhdrSize
= *(const uint16_t *)(ufoDebugImage
+ dbgpos
); dbgpos
+= 2u;
1617 lastdp
= ufoGetDebugVarInt(dbgpos
);
1618 dbgpos
= ufoSkipDebugVarInt(dbgpos
);
1620 if (fhdrSize
== 0) {
1622 infoOfs
= *(const uint32_t *)(ufoDebugImage
+ dbgpos
); dbgpos
+= 4u;
1627 filename
= (const char *)(ufoDebugImage
+ infoOfs
+ 3u * 4u);
1628 namelen
= ((const uint32_t *)(ufoDebugImage
+ infoOfs
))[2];
1629 namehash
= ((const uint32_t *)(ufoDebugImage
+ infoOfs
))[1];
1630 if (filename
[0] == 0) filename
= NULL
;
1632 lastline
= ~(uint32_t)0;
1634 const uint32_t ln
= ufoGetDebugVarInt(dbgpos
);
1635 dbgpos
= ufoSkipDebugVarInt(dbgpos
);
1636 ufo_assert(ln
!= 0);
1638 const uint32_t edp
= ufoGetDebugVarInt(dbgpos
);
1639 dbgpos
= ufoSkipDebugVarInt(dbgpos
);
1640 if (ip
>= lastdp
&& ip
< lastdp
+ edp
) {
1641 if (line
) *line
= lastline
;
1642 if (nlen
) *nlen
= namelen
;
1643 if (nhash
) *nhash
= namehash
;
1650 if (line
) *line
= 0;
1651 if (nlen
) *nlen
= 0;
1652 if (nhash
) *nlen
= 0;
1657 //==========================================================================
1661 //==========================================================================
1662 UFO_FORCE_INLINE
void ufoBumpDP (uint32_t delta
) {
1663 uint32_t dp
= ufoImgGetU32(ufoAddrDPTemp
);
1665 dp
= ufoImgGetU32(ufoAddrDP
);
1666 if ((dp
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) ufoRecordDebug(dp
+ delta
);
1668 ufoImgPutU32(ufoAddrDP
, dp
);
1670 dp
= ufoImgGetU32(ufoAddrDPTemp
);
1671 if ((dp
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) ufoRecordDebug(dp
+ delta
);
1673 ufoImgPutU32(ufoAddrDPTemp
, dp
);
1678 //==========================================================================
1682 //==========================================================================
1683 UFO_FORCE_INLINE
void ufoImgEmitU8 (uint32_t value
) {
1684 ufoImgPutU8(UFO_GET_DP(), value
);
1689 //==========================================================================
1693 //==========================================================================
1694 UFO_FORCE_INLINE
void ufoImgEmitU32 (uint32_t value
) {
1695 ufoImgPutU32(UFO_GET_DP(), value
);
1700 #ifdef UFO_FAST_MEM_ACCESS
1702 //==========================================================================
1704 // ufoImgEmitU32_NoInline
1708 //==========================================================================
1709 UFO_FORCE_INLINE
void ufoImgEmitU32_NoInline (uint32_t value
) {
1710 ufoImgPutU32(UFO_GET_DP(), value
);
1716 //==========================================================================
1718 // ufoImgEmitU32_NoInline
1722 //==========================================================================
1723 UFO_DISABLE_INLINE
void ufoImgEmitU32_NoInline (uint32_t value
) {
1724 ufoImgPutU32(UFO_GET_DP(), value
);
1731 //==========================================================================
1735 // this understands handle addresses
1737 //==========================================================================
1738 UFO_FORCE_INLINE
uint32_t ufoImgGetU8Ext (uint32_t addr
) {
1739 if ((addr
& UFO_ADDR_HANDLE_BIT
) == 0) {
1740 return ufoImgGetU8(addr
);
1744 UFCALL(PAR_HANDLE_LOAD_BYTE
);
1750 //==========================================================================
1754 // this understands handle addresses
1756 //==========================================================================
1757 UFO_FORCE_INLINE
void ufoImgPutU8Ext (uint32_t addr
, uint32_t value
) {
1758 if ((addr
& UFO_ADDR_HANDLE_BIT
) == 0) {
1759 ufoImgPutU8(addr
, value
);
1764 UFCALL(PAR_HANDLE_STORE_BYTE
);
1769 //==========================================================================
1773 //==========================================================================
1774 UFO_FORCE_INLINE
void ufoImgEmitAlign (void) {
1775 while ((UFO_GET_DP() & 3) != 0) ufoImgEmitU8(0);
1779 //==========================================================================
1783 //==========================================================================
1784 UFO_FORCE_INLINE
void ufoResetTib (void) {
1785 uint32_t defTIB
= ufoImgGetU32(ufoAddrDefTIB
);
1786 //fprintf(stderr, "ufoResetTib(%p): defTIB=0x%08x\n", ufoCurrState, defTIB);
1788 // create new TIB handle
1789 UfoHandle
*tibh
= ufoAllocHandle(0x69a029a6); // arbitrary number
1790 defTIB
= tibh
->ufoHandle
;
1791 ufoImgPutU32(ufoAddrDefTIB
, defTIB
);
1793 if ((defTIB
& UFO_ADDR_HANDLE_BIT
) != 0) {
1794 UfoHandle
*hh
= ufoGetHandle(defTIB
);
1795 if (hh
== NULL
) ufoFatal("default TIB is not allocated");
1796 if (hh
->size
== 0) {
1797 ufo_assert(hh
->data
== NULL
);
1798 hh
->data
= calloc(1, UFO_ADDR_HANDLE_OFS_MASK
+ 1);
1799 if (hh
->data
== NULL
) ufoFatal("out of memory for default TIB");
1800 hh
->size
= UFO_ADDR_HANDLE_OFS_MASK
+ 1;
1803 const uint32_t oldA
= ufoRegA
;
1804 ufoImgPutU32(ufoAddrTIBx
, defTIB
);
1805 ufoImgPutU32(ufoAddrINx
, 0);
1807 ufoPush(0); // value
1808 ufoPush(0); // offset
1809 UFCALL(CPOKE_REGA_IDX
);
1814 //==========================================================================
1818 //==========================================================================
1819 UFO_DISABLE_INLINE
void ufoTibEnsureSize (uint32_t size
) {
1820 if (size
> 1024u * 1024u * 256u) ufoFatal("TIB size too big");
1821 const uint32_t tib
= ufoImgGetU32(ufoAddrTIBx
);
1822 //fprintf(stderr, "ufoTibEnsureSize: TIB=0x%08x; size=%u\n", tib, size);
1823 if ((tib
& UFO_ADDR_HANDLE_BIT
) != 0) {
1824 UfoHandle
*hh
= ufoGetHandle(tib
);
1826 ufoFatal("cannot resize TIB, TIB is not a handle");
1828 if (hh
->size
< size
) {
1829 const uint32_t newsz
= (size
| 0xfffU
) + 1u;
1830 uint8_t *nx
= realloc(hh
->data
, newsz
);
1831 if (nx
== NULL
) ufoFatal("out of memory for restored TIB");
1838 ufoFatal("cannot resize TIB, TIB is not a handle (0x%08x)", tib
);
1844 //==========================================================================
1848 //==========================================================================
1850 UFO_DISABLE_INLINE uint32_t ufoTibGetSize (void) {
1851 const uint32_t tib = ufoImgGetU32(ufoAddrTIBx);
1852 if ((tib & UFO_ADDR_HANDLE_BIT) == 0) {
1853 ufoFatal("cannot query TIB, TIB is not a handle");
1855 UfoHandle *hh = ufoGetHandle(tib);
1857 ufoFatal("cannot query TIB, TIB is not a handle");
1864 //==========================================================================
1868 //==========================================================================
1869 UFO_FORCE_INLINE
uint8_t ufoTibPeekCh (void) {
1870 return (uint8_t)ufoImgGetU8Ext(ufoImgGetU32(ufoAddrTIBx
) + ufoImgGetU32(ufoAddrINx
));
1874 //==========================================================================
1878 //==========================================================================
1879 UFO_FORCE_INLINE
uint8_t ufoTibPeekChOfs (uint32_t ofs
) {
1880 const uint32_t tib
= ufoImgGetU32(ufoAddrTIBx
);
1881 if (ofs
<= UFO_ADDR_HANDLE_OFS_MASK
|| (tib
& UFO_ADDR_HANDLE_BIT
) == 0) {
1882 return (uint8_t)ufoImgGetU8Ext(tib
+ ufoImgGetU32(ufoAddrINx
) + ofs
);
1889 //==========================================================================
1893 //==========================================================================
1894 UFO_DISABLE_INLINE
void ufoTibPokeChOfs (uint8_t ch
, uint32_t ofs
) {
1895 const uint32_t oldA
= ufoRegA
;
1896 ufoRegA
= ufoImgGetU32(ufoAddrTIBx
);
1898 ufoPush(ufoImgGetU32(ufoAddrINx
) + ofs
);
1899 UFCALL(CPOKE_REGA_IDX
);
1904 //==========================================================================
1908 //==========================================================================
1909 UFO_FORCE_INLINE
uint8_t ufoTibGetCh (void) {
1910 const uint8_t ch
= ufoTibPeekCh();
1911 if (ch
) ufoImgPutU32(ufoAddrINx
, ufoImgGetU32(ufoAddrINx
) + 1u);
1916 //==========================================================================
1920 //==========================================================================
1921 UFO_FORCE_INLINE
void ufoTibSkipCh (void) {
1922 (void)ufoTibGetCh();
1926 // ////////////////////////////////////////////////////////////////////////// //
1927 // native CFA implementations
1930 //==========================================================================
1934 //==========================================================================
1935 static void ufoDoForth (uint32_t pfa
) {
1941 //==========================================================================
1945 //==========================================================================
1946 static void ufoDoVariable (uint32_t pfa
) {
1951 //==========================================================================
1953 // ufoDoUserVariable
1955 //==========================================================================
1956 static void ufoDoUserVariable (uint32_t pfa
) {
1957 ufoPush(ufoImgGetU32(pfa
));
1961 //==========================================================================
1965 //==========================================================================
1966 static void ufoDoValue (uint32_t pfa
) {
1967 ufoPush(ufoImgGetU32(pfa
));
1971 //==========================================================================
1975 //==========================================================================
1976 static void ufoDoConst (uint32_t pfa
) {
1977 ufoPush(ufoImgGetU32(pfa
));
1981 //==========================================================================
1985 //==========================================================================
1986 static void ufoDoDefer (uint32_t pfa
) {
1987 const uint32_t cfa
= ufoImgGetU32(pfa
);
1995 //==========================================================================
1999 //==========================================================================
2000 static void ufoDoVoc (uint32_t pfa
) {
2001 ufoImgPutU32(ufoAddrContext
, ufoImgGetU32(pfa
));
2005 //==========================================================================
2009 //==========================================================================
2010 static void ufoDoCreate (uint32_t pfa
) {
2015 //==========================================================================
2019 // this also increments last used file id
2021 //==========================================================================
2022 static void ufoPushInFile (void) {
2023 if (ufoFileStackPos
>= UFO_MAX_NESTED_INCLUDES
) ufoFatal("too many includes");
2024 UFOFileStackEntry
*stk
= &ufoFileStack
[ufoFileStackPos
];
2025 stk
->fl
= ufoInFile
;
2026 stk
->fname
= ufoInFileName
;
2027 stk
->fline
= ufoInFileLine
;
2028 stk
->id
= ufoFileId
;
2029 stk
->incpath
= (ufoLastIncPath
? strdup(ufoLastIncPath
) : NULL
);
2030 stk
->sysincpath
= (ufoLastSysIncPath
? strdup(ufoLastSysIncPath
) : NULL
);
2031 ufoFileStackPos
+= 1;
2033 ufoInFileName
= NULL
; ufoInFileNameLen
= 0; ufoInFileNameHash
= 0;
2035 ufoLastUsedFileId
+= 1;
2036 ufo_assert(ufoLastUsedFileId
!= 0); // just in case ;-)
2037 //ufoLastIncPath = NULL;
2041 //==========================================================================
2043 // ufoWipeIncludeStack
2045 //==========================================================================
2046 static void ufoWipeIncludeStack (void) {
2047 if (ufoInFileName
) { free(ufoInFileName
); ufoInFileName
= NULL
; }
2048 if (ufoInFile
) { fclose(ufoInFile
); ufoInFile
= NULL
; }
2049 if (ufoLastIncPath
) { free(ufoLastIncPath
); ufoLastIncPath
= NULL
; }
2050 if (ufoLastSysIncPath
) { free(ufoLastSysIncPath
); ufoLastSysIncPath
= NULL
; }
2051 while (ufoFileStackPos
!= 0) {
2052 ufoFileStackPos
-= 1;
2053 UFOFileStackEntry
*stk
= &ufoFileStack
[ufoFileStackPos
];
2054 if (stk
->fl
) fclose(stk
->fl
);
2055 if (stk
->fname
) free(stk
->fname
);
2056 if (stk
->incpath
) free(stk
->incpath
);
2061 //==========================================================================
2065 //==========================================================================
2066 static void ufoPopInFile (void) {
2067 if (ufoFileStackPos
== 0) ufoFatal("trying to pop include from empty stack");
2068 if (ufoInFileName
) { free(ufoInFileName
); ufoInFileName
= NULL
; }
2069 if (ufoInFile
) { fclose(ufoInFile
); ufoInFile
= NULL
; }
2070 if (ufoLastIncPath
) { free(ufoLastIncPath
); ufoLastIncPath
= NULL
; }
2071 if (ufoLastSysIncPath
) { free(ufoLastSysIncPath
); ufoLastSysIncPath
= NULL
; }
2072 ufoFileStackPos
-= 1;
2073 UFOFileStackEntry
*stk
= &ufoFileStack
[ufoFileStackPos
];
2074 ufoInFile
= stk
->fl
;
2075 ufoSetInFileNameReuse(stk
->fname
);
2076 ufoInFileLine
= stk
->fline
;
2077 ufoLastIncPath
= stk
->incpath
;
2078 ufoLastSysIncPath
= stk
->sysincpath
;
2079 ufoFileId
= stk
->id
;
2081 #ifdef UFO_DEBUG_INCLUDE
2082 if (ufoInFileName
== NULL
) {
2083 fprintf(stderr
, "INC-POP: no more files.\n");
2085 fprintf(stderr
, "INC-POP: fname: %s\n", ufoInFileName
);
2091 //==========================================================================
2095 //==========================================================================
2096 void ufoDeinit (void) {
2097 #ifdef UFO_DEBUG_WRITE_MAIN_IMAGE
2099 FILE *fo
= fopen("zufo_main.img", "w");
2100 uint32_t dpTemp
= ufoImgGetU32(ufoAddrDPTemp
);
2101 uint32_t dpMain
= ufoImgGetU32(ufoAddrDP
);
2102 if ((dpMain
& UFO_ADDR_SPECIAL_BITS_MASK
) != 0) dpMain
= ufoImageSize
;
2103 if (dpTemp
!= 0 && (dpTemp
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) {
2104 if (dpTemp
> dpMain
) dpMain
= dpTemp
;
2106 fwrite(ufoImage
, dpMain
, 1, fo
);
2111 #ifdef UFO_DEBUG_WRITE_DEBUG_IMAGE
2113 FILE *fo
= fopen("zufo_debug.img", "w");
2114 fwrite(ufoDebugImage
, ufoDebugImageUsed
, 1, fo
);
2119 #ifdef UFO_DEBUG_DEBUG
2121 uint32_t dpTemp
= ufoImgGetU32(ufoAddrDPTemp
);
2122 uint32_t dpMain
= ufoImgGetU32(ufoAddrDP
);
2123 if ((dpMain
& UFO_ADDR_SPECIAL_BITS_MASK
) != 0) dpMain
= ufoImageSize
;
2124 if (dpTemp
!= 0 && (dpTemp
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) {
2125 if (dpTemp
> dpMain
) dpMain
= dpTemp
;
2127 fprintf(stderr
, "UFO: image used: %u; size: %u\n",
2128 dpMain
, ufoImageSize
);
2129 fprintf(stderr
, "UFO: debug image used: %u; size: %u\n",
2130 ufoDebugImageUsed
, ufoDebugImageSize
);
2131 ufoDumpDebugImage();
2136 ufoCurrState
= NULL
;
2137 ufoYieldedState
= NULL
;
2138 ufoDebuggerState
= NULL
;
2139 for (uint32_t fidx
= 0; fidx
< (uint32_t)(UFO_MAX_STATES
/32); fidx
+= 1u) {
2140 uint32_t bmp
= ufoStateUsedBitmap
[fidx
];
2142 uint32_t stid
= fidx
* 32u;
2144 if ((bmp
& 0x01) != 0) ufoFreeState(ufoStateMap
[stid
]);
2145 stid
+= 1u; bmp
>>= 1;
2150 free(ufoDebugImage
);
2151 ufoDebugImage
= NULL
;
2152 ufoDebugImageUsed
= 0;
2153 ufoDebugImageSize
= 0;
2154 ufoDebugFileNameHash
= 0;
2155 ufoDebugFileNameLen
= 0;
2156 ufoDebugLastLine
= 0;
2157 ufoDebugLastLinePCOfs
= 0;
2158 ufoDebugLastLineDP
= 0;
2162 ufoClearCondDefines();
2163 ufoWipeIncludeStack();
2165 // release all includes
2167 if (ufoInFileName
) free(ufoInFileName
);
2168 if (ufoLastIncPath
) free(ufoLastIncPath
);
2169 if (ufoLastSysIncPath
) free(ufoLastSysIncPath
);
2170 ufoInFileName
= NULL
; ufoLastIncPath
= NULL
; ufoLastSysIncPath
= NULL
;
2171 ufoInFileNameHash
= 0; ufoInFileNameLen
= 0;
2175 ufoForthCFAs
= NULL
;
2182 ufoMode
= UFO_MODE_NATIVE
;
2183 ufoForthVocId
= 0; ufoCompilerVocId
= 0;
2187 for (uint32_t f
= 0; f
< ufoHandlesUsed
; f
+= 1) {
2188 UfoHandle
*hh
= ufoHandles
[f
];
2190 if (hh
->data
!= NULL
) free(hh
->data
);
2194 if (ufoHandles
!= NULL
) free(ufoHandles
);
2195 ufoHandles
= NULL
; ufoHandlesUsed
= 0; ufoHandlesAlloted
= 0;
2196 ufoHandleFreeList
= NULL
;
2198 ufoLastEmitWasCR
= 1;
2200 ufoClearCondDefines();
2204 //==========================================================================
2206 // ufoDumpWordHeader
2208 //==========================================================================
2209 __attribute__((unused
)) static void ufoDumpWordHeader (const uint32_t lfa
) {
2210 fprintf(stderr
, "=== WORD: LFA: 0x%08x ===\n", lfa
);
2212 fprintf(stderr
, " (XFA): 0x%08x\n", ufoImgGetU32(UFO_LFA_TO_XFA(lfa
)));
2213 fprintf(stderr
, " (YFA): 0x%08x\n", ufoImgGetU32(UFO_LFA_TO_YFA(lfa
)));
2214 fprintf(stderr
, " (BFA): 0x%08x\n", ufoImgGetU32(UFO_LFA_TO_BFA(lfa
)));
2215 fprintf(stderr
, " (LFA): 0x%08x\n", ufoImgGetU32(lfa
));
2216 fprintf(stderr
, " (NHH): 0x%08x\n", ufoImgGetU32(UFO_LFA_TO_NHASH(lfa
)));
2217 const uint32_t cfa
= UFO_LFA_TO_CFA(lfa
);
2218 fprintf(stderr
, " CFA: 0x%08x\n", cfa
);
2219 fprintf(stderr
, " PFA: 0x%08x\n", UFO_CFA_TO_PFA(cfa
));
2220 fprintf(stderr
, " (CFA): 0x%08x\n", ufoImgGetU32(cfa
));
2221 const uint32_t nfa
= UFO_LFA_TO_NFA(lfa
);
2222 const uint32_t nlen
= ufoImgGetU8(nfa
);
2223 fprintf(stderr
, " NFA: 0x%08x (nlen: %u)\n", nfa
, nlen
);
2224 const uint32_t flags
= ufoImgGetU32(nfa
);
2225 fprintf(stderr
, " FLAGS: 0x%08x\n", flags
);
2226 if ((flags
& 0xffff0000U
) != 0) {
2227 fprintf(stderr
, " FLAGS:");
2228 if (flags
& UFW_FLAG_IMMEDIATE
) fprintf(stderr
, " IMM");
2229 if (flags
& UFW_FLAG_SMUDGE
) fprintf(stderr
, " SMUDGE");
2230 if (flags
& UFW_FLAG_NORETURN
) fprintf(stderr
, " NORET");
2231 if (flags
& UFW_FLAG_HIDDEN
) fprintf(stderr
, " HIDDEN");
2232 if (flags
& UFW_FLAG_CBLOCK
) fprintf(stderr
, " CBLOCK");
2233 if (flags
& UFW_FLAG_VOCAB
) fprintf(stderr
, " VOCAB");
2234 if (flags
& UFW_FLAG_SCOLON
) fprintf(stderr
, " SCOLON");
2235 if (flags
& UFW_FLAG_PROTECTED
) fprintf(stderr
, " PROTECTED");
2236 fputc('\n', stderr
);
2238 if ((flags
& 0xff00U
) != 0) {
2239 fprintf(stderr
, " ARGS: ");
2240 switch (flags
& UFW_WARG_MASK
) {
2241 case UFW_WARG_NONE
: fprintf(stderr
, "NONE"); break;
2242 case UFW_WARG_BRANCH
: fprintf(stderr
, "BRANCH"); break;
2243 case UFW_WARG_LIT
: fprintf(stderr
, "LIT"); break;
2244 case UFW_WARG_C4STRZ
: fprintf(stderr
, "C4STRZ"); break;
2245 case UFW_WARG_CFA
: fprintf(stderr
, "CFA"); break;
2246 case UFW_WARG_CBLOCK
: fprintf(stderr
, "CBLOCK"); break;
2247 case UFW_WARG_VOCID
: fprintf(stderr
, "VOCID"); break;
2248 case UFW_WARG_C1STRZ
: fprintf(stderr
, "C1STRZ"); break;
2249 case UFW_WARG_DATASKIP
: fprintf(stderr
, "DATA"); break;
2250 default: fprintf(stderr
, "wtf?!"); break;
2252 fputc('\n', stderr
);
2254 fprintf(stderr
, " BACKLEN: %u (nfa at 0x%08x)\n", ufoImgGetU8(cfa
- 1u), UFO_CFA_TO_NFA(cfa
));
2255 fprintf(stderr
, " NAME(%u): ", nlen
);
2256 for (uint32_t f
= 0; f
< nlen
; f
+= 1) {
2257 const uint8_t ch
= ufoImgGetU8(nfa
+ 4u + f
);
2258 if (ch
<= 32 || ch
>= 127) {
2259 fprintf(stderr
, "\\x%02x", ch
);
2261 fprintf(stderr
, "%c", (char)ch
);
2264 fprintf(stderr
, "\n");
2265 ufo_assert(UFO_CFA_TO_LFA(cfa
) == lfa
);
2270 //==========================================================================
2276 //==========================================================================
2277 static uint32_t ufoVocCheckName (uint32_t lfa
, const void *wname
, uint32_t wnlen
, uint32_t hash
,
2281 #ifdef UFO_DEBUG_FIND_WORD
2282 fprintf(stderr
, "CHECK-NAME: %.*s; LFA: 0x%08x; hash: 0x%08x (wname: 0x%08x)\n",
2283 (unsigned) wnlen
, (const char *)wname
,
2284 lfa
, (lfa
!= 0 ? ufoImgGetU32(UFO_LFA_TO_NHASH(lfa
)) : 0), hash
);
2285 ufoDumpWordHeader(lfa
);
2287 if (lfa
!= 0 && ufoImgGetU32(UFO_LFA_TO_NHASH(lfa
)) == hash
) {
2288 const uint32_t lenflags
= ufoImgGetU32(UFO_LFA_TO_NFA(lfa
));
2289 if ((lenflags
& UFW_FLAG_SMUDGE
) == 0 &&
2290 (allowvochid
|| (lenflags
& UFW_FLAG_HIDDEN
) == 0))
2292 const uint32_t nlen
= lenflags
&0xffU
;
2293 if (nlen
== wnlen
) {
2294 uint32_t naddr
= UFO_LFA_TO_NFA(lfa
) + 4u;
2296 while (pos
< nlen
) {
2297 uint8_t c0
= ((const unsigned char *)wname
)[pos
];
2298 if (c0
>= 'a' && c0
<= 'z') c0
= c0
- 'a' + 'A';
2299 uint8_t c1
= ufoImgGetU8(naddr
+ pos
);
2300 if (c1
>= 'a' && c1
<= 'z') c1
= c1
- 'a' + 'A';
2301 if (c0
!= c1
) break;
2307 res
= UFO_ALIGN4(naddr
);
2316 //==========================================================================
2322 //==========================================================================
2323 static uint32_t ufoFindWordInVoc (const void *wname
, uint32_t wnlen
, uint32_t hash
,
2324 uint32_t vocid
, int allowvochid
)
2327 if (wname
== NULL
) ufo_assert(wnlen
== 0);
2328 if (wnlen
!= 0 && vocid
!= 0) {
2329 if (hash
== 0) hash
= joaatHashBufCI(wname
, wnlen
);
2330 #if defined(UFO_DEBUG_FIND_WORD) || defined(UFO_DEBUG_FIND_WORD_IN_VOC)
2331 fprintf(stderr
, "IN-VOC: %.*s; VOCID: 0x%08x; whash: 0x%08x; htbl[0]: 0x%08x\n",
2332 (unsigned) wnlen
, (const char *)wname
,
2333 vocid
, hash
, ufoImgGetU32(vocid
+ UFW_VOCAB_OFS_HTABLE
));
2335 const uint32_t htbl
= vocid
+ UFW_VOCAB_OFS_HTABLE
;
2336 if (ufoImgGetU32(htbl
) != UFO_NO_HTABLE_FLAG
) {
2337 // hash table present, use it
2338 uint32_t bfa
= htbl
+ (hash
% (uint32_t)UFO_HASHTABLE_SIZE
) * 4u;
2339 bfa
= ufoImgGetU32(bfa
);
2340 while (res
== 0 && bfa
!= 0) {
2341 #if defined(UFO_DEBUG_FIND_WORD) || defined(UFO_DEBUG_FIND_WORD_IN_VOC)
2342 fprintf(stderr
, "IN-VOC: bfa: 0x%08x\n", bfa
);
2344 res
= ufoVocCheckName(UFO_BFA_TO_LFA(bfa
), wname
, wnlen
, hash
, allowvochid
);
2345 bfa
= ufoImgGetU32(bfa
);
2348 // no hash table, use linear search
2349 uint32_t lfa
= vocid
+ UFW_VOCAB_OFS_LATEST
;
2350 lfa
= ufoImgGetU32(lfa
);
2351 while (res
== 0 && lfa
!= 0) {
2352 res
= ufoVocCheckName(lfa
, wname
, wnlen
, hash
, allowvochid
);
2353 lfa
= ufoImgGetU32(lfa
);
2361 //==========================================================================
2365 // return part after the colon, or `NULL`
2367 //==========================================================================
2368 static const void *ufoFindColon (const void *wname
, uint32_t wnlen
) {
2369 const void *res
= NULL
;
2371 ufo_assert(wname
!= NULL
);
2372 const char *str
= (const char *)wname
;
2373 while (wnlen
!= 0 && str
[0] != ':') {
2374 str
+= 1; wnlen
-= 1;
2377 res
= (const void *)(str
+ 1); // skip colon
2384 //==========================================================================
2386 // ufoFindWordInVocAndParents
2388 //==========================================================================
2389 static uint32_t ufoFindWordInVocAndParents (const void *wname
, uint32_t wnlen
, uint32_t hash
,
2390 uint32_t vocid
, int allowvochid
)
2393 if (hash
== 0) hash
= joaatHashBufCI(wname
, wnlen
);
2394 while (res
== 0 && vocid
!= 0) {
2395 res
= ufoFindWordInVoc(wname
, wnlen
, hash
, vocid
, allowvochid
);
2396 vocid
= ufoImgGetU32(vocid
+ UFW_VOCAB_OFS_PARENT
);
2402 //==========================================================================
2404 // ufoFindWordNameRes
2406 // find with name resolution
2410 //==========================================================================
2411 static uint32_t ufoFindWordNameRes (const void *wname
, uint32_t wnlen
) {
2413 if (wnlen
!= 0 && *(const char *)wname
!= ':') {
2414 ufo_assert(wname
!= NULL
);
2416 const void *stx
= wname
;
2417 wname
= ufoFindColon(wname
, wnlen
);
2418 if (wname
!= NULL
) {
2419 // look in all vocabs (excluding hidden ones)
2420 uint32_t xlen
= (uint32_t)(ptrdiff_t)(wname
- stx
) - 1u;
2421 ufo_assert(xlen
> 0 && xlen
< 255);
2422 uint32_t xhash
= joaatHashBufCI(stx
, xlen
);
2423 uint32_t voclink
= ufoImgGetU32(ufoAddrVocLink
);
2424 #ifdef UFO_DEBUG_FIND_WORD_COLON
2425 fprintf(stderr
, "COLON-FIND: first voc: {%.*s}; xhash=0x%08x; voc-link: 0x%08x\n",
2426 (unsigned)xlen
, (const char *)stx
, xhash
, voclink
);
2428 while (res
== 0 && voclink
!= 0) {
2429 const uint32_t vhdraddr
= voclink
- UFW_VOCAB_OFS_VOCLINK
+ UFW_VOCAB_OFS_HEADER
;
2430 const uint32_t vhdr
= ufoImgGetU32(vhdraddr
);
2432 res
= ufoVocCheckName(UFO_NFA_TO_LFA(vhdr
), stx
, xlen
, xhash
, 0);
2434 if (res
== 0) voclink
= ufoImgGetU32(voclink
);
2437 uint32_t vocid
= voclink
- UFW_VOCAB_OFS_VOCLINK
;
2438 ufo_assert(voclink
!= 0);
2440 #ifdef UFO_DEBUG_FIND_WORD_COLON
2441 fprintf(stderr
, "searching {%.*s}(%u) in {%.*s}\n",
2442 (unsigned)wnlen
, wname
, wnlen
, (unsigned)xlen
, stx
);
2444 while (res
!= 0 && wname
!= NULL
) {
2445 // first, the whole rest
2446 res
= ufoFindWordInVocAndParents(wname
, wnlen
, 0, vocid
, 1);
2451 wname
= ufoFindColon(wname
, wnlen
);
2452 if (wname
== NULL
) xlen
= wnlen
; else xlen
= (uint32_t)(ptrdiff_t)(wname
- stx
) - 1u;
2453 ufo_assert(xlen
> 0 && xlen
< 255);
2454 res
= ufoFindWordInVocAndParents(stx
, xlen
, 0, vocid
, 1);
2457 if (wname
!= NULL
) {
2458 // it should be a vocabulary
2459 const uint32_t nfa
= UFO_CFA_TO_NFA(res
);
2460 if ((ufoImgGetU32(nfa
) & UFW_FLAG_VOCAB
) != 0) {
2461 vocid
= ufoImgGetU32(UFO_CFA_TO_PFA(res
)); // pfa points to vocabulary
2477 //==========================================================================
2481 // doesn't look in CURRENT, does name resolution ("a:b" is word "b" in "a")
2485 //==========================================================================
2486 static uint32_t ufoFindWord (const char *wname
) {
2488 if (wname
&& wname
[0] != 0) {
2489 const size_t wnlen
= strlen(wname
);
2490 ufo_assert(wnlen
< 8192);
2491 uint32_t ctx
= ufoImgGetU32(ufoAddrContext
);
2492 const uint32_t hash
= joaatHashBufCI(wname
, (uint32_t)wnlen
);
2494 //fprintf(stderr, "FIND-WORD: whash: 0x%08x; name:{%s}\n", hash, wname);
2496 // first search in context
2497 res
= ufoFindWordInVocAndParents(wname
, (uint32_t)wnlen
, hash
, ctx
, (ctx
== ufoImgGetU32(ufoAddrCurrent
)));
2499 // now try vocabulary stack
2500 uint32_t vstp
= ufoVSP
;
2501 while (res
== 0 && vstp
!= 0) {
2503 ctx
= ufoVocStack
[vstp
];
2504 res
= ufoFindWordInVocAndParents(wname
, (uint32_t)wnlen
, hash
, ctx
, (ctx
== ufoImgGetU32(ufoAddrCurrent
)));
2507 // if not found, try name resolution
2508 if (res
== 0) res
= ufoFindWordNameRes(wname
, (uint32_t)wnlen
);
2515 //==========================================================================
2517 // ufoCreateWordHeader
2519 // create word header up to CFA, link to the current dictionary
2521 //==========================================================================
2522 static void ufoCreateWordHeader (const char *wname
, uint32_t flags
) {
2523 if (wname
== NULL
) wname
= "";
2524 const size_t wnlen
= strlen(wname
);
2525 ufo_assert(wnlen
< UFO_MAX_WORD_LENGTH
);
2526 const uint32_t hash
= joaatHashBufCI(wname
, (uint32_t)wnlen
);
2527 const uint32_t curr
= ufoImgGetU32(ufoAddrCurrent
);
2528 ufo_assert(curr
!= 0);
2530 const uint32_t warn
= ufoImgGetU32(ufoAddrRedefineWarning
);
2531 if (wnlen
!= 0 && warn
!= UFO_REDEF_WARN_DONT_CARE
) {
2533 if (warn
!= UFO_REDEF_WARN_PARENTS
) {
2534 cfa
= ufoFindWordInVoc(wname
, wnlen
, hash
, curr
, 1);
2536 cfa
= ufoFindWordInVocAndParents(wname
, wnlen
, hash
, curr
, 1);
2539 const uint32_t nfa
= UFO_CFA_TO_NFA(cfa
);
2540 const uint32_t flags
= ufoImgGetU32(nfa
);
2541 if ((flags
& UFW_FLAG_PROTECTED
) != 0) {
2542 ufoFatal("trying to redefine protected word '%s'", wname
);
2543 } else if (warn
!= UFO_REDEF_WARN_NONE
) {
2544 ufoWarning("redefining word '%s'", wname
);
2548 //fprintf(stderr, "000: HERE: 0x%08x\n", UFO_GET_DP());
2549 const uint32_t bkt
= (hash
% (uint32_t)UFO_HASHTABLE_SIZE
) * 4u;
2550 const uint32_t htbl
= curr
+ UFW_VOCAB_OFS_HTABLE
;
2552 const uint32_t xfaAddr
= UFO_GET_DP();
2553 if ((xfaAddr
& UFO_ADDR_TEMP_BIT
) == 0) {
2554 // link previous yfa here
2555 const uint32_t lastxfa
= ufoImgGetU32(ufoAddrLastXFA
);
2556 // fix YFA of the previous word
2558 ufoImgPutU32(UFO_XFA_TO_YFA(lastxfa
), UFO_XFA_TO_YFA(xfaAddr
));
2560 // our XFA points to the previous XFA
2561 ufoImgEmitU32(lastxfa
); // xfa
2563 ufoImgPutU32(ufoAddrLastXFA
, xfaAddr
);
2565 ufoImgEmitU32(0); // xfa
2567 ufoImgEmitU32(0); // yfa
2568 // bucket link (bfa)
2569 if (wnlen
== 0 || ufoImgGetU32(htbl
) == UFO_NO_HTABLE_FLAG
) {
2572 #ifdef UFO_DEBUG_DUMP_NEW_HEADERS
2573 fprintf(stderr
, "NEW HEADER: %s; curr: 0x%08x; htbl: 0x%08x; bkt: 0x%08x\n",
2574 wname
, curr
, htbl
, bkt
);
2575 fprintf(stderr
, " [bkt]: 0x%08x; nbk: 0x%08x\n", ufoImgGetU32(htbl
+ bkt
), UFO_GET_DP());
2577 // bfa points to bfa
2578 const uint32_t bfa
= UFO_GET_DP();
2579 ufoImgEmitU32(ufoImgGetU32(htbl
+ bkt
));
2580 ufoImgPutU32(htbl
+ bkt
, bfa
);
2583 const uint32_t lfa
= UFO_GET_DP();
2584 ufoImgEmitU32(ufoImgGetU32(curr
+ UFW_VOCAB_OFS_LATEST
));
2586 ufoImgPutU32(curr
+ UFW_VOCAB_OFS_LATEST
, lfa
);
2588 ufoImgEmitU32(hash
);
2590 const uint32_t nfa
= UFO_GET_DP();
2591 ufoImgEmitU32(((uint32_t)wnlen
&0xffU
) | (flags
& 0xffffff00U
));
2592 const uint32_t nstart
= UFO_GET_DP();
2594 for (size_t f
= 0; f
< wnlen
; f
+= 1) {
2595 ufoImgEmitU8(((const unsigned char *)wname
)[f
]);
2597 while ((UFO_GET_DP() & 3) != 3) ufoImgEmitU8(0);
2598 const uint32_t nend
= UFO_GET_DP(); // length byte itself is not included
2599 // name length, again
2600 ufo_assert(nend
- nstart
<= 255);
2601 ufoImgEmitU8((uint8_t)(nend
- nstart
));
2602 ufo_assert((UFO_GET_DP() & 3) == 0);
2603 ufo_assert(UFO_CFA_TO_NFA(UFO_GET_DP()) == nfa
);
2604 if ((nend
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) ufoRecordDebug(nend
);
2605 #ifdef UFO_DEBUG_DUMP_NEW_HEADERS
2606 fprintf(stderr
, "*** NEW HEADER ***\n");
2607 fprintf(stderr
, "CFA: 0x%08x\n", UFO_GET_DP());
2608 fprintf(stderr
, "NSTART: 0x%08x\n", nstart
);
2609 fprintf(stderr
, "NEND: 0x%08x\n", nend
);
2610 fprintf(stderr
, "NLEN: %u (%u)\n", nend
- nstart
, ufoImgGetU8(UFO_GET_DP() - 1u));
2611 ufoDumpWordHeader(lfa
);
2614 fprintf(stderr
, "NEW WORD CFA 0x%08x: %s\n", UFO_GET_DP(), wname
);
2619 //==========================================================================
2623 //==========================================================================
2624 static void ufoDecompilePart (uint32_t addr
, uint32_t eaddr
, int indent
) {
2627 while (addr
< eaddr
) {
2628 uint32_t cfa
= ufoImgGetU32(addr
);
2629 for (int n
= 0; n
< indent
; n
+= 1) fputc(' ', fo
);
2630 fprintf(fo
, "%6u: 0x%08x: ", addr
, cfa
);
2631 uint32_t nfa
= UFO_CFA_TO_NFA(cfa
);
2632 uint32_t flags
= ufoImgGetU32(nfa
);
2633 //fprintf(fo, "[0x%08x] ", flags & UFW_WARG_MASK);
2634 uint32_t nlen
= flags
& 0xffU
;
2635 for (uint32_t f
= 0; f
< nlen
; f
+= 1) {
2636 const uint8_t ch
= ufoImgGetU8(nfa
+ 4u + f
);
2637 if (ch
<= 32 || ch
>= 127) {
2638 fprintf(fo
, "\\x%02x", ch
);
2640 fprintf(fo
, "%c", (char)ch
);
2644 switch (flags
& UFW_WARG_MASK
) {
2647 case UFW_WARG_BRANCH
:
2648 fprintf(fo
, " @%u", ufoImgGetU32(addr
)); addr
+= 4u;
2651 fprintf(fo
, " %u : %d : 0x%08x", ufoImgGetU32(addr
),
2652 (int32_t)ufoImgGetU32(addr
), ufoImgGetU32(addr
)); addr
+= 4u;
2654 case UFW_WARG_C4STRZ
:
2655 count
= ufoImgGetU32(addr
); addr
+= 4;
2657 fprintf(fo
, " str:");
2658 for (int f
= 0; f
< count
; f
+= 1) {
2659 const uint8_t ch
= ufoImgGetU8(addr
); addr
+= 1u;
2660 if (ch
<= 32 || ch
>= 127) {
2661 fprintf(fo
, "\\x%02x", ch
);
2663 fprintf(fo
, "%c", (char)ch
);
2666 addr
+= 1u; // skip zero byte
2667 addr
= UFO_ALIGN4(addr
);
2670 cfa
= ufoImgGetU32(addr
); addr
+= 4u;
2671 fprintf(fo
, " CFA:%u: ", cfa
);
2672 nfa
= UFO_CFA_TO_NFA(cfa
);
2673 nlen
= ufoImgGetU8(nfa
);
2674 for (uint32_t f
= 0; f
< nlen
; f
+= 1) {
2675 const uint8_t ch
= ufoImgGetU8(nfa
+ 4u + f
);
2676 if (ch
<= 32 || ch
>= 127) {
2677 fprintf(fo
, "\\x%02x", ch
);
2679 fprintf(fo
, "%c", (char)ch
);
2683 case UFW_WARG_CBLOCK
:
2684 fprintf(fo
, " CBLOCK:%u", ufoImgGetU32(addr
)); addr
+= 4u;
2686 case UFW_WARG_VOCID
:
2687 fprintf(fo
, " VOCID:%u", ufoImgGetU32(addr
)); addr
+= 4u;
2689 case UFW_WARG_C1STRZ
:
2690 count
= ufoImgGetU8(addr
); addr
+= 1;
2692 case UFW_WARG_DATASKIP
:
2693 fprintf(fo
, " DATA:%u", ufoImgGetU32(addr
));
2694 addr
+= ufoImgGetU32(addr
) + 4u;
2697 fprintf(fo
, " -- WTF?!\n");
2705 //==========================================================================
2709 //==========================================================================
2710 static void ufoDecompileWord (const uint32_t cfa
) {
2712 const uint32_t lfa
= UFO_CFA_TO_LFA(cfa
);
2713 fprintf(stdout
, "#### DECOMPILING CFA %u ###\n", cfa
);
2714 ufoDumpWordHeader(lfa
);
2715 const uint32_t yfa
= ufoGetWordEndAddr(cfa
);
2716 if (ufoImgGetU32(cfa
) == ufoDoForthCFA
) {
2717 fprintf(stdout
, "--- DECOMPILED CODE ---\n");
2718 ufoDecompilePart(UFO_CFA_TO_PFA(cfa
), yfa
, 0);
2719 fprintf(stdout
, "=======================\n");
2725 //==========================================================================
2727 // ufoBTShowWordName
2729 //==========================================================================
2730 static void ufoBTShowWordName (uint32_t nfa
) {
2732 uint32_t len
= ufoImgGetU8(nfa
); nfa
+= 4u;
2733 //fprintf(stderr, "(0x%08x)", ufoImgGetU32(nfa - 4u));
2735 uint8_t ch
= ufoImgGetU8(nfa
); nfa
+= 1u; len
-= 1u;
2736 if (ch
<= 32 || ch
>= 127) {
2737 fprintf(stderr
, "\\x%02x", ch
);
2739 fprintf(stderr
, "%c", (char)ch
);
2746 //==========================================================================
2750 //==========================================================================
2751 static void ufoBacktrace (uint32_t ip
, int showDataStack
) {
2752 // dump data stack (top 16)
2754 if (!ufoLastEmitWasCR
) { printf("\n"); ufoLastEmitWasCR
= 1; }
2756 if (showDataStack
) {
2757 fprintf(stderr
, "***UFO STACK DEPTH: %u\n", ufoSP
);
2758 uint32_t xsp
= ufoSP
;
2759 if (xsp
> 16) xsp
= 16;
2760 for (uint32_t sp
= 0; sp
< xsp
; ++sp
) {
2761 fprintf(stderr
, " %2u: 0x%08x %d%s\n",
2762 sp
, ufoDStack
[xsp
- sp
- 1], (int32_t)ufoDStack
[xsp
- sp
- 1],
2763 (sp
== 0 ? " -- TOS" : ""));
2765 if (ufoSP
> 16) fprintf(stderr
, " ...more...\n");
2768 // dump return stack (top 32)
2773 fprintf(stderr
, "***UFO RETURN STACK DEPTH: %u\n", ufoRP
);
2775 nfa
= ufoFindWordForIP(ip
);
2777 fprintf(stderr
, " **: %8u -- ", ip
);
2778 ufoBTShowWordName(nfa
);
2779 fname
= ufoFindFileForIP(ip
, &fline
, NULL
, NULL
);
2780 if (fname
!= NULL
) { fprintf(stderr
, " (at %s:%u)", fname
, fline
); }
2781 fputc('\n', stderr
);
2784 uint32_t rp
= ufoRP
;
2785 uint32_t rscount
= 0;
2786 if (rp
> UFO_RSTACK_SIZE
) rp
= UFO_RSTACK_SIZE
;
2787 while (rscount
!= 32 && rp
!= 0) {
2789 const uint32_t val
= ufoRStack
[rp
];
2790 nfa
= ufoFindWordForIP(val
);
2792 fprintf(stderr
, " %2u: %8u -- ", ufoRP
- rp
- 1u, val
);
2793 ufoBTShowWordName(nfa
);
2794 fname
= ufoFindFileForIP(val
- 4u, &fline
, NULL
, NULL
);
2795 if (fname
!= NULL
) { fprintf(stderr
, " (at %s:%u)", fname
, fline
); }
2796 fputc('\n', stderr
);
2798 fprintf(stderr
, " %2u: 0x%08x %d\n", ufoRP
- rp
- 1u, val
, (int32_t)val
);
2802 if (ufoRP
> 32) fprintf(stderr
, " ...more...\n");
2808 //==========================================================================
2812 //==========================================================================
2814 static void ufoDumpVocab (uint32_t vocid) {
2816 fprintf(stderr, "*** VOCID: 0x%08x ***\n", vocid);
2817 uint32_t vochdr = vocid + UFW_VOCAB_OFS_HEADER;
2818 vochdr = ufoImgGetU32(vochdr);
2820 fprintf(stderr, "--- HEADER ---\n");
2821 ufoDumpWordHeader(UFO_NFA_TO_LFA(vochdr));
2822 fprintf(stderr, "========\n");
2823 uint32_t htbl = vocid + UFW_VOCAB_OFS_HTABLE;
2824 if (ufoImgGetU32(htbl) != UFO_NO_HTABLE_FLAG) {
2825 fprintf(stderr, "--- HASH TABLE ---\n");
2826 for (int f = 0; f < UFO_HASHTABLE_SIZE; f += 1) {
2827 uint32_t bfa = ufoImgGetU32(htbl);
2829 fprintf(stderr, "**** %2d: 0x%08x\n", f, bfa);
2831 ufoDumpWordHeader(UFO_BFA_TO_LFA(bfa));
2832 bfa = ufoImgGetU32(bfa);
2844 // if set, this will be used when we are out of include files. intended for UrAsm.
2845 // return 0 if there is no more lines, otherwise the string should be copied
2846 // to buffer, `*fname` and `*fline` should be properly set.
2847 int (*ufoFileReadLine
) (void *buf
, size_t bufsize
, const char **fname
, int *fline
) = NULL
;
2850 //==========================================================================
2852 // ufoLoadNextUserLine
2854 //==========================================================================
2855 static int ufoLoadNextUserLine (void) {
2856 uint32_t tibPos
= 0;
2857 const char *fname
= NULL
;
2860 if (ufoFileReadLine
!= NULL
&& ufoFileReadLine(ufoCurrFileLine
, 510, &fname
, &fline
) != 0) {
2861 ufoCurrFileLine
[510] = 0;
2862 uint32_t slen
= (uint32_t)strlen(ufoCurrFileLine
);
2863 while (slen
!= 0 && (ufoCurrFileLine
[slen
- 1u] == 10 || ufoCurrFileLine
[slen
- 1u] == 13)) {
2866 if (tibPos
+ slen
+ 1u > UFO_ADDR_HANDLE_OFS_MASK
) {
2867 ufoFatal("input text line too long (at least %u bytes)", tibPos
+ slen
);
2869 ufoTibEnsureSize(tibPos
+ slen
+ 1u);
2870 for (uint32_t f
= 0; f
< slen
; f
+= 1) {
2871 ufoTibPokeChOfs(((const unsigned char *)ufoCurrFileLine
)[f
], tibPos
+ f
);
2873 ufoTibPokeChOfs(0, tibPos
+ slen
);
2875 if (fname
== NULL
) fname
= "<user>";
2876 ufoSetInFileName(fname
);
2877 ufoInFileLine
= fline
;
2885 //==========================================================================
2887 // ufoLoadNextLine_NativeMode
2889 // load next file line into TIB
2890 // always strips final '\n'
2892 // return 0 on EOF, 1 on success
2894 //==========================================================================
2895 static int ufoLoadNextLine (int crossInclude
) {
2897 uint32_t tibPos
= 0;
2900 if (ufoMode
== UFO_MODE_MACRO
) {
2901 //fprintf(stderr, "***MAC!\n");
2905 while (ufoInFile
!= NULL
&& !done
) {
2906 if (fgets(ufoCurrFileLine
, 510, ufoInFile
) != NULL
) {
2907 // check for a newline
2908 // if there is no newline char at the end, the string was truncated
2909 ufoCurrFileLine
[510] = 0;
2910 const uint32_t slen
= (uint32_t)strlen(ufoCurrFileLine
);
2911 if (tibPos
+ slen
+ 1u > UFO_ADDR_HANDLE_OFS_MASK
) {
2912 ufoFatal("input text line too long (at least %u bytes)", tibPos
+ slen
);
2914 ufoTibEnsureSize(tibPos
+ slen
+ 1u);
2915 for (uint32_t f
= 0; f
< slen
; f
+= 1) {
2916 ufoTibPokeChOfs(((const unsigned char *)ufoCurrFileLine
)[f
], tibPos
+ f
);
2918 ufoTibPokeChOfs(0, tibPos
+ slen
);
2920 if (slen
!= 0 && (ufoCurrFileLine
[slen
- 1u] == 13 || ufoCurrFileLine
[slen
- 1u] == 10)) {
2924 // continuation, nothing to do
2927 // if we read nothing, this is EOF
2928 if (tibPos
== 0 && crossInclude
) {
2929 // we read nothing, and allowed to cross include boundaries
2938 // eof, try user-supplied input
2939 if (ufoFileStackPos
== 0) {
2940 return ufoLoadNextUserLine();
2945 // if we read at least something, this is not EOF
2951 // ////////////////////////////////////////////////////////////////////////// //
2956 UFWORD(DUMP_STACK
) {
2957 if (!ufoLastEmitWasCR
) { printf("\n"); ufoLastEmitWasCR
= 1; }
2958 printf("***UFO STACK DEPTH: %u\n", ufoSP
);
2959 uint32_t xsp
= ufoSP
;
2960 if (xsp
> 16) xsp
= 16;
2961 for (uint32_t sp
= 0; sp
< xsp
; ++sp
) {
2962 printf(" %2u: 0x%08x %d%s\n",
2963 sp
, ufoDStack
[xsp
- sp
- 1], (int32_t)ufoDStack
[xsp
- sp
- 1],
2964 (sp
== 0 ? " -- TOS" : ""));
2966 if (ufoSP
> 16) printf(" ...more...\n");
2967 ufoLastEmitWasCR
= 1;
2972 UFWORD(UFO_BACKTRACE
) {
2974 if (!ufoLastEmitWasCR
) { printf("\n"); ufoLastEmitWasCR
= 1; }
2975 if (ufoInFile
!= NULL
) {
2976 fprintf(stderr
, "*** at file %s, line %d ***\n", ufoInFileName
, ufoInFileLine
);
2978 fprintf(stderr
, "*** somewhere in time ***\n");
2980 ufoBacktrace(ufoIP
, 1);
2985 UFWORD(DUMP_STACK_TASK
) {
2986 UfoState
*st
= ufoFindState(ufoPop());
2987 if (st
== NULL
) ufoFatal("invalid state id");
2988 // temporarily switch the task
2989 UfoState
*oldst
= ufoCurrState
; ufoCurrState
= st
;
2991 if (!ufoLastEmitWasCR
) { printf("\n"); ufoLastEmitWasCR
= 1; }
2992 printf("***UFO STACK DEPTH: %u\n", ufoSP
);
2993 uint32_t xsp
= ufoSP
;
2994 if (xsp
> 16) xsp
= 16;
2995 for (uint32_t sp
= 0; sp
< xsp
; ++sp
) {
2996 printf(" %2u: 0x%08x %d%s\n",
2997 sp
, ufoDStack
[xsp
- sp
- 1], (int32_t)ufoDStack
[xsp
- sp
- 1],
2998 (sp
== 0 ? " -- TOS" : ""));
3000 if (ufoSP
> 16) printf(" ...more...\n");
3001 ufoLastEmitWasCR
= 1;
3003 ufoCurrState
= oldst
;
3008 UFWORD(DUMP_RSTACK_TASK
) {
3009 UfoState
*st
= ufoFindState(ufoPop());
3010 if (st
== NULL
) ufoFatal("invalid state id");
3011 // temporarily switch the task
3012 UfoState
*oldst
= ufoCurrState
; ufoCurrState
= st
;
3015 if (!ufoLastEmitWasCR
) { printf("\n"); ufoLastEmitWasCR
= 1; }
3016 if (ufoInFile
!= NULL
) {
3017 fprintf(stderr
, "*** at file %s, line %d ***\n", ufoInFileName
, ufoInFileLine
);
3019 fprintf(stderr
, "*** somewhere in time ***\n");
3021 ufoBacktrace(ufoIP
, 0);
3023 ufoCurrState
= oldst
;
3028 UFWORD(UFO_BACKTRACE_TASK
) {
3029 UfoState
*st
= ufoFindState(ufoPop());
3030 if (st
== NULL
) ufoFatal("invalid state id");
3031 // temporarily switch the task
3032 UfoState
*oldst
= ufoCurrState
; ufoCurrState
= st
;
3035 if (!ufoLastEmitWasCR
) { printf("\n"); ufoLastEmitWasCR
= 1; }
3036 if (ufoInFile
!= NULL
) {
3037 fprintf(stderr
, "*** at file %s, line %d ***\n", ufoInFileName
, ufoInFileLine
);
3039 fprintf(stderr
, "*** somewhere in time ***\n");
3041 ufoBacktrace(ufoIP
, 1);
3043 ufoCurrState
= oldst
;
3047 // ////////////////////////////////////////////////////////////////////////// //
3048 // some init words, and PAD
3053 UFWORD(SP0_STORE
) { ufoSP
= 0; }
3058 if (ufoRP
!= ufoRPTop
) {
3060 // we need to push a dummy value
3061 ufoRPush(0xdeadf00d);
3067 // PAD is at the beginning of temp area
3069 ufoPush(UFO_PAD_ADDR
);
3073 // ////////////////////////////////////////////////////////////////////////// //
3074 // peeks and pokes with address register
3085 UFWORD(REGA_STORE
) {
3093 const uint32_t newa
= ufoPop();
3106 UFWORD(REGA_INC_CELL
) {
3119 ufoRegA
= ufoRPop();
3123 // ////////////////////////////////////////////////////////////////////////// //
3124 // useful to work with handles and normal addreses uniformly
3129 UFWORD(CPEEK_REGA_IDX
) {
3130 if ((ufoRegA
& UFO_ADDR_HANDLE_BIT
) == 0) {
3131 const uint32_t idx
= ufoPop();
3132 const uint32_t newaddr
= ufoRegA
+ idx
;
3133 if ((ufoRegA
& UFO_ADDR_SPECIAL_BITS_MASK
) == (newaddr
& UFO_ADDR_SPECIAL_BITS_MASK
)) {
3134 ufoPush(ufoImgGetU8Ext(newaddr
));
3136 ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
3137 ufoRegA
, idx
, newaddr
);
3141 UFCALL(PAR_HANDLE_LOAD_BYTE
);
3147 UFWORD(WPEEK_REGA_IDX
) {
3148 if ((ufoRegA
& UFO_ADDR_HANDLE_BIT
) == 0) {
3149 const uint32_t idx
= ufoPop();
3150 const uint32_t newaddr
= ufoRegA
+ idx
;
3151 if ((ufoRegA
& UFO_ADDR_SPECIAL_BITS_MASK
) == (newaddr
& UFO_ADDR_SPECIAL_BITS_MASK
) &&
3152 (ufoRegA
& UFO_ADDR_SPECIAL_BITS_MASK
) == ((newaddr
+ 1u) & UFO_ADDR_SPECIAL_BITS_MASK
))
3154 ufoPush(ufoImgGetU16(newaddr
));
3156 ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
3157 ufoRegA
, idx
, newaddr
);
3161 UFCALL(PAR_HANDLE_LOAD_WORD
);
3167 UFWORD(PEEK_REGA_IDX
) {
3168 if ((ufoRegA
& UFO_ADDR_HANDLE_BIT
) == 0) {
3169 const uint32_t idx
= ufoPop();
3170 const uint32_t newaddr
= ufoRegA
+ idx
;
3171 if ((ufoRegA
& UFO_ADDR_SPECIAL_BITS_MASK
) == (newaddr
& UFO_ADDR_SPECIAL_BITS_MASK
) &&
3172 (ufoRegA
& UFO_ADDR_SPECIAL_BITS_MASK
) == ((newaddr
+ 3u) & UFO_ADDR_SPECIAL_BITS_MASK
))
3174 ufoPush(ufoImgGetU32(newaddr
));
3176 ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
3177 ufoRegA
, idx
, newaddr
);
3181 UFCALL(PAR_HANDLE_LOAD_CELL
);
3187 UFWORD(CPOKE_REGA_IDX
) {
3188 if ((ufoRegA
& UFO_ADDR_HANDLE_BIT
) == 0) {
3189 const uint32_t idx
= ufoPop();
3190 const uint32_t newaddr
= ufoRegA
+ idx
;
3191 if ((ufoRegA
& UFO_ADDR_SPECIAL_BITS_MASK
) == (newaddr
& UFO_ADDR_SPECIAL_BITS_MASK
)) {
3192 const uint32_t value
= ufoPop();
3193 ufoImgPutU8(newaddr
, value
);
3195 ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
3196 ufoRegA
, idx
, newaddr
);
3200 UFCALL(PAR_HANDLE_STORE_BYTE
);
3206 UFWORD(WPOKE_REGA_IDX
) {
3207 if ((ufoRegA
& UFO_ADDR_HANDLE_BIT
) == 0) {
3208 const uint32_t idx
= ufoPop();
3209 const uint32_t newaddr
= ufoRegA
+ idx
;
3210 if ((ufoRegA
& UFO_ADDR_SPECIAL_BITS_MASK
) == (newaddr
& UFO_ADDR_SPECIAL_BITS_MASK
) &&
3211 (ufoRegA
& UFO_ADDR_SPECIAL_BITS_MASK
) == ((newaddr
+ 1u) & UFO_ADDR_SPECIAL_BITS_MASK
))
3213 const uint32_t value
= ufoPop();
3214 ufoImgPutU16(newaddr
, value
);
3216 ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
3217 ufoRegA
, idx
, newaddr
);
3221 UFCALL(PAR_HANDLE_STORE_WORD
);
3227 UFWORD(POKE_REGA_IDX
) {
3228 if ((ufoRegA
& UFO_ADDR_HANDLE_BIT
) == 0) {
3229 const uint32_t idx
= ufoPop();
3230 const uint32_t newaddr
= ufoRegA
+ idx
;
3231 if ((ufoRegA
& UFO_ADDR_SPECIAL_BITS_MASK
) == (newaddr
& UFO_ADDR_SPECIAL_BITS_MASK
) &&
3232 (ufoRegA
& UFO_ADDR_SPECIAL_BITS_MASK
) == ((newaddr
+ 3u) & UFO_ADDR_SPECIAL_BITS_MASK
))
3234 const uint32_t value
= ufoPop();
3235 ufoImgPutU32(newaddr
, value
);
3237 ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
3238 ufoRegA
, idx
, newaddr
);
3242 UFCALL(PAR_HANDLE_STORE_CELL
);
3247 // ////////////////////////////////////////////////////////////////////////// //
3252 // ( addr -- value8 )
3254 ufoPush(ufoImgGetU8Ext(ufoPop()));
3258 // ( addr -- value16 )
3260 const uint32_t addr
= ufoPop();
3261 if ((addr
& UFO_ADDR_HANDLE_BIT
) == 0) {
3262 ufoPush(ufoImgGetU16(addr
));
3266 UFCALL(PAR_HANDLE_LOAD_WORD
);
3271 // ( addr -- value32 )
3273 const uint32_t addr
= ufoPop();
3274 if ((addr
& UFO_ADDR_HANDLE_BIT
) == 0) {
3275 ufoPush(ufoImgGetU32(addr
));
3279 UFCALL(PAR_HANDLE_LOAD_CELL
);
3286 const uint32_t addr
= ufoPop();
3287 const uint32_t val
= ufoPop();
3288 ufoImgPutU8Ext(addr
, val
);
3292 // ( val16 addr -- )
3294 const uint32_t addr
= ufoPop();
3295 const uint32_t val
= ufoPop();
3296 if ((addr
& UFO_ADDR_HANDLE_BIT
) == 0) {
3297 ufoImgPutU16(addr
, val
);
3302 UFCALL(PAR_HANDLE_STORE_WORD
);
3307 // ( val32 addr -- )
3309 const uint32_t addr
= ufoPop();
3310 const uint32_t val
= ufoPop();
3311 if ((addr
& UFO_ADDR_HANDLE_BIT
) == 0) {
3312 ufoImgPutU32(addr
, val
);
3317 UFCALL(PAR_HANDLE_STORE_CELL
);
3322 // ////////////////////////////////////////////////////////////////////////// //
3323 // dictionary emitters
3328 UFWORD(CCOMMA
) { const uint32_t val
= ufoPop(); ufoImgEmitU8(val
); }
3332 UFWORD(WCOMMA
) { const uint32_t val
= ufoPop(); ufoImgEmitU8(val
&0xffU
); ufoImgEmitU8((val
>> 8)&0xffU
); }
3336 UFWORD(COMMA
) { const uint32_t val
= ufoPop(); ufoImgEmitU32(val
); }
3339 // ////////////////////////////////////////////////////////////////////////// //
3345 const uint32_t v
= ufoImgGetU32(ufoIP
); ufoIP
+= 4;
3349 // (LITCFA) ( -- n )
3350 UFWORD(PAR_LITCFA
) {
3351 const uint32_t v
= ufoImgGetU32(ufoIP
); ufoIP
+= 4;
3355 // (LITVOCID) ( -- n )
3356 UFWORD(PAR_LITVOCID
) {
3357 const uint32_t v
= ufoImgGetU32(ufoIP
); ufoIP
+= 4;
3362 UFWORD(PAR_LITSTR8
) {
3363 const uint32_t count
= ufoImgGetU8(ufoIP
); ufoIP
+= 1;
3366 ufoIP
+= count
+ 1; // 1 for terminating 0
3368 ufoIP
= UFO_ALIGN4(ufoIP
);
3372 // ////////////////////////////////////////////////////////////////////////// //
3377 UFWORD(PAR_BRANCH
) {
3378 ufoIP
= ufoImgGetU32(ufoIP
);
3381 // (TBRANCH) ( flag )
3382 UFWORD(PAR_TBRANCH
) {
3384 ufoIP
= ufoImgGetU32(ufoIP
);
3390 // (0BRANCH) ( flag )
3391 UFWORD(PAR_0BRANCH
) {
3393 ufoIP
= ufoImgGetU32(ufoIP
);
3399 // (+0BRANCH) ( flag )
3400 UFWORD(PAR_P0BRANCH
) {
3401 if ((ufoPop() & 0x80000000u
) == 0) {
3402 ufoIP
= ufoImgGetU32(ufoIP
);
3408 // (+BRANCH) ( flag )
3409 UFWORD(PAR_PBRANCH
) {
3410 const uint32_t v
= ufoPop();
3411 if (v
> 0 && v
< 0x80000000u
) {
3412 ufoIP
= ufoImgGetU32(ufoIP
);
3418 // (-0BRANCH) ( flag )
3419 UFWORD(PAR_M0BRANCH
) {
3420 const uint32_t v
= ufoPop();
3421 if (v
== 0 || v
>= 0x80000000u
) {
3422 ufoIP
= ufoImgGetU32(ufoIP
);
3428 // (-BRANCH) ( flag )
3429 UFWORD(PAR_MBRANCH
) {
3430 if ((ufoPop() & 0x80000000u
) != 0) {
3431 ufoIP
= ufoImgGetU32(ufoIP
);
3437 // (DATASKIP) ( -- )
3438 UFWORD(PAR_DATASKIP
) {
3439 ufoIP
+= ufoImgGetU32(ufoIP
) + 4u;
3443 // ////////////////////////////////////////////////////////////////////////// //
3444 // execute words by CFA
3453 // EXECUTE-TAIL ( cfa )
3454 UFWORD(EXECUTE_TAIL
) {
3461 // ////////////////////////////////////////////////////////////////////////// //
3462 // word termination, locals support
3472 UFWORD(PAR_LENTER
) {
3473 // low byte of loccount is total number of locals
3474 // high byte is the number of args
3475 uint32_t lcount
= ufoImgGetU32(ufoIP
); ufoIP
+= 4u;
3476 uint32_t acount
= (lcount
>> 8) & 0xff;
3478 if (lcount
== 0 || lcount
< acount
) ufoFatal("invalid call to (L-ENTER)");
3479 if ((ufoLBP
!= 0 && ufoLBP
>= ufoLP
) || UFO_LSTACK_SIZE
- ufoLP
<= lcount
+ 2) {
3480 ufoFatal("out of locals stack");
3483 if (ufoLP
== 0) { ufoLP
= 1; newbp
= 1; } else newbp
= ufoLP
;
3484 //fprintf(stderr, "LP: %u; LBP: %u; locs: %u; word: %s\n", ufoLP, ufoLBP, fw->locs, fw->name);
3485 ufoLStack
[ufoLP
] = ufoLBP
; ufoLP
+= 1;
3486 ufoLBP
= newbp
; ufoLP
+= lcount
;
3489 while (newbp
!= ufoLBP
) {
3490 ufoLStack
[newbp
] = ufoPop();
3496 UFWORD(PAR_LLEAVE
) {
3497 if (ufoLBP
== 0) ufoFatal("(L-LEAVE) with empty locals stack");
3498 if (ufoLBP
>= ufoLP
) ufoFatal("(L-LEAVE) broken locals stack");
3500 ufoLBP
= ufoLStack
[ufoLBP
];
3503 //==========================================================================
3507 //==========================================================================
3508 UFO_FORCE_INLINE
void ufoLoadLocal (const uint32_t lidx
) {
3509 if (lidx
== 0 || lidx
>= UFO_LSTACK_SIZE
) ufoFatal("invalid local index");
3510 if (ufoLBP
== 0 || ufoLBP
>= ufoLP
|| ufoLP
- ufoLBP
<= lidx
) ufoFatal("invalid local index");
3511 ufoPush(ufoLStack
[ufoLBP
+ lidx
]);
3514 //==========================================================================
3518 //==========================================================================
3519 UFO_FORCE_INLINE
void ufoStoreLocal (const uint32_t lidx
) {
3520 const uint32_t value
= ufoPop();
3521 if (lidx
== 0 || lidx
>= UFO_LSTACK_SIZE
) ufoFatal("invalid local index");
3522 if (ufoLBP
== 0 || ufoLBP
>= ufoLP
|| ufoLP
- ufoLBP
<= lidx
) ufoFatal("invalid local index");
3523 ufoLStack
[ufoLBP
+ lidx
] = value
;
3528 UFWORD(PAR_LOCAL_LOAD
) { ufoLoadLocal(ufoPop()); }
3532 UFWORD(PAR_LOCAL_STORE
) { ufoStoreLocal(ufoPop()); }
3535 // ////////////////////////////////////////////////////////////////////////// //
3536 // stack manipulation
3541 UFWORD(DUP
) { ufoDup(); }
3543 // ( n -- n n ) | ( 0 -- 0 )
3544 UFWORD(QDUP
) { if (ufoPeek()) ufoDup(); }
3546 // ( n0 n1 -- n0 n1 n0 n1 )
3547 UFWORD(DDUP
) { ufo2Dup(); }
3550 UFWORD(DROP
) { ufoDrop(); }
3553 UFWORD(DDROP
) { ufo2Drop(); }
3555 // ( n0 n1 -- n1 n0 )
3556 UFWORD(SWAP
) { ufoSwap(); }
3558 // ( n0 n1 -- n1 n0 )
3559 UFWORD(DSWAP
) { ufo2Swap(); }
3561 // ( n0 n1 -- n0 n1 n0 )
3562 UFWORD(OVER
) { ufoOver(); }
3564 // ( n0 n1 -- n0 n1 n0 )
3565 UFWORD(DOVER
) { ufo2Over(); }
3567 // ( n0 n1 n2 -- n1 n2 n0 )
3568 UFWORD(ROT
) { ufoRot(); }
3570 // ( n0 n1 n2 -- n2 n0 n1 )
3571 UFWORD(NROT
) { ufoNRot(); }
3575 UFWORD(RDUP
) { ufoRDup(); }
3578 UFWORD(RDROP
) { ufoRDrop(); }
3582 UFWORD(DTOR
) { ufoRPush(ufoPop()); }
3585 UFWORD(RTOD
) { ufoPush(ufoRPop()); }
3588 UFWORD(RPEEK
) { ufoPush(ufoRPeek()); }
3593 const uint32_t n
= ufoPop();
3594 if (n
>= ufoSP
) ufoFatal("invalid PICK index %u", n
);
3595 ufoPush(ufoDStack
[ufoSP
- n
- 1u]);
3601 const uint32_t n
= ufoPop();
3602 if (n
>= ufoRP
- ufoRPTop
) ufoFatal("invalid RPICK index %u", n
);
3603 const uint32_t rp
= ufoRP
- n
- 1u;
3604 ufoPush(ufoRStack
[rp
]);
3610 const uint32_t n
= ufoPop();
3611 if (n
>= ufoSP
) ufoFatal("invalid ROLL index %u", n
);
3613 case 0: break; // do nothing
3614 case 1: ufoSwap(); break;
3615 case 2: ufoRot(); break;
3618 const uint32_t val
= ufoDStack
[ufoSP
- n
- 1u];
3619 for (uint32_t f
= ufoSP
- n
; f
< ufoSP
; f
+= 1) ufoDStack
[f
- 1] = ufoDStack
[f
];
3620 ufoDStack
[ufoSP
- 1u] = val
;
3629 const uint32_t n
= ufoPop();
3630 if (n
>= ufoRP
- ufoRPTop
) ufoFatal("invalid RROLL index %u", n
);
3632 const uint32_t rp
= ufoRP
- n
- 1u;
3633 const uint32_t val
= ufoRStack
[rp
];
3634 for (uint32_t f
= rp
+ 1u; f
< ufoRP
; f
+= 1u) ufoRStack
[f
- 1u] = ufoRStack
[f
];
3635 ufoRStack
[ufoRP
- 1u] = val
;
3640 // ( | a b -- | b a )
3642 const uint32_t b
= ufoRPop();
3643 const uint32_t a
= ufoRPop();
3644 ufoRPush(b
); ufoRPush(a
);
3648 // ( | a b -- | a b a )
3650 const uint32_t b
= ufoRPop();
3651 const uint32_t a
= ufoRPop();
3652 ufoRPush(a
); ufoRPush(b
); ufoRPush(a
);
3656 // ( | a b c -- | b c a )
3658 const uint32_t c
= ufoRPop();
3659 const uint32_t b
= ufoRPop();
3660 const uint32_t a
= ufoRPop();
3661 ufoRPush(b
); ufoRPush(c
); ufoRPush(a
);
3665 // ( | a b c -- | c a b )
3667 const uint32_t c
= ufoRPop();
3668 const uint32_t b
= ufoRPop();
3669 const uint32_t a
= ufoRPop();
3670 ufoRPush(c
); ufoRPush(a
); ufoRPush(b
);
3674 // ////////////////////////////////////////////////////////////////////////// //
3681 ufoPushBool(ufoLoadNextLine(1));
3686 UFWORD(REFILL_NOCROSS
) {
3687 ufoPushBool(ufoLoadNextLine(0));
3693 ufoPush(ufoImgGetU32(ufoAddrTIBx
) + ufoImgGetU32(ufoAddrINx
));
3698 UFWORD(TIB_PEEKCH
) {
3699 ufoPush(ufoTibPeekCh());
3704 UFWORD(TIB_PEEKCH_OFS
) {
3705 const uint32_t ofs
= ufoPop();
3706 ufoPush(ufoTibPeekChOfs(ofs
));
3712 ufoPush(ufoTibGetCh());
3717 UFWORD(TIB_SKIPCH
) {
3722 // ////////////////////////////////////////////////////////////////////////// //
3726 //==========================================================================
3730 //==========================================================================
3731 UFO_FORCE_INLINE
int ufoIsDelim (uint8_t ch
, uint8_t delim
) {
3732 return (delim
== 32 ? (ch
<= 32) : (ch
== delim
));
3736 // ( delim skip-leading-delim? -- addr count TRUE / FALSE )
3737 // does base TIB parsing; never copies anything.
3738 // as our reader is line-based, returns FALSE on EOL.
3739 // EOL is detected after skipping leading delimiters.
3740 // passing -1 as delimiter skips the whole line, and always returns FALSE.
3741 // trailing delimiter is always skipped.
3743 const uint32_t skipDelim
= ufoPop();
3744 const uint32_t delim
= ufoPop();
3747 if (delim
== 0 || delim
> 0xffU
) {
3749 while (ufoTibGetCh() != 0) {}
3752 ch
= ufoTibPeekCh();
3753 // skip initial delimiters
3755 while (ch
!= 0 && ufoIsDelim(ch
, delim
)) {
3757 ch
= ufoTibPeekCh();
3764 const uint32_t staddr
= ufoImgGetU32(ufoAddrTIBx
) + ufoImgGetU32(ufoAddrINx
);
3766 while (ch
!= 0 && !ufoIsDelim(ch
, delim
)) {
3769 ch
= ufoTibPeekCh();
3772 if (ch
!= 0) ufoTibSkipCh();
3780 // PARSE-SKIP-BLANKS
3782 UFWORD(PARSE_SKIP_BLANKS
) {
3783 uint8_t ch
= ufoTibPeekCh();
3784 while (ch
!= 0 && ch
<= 32) {
3786 ch
= ufoTibPeekCh();
3790 //==========================================================================
3792 // ufoParseMLComment
3794 // initial two chars are skipped
3796 //==========================================================================
3797 static void ufoParseMLComment (uint32_t allowMulti
, int nested
) {
3800 while (level
!= 0) {
3804 UFCALL(REFILL_NOCROSS
);
3805 if (ufoPop() == 0) ufoFatal("unexpected end of file in comment");
3807 ufoFatal("unexpected end of line in comment");
3810 ch1
= ufoTibPeekCh();
3811 if (nested
&& ch
== '(' && ch1
== '(') { ufoTibSkipCh(); level
+= 1; }
3812 else if (nested
&& ch
== ')' && ch1
== ')') { ufoTibSkipCh(); level
-= 1; }
3813 else if (!nested
&& ch
== '*' && ch1
== ')') { ufo_assert(level
== 1); ufoTibSkipCh(); level
= 0; }
3818 // (PARSE-SKIP-COMMENTS)
3819 // ( allow-multiline? -- )
3820 // skip all blanks and comments
3821 UFWORD(PAR_PARSE_SKIP_COMMENTS
) {
3822 const uint32_t allowMulti
= ufoPop();
3824 ch
= ufoTibPeekCh();
3826 fprintf(stderr
, "(PARSE-SKIP-COMMENTS): first-ch:'%c'\n", (char)ch
);
3831 ch
= ufoTibPeekCh();
3833 fprintf(stderr
, "(PARSE-SKIP-COMMENTS): blank-ch:'%c'\n", (char)ch
);
3835 } else if (ch
== '(') {
3837 fprintf(stderr
, "(PARSE-SKIP-COMMENTS): ch:'%c'; ch1:'%c' ('%c')\n", (char)ch
, (char)ch1
,
3838 ufoTibPeekChOfs(0));
3840 ch1
= ufoTibPeekChOfs(1);
3842 // single-line comment
3843 do { ch
= ufoTibGetCh(); } while (ch
!= 0 && ch
!= ')');
3844 ch
= ufoTibPeekCh();
3845 } else if ((ch1
== '*' || ch1
== '(') && ufoTibPeekChOfs(2) <= 32) {
3846 // possibly multiline
3847 ufoTibSkipCh(); ufoTibSkipCh(); // skip opening
3848 ufoParseMLComment(allowMulti
, (ch1
== '('));
3849 ch
= ufoTibPeekCh();
3853 } else if (ch
== '\\' && ufoTibPeekChOfs(1) <= 32) {
3854 // single-line comment
3855 while (ch
!= 0) ch
= ufoTibGetCh();
3856 } else if ((ch
== ';' || ch
== '-' || ch
== '/') && (ufoTibPeekChOfs(1) == ch
)) {
3858 while (ch
!= 0) ch
= ufoTibGetCh();
3864 fprintf(stderr
, "(PARSE-SKIP-COMMENTS): end-ch:'%c'\n", ufoTibPeekCh());
3870 UFWORD(PARSE_SKIP_LINE
) {
3871 ufoPush(0); ufoPushBool(0); UFCALL(PAR_PARSE
);
3872 if (ufoPop() != 0) {
3878 // ( -- addr count )
3879 // parse with leading blanks skipping. doesn't copy anything.
3880 // return empty string on EOL.
3881 UFWORD(PARSE_NAME
) {
3882 ufoPush(32); ufoPushBool(1); UFCALL(PAR_PARSE
);
3883 if (ufoPop() == 0) {
3890 // ( delim -- addr count TRUE / FALSE )
3891 // parse without skipping delimiters; never copies anything.
3892 // as our reader is line-based, returns FALSE on EOL.
3893 // passing 0 as delimiter skips the whole line, and always returns FALSE.
3894 // trailing delimiter is always skipped.
3896 ufoPushBool(0); UFCALL(PAR_PARSE
);
3900 // ////////////////////////////////////////////////////////////////////////// //
3906 UFWORD(PAR_NORM_EMIT_CHAR
) {
3907 uint32_t ch
= ufoPop()&0xffU
;
3908 if (ch
< 32 || ch
== 127) {
3909 if (ch
!= 9 && ch
!= 10 && ch
!= 13) ch
= '?';
3914 // (NORM-XEMIT-CHAR)
3916 UFWORD(PAR_NORM_XEMIT_CHAR
) {
3917 uint32_t ch
= ufoPop()&0xffU
;
3918 if (ch
< 32 || ch
== 127) ch
= '?';
3925 uint32_t ch
= ufoPop()&0xffU
;
3926 ufoLastEmitWasCR
= (ch
== 10);
3933 ufoPushBool(ufoLastEmitWasCR
);
3939 ufoLastEmitWasCR
= !!ufoPop();
3944 UFWORD(FLUSH_EMIT
) {
3949 // ////////////////////////////////////////////////////////////////////////// //
3953 #define UF_UMATH(name_,op_) \
3955 const uint32_t a = ufoPop(); \
3959 #define UF_BMATH(name_,op_) \
3961 const uint32_t b = ufoPop(); \
3962 const uint32_t a = ufoPop(); \
3966 #define UF_BDIV(name_,op_) \
3968 const uint32_t b = ufoPop(); \
3969 const uint32_t a = ufoPop(); \
3970 if (b == 0) ufoFatal("division by zero"); \
3974 #define UFO_POP_U64() ({ \
3975 const uint32_t hi_ = ufoPop(); \
3976 const uint32_t lo_ = ufoPop(); \
3977 (((uint64_t)hi_ << 32) | lo_); \
3980 // this is UB by the idiotic C standard. i don't care.
3981 #define UFO_POP_I64() ((int64_t)UFO_POP_U64())
3983 #define UFO_PUSH_U64(vn_) do { \
3984 ufoPush((uint32_t)(vn_)); \
3985 ufoPush((uint32_t)((vn_) >> 32)); \
3988 // this is UB by the idiotic C standard. i don't care.
3989 #define UFO_PUSH_I64(vn_) UFO_PUSH_U64((uint64_t)(vn_))
3993 UF_BMATH(PLUS
, a
+ b
);
3997 UF_BMATH(MINUS
, a
- b
);
4001 UF_BMATH(MUL
, (uint32_t)((int32_t)a
* (int32_t)b
));
4005 UF_BMATH(UMUL
, a
* b
);
4009 UF_BDIV(DIV
, (uint32_t)((int32_t)a
/ (int32_t)b
));
4013 UF_BDIV(UDIV
, a
/ b
);
4017 UF_BDIV(MOD
, (uint32_t)((int32_t)a
% (int32_t)b
));
4021 UF_BDIV(UMOD
, a
% b
);
4024 // ( a b -- a/b, a%b )
4026 const int32_t b
= (int32_t)ufoPop();
4027 const int32_t a
= (int32_t)ufoPop();
4028 if (b
== 0) ufoFatal("division by zero");
4029 ufoPush((uint32_t)(a
/b
));
4030 ufoPush((uint32_t)(a
%b
));
4034 // ( a b -- a/b, a%b )
4036 const uint32_t b
= ufoPop();
4037 const uint32_t a
= ufoPop();
4038 if (b
== 0) ufoFatal("division by zero");
4039 ufoPush((uint32_t)(a
/b
));
4040 ufoPush((uint32_t)(a
%b
));
4044 // ( a b c -- a*b/c )
4045 // this uses 64-bit intermediate value
4047 const int32_t c
= (int32_t)ufoPop();
4048 const int32_t b
= (int32_t)ufoPop();
4049 const int32_t a
= (int32_t)ufoPop();
4050 if (c
== 0) ufoFatal("division by zero");
4051 int64_t xval
= a
; xval
*= b
; xval
/= c
;
4052 ufoPush((uint32_t)(int32_t)xval
);
4056 // ( a b c -- a*b/c )
4057 // this uses 64-bit intermediate value
4059 const uint32_t c
= ufoPop();
4060 const uint32_t b
= ufoPop();
4061 const uint32_t a
= ufoPop();
4062 if (c
== 0) ufoFatal("division by zero");
4063 uint64_t xval
= a
; xval
*= b
; xval
/= c
;
4064 ufoPush((uint32_t)xval
);
4068 // ( a b c -- a*b/c a*b%c )
4069 // this uses 64-bit intermediate value
4071 const int32_t c
= (int32_t)ufoPop();
4072 const int32_t b
= (int32_t)ufoPop();
4073 const int32_t a
= (int32_t)ufoPop();
4074 if (c
== 0) ufoFatal("division by zero");
4075 int64_t xval
= a
; xval
*= b
;
4076 ufoPush((uint32_t)(int32_t)(xval
/ c
));
4077 ufoPush((uint32_t)(int32_t)(xval
% c
));
4081 // ( a b c -- a*b/c )
4082 // this uses 64-bit intermediate value
4083 UFWORD(UMULDIVMOD
) {
4084 const uint32_t c
= ufoPop();
4085 const uint32_t b
= ufoPop();
4086 const uint32_t a
= ufoPop();
4087 if (c
== 0) ufoFatal("division by zero");
4088 uint64_t xval
= a
; xval
*= b
;
4089 ufoPush((uint32_t)(xval
/ c
));
4090 ufoPush((uint32_t)(xval
% c
));
4094 // ( a b -- lo(a*b) hi(a*b) )
4095 // this leaves 64-bit result
4097 const int32_t b
= (int32_t)ufoPop();
4098 const int32_t a
= (int32_t)ufoPop();
4099 int64_t xval
= a
; xval
*= b
;
4104 // ( a b -- lo(a*b) hi(a*b) )
4105 // this leaves 64-bit result
4107 const uint32_t b
= ufoPop();
4108 const uint32_t a
= ufoPop();
4109 uint64_t xval
= a
; xval
*= b
;
4114 // ( alo ahi b -- a/b a%b )
4116 const int32_t b
= (int32_t)ufoPop();
4117 if (b
== 0) ufoFatal("division by zero");
4118 int64_t a
= UFO_POP_I64();
4119 int32_t adiv
= (int32_t)(a
/ b
);
4120 int32_t amod
= (int32_t)(a
% b
);
4121 ufoPush((uint32_t)adiv
);
4122 ufoPush((uint32_t)amod
);
4126 // ( alo ahi b -- a/b a%b )
4128 const uint32_t b
= ufoPop();
4129 if (b
== 0) ufoFatal("division by zero");
4130 uint64_t a
= UFO_POP_U64();
4131 uint32_t adiv
= (uint32_t)(a
/ b
);
4132 uint32_t amod
= (uint32_t)(a
% b
);
4138 // ( alo ahi u -- lo hi )
4140 const uint32_t b
= ufoPop();
4141 uint64_t a
= UFO_POP_U64();
4147 // ( lo0 hi0 lo1 hi1 -- lo hi )
4149 uint64_t n1
= UFO_POP_U64();
4150 uint64_t n0
= UFO_POP_U64();
4156 // ( lo0 hi0 lo1 hi1 -- lo hi )
4158 uint64_t n1
= UFO_POP_U64();
4159 uint64_t n0
= UFO_POP_U64();
4165 // ( lo0 hi0 lo1 hi1 -- bool )
4167 uint64_t n1
= UFO_POP_U64();
4168 uint64_t n0
= UFO_POP_U64();
4169 ufoPushBool(n0
== n1
);
4173 // ( lo0 hi0 lo1 hi1 -- bool )
4175 int64_t n1
= UFO_POP_I64();
4176 int64_t n0
= UFO_POP_I64();
4177 ufoPushBool(n0
< n1
);
4181 // ( lo0 hi0 lo1 hi1 -- bool )
4183 int64_t n1
= UFO_POP_I64();
4184 int64_t n0
= UFO_POP_I64();
4185 ufoPushBool(n0
<= n1
);
4189 // ( lo0 hi0 lo1 hi1 -- bool )
4191 uint64_t n1
= UFO_POP_U64();
4192 uint64_t n0
= UFO_POP_U64();
4193 ufoPushBool(n0
< n1
);
4197 // ( lo0 hi0 lo1 hi1 -- bool )
4199 uint64_t n1
= UFO_POP_U64();
4200 uint64_t n0
= UFO_POP_U64();
4201 ufoPushBool(n0
<= n1
);
4205 // ( dlo dhi n -- nmod ndiv )
4206 // rounds toward zero
4208 const int32_t n
= (int32_t)ufoPop();
4209 if (n
== 0) ufoFatal("division by zero");
4210 int64_t d
= UFO_POP_I64();
4211 int32_t ndiv
= (int32_t)(d
/ n
);
4212 int32_t nmod
= (int32_t)(d
% n
);
4218 // ( dlo dhi n -- nmod ndiv )
4219 // rounds toward negative infinity
4221 const int32_t n
= (int32_t)ufoPop();
4222 if (n
== 0) ufoFatal("division by zero");
4223 int64_t d
= UFO_POP_I64();
4224 int32_t ndiv
= (int32_t)(d
/ n
);
4225 int32_t nmod
= (int32_t)(d
% n
);
4226 if (nmod
!= 0 && ((uint32_t)n
^ (uint32_t)(d
>> 32)) >= 0x80000000u
) {
4235 // ////////////////////////////////////////////////////////////////////////// //
4236 // simple logic and bit manipulation
4239 #define UF_CMP(name_,op_) \
4241 const uint32_t b = ufoPop(); \
4242 const uint32_t a = ufoPop(); \
4248 UF_CMP(LESS
, (int32_t)a
< (int32_t)b
);
4252 UF_CMP(ULESS
, a
< b
);
4256 UF_CMP(GREAT
, (int32_t)a
> (int32_t)b
);
4260 UF_CMP(UGREAT
, a
> b
);
4264 UF_CMP(LESSEQU
, (int32_t)a
<= (int32_t)b
);
4268 UF_CMP(ULESSEQU
, a
<= b
);
4272 UF_CMP(GREATEQU
, (int32_t)a
>= (int32_t)b
);
4276 UF_CMP(UGREATEQU
, a
>= b
);
4280 UF_CMP(EQU
, a
== b
);
4284 UF_CMP(NOTEQU
, a
!= b
);
4289 const uint32_t a
= ufoPop();
4290 ufoPushBool(a
== 0);
4295 UFWORD(ZERO_NOTEQU
) {
4296 const uint32_t a
= ufoPop();
4297 ufoPushBool(a
!= 0);
4302 UF_CMP(LOGAND
, a
&& b
);
4306 UF_CMP(LOGOR
, a
|| b
);
4311 const uint32_t b
= ufoPop();
4312 const uint32_t a
= ufoPop();
4319 const uint32_t b
= ufoPop();
4320 const uint32_t a
= ufoPop();
4327 const uint32_t b
= ufoPop();
4328 const uint32_t a
= ufoPop();
4335 const uint32_t a
= ufoPop();
4341 // arithmetic shift; positive `n` shifts to the left
4343 int32_t c
= (int32_t)ufoPop();
4346 int32_t n
= (int32_t)ufoPop();
4348 if (n
< 0) n
= -1; else n
= 0;
4350 n
>>= (uint8_t)(-c
);
4352 ufoPush((uint32_t)n
);
4355 uint32_t u
= ufoPop();
4367 // logical shift; positive `n` shifts to the left
4369 int32_t c
= (int32_t) ufoPop();
4370 uint32_t u
= ufoPop();
4376 u
>>= (uint8_t)(-c
);
4390 // ////////////////////////////////////////////////////////////////////////// //
4391 // string unescaping
4395 // ( addr count -- addr count )
4396 UFWORD(PAR_UNESCAPE
) {
4397 const uint32_t count
= ufoPop();
4398 const uint32_t addr
= ufoPeek();
4399 if ((count
& ((uint32_t)1<<31)) == 0) {
4400 const uint32_t eaddr
= addr
+ count
;
4401 uint32_t caddr
= addr
;
4402 uint32_t daddr
= addr
;
4403 while (caddr
!= eaddr
) {
4404 uint8_t ch
= ufoImgGetU8Ext(caddr
); caddr
+= 1u;
4405 if (ch
== '\\' && caddr
!= eaddr
) {
4406 ch
= ufoImgGetU8Ext(caddr
); caddr
+= 1u;
4408 case 'r': ch
= '\r'; break;
4409 case 'n': ch
= '\n'; break;
4410 case 't': ch
= '\t'; break;
4411 case 'e': ch
= '\x1b'; break;
4412 case '`': ch
= '"'; break; // special escape to insert double-quote
4413 case '"': ch
= '"'; break;
4414 case '\\': ch
= '\\'; break;
4416 if (eaddr
- daddr
>= 1) {
4417 const int dg0
= digitInBase((char)(ufoImgGetU8Ext(caddr
)), 16);
4418 if (dg0
< 0) ufoFatal("invalid hex string escape");
4419 if (eaddr
- daddr
>= 2) {
4420 const int dg1
= digitInBase((char)(ufoImgGetU8Ext(caddr
+ 1u)), 16);
4421 if (dg1
< 0) ufoFatal("invalid hex string escape");
4422 ch
= (uint8_t)(dg0
* 16 + dg1
);
4429 ufoFatal("invalid hex string escape");
4432 default: ufoFatal("invalid string escape");
4435 ufoImgPutU8Ext(daddr
, ch
); daddr
+= 1u;
4437 ufoPush(daddr
- addr
);
4444 // ////////////////////////////////////////////////////////////////////////// //
4445 // numeric conversions
4448 // (BASED-NUMBER) ( addr count allowsign? base -- num TRUE / FALSE )
4449 UFWORD(PAR_BASED_NUMBER
) {
4450 const uint32_t xbase
= ufoPop();
4451 const uint32_t allowSign
= ufoPop();
4452 int32_t count
= (int32_t)ufoPop();
4453 uint32_t addr
= ufoPop();
4459 if (allowSign
&& count
> 1) {
4460 ch
= ufoImgGetU8Ext(addr
);
4461 if (ch
== '-') { neg
= 1; addr
+= 1u; count
-= 1; }
4462 else if (ch
== '+') { neg
= 0; addr
+= 1u; count
-= 1; }
4465 // special-based numbers
4466 if (count
>= 3 && ufoImgGetU8Ext(addr
) == '0') {
4467 switch (ufoImgGetU8Ext(addr
+ 1u)) {
4468 case 'x': case 'X': base
= 16; break;
4469 case 'o': case 'O': base
= 8; break;
4470 case 'b': case 'B': base
= 2; break;
4471 case 'd': case 'D': base
= 10; break;
4474 if (base
) { addr
+= 2; count
-= 2; }
4475 } else if (count
>= 2 && ufoImgGetU8Ext(addr
) == '$') {
4477 addr
+= 1; count
-= 1;
4478 } else if (count
>= 2 && ufoImgGetU8Ext(addr
) == '#') {
4480 addr
+= 1; count
-= 1;
4481 } else if (count
>= 2 && ufoImgGetU8Ext(addr
) == '%') {
4483 addr
+= 1; count
-= 1;
4484 } else if (count
>= 3 && ufoImgGetU8Ext(addr
) == '&') {
4485 switch (ufoImgGetU8Ext(addr
+ 1u)) {
4486 case 'h': case 'H': base
= 16; break;
4487 case 'o': case 'O': base
= 8; break;
4488 case 'b': case 'B': base
= 2; break;
4489 case 'd': case 'D': base
= 10; break;
4492 if (base
) { addr
+= 2; count
-= 2; }
4493 } else if (xbase
< 12 && count
> 2 && toUpperU8(ufoImgGetU8Ext(addr
+ (uint32_t)count
- 1u)) == 'B') {
4496 } else if (xbase
< 18 && count
> 2 && toUpperU8(ufoImgGetU8Ext(addr
+ (uint32_t)count
- 1u)) == 'H') {
4499 } else if (xbase
< 25 && count
> 2 && toUpperU8(ufoImgGetU8Ext(addr
+ (uint32_t)count
- 1u)) == 'O') {
4505 if (!base
&& xbase
< 255) base
= xbase
;
4507 if (count
<= 0 || base
< 1 || base
> 36) {
4511 int wasDig
= 0, wasUnder
= 1, error
= 0, dig
;
4512 while (!error
&& count
!= 0) {
4513 ch
= ufoImgGetU8Ext(addr
); addr
+= 1u; count
-= 1;
4515 error
= 1; wasUnder
= 0; wasDig
= 1;
4516 dig
= digitInBase((char)ch
, (int)base
);
4518 nc
= n
* (uint32_t)base
;
4520 nc
+= (uint32_t)dig
;
4533 if (!error
&& wasDig
&& !wasUnder
) {
4534 if (allowSign
&& neg
) n
= ~n
+ 1u;
4544 // ////////////////////////////////////////////////////////////////////////// //
4545 // compiler-related, dictionary-related
4548 static char ufoWNameBuf
[256];
4550 // (CREATE-WORD-HEADER)
4551 // ( addr count word-flags -- )
4552 UFWORD(PAR_CREATE_WORD_HEADER
) {
4553 const uint32_t flags
= ufoPop();
4554 const uint32_t wlen
= ufoPop();
4555 const uint32_t waddr
= ufoPop();
4556 if (wlen
== 0) ufoFatal("word name expected");
4557 if (wlen
>= UFO_MAX_WORD_LENGTH
) ufoFatal("word name too long");
4558 // copy to separate buffer
4559 for (uint32_t f
= 0; f
< wlen
; f
+= 1) {
4560 ufoWNameBuf
[f
] = (char)ufoImgGetU8Ext(waddr
+ f
);
4562 ufoWNameBuf
[wlen
] = 0;
4563 ufoCreateWordHeader(ufoWNameBuf
, flags
);
4566 // (CREATE-NAMELESS-WORD-HEADER)
4567 // ( word-flags -- )
4568 UFWORD(PAR_CREATE_NAMELESS_WORD_HEADER
) {
4569 const uint32_t flags
= ufoPop();
4570 ufoCreateWordHeader("", flags
);
4574 // ( addr count -- cfa TRUE / FALSE)
4576 const uint32_t wlen
= ufoPop();
4577 const uint32_t waddr
= ufoPop();
4578 if (wlen
> 0 && wlen
< UFO_MAX_WORD_LENGTH
) {
4579 // copy to separate buffer
4580 for (uint32_t f
= 0; f
< wlen
; f
+= 1) {
4581 ufoWNameBuf
[f
] = (char)ufoImgGetU8Ext(waddr
+ f
);
4583 ufoWNameBuf
[wlen
] = 0;
4584 const uint32_t cfa
= ufoFindWord(ufoWNameBuf
);
4596 // (FIND-WORD-IN-VOC)
4597 // ( addr count vocid allowhidden -- cfa TRUE / FALSE)
4598 // find only in the given voc; no name resolution
4599 UFWORD(FIND_WORD_IN_VOC
) {
4600 const uint32_t allowHidden
= ufoPop();
4601 const uint32_t vocid
= ufoPop();
4602 const uint32_t wlen
= ufoPop();
4603 const uint32_t waddr
= ufoPop();
4604 if (wlen
> 0 && wlen
< UFO_MAX_WORD_LENGTH
) {
4605 // copy to separate buffer
4606 for (uint32_t f
= 0; f
< wlen
; f
+= 1) {
4607 ufoWNameBuf
[f
] = (char)ufoImgGetU8Ext(waddr
+ f
);
4609 ufoWNameBuf
[wlen
] = 0;
4610 const uint32_t cfa
= ufoFindWordInVoc(ufoWNameBuf
, wlen
, 0, vocid
, (allowHidden
? 1 : 0));
4622 // (FIND-WORD-IN-VOC-AND-PARENTS)
4623 // ( addr count vocid allowhidden -- cfa TRUE / FALSE)
4624 // find only in the given voc; no name resolution
4625 UFWORD(FIND_WORD_IN_VOC_AND_PARENTS
) {
4626 const uint32_t allowHidden
= ufoPop();
4627 const uint32_t vocid
= ufoPop();
4628 const uint32_t wlen
= ufoPop();
4629 const uint32_t waddr
= ufoPop();
4630 if (wlen
> 0 && wlen
< UFO_MAX_WORD_LENGTH
) {
4631 // copy to separate buffer
4632 for (uint32_t f
= 0; f
< wlen
; f
+= 1) {
4633 ufoWNameBuf
[f
] = (char)ufoImgGetU8Ext(waddr
+ f
);
4635 ufoWNameBuf
[wlen
] = 0;
4636 const uint32_t cfa
= ufoFindWordInVocAndParents(ufoWNameBuf
, wlen
, 0, vocid
, (allowHidden
? 1 : 0));
4649 // ////////////////////////////////////////////////////////////////////////// //
4650 // more compiler words
4653 // ////////////////////////////////////////////////////////////////////////// //
4654 // vocabulary and wordlist utilities
4659 UFWORD(PAR_GET_VSP
) {
4665 UFWORD(PAR_SET_VSP
) {
4666 const uint32_t vsp
= ufoPop();
4667 if (vsp
>= UFO_VOCSTACK_SIZE
) ufoFatal("VSP %u out of range (%u)", vsp
, UFO_VOCSTACK_SIZE
);
4673 UFWORD(PAR_VSP_LOAD
) {
4674 const uint32_t vsp
= ufoPop();
4675 if (vsp
>= UFO_VOCSTACK_SIZE
) ufoFatal("VSP %u out of range (%u)", vsp
, UFO_VOCSTACK_SIZE
);
4676 ufoPush(ufoVocStack
[vsp
]);
4681 UFWORD(PAR_VSP_STORE
) {
4682 const uint32_t vsp
= ufoPop();
4683 const uint32_t value
= ufoPop();
4684 if (vsp
> UFO_VOCSTACK_SIZE
) ufoFatal("VSP %u out of range (%u)", vsp
, UFO_VOCSTACK_SIZE
);
4685 ufoVocStack
[vsp
] = value
;
4689 // ////////////////////////////////////////////////////////////////////////// //
4690 // word field address conversion
4696 const uint32_t cfa
= ufoPop();
4697 ufoPush(UFO_CFA_TO_PFA(cfa
));
4703 const uint32_t cfa
= ufoPop();
4704 ufoPush(UFO_CFA_TO_NFA(cfa
));
4710 const uint32_t cfa
= ufoPop();
4711 ufoPush(UFO_CFA_TO_LFA(cfa
));
4715 // ( cfa -- wend-addr )
4717 const uint32_t cfa
= ufoPop();
4718 ufoPush(ufoGetWordEndAddr(cfa
));
4724 const uint32_t pfa
= ufoPop();
4725 ufoPush(UFO_PFA_TO_CFA(pfa
));
4731 const uint32_t pfa
= ufoPop();
4732 const uint32_t cfa
= UFO_PFA_TO_CFA(pfa
);
4733 ufoPush(UFO_CFA_TO_NFA(cfa
));
4739 const uint32_t nfa
= ufoPop();
4740 ufoPush(UFO_NFA_TO_CFA(nfa
));
4746 const uint32_t nfa
= ufoPop();
4747 const uint32_t cfa
= UFO_NFA_TO_CFA(nfa
);
4748 ufoPush(UFO_CFA_TO_PFA(cfa
));
4754 const uint32_t nfa
= ufoPop();
4755 ufoPush(UFO_NFA_TO_LFA(nfa
));
4761 const uint32_t lfa
= ufoPop();
4762 ufoPush(UFO_LFA_TO_CFA(lfa
));
4768 const uint32_t lfa
= ufoPop();
4769 const uint32_t cfa
= UFO_LFA_TO_CFA(lfa
);
4770 ufoPush(UFO_CFA_TO_PFA(cfa
));
4776 const uint32_t lfa
= ufoPop();
4777 ufoPush(UFO_LFA_TO_BFA(lfa
));
4783 const uint32_t lfa
= ufoPop();
4784 ufoPush(UFO_LFA_TO_XFA(lfa
));
4790 const uint32_t lfa
= ufoPop();
4791 ufoPush(UFO_LFA_TO_YFA(lfa
));
4797 const uint32_t lfa
= ufoPop();
4798 ufoPush(UFO_LFA_TO_NFA(lfa
));
4802 // ( ip -- nfa / 0 )
4804 const uint32_t ip
= ufoPop();
4805 ufoPush(ufoFindWordForIP(ip
));
4809 // ( ip -- addr count line TRUE / FALSE )
4810 // name is at PAD; it is safe to use PAD, because each task has its own temp image
4811 UFWORD(IP2FILELINE
) {
4812 const uint32_t ip
= ufoPop();
4814 const char *fname
= ufoFindFileForIP(ip
, &fline
, NULL
, NULL
);
4815 if (fname
!= NULL
) {
4817 uint32_t addr
= ufoPeek();
4819 while (*fname
!= 0) {
4820 ufoImgPutU8(addr
, *(const unsigned char *)fname
);
4821 fname
+= 1u; addr
+= 1u; count
+= 1u;
4823 ufoImgPutU8(addr
, 0); // just in case
4833 // IP->FILE-HASH/LINE
4834 // ( ip -- len hash line TRUE / FALSE )
4835 UFWORD(IP2FILEHASHLINE
) {
4836 const uint32_t ip
= ufoPop();
4837 uint32_t fline
, fhash
, flen
;
4838 const char *fname
= ufoFindFileForIP(ip
, &fline
, &flen
, &fhash
);
4839 if (fname
!= NULL
) {
4850 // ////////////////////////////////////////////////////////////////////////// //
4851 // string operations
4854 UFO_FORCE_INLINE
uint32_t ufoHashBuf (uint32_t addr
, uint32_t size
, uint8_t orbyte
) {
4855 uint32_t hash
= 0x29a;
4856 if ((size
& ((uint32_t)1<<31)) == 0) {
4858 hash
+= ufoImgGetU8Ext(addr
) | orbyte
;
4861 addr
+= 1u; size
-= 1u;
4871 //==========================================================================
4875 //==========================================================================
4876 UFO_FORCE_INLINE
int ufoBufEqu (uint32_t addr0
, uint32_t addr1
, uint32_t count
) {
4878 if ((count
& ((uint32_t)1<<31)) == 0) {
4880 while (res
!= 0 && count
!= 0) {
4881 res
= (toUpperU8(ufoImgGetU8Ext(addr0
)) == toUpperU8(ufoImgGetU8Ext(addr1
)));
4882 addr0
+= 1u; addr1
+= 1u; count
-= 1u;
4891 // ( a0 c0 a1 c1 -- bool )
4893 int32_t c1
= (int32_t)ufoPop();
4894 uint32_t a1
= ufoPop();
4895 int32_t c0
= (int32_t)ufoPop();
4896 uint32_t a0
= ufoPop();
4901 while (res
!= 0 && c0
!= 0) {
4902 res
= (ufoImgGetU8Ext(a0
) == ufoImgGetU8Ext(a1
));
4903 a0
+= 1; a1
+= 1; c0
-= 1;
4912 // ( a0 c0 a1 c1 -- bool )
4914 int32_t c1
= (int32_t)ufoPop();
4915 uint32_t a1
= ufoPop();
4916 int32_t c0
= (int32_t)ufoPop();
4917 uint32_t a0
= ufoPop();
4922 while (res
!= 0 && c0
!= 0) {
4923 res
= (toUpperU8(ufoImgGetU8Ext(a0
)) == toUpperU8(ufoImgGetU8Ext(a1
)));
4924 a0
+= 1; a1
+= 1; c0
-= 1;
4932 // search the string specified by c-addr1 u1 for the string specified by c-addr2 u2.
4933 // if flag is true, a match was found at c-addr3 with u3 characters remaining.
4934 // if flag is false there was no match and c-addr3 is c-addr1 and u3 is u1.
4935 // ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 flag )
4937 const uint32_t pcount
= ufoPop();
4938 const uint32_t paddr
= ufoPop();
4939 const uint32_t tcount
= ufoPop();
4940 const uint32_t taddr
= ufoPop();
4941 if ((pcount
& ((uint32_t)1 << 31)) == 0 && (tcount
& ((uint32_t)1 << 31)) == 0) {
4942 for (uint32_t f
= 0; tcount
- f
>= pcount
; f
+= 1) {
4943 if (ufoBufEqu(taddr
+ f
, paddr
, pcount
)) {
4945 ufoPush(tcount
- f
);
4957 // ( addr count -- hash )
4959 uint32_t count
= ufoPop();
4960 uint32_t addr
= ufoPop();
4961 ufoPush(ufoHashBuf(addr
, count
, 0));
4965 // ( addr count -- hash )
4967 uint32_t count
= ufoPop();
4968 uint32_t addr
= ufoPop();
4969 ufoPush(ufoHashBuf(addr
, count
, 0x20));
4973 // ////////////////////////////////////////////////////////////////////////// //
4974 // conditional defines
4977 typedef struct UForthCondDefine_t UForthCondDefine
;
4978 struct UForthCondDefine_t
{
4982 UForthCondDefine
*next
;
4985 static UForthCondDefine
*ufoCondDefines
= NULL
;
4986 static char ufoErrMsgBuf
[4096];
4989 //==========================================================================
4993 //==========================================================================
4994 UFO_DISABLE_INLINE
int ufoStrEquCI (const void *str0
, const void *str1
) {
4995 const unsigned char *s0
= (const unsigned char *)str0
;
4996 const unsigned char *s1
= (const unsigned char *)str1
;
4997 while (*s0
&& *s1
) {
4998 if (toUpperU8(*s0
) != toUpperU8(*s1
)) return 0;
5001 return (*s0
== 0 && *s1
== 0);
5005 //==========================================================================
5009 //==========================================================================
5010 UFO_FORCE_INLINE
int ufoBufEquCI (uint32_t addr
, uint32_t count
, const void *buf
) {
5012 if ((count
& ((uint32_t)1<<31)) == 0) {
5013 const unsigned char *src
= (const unsigned char *)buf
;
5015 while (res
!= 0 && count
!= 0) {
5016 res
= (toUpperU8(*src
) == toUpperU8(ufoImgGetU8Ext(addr
)));
5017 src
+= 1; addr
+= 1u; count
-= 1u;
5026 //==========================================================================
5028 // ufoClearCondDefines
5030 //==========================================================================
5031 static void ufoClearCondDefines (void) {
5032 while (ufoCondDefines
) {
5033 UForthCondDefine
*df
= ufoCondDefines
;
5034 ufoCondDefines
= df
->next
;
5035 if (df
->name
) free(df
->name
);
5041 //==========================================================================
5045 //==========================================================================
5046 int ufoHasCondDefine (const char *name
) {
5048 if (name
!= NULL
&& name
[0] != 0) {
5049 const size_t nlen
= strlen(name
);
5051 const uint32_t hash
= joaatHashBufCI(name
, nlen
);
5052 UForthCondDefine
*dd
= ufoCondDefines
;
5053 while (res
== 0 && dd
!= NULL
) {
5054 if (dd
->hash
== hash
&& dd
->namelen
== (uint32_t)nlen
) {
5055 res
= ufoStrEquCI(name
, dd
->name
);
5065 //==========================================================================
5069 //==========================================================================
5070 void ufoCondDefine (const char *name
) {
5071 if (name
!= NULL
&& name
[0] != 0) {
5072 const size_t nlen
= strlen(name
);
5073 if (nlen
> 255) ufoFatal("conditional define name too long");
5074 const uint32_t hash
= joaatHashBufCI(name
, nlen
);
5075 UForthCondDefine
*dd
= ufoCondDefines
;
5077 while (res
== 0 && dd
!= NULL
) {
5078 if (dd
->hash
== hash
&& dd
->namelen
== (uint32_t)nlen
) {
5079 res
= ufoStrEquCI(name
, dd
->name
);
5085 dd
= calloc(1, sizeof(UForthCondDefine
));
5086 if (dd
== NULL
) ufoFatal("out of memory for defines");
5087 dd
->name
= strdup(name
);
5088 if (dd
->name
== NULL
) { free(dd
); ufoFatal("out of memory for defines"); }
5089 dd
->namelen
= (uint32_t)nlen
;
5091 dd
->next
= ufoCondDefines
;
5092 ufoCondDefines
= dd
;
5098 //==========================================================================
5102 //==========================================================================
5103 void ufoCondUndef (const char *name
) {
5104 if (name
!= NULL
&& name
[0] != 0) {
5105 const size_t nlen
= strlen(name
);
5107 const uint32_t hash
= joaatHashBufCI(name
, nlen
);
5108 UForthCondDefine
*dd
= ufoCondDefines
;
5109 UForthCondDefine
*prev
= NULL
;
5110 while (dd
!= NULL
) {
5111 if (dd
->hash
== hash
&& dd
->namelen
== (uint32_t)nlen
) {
5112 if (ufoStrEquCI(name
, dd
->name
)) {
5113 if (prev
!= NULL
) prev
->next
= dd
->next
; else ufoCondDefines
= dd
->next
;
5119 if (dd
!= NULL
) { prev
= dd
; dd
= dd
->next
; }
5127 // ( addr count -- )
5128 UFWORD(PAR_DLR_DEFINE
) {
5129 uint32_t count
= ufoPop();
5130 uint32_t addr
= ufoPop();
5131 if (count
== 0) ufoFatal("empty define");
5132 if (count
>= UFO_MAX_WORD_LENGTH
) ufoFatal("define too long");
5133 const uint32_t hash
= ufoHashBuf(addr
, count
, 0x20);
5134 UForthCondDefine
*dd
;
5135 for (dd
= ufoCondDefines
; dd
!= NULL
; dd
= dd
->next
) {
5136 if (dd
->hash
== hash
&& dd
->namelen
== count
) {
5137 if (ufoBufEquCI(addr
, count
, dd
->name
)) return;
5141 dd
= calloc(1, sizeof(UForthCondDefine
));
5142 if (dd
== NULL
) ufoFatal("out of memory for defines");
5143 dd
->name
= calloc(1, count
+ 1u);
5144 if (dd
->name
== NULL
) { free(dd
); ufoFatal("out of memory for defines"); }
5145 for (uint32_t f
= 0; f
< count
; f
+= 1) {
5146 ((unsigned char *)dd
->name
)[f
] = ufoImgGetU8Ext(addr
+ f
);
5148 dd
->namelen
= count
;
5150 dd
->next
= ufoCondDefines
;
5151 ufoCondDefines
= dd
;
5155 // ( addr count -- )
5156 UFWORD(PAR_DLR_UNDEF
) {
5157 uint32_t count
= ufoPop();
5158 uint32_t addr
= ufoPop();
5159 if (count
== 0) ufoFatal("empty define");
5160 if (count
>= UFO_MAX_WORD_LENGTH
) ufoFatal("define too long");
5161 const uint32_t hash
= ufoHashBuf(addr
, count
, 0x20);
5162 UForthCondDefine
*prev
= NULL
;
5163 UForthCondDefine
*dd
;
5164 for (dd
= ufoCondDefines
; dd
!= NULL
; prev
= dd
, dd
= dd
->next
) {
5165 if (dd
->hash
== hash
&& dd
->namelen
== count
) {
5166 if (ufoBufEquCI(addr
, count
, dd
->name
)) {
5167 if (prev
== NULL
) ufoCondDefines
= dd
->next
; else prev
->next
= dd
->next
;
5177 // ( addr count -- bool )
5178 UFWORD(PAR_DLR_DEFINEDQ
) {
5179 uint32_t count
= ufoPop();
5180 uint32_t addr
= ufoPop();
5181 if (count
== 0) ufoFatal("empty define");
5182 if (count
>= UFO_MAX_WORD_LENGTH
) ufoFatal("define too long");
5183 const uint32_t hash
= ufoHashBuf(addr
, count
, 0x20);
5185 UForthCondDefine
*dd
= ufoCondDefines
;
5186 while (!found
&& dd
!= NULL
) {
5187 if (dd
->hash
== hash
&& dd
->namelen
== count
) {
5188 found
= ufoBufEquCI(addr
, count
, dd
->name
);
5196 // ////////////////////////////////////////////////////////////////////////// //
5201 // ( addr count -- )
5203 uint32_t count
= ufoPop();
5204 uint32_t addr
= ufoPop();
5205 if (count
& (1u<<31)) ufoFatal("invalid error message");
5206 if (count
== 0) ufoFatal("some error");
5207 if (count
> (uint32_t)sizeof(ufoErrMsgBuf
) - 1u) count
= (uint32_t)sizeof(ufoErrMsgBuf
) - 1u;
5208 for (uint32_t f
= 0; f
< count
; f
+= 1) {
5209 ufoErrMsgBuf
[f
] = (char)ufoImgGetU8Ext(addr
+ f
);
5211 ufoErrMsgBuf
[count
] = 0;
5212 ufoFatal("%s", ufoErrMsgBuf
);
5215 // ////////////////////////////////////////////////////////////////////////// //
5219 static char ufoFNameBuf
[4096];
5222 //==========================================================================
5224 // ufoScanIncludeFileName
5226 // `*psys` and `*psoft` must be initialised!
5228 //==========================================================================
5229 static void ufoScanIncludeFileName (uint32_t addr
, uint32_t count
, char *dest
, size_t destsz
,
5230 uint32_t *psys
, uint32_t *psoft
)
5234 ufo_assert(dest
!= NULL
);
5235 ufo_assert(destsz
> 0);
5237 while (count
!= 0) {
5238 ch
= ufoImgGetU8Ext(addr
);
5240 //if (system) ufoFatal("invalid file name (duplicate system mark)");
5242 } else if (ch
== '?') {
5243 //if (softinclude) ufoFatal("invalid file name (duplicate soft mark)");
5249 addr
+= 1; count
-= 1;
5250 ch
= ufoImgGetU8Ext(addr
);
5251 } while (ch
<= 32 && count
!= 0);
5254 if (count
== 0) ufoFatal("empty include file name");
5255 if (count
>= destsz
) ufoFatal("include file name too long");
5258 while (count
!= 0) {
5259 dest
[dpos
] = (char)ufoImgGetU8Ext(addr
); dpos
+= 1;
5260 addr
+= 1; count
-= 1;
5268 // return number of items in include stack
5269 UFWORD(PAR_INCLUDE_DEPTH
) {
5270 ufoPush(ufoFileStackPos
);
5273 // (INCLUDE-FILE-ID)
5274 // ( isp -- id ) -- isp 0 is current, then 1, etc.
5275 // each include file has unique non-zero id.
5276 UFWORD(PAR_INCLUDE_FILE_ID
) {
5277 const uint32_t isp
= ufoPop();
5280 } else if (isp
<= ufoFileStackPos
) {
5281 UFOFileStackEntry
*stk
= &ufoFileStack
[ufoFileStackPos
- isp
];
5284 ufoFatal("invalid include stack index");
5288 // (INCLUDE-FILE-LINE)
5290 UFWORD(PAR_INCLUDE_FILE_LINE
) {
5291 const uint32_t isp
= ufoPop();
5293 ufoPush(ufoInFileLine
);
5294 } else if (isp
<= ufoFileStackPos
) {
5295 UFOFileStackEntry
*stk
= &ufoFileStack
[ufoFileStackPos
- isp
];
5296 ufoPush(stk
->fline
);
5298 ufoFatal("invalid include stack index");
5300 ufoPush(ufoInFileLine
);
5303 // (INCLUDE-FILE-NAME)
5304 // ( isp -- addr count )
5305 // current file name; at PAD
5306 UFWORD(PAR_INCLUDE_FILE_NAME
) {
5307 const uint32_t isp
= ufoPop();
5308 const char *fname
= NULL
;
5310 fname
= ufoInFileName
;
5311 } else if (isp
<= ufoFileStackPos
) {
5312 UFOFileStackEntry
*stk
= &ufoFileStack
[ufoFileStackPos
- isp
];
5315 ufoFatal("invalid include stack index");
5318 uint32_t addr
= ufoPop();
5320 while (fname
[count
] != 0) {
5321 ufoImgPutU8Ext(addr
+ count
, ((const unsigned char *)fname
)[count
]);
5324 ufoImgPutU8Ext(addr
+ count
, 0);
5330 // ( addr count soft? system? -- )
5331 UFWORD(PAR_INCLUDE
) {
5332 uint32_t system
= ufoPop();
5333 uint32_t softinclude
= ufoPop();
5334 uint32_t count
= ufoPop();
5335 uint32_t addr
= ufoPop();
5337 if (ufoMode
== UFO_MODE_MACRO
) ufoFatal("macros cannot include files");
5339 if ((count
& ((uint32_t)1<<31)) != 0) ufoFatal("invalid include name");
5341 ufoScanIncludeFileName(addr
, count
, ufoFNameBuf
, sizeof(ufoFNameBuf
),
5342 &system
, &softinclude
);
5344 char *ffn
= ufoCreateIncludeName(ufoFNameBuf
, system
, (system
? ufoLastSysIncPath
: ufoLastIncPath
));
5346 FILE *fl
= fopen(ffn
, "rb");
5348 FILE *fl
= fopen(ffn
, "r");
5351 if (softinclude
) { free(ffn
); return; }
5352 ufoFatal("include file '%s' not found", ffn
);
5354 #ifdef UFO_DEBUG_INCLUDE
5355 fprintf(stderr
, "INC-PUSH: new fname: %s\n", ffn
);
5360 ufoSetInFileNameReuse(ffn
);
5361 ufoFileId
= ufoLastUsedFileId
;
5362 setLastIncPath(ufoInFileName
, system
);
5363 // trigger next line loading
5365 if (!ufoPop()) ufoFatal("(INCLUDE) internal error");
5369 UFWORD(DLR_INCLUDE_IMM
) {
5370 int soft
= 0, system
= 0;
5371 // parse include filename
5372 //UFCALL(PARSE_SKIP_BLANKS);
5373 ufoPushBool(0); UFCALL(PAR_PARSE_SKIP_COMMENTS
);
5374 uint8_t ch
= ufoTibPeekCh();
5376 ufoTibSkipCh(); // skip quote
5378 } else if (ch
== '<') {
5379 ufoTibSkipCh(); // skip quote
5383 ufoFatal("expected quoted string");
5386 if (!ufoPop()) ufoFatal("file name expected");
5387 ufoPushBool(0); UFCALL(PAR_PARSE_SKIP_COMMENTS
);
5388 if (ufoTibPeekCh() != 0) {
5389 ufoFatal("$INCLUDE doesn't accept extra args yet");
5391 // ( addr count soft? system? -- )
5392 ufoPushBool(soft
); ufoPushBool(system
); UFCALL(PAR_INCLUDE
);
5396 //==========================================================================
5398 // ufoCreateFileGuard
5400 //==========================================================================
5401 static const char *ufoCreateFileGuard (const char *fname
) {
5402 if (fname
== NULL
|| fname
[0] == 0) return NULL
;
5403 char *rp
= ufoRealPath(fname
);
5404 if (rp
== NULL
) return NULL
;
5406 for (char *s
= rp
; *s
; s
+= 1) if (*s
== '\\') *s
= '/';
5408 // hash the buffer; extract file name; create string with path len, file name, and hash
5409 const size_t orgplen
= strlen(rp
);
5410 const uint32_t phash
= joaatHashBuf(rp
, orgplen
, 0);
5411 size_t plen
= orgplen
;
5412 while (plen
!= 0 && rp
[plen
- 1u] != '/') plen
-= 1;
5413 snprintf(ufoRealPathHashBuf
, sizeof(ufoRealPathHashBuf
),
5414 "__INCLUDE_GUARD_%08X_%08X_%s__", phash
, (uint32_t)orgplen
, rp
+ plen
);
5415 return ufoRealPathHashBuf
;
5419 // $INCLUDE-ONCE "str"
5420 // includes file only once; unreliable on shitdoze, i believe
5421 UFWORD(DLR_INCLUDE_ONCE_IMM
) {
5422 uint32_t softinclude
= 0, system
= 0;
5423 // parse include filename
5424 //UFCALL(PARSE_SKIP_BLANKS);
5425 ufoPushBool(0); UFCALL(PAR_PARSE_SKIP_COMMENTS
);
5426 uint8_t ch
= ufoTibPeekCh();
5428 ufoTibSkipCh(); // skip quote
5430 } else if (ch
== '<') {
5431 ufoTibSkipCh(); // skip quote
5435 ufoFatal("expected quoted string");
5438 if (!ufoPop()) ufoFatal("file name expected");
5439 const uint32_t count
= ufoPop();
5440 const uint32_t addr
= ufoPop();
5441 ufoPushBool(0); UFCALL(PAR_PARSE_SKIP_COMMENTS
);
5442 if (ufoTibPeekCh() != 0) {
5443 ufoFatal("$REQUIRE doesn't accept extra args yet");
5445 ufoScanIncludeFileName(addr
, count
, ufoRealPathHashBuf
, sizeof(ufoRealPathHashBuf
),
5446 &system
, &softinclude
);
5447 char *incfname
= ufoCreateIncludeName(ufoRealPathHashBuf
, system
, (system
? ufoLastSysIncPath
: ufoLastIncPath
));
5448 if (incfname
== NULL
) ufoFatal("cannot resolve include file '%s'", ufoRealPathHashBuf
);
5449 //fprintf(stderr, "?:%d;!:%d;%s|%s\n", softinclude, system, ufoRealPathHashBuf, incfname);
5450 // this will overwrite `ufoRealPathHashBuf`
5451 const char *guard
= ufoCreateFileGuard(incfname
);
5453 if (guard
== NULL
) {
5454 if (!softinclude
) ufoFatal("cannot include file '%s'", ufoRealPathHashBuf
);
5458 fprintf(stderr
, "GUARD: <%s>\n", guard
);
5460 // now check for the guard
5461 const uint32_t glen
= (uint32_t)strlen(guard
);
5462 const uint32_t ghash
= joaatHashBuf(guard
, glen
, 0);
5463 UForthCondDefine
*dd
;
5464 for (dd
= ufoCondDefines
; dd
!= NULL
; dd
= dd
->next
) {
5465 if (dd
->hash
== ghash
&& dd
->namelen
== glen
&& strcmp(guard
, dd
->name
) == 0) {
5466 // nothing to do: already included
5471 dd
= calloc(1, sizeof(UForthCondDefine
));
5472 if (dd
== NULL
) ufoFatal("out of memory for defines");
5473 dd
->name
= calloc(1, glen
+ 1u);
5474 if (dd
->name
== NULL
) { free(dd
); ufoFatal("out of memory for defines"); }
5475 strcpy(dd
->name
, guard
);
5478 dd
->next
= ufoCondDefines
;
5479 ufoCondDefines
= dd
;
5480 // ( addr count soft? system? -- )
5481 ufoPush(addr
); ufoPush(count
); ufoPushBool(softinclude
); ufoPushBool(system
);
5482 UFCALL(PAR_INCLUDE
);
5486 // ////////////////////////////////////////////////////////////////////////// //
5492 UFWORD(PAR_NEW_HANDLE
) {
5493 const uint32_t typeid = ufoPop();
5494 if (typeid == UFO_HANDLE_FREE
) ufoFatal("invalid handle typeid");
5495 UfoHandle
*hh
= ufoAllocHandle(typeid);
5496 ufoPush(hh
->ufoHandle
);
5501 UFWORD(PAR_FREE_HANDLE
) {
5502 const uint32_t hx
= ufoPop();
5504 if ((hx
& UFO_ADDR_HANDLE_BIT
) == 0) ufoFatal("trying to free something that is not a handle");
5505 UfoHandle
*hh
= ufoGetHandle(hx
);
5506 if (hh
== NULL
) ufoFatal("trying to free invalid handle");
5513 UFWORD(PAR_HANDLE_GET_TYPEID
) {
5514 const uint32_t hx
= ufoPop();
5515 if ((hx
& UFO_ADDR_HANDLE_BIT
) == 0) ufoFatal("not a handle");
5516 UfoHandle
*hh
= ufoGetHandle(hx
);
5517 if (hh
== NULL
) ufoFatal("invalid handle");
5518 ufoPush(hh
->typeid);
5523 UFWORD(PAR_HANDLE_SET_TYPEID
) {
5524 const uint32_t hx
= ufoPop();
5525 const uint32_t typeid = ufoPop();
5526 if ((hx
& UFO_ADDR_HANDLE_BIT
) == 0) ufoFatal("not a handle");
5527 if (typeid == UFO_HANDLE_FREE
) ufoFatal("invalid handle typeid");
5528 UfoHandle
*hh
= ufoGetHandle(hx
);
5529 if (hh
== NULL
) ufoFatal("invalid handle");
5530 hh
->typeid = typeid;
5535 UFWORD(PAR_HANDLE_GET_SIZE
) {
5536 const uint32_t hx
= ufoPop();
5538 if ((hx
& UFO_ADDR_HANDLE_BIT
) == 0) ufoFatal("not a handle");
5539 UfoHandle
*hh
= ufoGetHandle(hx
);
5540 if (hh
== NULL
) ufoFatal("invalid handle");
5549 UFWORD(PAR_HANDLE_SET_SIZE
) {
5550 const uint32_t hx
= ufoPop();
5551 const uint32_t size
= ufoPop();
5552 if (size
> 0x04000000) ufoFatal("invalid handle size");
5553 if ((hx
& UFO_ADDR_HANDLE_BIT
) == 0) ufoFatal("not a handle");
5554 UfoHandle
*hh
= ufoGetHandle(hx
);
5555 if (hh
== NULL
) ufoFatal("invalid handle");
5556 if (hh
->size
!= size
) {
5561 uint8_t *nx
= realloc(hh
->data
, size
* sizeof(hh
->data
[0]));
5562 if (nx
== NULL
) ufoFatal("out of memory for handle of size %u", size
);
5564 if (size
> hh
->size
) memset(hh
->data
, 0, size
- hh
->size
);
5567 if (hh
->used
> size
) hh
->used
= size
;
5573 UFWORD(PAR_HANDLE_GET_USED
) {
5574 const uint32_t hx
= ufoPop();
5576 if ((hx
& UFO_ADDR_HANDLE_BIT
) == 0) ufoFatal("not a handle");
5577 UfoHandle
*hh
= ufoGetHandle(hx
);
5578 if (hh
== NULL
) ufoFatal("invalid handle");
5587 UFWORD(PAR_HANDLE_SET_USED
) {
5588 const uint32_t hx
= ufoPop();
5589 const uint32_t used
= ufoPop();
5590 if (used
> 0x04000000) ufoFatal("invalid handle used");
5591 if ((hx
& UFO_ADDR_HANDLE_BIT
) == 0) ufoFatal("not a handle");
5592 UfoHandle
*hh
= ufoGetHandle(hx
);
5593 if (hh
== NULL
) ufoFatal("invalid handle");
5594 if (used
> hh
->size
) ufoFatal("handle used %u out of range (%u)", used
, hh
->size
);
5598 #define POP_PREPARE_HANDLE() \
5599 const uint32_t hx = ufoPop(); \
5600 uint32_t idx = ufoPop(); \
5601 if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle"); \
5602 if (idx > 0x1fffffffU - UFO_ADDR_HANDLE_OFS_MASK) ufoFatal("handle index %u out of range", idx); \
5603 idx += (hx & UFO_ADDR_HANDLE_OFS_MASK); \
5604 UfoHandle *hh = ufoGetHandle(hx); \
5605 if (hh == NULL) ufoFatal("invalid handle")
5608 // ( idx hx -- value )
5609 UFWORD(PAR_HANDLE_LOAD_BYTE
) {
5610 POP_PREPARE_HANDLE();
5611 if (idx
>= hh
->size
) ufoFatal("handle index %u out of range (%u)", idx
, hh
->size
);
5612 ufoPush(hh
->data
[idx
]);
5616 // ( idx hx -- value )
5617 UFWORD(PAR_HANDLE_LOAD_WORD
) {
5618 POP_PREPARE_HANDLE();
5619 if (idx
>= hh
->size
|| hh
->size
- idx
< 2u) {
5620 ufoFatal("handle index %u out of range (%u)", idx
, hh
->size
);
5622 #ifdef UFO_FAST_MEM_ACCESS
5623 ufoPush(*(const uint16_t *)(hh
->data
+ idx
));
5625 uint32_t res
= hh
->data
[idx
];
5626 res
|= hh
->data
[idx
+ 1u] << 8;
5632 // ( idx hx -- value )
5633 UFWORD(PAR_HANDLE_LOAD_CELL
) {
5634 POP_PREPARE_HANDLE();
5635 if (idx
>= hh
->size
|| hh
->size
- idx
< 4u) {
5636 ufoFatal("handle index %u out of range (%u)", idx
, hh
->size
);
5638 #ifdef UFO_FAST_MEM_ACCESS
5639 ufoPush(*(const uint32_t *)(hh
->data
+ idx
));
5641 uint32_t res
= hh
->data
[idx
];
5642 res
|= hh
->data
[idx
+ 1u] << 8;
5643 res
|= hh
->data
[idx
+ 2u] << 16;
5644 res
|= hh
->data
[idx
+ 3u] << 24;
5650 // ( value idx hx -- value )
5651 UFWORD(PAR_HANDLE_STORE_BYTE
) {
5652 POP_PREPARE_HANDLE();
5653 const uint32_t value
= ufoPop();
5654 if (idx
>= hh
->size
) ufoFatal("handle index %u out of range (%u)", idx
, hh
->size
);
5655 hh
->data
[idx
] = value
;
5659 // ( value idx hx -- )
5660 UFWORD(PAR_HANDLE_STORE_WORD
) {
5661 POP_PREPARE_HANDLE();
5662 const uint32_t value
= ufoPop();
5663 if (idx
>= hh
->size
|| hh
->size
- idx
< 2u) {
5664 ufoFatal("handle index %u out of range (%u)", idx
, hh
->size
);
5666 #ifdef UFO_FAST_MEM_ACCESS
5667 *(uint16_t *)(hh
->data
+ idx
) = (uint16_t)value
;
5669 hh
->data
[idx
] = (uint8_t)value
;
5670 hh
->data
[idx
+ 1u] = (uint8_t)(value
>> 8);
5675 // ( value idx hx -- )
5676 UFWORD(PAR_HANDLE_STORE_CELL
) {
5677 POP_PREPARE_HANDLE();
5678 const uint32_t value
= ufoPop();
5679 if (idx
>= hh
->size
|| hh
->size
- idx
< 4u) {
5680 ufoFatal("handle index %u out of range (%u)", idx
, hh
->size
);
5682 #ifdef UFO_FAST_MEM_ACCESS
5683 *(uint32_t *)(hh
->data
+ idx
) = value
;
5685 hh
->data
[idx
] = (uint8_t)value
;
5686 hh
->data
[idx
+ 1u] = (uint8_t)(value
>> 8);
5687 hh
->data
[idx
+ 2u] = (uint8_t)(value
>> 16);
5688 hh
->data
[idx
+ 3u] = (uint8_t)(value
>> 24);
5694 // ( addr count -- stx / FALSE )
5695 UFWORD(PAR_HANDLE_LOAD_FILE
) {
5696 uint32_t count
= ufoPop();
5697 uint32_t addr
= ufoPop();
5699 if ((count
& ((uint32_t)1<<31)) != 0) ufoFatal("invalid file name");
5701 uint8_t *dest
= (uint8_t *)ufoFNameBuf
;
5702 while (count
!= 0 && dest
< (uint8_t *)ufoFNameBuf
+ sizeof(ufoFNameBuf
)) {
5703 uint8_t ch
= ufoImgGetU8Ext(addr
);
5705 dest
+= 1u; addr
+= 1u; count
-= 1u;
5707 if (dest
== (uint8_t *)ufoFNameBuf
+ sizeof(ufoFNameBuf
)) ufoFatal("file name too long");
5710 if (*ufoFNameBuf
== 0) ufoFatal("empty file name");
5712 char *ffn
= ufoCreateIncludeName(ufoFNameBuf
, 0/*system*/, ufoLastIncPath
);
5714 FILE *fl
= fopen(ffn
, "rb");
5716 FILE *fl
= fopen(ffn
, "r");
5724 if (fseek(fl
, 0, SEEK_END
) != 0) {
5726 ufoFatal("seek error in file '%s'", ffn
);
5729 long sz
= ftell(fl
);
5730 if (sz
< 0 || sz
>= 1024 * 1024 * 64) {
5732 ufoFatal("tell error in file '%s' (or too big)", ffn
);
5735 if (fseek(fl
, 0, SEEK_SET
) != 0) {
5737 ufoFatal("seek error in file '%s'", ffn
);
5740 UfoHandle
*hh
= ufoAllocHandle(0);
5742 hh
->data
= malloc((uint32_t)sz
);
5743 if (hh
->data
== NULL
) {
5745 ufoFatal("out of memory for file '%s'", ffn
);
5747 hh
->size
= (uint32_t)sz
;
5748 if (fread(hh
->data
, (uint32_t)sz
, 1, fl
) != 1) {
5750 ufoFatal("error reading file '%s'", ffn
);
5756 ufoPush(hh
->ufoHandle
);
5760 // ////////////////////////////////////////////////////////////////////////// //
5764 // DEBUG:(DECOMPILE-CFA)
5766 UFWORD(DEBUG_DECOMPILE_CFA
) {
5767 const uint32_t cfa
= ufoPop();
5769 ufoDecompileWord(cfa
);
5772 // DEBUG:(DECOMPILE-MEM)
5773 // ( addr-start addr-end -- )
5774 UFWORD(DEBUG_DECOMPILE_MEM
) {
5775 const uint32_t end
= ufoPop();
5776 const uint32_t start
= ufoPop();
5778 ufoDecompilePart(start
, end
, 0);
5784 ufoPush((uint32_t)ufo_get_msecs());
5787 // this is called by INTERPRET when it is out of input stream
5788 UFWORD(UFO_INTERPRET_FINISHED_ACTION
) {
5794 UFWORD(MT_NEW_STATE
) {
5795 UfoState
*st
= ufoNewState();
5796 ufoInitStateUserVars(st
, ufoPop());
5802 UFWORD(MT_FREE_STATE
) {
5803 UfoState
*st
= ufoFindState(ufoPop());
5804 if (st
== NULL
) ufoFatal("cannot free unknown state");
5805 if (st
== ufoCurrState
) ufoFatal("cannot free current state");
5809 // MTASK:STATE-NAME@
5810 // ( stid -- addr count )
5812 UFWORD(MT_GET_STATE_NAME
) {
5813 UfoState
*st
= ufoFindState(ufoPop());
5814 if (st
== NULL
) ufoFatal("unknown state");
5816 uint32_t addr
= ufoPop();
5818 while (st
->name
[count
] != 0) {
5819 ufoImgPutU8Ext(addr
+ count
, ((const unsigned char *)st
->name
)[count
]);
5822 ufoImgPutU8Ext(addr
+ count
, 0);
5827 // MTASK:STATE-NAME!
5828 // ( addr count stid -- )
5829 UFWORD(MT_SET_STATE_NAME
) {
5830 UfoState
*st
= ufoFindState(ufoPop());
5831 if (st
== NULL
) ufoFatal("unknown state");
5832 uint32_t count
= ufoPop();
5833 uint32_t addr
= ufoPop();
5834 if ((count
& ((uint32_t)1 << 31)) == 0) {
5835 if (count
> UFO_MAX_TASK_NAME
) ufoFatal("task name too long");
5836 for (uint32_t f
= 0; f
< count
; f
+= 1u) {
5837 ((unsigned char *)st
->name
)[f
] = ufoImgGetU8Ext(addr
+ f
);
5839 st
->name
[count
] = 0;
5843 // MTASK:STATE-FIRST
5845 UFWORD(MT_STATE_FIRST
) {
5847 while (fidx
!= (uint32_t)(UFO_MAX_STATES
/32) && ufoStateUsedBitmap
[fidx
] == 0) fidx
+= 1u;
5848 // there should be at least one allocated state
5849 ufo_assert(fidx
!= (uint32_t)(UFO_MAX_STATES
/32));
5850 uint32_t bmp
= ufoStateUsedBitmap
[fidx
];
5852 while ((bmp
& 0x01) == 0) { fidx
+= 1u; bmp
>>= 1; }
5857 // ( stid -- stid / 0 )
5858 UFWORD(MT_STATE_NEXT
) {
5859 uint32_t stid
= ufoPop();
5860 if (stid
!= 0 && stid
< (uint32_t)(UFO_MAX_STATES
/32)) {
5861 // it is already incremented for us, yay!
5862 uint32_t fidx
= stid
/ 32u;
5863 uint8_t fofs
= stid
& 0x1f;
5864 while (fidx
< (uint32_t)(UFO_MAX_STATES
/32)) {
5865 const uint32_t bmp
= ufoStateUsedBitmap
[fidx
];
5867 while (fofs
!= 32u) {
5868 if ((bmp
& ((uint32_t)1 << (fofs
& 0x1f))) == 0) fofs
+= 1u;
5871 ufoPush(fidx
* 32u + fofs
+ 1u);
5875 fidx
+= 1u; fofs
= 0;
5883 // ( ... argc stid -- )
5884 UFWORD(MT_YIELD_TO
) {
5885 UfoState
*st
= ufoFindState(ufoPop());
5886 if (st
== NULL
) ufoFatal("cannot yield to unknown state");
5887 //if (st == ufoDebuggerState) ufoFatal("cannot yield to debugger"); // why not?
5888 const uint32_t argc
= ufoPop();
5889 if (argc
> 256) ufoFatal("too many YIELD-TO arguments");
5890 UfoState
*curst
= ufoCurrState
;
5891 if (st
!= ufoCurrState
) {
5892 for (uint32_t f
= 0; f
< argc
; f
+= 1) {
5893 ufoCurrState
= curst
;
5894 const uint32_t n
= ufoPop();
5898 ufoCurrState
= curst
; // we need to use API call to switch states
5900 ufoSwitchToState(st
); // always use API call for this!
5905 // MTASK:SET-SELF-AS-DEBUGGER
5907 UFWORD(MT_SET_SELF_AS_DEBUGGER
) {
5908 ufoDebuggerState
= ufoCurrState
;
5913 // debugger task receives debugge stid on the data stack, and -1 as argc.
5914 // i.e. debugger stask is: ( -1 old-stid )
5915 UFWORD(MT_DEBUGGER_BP
) {
5916 if (ufoDebuggerState
!= NULL
&& ufoCurrState
!= ufoDebuggerState
&& ufoIsGoodTTY()) {
5917 UfoState
*st
= ufoCurrState
;
5918 ufoSwitchToState(ufoDebuggerState
); // always use API call for this!
5923 UFCALL(UFO_BACKTRACE
);
5927 // MTASK:DEBUGGER-RESUME
5929 UFWORD(MT_RESUME_DEBUGEE
) {
5930 if (ufoCurrState
!= ufoDebuggerState
) ufoFatal("cannot resume from non-debugger");
5931 UfoState
*st
= ufoFindState(ufoPop());
5932 if (st
== NULL
) ufoFatal("cannot yield to unknown state");
5933 if (st
== ufoCurrState
) ufoFatal("cannot resume into debugger itself");
5934 ufoSwitchToState(st
); // always use API call for this!
5938 // MTASK:DEBUGGER-SINGLE-STEP
5940 UFWORD(MT_SINGLE_STEP_DEBUGEE
) {
5941 if (ufoCurrState
!= ufoDebuggerState
) ufoFatal("cannot resume from non-debugger");
5942 UfoState
*st
= ufoFindState(ufoPop());
5943 if (st
== NULL
) ufoFatal("cannot yield to unknown state");
5944 if (st
== ufoCurrState
) ufoFatal("cannot resume into debugger itself");
5945 ufoSwitchToState(st
); // always use API call for this!
5946 ufoSingleStep
= 2; // it will be decremented after returning from this word
5951 UFWORD(MT_STATE_IP_GET
) {
5952 UfoState
*st
= ufoFindState(ufoPop());
5953 if (st
== NULL
) ufoFatal("unknown state");
5959 UFWORD(MT_STATE_IP_SET
) {
5960 UfoState
*st
= ufoFindState(ufoPop());
5961 if (st
== NULL
) ufoFatal("unknown state");
5967 UFWORD(MT_STATE_REGA_GET
) {
5968 UfoState
*st
= ufoFindState(ufoPop());
5969 if (st
== NULL
) ufoFatal("unknown state");
5975 UFWORD(MT_STATE_REGA_SET
) {
5976 UfoState
*st
= ufoFindState(ufoPop());
5977 if (st
== NULL
) ufoFatal("unknown state");
5978 st
->regA
= ufoPop();
5981 // MTASK:STATE-USER@
5982 // ( addr stid -- value )
5983 UFWORD(MT_STATE_USER_GET
) {
5984 UfoState
*st
= ufoFindState(ufoPop());
5985 if (st
== NULL
) ufoFatal("unknown state");
5986 const uint32_t addr
= ufoPop();
5987 if ((addr
& UFO_ADDR_TEMP_BIT
) != 0 && (addr
& UFO_ADDR_TEMP_MASK
) + 3u < st
->imageTempSize
) {
5988 uint32_t v
= *(const uint32_t *)((const uint8_t *)st
->imageTemp
+ (addr
& UFO_ADDR_TEMP_MASK
));
5991 ufoFatal("invalid user area address");
5995 // MTASK:STATE-USER!
5996 // ( value addr stid -- )
5997 UFWORD(MT_STATE_USER_SET
) {
5998 UfoState
*st
= ufoFindState(ufoPop());
5999 if (st
== NULL
) ufoFatal("unknown state");
6000 const uint32_t addr
= ufoPop();
6001 const uint32_t value
= ufoPop();
6002 if ((addr
& UFO_ADDR_TEMP_BIT
) != 0 && (addr
& UFO_ADDR_TEMP_MASK
) + 3u < st
->imageTempSize
) {
6003 *(uint32_t *)((const uint8_t *)st
->imageTemp
+ (addr
& UFO_ADDR_TEMP_MASK
)) = value
;
6005 ufoFatal("invalid user area address");
6009 // MTASK:STATE-RPOPCFA@
6011 UFWORD(MT_STATE_RPOPCFA_GET
) {
6012 UfoState
*st
= ufoFindState(ufoPop());
6013 if (st
== NULL
) ufoFatal("unknown state");
6014 ufoPush(st
->vmRPopCFA
);
6017 // MTASK:STATE-RPOPCFA!
6019 UFWORD(MT_STATE_RPOPCFA_SET
) {
6020 UfoState
*st
= ufoFindState(ufoPop());
6021 if (st
== NULL
) ufoFatal("unknown state");
6022 st
->vmRPopCFA
= ufoPop();
6025 // MTASK:ACTIVE-STATE
6027 UFWORD(MT_ACTIVE_STATE
) {
6028 ufoPush(ufoCurrState
->id
);
6031 // MTASK:YIELDED-FROM
6033 UFWORD(MT_YIELDED_FROM
) {
6034 if (ufoYieldedState
!= NULL
) {
6035 ufoPush(ufoYieldedState
->id
);
6042 // ( stid -- depth )
6043 UFWORD(MT_DSTACK_DEPTH_GET
) {
6044 UfoState
*st
= ufoFindState(ufoPop());
6045 if (st
== NULL
) ufoFatal("unknown state");
6050 // ( stid -- depth )
6051 UFWORD(MT_RSTACK_DEPTH_GET
) {
6052 UfoState
*st
= ufoFindState(ufoPop());
6053 if (st
== NULL
) ufoFatal("unknown state");
6054 ufoPush(st
->RP
- st
->RPTop
);
6060 UfoState
*st
= ufoFindState(ufoPop());
6061 if (st
== NULL
) ufoFatal("unknown state");
6067 UFWORD(MT_LBP_GET
) {
6068 UfoState
*st
= ufoFindState(ufoPop());
6069 if (st
== NULL
) ufoFatal("unknown state");
6074 // ( depth stid -- )
6075 UFWORD(MT_DSTACK_DEPTH_SET
) {
6076 UfoState
*st
= ufoFindState(ufoPop());
6077 if (st
== NULL
) ufoFatal("unknown state");
6078 const uint32_t idx
= ufoPop();
6079 if (idx
>= UFO_DSTACK_SIZE
) ufoFatal("invalid stack index %u (%u)", idx
, UFO_DSTACK_SIZE
);
6084 // ( depth stid -- )
6085 UFWORD(MT_RSTACK_DEPTH_SET
) {
6086 UfoState
*st
= ufoFindState(ufoPop());
6087 if (st
== NULL
) ufoFatal("unknown state");
6088 const uint32_t idx
= ufoPop();
6089 const uint32_t left
= UFO_RSTACK_SIZE
- st
->RPTop
;
6090 if (idx
>= left
) ufoFatal("invalid rstack index %u (%u)", idx
, left
);
6091 st
->RP
= st
->RPTop
+ idx
;
6097 UfoState
*st
= ufoFindState(ufoPop());
6098 if (st
== NULL
) ufoFatal("unknown state");
6104 UFWORD(MT_LBP_SET
) {
6105 UfoState
*st
= ufoFindState(ufoPop());
6106 if (st
== NULL
) ufoFatal("unknown state");
6111 // ( idx stid -- value )
6112 UFWORD(MT_DSTACK_LOAD
) {
6113 UfoState
*st
= ufoFindState(ufoPop());
6114 if (st
== NULL
) ufoFatal("unknown state");
6115 const uint32_t idx
= ufoPop();
6116 if (idx
>= st
->SP
) ufoFatal("invalid stack index %u (%u)", idx
, st
->SP
);
6117 ufoPush(st
->dStack
[st
->SP
- idx
- 1u]);
6121 // ( idx stid -- value )
6122 UFWORD(MT_RSTACK_LOAD
) {
6123 UfoState
*st
= ufoFindState(ufoPop());
6124 if (st
== NULL
) ufoFatal("unknown state");
6125 const uint32_t idx
= ufoPop();
6126 if (idx
>= st
->RP
- st
->RPTop
) ufoFatal("invalid stack index %u (%u)", idx
, st
->RP
- st
->RPTop
);
6127 ufoPush(st
->dStack
[st
->RP
- idx
- 1u]);
6131 // ( idx stid -- value )
6132 UFWORD(MT_LSTACK_LOAD
) {
6133 UfoState
*st
= ufoFindState(ufoPop());
6134 if (st
== NULL
) ufoFatal("unknown state");
6135 const uint32_t idx
= ufoPop();
6136 if (idx
>= st
->LP
) ufoFatal("invalid lstack index %u (%u)", idx
, st
->LP
);
6137 ufoPush(st
->lStack
[st
->LP
- idx
- 1u]);
6141 // ( value idx stid -- )
6142 UFWORD(MT_DSTACK_STORE
) {
6143 UfoState
*st
= ufoFindState(ufoPop());
6144 if (st
== NULL
) ufoFatal("unknown state");
6145 const uint32_t idx
= ufoPop();
6146 const uint32_t value
= ufoPop();
6147 if (idx
>= st
->SP
) ufoFatal("invalid stack index %u (%u)", idx
, st
->SP
);
6148 st
->dStack
[st
->SP
- idx
- 1u] = value
;
6152 // ( value idx stid -- )
6153 UFWORD(MT_RSTACK_STORE
) {
6154 UfoState
*st
= ufoFindState(ufoPop());
6155 if (st
== NULL
) ufoFatal("unknown state");
6156 const uint32_t idx
= ufoPop();
6157 const uint32_t value
= ufoPop();
6158 if (idx
>= st
->RP
- st
->RPTop
) ufoFatal("invalid stack index %u (%u)", idx
, st
->RP
- st
->RPTop
);
6159 st
->dStack
[st
->RP
- idx
- 1u] = value
;
6163 // ( value idx stid -- )
6164 UFWORD(MT_LSTACK_STORE
) {
6165 UfoState
*st
= ufoFindState(ufoPop());
6166 if (st
== NULL
) ufoFatal("unknown state");
6167 const uint32_t idx
= ufoPop();
6168 const uint32_t value
= ufoPop();
6169 if (idx
>= st
->LP
) ufoFatal("invalid stack index %u (%u)", idx
, st
->LP
);
6170 st
->dStack
[st
->LP
- idx
- 1u] = value
;
6174 #include "urforth_tty.c"
6177 // ////////////////////////////////////////////////////////////////////////// //
6181 //==========================================================================
6185 // create a new state, its execution will start from the given CFA.
6186 // state is not automatically activated.
6188 //==========================================================================
6189 static UfoState
*ufoNewState (void) {
6190 // find free state id
6192 uint32_t bmp
= ufoStateUsedBitmap
[0];
6193 while (fidx
!= (uint32_t)(UFO_MAX_STATES
/32) && bmp
== ~(uint32_t)0) {
6195 bmp
= ufoStateUsedBitmap
[fidx
];
6197 if (fidx
== (uint32_t)(UFO_MAX_STATES
/32)) ufoFatal("too many execution states");
6198 //fprintf(stderr, "NST:000: fidx=%u; bmp=0x%08x\n", fidx, bmp);
6200 while ((bmp
& 0x01) != 0) { fidx
+= 1u; bmp
>>= 1; }
6201 ufo_assert(fidx
< UFO_MAX_STATES
);
6202 ufo_assert((ufoStateUsedBitmap
[fidx
/ 32u] & ((uint32_t)1 << (fidx
& 0x1f))) == 0);
6203 ufo_assert(ufoStateMap
[fidx
] == NULL
);
6204 UfoState
*st
= calloc(1, sizeof(UfoState
));
6205 if (st
== NULL
) ufoFatal("out of memory for states");
6207 ufoStateMap
[fidx
] = st
;
6208 ufoStateUsedBitmap
[fidx
/ 32u] |= ((uint32_t)1 << (fidx
& 0x1f));
6209 //fprintf(stderr, "NST: fidx=%u; 0x%08x\n", fidx, ufoStateUsedBitmap[fidx / 32u]);
6214 //==========================================================================
6218 // free all memory used for the state, remove it from state list.
6219 // WARNING! never free current state!
6221 //==========================================================================
6222 static void ufoFreeState (UfoState
*st
) {
6224 if (st
== ufoCurrState
) ufoFatal("cannot free active state");
6225 if (ufoYieldedState
== st
) ufoYieldedState
= NULL
;
6226 if (ufoDebuggerState
== st
) ufoDebuggerState
= NULL
;
6227 const uint32_t fidx
= st
->id
- 1u;
6228 //fprintf(stderr, "FST: fidx=%u; 0x%08x\n", fidx, ufoStateUsedBitmap[fidx / 32u]);
6229 ufo_assert(fidx
< UFO_MAX_STATES
);
6230 ufo_assert((ufoStateUsedBitmap
[fidx
/ 32u] & (1u << (fidx
& 0x1f))) != 0);
6231 ufo_assert(ufoStateMap
[fidx
] == st
);
6232 // free default TIB handle
6233 UfoState
*oldst
= ufoCurrState
;
6235 const uint32_t tib
= ufoImgGetU32(ufoAddrDefTIB
);
6236 if ((tib
& UFO_ADDR_TEMP_BIT
) != 0) {
6237 UfoHandle
*tibh
= ufoGetHandle(tib
);
6238 if (tibh
!= NULL
) ufoFreeHandle(tibh
);
6240 ufoCurrState
= oldst
;
6242 if (st
->imageTemp
!= NULL
) free(st
->imageTemp
);
6244 ufoStateMap
[fidx
] = NULL
;
6245 ufoStateUsedBitmap
[fidx
/ 32u] &= ~((uint32_t)1 << (fidx
& 0x1f));
6250 //==========================================================================
6254 //==========================================================================
6255 static UfoState
*ufoFindState (uint32_t stid
) {
6256 UfoState
*res
= NULL
;
6257 if (stid
>= 0 && stid
<= UFO_MAX_STATES
) {
6260 ufo_assert(ufoCurrState
!= NULL
);
6261 stid
= ufoCurrState
->id
- 1u;
6265 res
= ufoStateMap
[stid
];
6267 ufo_assert((ufoStateUsedBitmap
[stid
/ 32u] & (1u << (stid
& 0x1f))) != 0);
6268 ufo_assert(res
->id
== stid
+ 1u);
6270 ufo_assert((ufoStateUsedBitmap
[stid
/ 32u] & (1u << (stid
& 0x1f))) == 0);
6277 //==========================================================================
6281 //==========================================================================
6282 static void ufoSwitchToState (UfoState
*newst
) {
6283 ufo_assert(newst
!= NULL
);
6284 if (newst
!= ufoCurrState
) {
6285 ufoCurrState
= newst
;
6291 // ////////////////////////////////////////////////////////////////////////// //
6292 // initial dictionary definitions
6297 #define UFWORD(name_) do { \
6298 const uint32_t xcfa_ = ufoCFAsUsed; \
6299 ufo_assert(xcfa_ < UFO_MAX_NATIVE_CFAS); \
6300 ufoForthCFAs[xcfa_] = &ufoWord_##name_; \
6302 ufoDefineNative(""#name_, xcfa_, 0); \
6305 #define UFWORDX(strname_,name_) do { \
6306 const uint32_t xcfa_ = ufoCFAsUsed; \
6307 ufo_assert(xcfa_ < UFO_MAX_NATIVE_CFAS); \
6308 ufoForthCFAs[xcfa_] = &ufoWord_##name_; \
6310 ufoDefineNative(strname_, xcfa_, 0); \
6313 #define UFWORD_IMM(name_) do { \
6314 const uint32_t xcfa_ = ufoCFAsUsed; \
6315 ufo_assert(xcfa_ < UFO_MAX_NATIVE_CFAS); \
6316 ufoForthCFAs[xcfa_] = &ufoWord_##name_; \
6318 ufoDefineNative(""#name_, xcfa_, 1); \
6321 #define UFWORDX_IMM(strname_,name_) do { \
6322 const uint32_t xcfa_ = ufoCFAsUsed; \
6323 ufo_assert(xcfa_ < UFO_MAX_NATIVE_CFAS); \
6324 ufoForthCFAs[xcfa_] = &ufoWord_##name_; \
6326 ufoDefineNative(strname_, xcfa_, 1); \
6329 #define UFC(name_) ufoImgEmitU32_NoInline(ufoFindWordChecked(name_))
6332 //==========================================================================
6334 // ufoFindWordChecked
6336 //==========================================================================
6337 UFO_DISABLE_INLINE
uint32_t ufoFindWordChecked (const char *wname
) {
6338 const uint32_t cfa
= ufoFindWord(wname
);
6339 if (cfa
== 0) ufoFatal("word '%s' not found", wname
);
6344 //==========================================================================
6348 // get "FORTH" vocid
6350 //==========================================================================
6351 uint32_t ufoGetForthVocId (void) {
6352 return ufoForthVocId
;
6356 //==========================================================================
6358 // ufoVocSetOnlyDefs
6360 //==========================================================================
6361 void ufoVocSetOnlyDefs (uint32_t vocid
) {
6362 ufoImgPutU32(ufoAddrCurrent
, vocid
);
6363 ufoImgPutU32(ufoAddrContext
, vocid
);
6367 //==========================================================================
6371 // return voc PFA (vocid)
6373 //==========================================================================
6374 uint32_t ufoCreateVoc (const char *wname
, uint32_t parentvocid
, uint32_t flags
) {
6375 // create wordlist struct
6376 // typeid, used by Forth code (structs and such)
6377 ufoImgEmitU32(0); // typeid
6378 // vocid points here, to "LATEST-LFA"
6379 const uint32_t vocid
= UFO_GET_DP();
6380 //fprintf(stderr, "NEW VOCID (%s): 0x%08x\n", wname, vocid);
6381 ufoImgEmitU32(0); // latest
6382 const uint32_t vlink
= UFO_GET_DP();
6383 if ((vocid
& UFO_ADDR_TEMP_BIT
) == 0) {
6384 ufoImgEmitU32(ufoImgGetU32(ufoAddrVocLink
)); // voclink
6385 ufoImgPutU32(ufoAddrVocLink
, vlink
); // update voclink
6390 ufoImgEmitU32(parentvocid
); // parent
6391 const uint32_t hdraddr
= UFO_GET_DP();
6392 ufoImgEmitU32(0); // word header
6393 // create empty hash table
6394 for (int f
= 0; f
< UFO_HASHTABLE_SIZE
; f
+= 1) ufoImgEmitU32(0);
6395 // update CONTEXT and CURRENT if this is the first wordlist ever
6396 if (ufoImgGetU32(ufoAddrContext
) == 0) {
6397 ufoImgPutU32(ufoAddrContext
, vocid
);
6399 if (ufoImgGetU32(ufoAddrCurrent
) == 0) {
6400 ufoImgPutU32(ufoAddrCurrent
, vocid
);
6402 // create word header
6403 if (wname
!= NULL
&& wname
[0] != 0) {
6405 uint32_t flags = ufoImgGetU32(ufoAddrNewWordFlags);
6407 //UFW_FLAG_IMMEDIATE|
6409 //UFW_FLAG_NORETURN|
6415 flags |= UFW_FLAG_VOCAB;
6417 flags
&= 0xffffff00u
;
6418 flags
|= UFW_FLAG_VOCAB
;
6419 ufoCreateWordHeader(wname
, flags
);
6420 const uint32_t cfa
= UFO_GET_DP();
6421 ufoImgEmitU32(ufoDoVocCFA
); // cfa
6422 ufoImgEmitU32(vocid
); // pfa
6423 // update vocab header pointer
6424 const uint32_t lfa
= UFO_CFA_TO_LFA(cfa
);
6425 ufoImgPutU32(hdraddr
, UFO_LFA_TO_NFA(lfa
));
6426 #ifdef UFO_DEBUG_DUMP_NEW_HEADERS
6427 ufoDumpWordHeader(lfa
);
6434 //==========================================================================
6438 //==========================================================================
6439 static void ufoSetLatestArgs (uint32_t warg
) {
6440 const uint32_t curr
= ufoImgGetU32(ufoAddrCurrent
);
6441 const uint32_t lfa
= ufoImgGetU32(curr
);
6442 const uint32_t nfa
= UFO_LFA_TO_NFA(lfa
);
6443 uint32_t flags
= ufoImgGetU32(nfa
);
6444 //fprintf(stderr, "OLD FLAGS: 0x%08x\n", flags);
6445 flags
&= ~UFW_WARG_MASK
;
6446 flags
|= warg
& UFW_WARG_MASK
;
6447 //fprintf(stderr, "NEW FLAGS: 0x%08x\n", flags);
6448 ufoImgPutU32(nfa
, flags
);
6449 #ifdef UFO_DEBUG_DUMP_NEW_HEADERS
6450 ufoDumpWordHeader(lfa
);
6455 //==========================================================================
6459 //==========================================================================
6460 static void ufoDefineNative (const char *wname
, uint32_t cfaidx
, int immed
) {
6461 cfaidx
|= UFO_ADDR_CFA_BIT
;
6462 uint32_t flags
= ufoImgGetU32(ufoAddrNewWordFlags
);
6464 //UFW_FLAG_IMMEDIATE|
6466 //UFW_FLAG_NORETURN|
6472 if (immed
) flags
|= UFW_FLAG_IMMEDIATE
;
6473 ufoCreateWordHeader(wname
, flags
);
6474 ufoImgEmitU32(cfaidx
);
6478 //==========================================================================
6480 // ufoDefineConstant
6482 //==========================================================================
6483 static void ufoDefineConstant (const char *name
, uint32_t value
) {
6484 ufoDefineNative(name
, ufoDoConstCFA
, 0);
6485 ufoImgEmitU32(value
);
6489 //==========================================================================
6493 //==========================================================================
6494 static void ufoDefineUserVar (const char *name
, uint32_t addr
) {
6495 ufoDefineNative(name
, ufoDoUserVariableCFA
, 0);
6496 ufoImgEmitU32(addr
);
6500 //==========================================================================
6504 //==========================================================================
6506 static void ufoDefineVar (const char *name, uint32_t value) {
6507 ufoDefineNative(name, ufoDoVarCFA, 0);
6508 ufoImgEmitU32(value);
6513 //==========================================================================
6517 //==========================================================================
6519 static void ufoDefineDefer (const char *name, uint32_t value) {
6520 ufoDefineNative(name, ufoDoDeferCFA, 0);
6521 ufoImgEmitU32(value);
6526 //==========================================================================
6530 //==========================================================================
6531 static void ufoHiddenWords (void) {
6532 const uint32_t flags
= ufoImgGetU32(ufoAddrNewWordFlags
);
6533 ufoImgPutU32(ufoAddrNewWordFlags
, flags
| UFW_FLAG_HIDDEN
);
6537 //==========================================================================
6541 //==========================================================================
6542 static void ufoPublicWords (void) {
6543 const uint32_t flags
= ufoImgGetU32(ufoAddrNewWordFlags
);
6544 ufoImgPutU32(ufoAddrNewWordFlags
, flags
& ~UFW_FLAG_HIDDEN
);
6548 //==========================================================================
6552 //==========================================================================
6554 static void ufoDefineForth (const char *name) {
6555 ufoDefineNative(name, ufoDoForthCFA, 0);
6560 //==========================================================================
6562 // ufoDefineForthImm
6564 //==========================================================================
6566 static void ufoDefineForthImm (const char *name) {
6567 ufoDefineNative(name, ufoDoForthCFA, 1);
6572 //==========================================================================
6574 // ufoDefineForthHidden
6576 //==========================================================================
6578 static void ufoDefineForthHidden (const char *name) {
6579 const uint32_t flags = ufoImgGetU32(ufoAddrNewWordFlags);
6580 ufoImgPutU32(ufoAddrNewWordFlags, flags | UFW_FLAG_HIDDEN);
6581 ufoDefineNative(name, ufoDoForthCFA, 0);
6582 ufoImgPutU32(ufoAddrNewWordFlags, flags);
6587 //==========================================================================
6589 // ufoDefineSColonForth
6591 // create word suitable for scattered colon extension
6593 //==========================================================================
6594 static void ufoDefineSColonForth (const char *name
) {
6595 ufoDefineNative(name
, ufoDoForthCFA
, 0);
6596 // placeholder for scattered colon
6597 // it will compile two branches:
6598 // the first branch will jump to the first "..:" word (or over the two branches)
6599 // the second branch is never taken, and works as a pointer to the latest branch addr in the list
6600 // this way, each extension word will simply fix the last branch address, and update list tail
6601 // at the creation time, second branch points to the first branch
6602 UFC("FORTH:(BRANCH)");
6603 const uint32_t xjmp
= UFO_GET_DP();
6605 UFC("FORTH:(BRANCH)"); ufoImgEmitU32(xjmp
);
6606 ufoImgPutU32(xjmp
, UFO_GET_DP());
6610 //==========================================================================
6614 //==========================================================================
6615 UFO_FORCE_INLINE
void ufoDoneForth (void) {
6616 UFC("FORTH:(EXIT)");
6620 //==========================================================================
6624 // compile string literal, the same as QUOTE_IMM
6626 //==========================================================================
6627 static void ufoCompileStrLitEx (const char *str
, const uint32_t slen
) {
6628 if (str
== NULL
) str
= "";
6629 if (slen
> 255) ufoFatal("string literal too long");
6630 UFC("FORTH:(LITSTR8)");
6631 ufoImgEmitU8((uint8_t)slen
);
6632 for (size_t f
= 0; f
< slen
; f
+= 1) {
6633 ufoImgEmitU8(((const unsigned char *)str
)[f
]);
6640 //==========================================================================
6644 //==========================================================================
6646 static void ufoCompileStrLit (const char *str) {
6647 ufoCompileStrLitEx(str, (uint32_t)strlen(str));
6652 //==========================================================================
6656 //==========================================================================
6657 static void ufoCompileLit (uint32_t value
) {
6659 ufoImgEmitU32(value
);
6663 //==========================================================================
6667 //==========================================================================
6669 static void ufoCompileCFALit (const char *wname) {
6670 UFC("FORTH:(LITCFA)");
6671 const uint32_t cfa = ufoFindWordChecked(wname);
6677 //==========================================================================
6681 //==========================================================================
6682 static int ufoXStrEquCI (const char *word
, const char *text
, uint32_t tlen
) {
6683 while (tlen
!= 0 && *word
) {
6684 if (toUpper(*word
) != toUpper(*text
)) return 0;
6685 word
+= 1u; text
+= 1u; tlen
-= 1u;
6687 return (tlen
== 0 && *word
== 0);
6691 #define UFO_MAX_LABEL_NAME (63)
6692 typedef struct UfoLabel_t
{
6695 char name
[UFO_MAX_LABEL_NAME
];
6696 uint32_t addr
; // jump chain tail, or address
6698 uint32_t word
; // is this a forward word definition?
6699 struct UfoLabel_t
*next
;
6702 static UfoLabel
*ufoLabels
= NULL
;
6705 //==========================================================================
6707 // ufoFindAddLabelEx
6709 //==========================================================================
6710 static UfoLabel
*ufoFindAddLabelEx (const char *name
, uint32_t namelen
, int allowAdd
) {
6711 if (namelen
== 0 || namelen
> UFO_MAX_LABEL_NAME
) ufoFatal("invalid label name");
6712 const uint32_t hash
= joaatHashBufCI(name
, namelen
);
6713 UfoLabel
*lbl
= ufoLabels
;
6714 while (lbl
!= NULL
) {
6715 if (lbl
->hash
== hash
&& lbl
->namelen
== namelen
) {
6718 while (ok
&& sidx
!= namelen
) {
6719 ok
= (toUpper(name
[sidx
]) == toUpper(lbl
->name
[sidx
]));
6728 lbl
= calloc(1, sizeof(UfoLabel
));
6730 lbl
->namelen
= namelen
;
6731 memcpy(lbl
->name
, name
, namelen
);
6732 lbl
->name
[namelen
] = 0;
6733 lbl
->next
= ufoLabels
;
6742 //==========================================================================
6746 //==========================================================================
6747 static UfoLabel
*ufoFindAddLabel (const char *name
, uint32_t namelen
) {
6748 return ufoFindAddLabelEx(name
, namelen
, 1);
6752 //==========================================================================
6756 //==========================================================================
6757 static UfoLabel
*ufoFindLabel (const char *name
, uint32_t namelen
) {
6758 return ufoFindAddLabelEx(name
, namelen
, 0);
6762 //==========================================================================
6764 // ufoTrySimpleNumber
6766 // only decimal and C-like hexes; with an optional sign
6768 //==========================================================================
6769 static int ufoTrySimpleNumber (const char *text
, uint32_t tlen
, uint32_t *num
) {
6772 if (tlen
!= 0 && *text
== '+') { text
+= 1u; tlen
-= 1u; }
6773 else if (tlen
!= 0 && *text
== '-') { neg
= 1; text
+= 1u; tlen
-= 1u; }
6775 int base
= 10; // default base
6776 if (tlen
> 2 && text
[0] == '0' && toUpper(text
[1]) == 'X') {
6779 text
+= 2u; tlen
-= 2u;
6782 if (tlen
== 0 || digitInBase(*text
, base
) < 0) return 0;
6789 if (!wasDigit
) return 0;
6792 dig
= digitInBase(*text
, base
);
6793 if (dig
< 0) return 0;
6795 n
= n
* (uint32_t)base
+ (uint32_t)dig
;
6797 text
+= 1u; tlen
-= 1u;
6800 if (!wasDigit
) return 0;
6801 if (neg
) n
= ~n
+ 1u;
6807 //==========================================================================
6809 // ufoEmitLabelChain
6811 //==========================================================================
6812 static void ufoEmitLabelChain (UfoLabel
*lbl
) {
6813 ufo_assert(lbl
!= NULL
);
6814 ufo_assert(lbl
->defined
== 0);
6815 const uint32_t here
= UFO_GET_DP();
6816 ufoImgEmitU32(lbl
->addr
);
6821 //==========================================================================
6823 // ufoFixLabelChainHere
6825 //==========================================================================
6826 static void ufoFixLabelChainHere (UfoLabel
*lbl
) {
6827 ufo_assert(lbl
!= NULL
);
6828 ufo_assert(lbl
->defined
== 0);
6829 const uint32_t here
= UFO_GET_DP();
6830 while (lbl
->addr
!= 0) {
6831 const uint32_t aprev
= ufoImgGetU32(lbl
->addr
);
6832 ufoImgPutU32(lbl
->addr
, here
);
6840 #define UFO_MII_WORD_COMPILE_IMM (-4)
6841 #define UFO_MII_WORD_CFA_LIT (-3)
6842 #define UFO_MII_WORD_COMPILE (-2)
6843 #define UFO_MII_IN_WORD (-1)
6844 #define UFO_MII_NO_WORD (0)
6845 #define UFO_MII_WORD_NAME (1)
6846 #define UFO_MII_WORD_NAME_IMM (2)
6847 #define UFO_MII_WORD_NAME_HIDDEN (3)
6849 static int ufoMinInterpState
= UFO_MII_NO_WORD
;
6852 //==========================================================================
6854 // ufoFinalLabelCheck
6856 //==========================================================================
6857 static void ufoFinalLabelCheck (void) {
6859 if (ufoMinInterpState
!= UFO_MII_NO_WORD
) {
6860 ufoFatal("missing semicolon");
6862 while (ufoLabels
!= NULL
) {
6863 UfoLabel
*lbl
= ufoLabels
; ufoLabels
= lbl
->next
;
6864 if (!lbl
->defined
) {
6865 fprintf(stderr
, "UFO ERROR: label '%s' is not defined!\n", lbl
->name
);
6870 if (errorCount
!= 0) {
6871 ufoFatal("%d undefined label%s", errorCount
, (errorCount
!= 1 ? "s" : ""));
6876 //==========================================================================
6880 // this is so i could write Forth definitions more easily
6883 // $name -- reference
6884 // $name: -- definition
6886 //==========================================================================
6887 UFO_DISABLE_INLINE
void ufoInterpretLine (const char *line
) {
6888 char wname
[UFO_MAX_WORD_LENGTH
];
6889 uint32_t wlen
, num
, cfa
;
6892 if (*(const unsigned char *)line
<= 32) {
6894 } else if (ufoMinInterpState
== UFO_MII_WORD_CFA_LIT
||
6895 ufoMinInterpState
== UFO_MII_WORD_COMPILE
||
6896 ufoMinInterpState
== UFO_MII_WORD_COMPILE_IMM
)
6898 // "[']"/"COMPILE"/"[COMPILE]" argument
6900 while (((const unsigned char *)line
)[wlen
] > 32) wlen
+= 1;
6901 if (wlen
>= UFO_MAX_WORD_LENGTH
) ufoFatal("word name too long");
6902 memcpy(wname
, line
, wlen
);
6904 switch (ufoMinInterpState
) {
6905 case UFO_MII_WORD_CFA_LIT
: UFC("FORTH:(LITCFA)"); break;
6906 case UFO_MII_WORD_COMPILE
: UFC("FORTH:(LITCFA)"); break;
6907 case UFO_MII_WORD_COMPILE_IMM
: break;
6908 default: ufo_assert(0);
6910 cfa
= ufoFindWord(wname
);
6914 // forward reference
6915 lbl
= ufoFindAddLabel(line
, wlen
);
6916 if (lbl
->defined
|| (lbl
->word
== 0 && lbl
->addr
)) {
6917 ufoFatal("unknown word: '%s'", wname
);
6920 ufoEmitLabelChain(lbl
);
6922 switch (ufoMinInterpState
) {
6923 case UFO_MII_WORD_CFA_LIT
: break;
6924 case UFO_MII_WORD_COMPILE
: UFC("FORTH:COMPILE,"); break;
6925 case UFO_MII_WORD_COMPILE_IMM
: break;
6926 default: ufo_assert(0);
6928 ufoMinInterpState
= UFO_MII_IN_WORD
;
6930 } else if (ufoMinInterpState
> UFO_MII_NO_WORD
) {
6933 while (((const unsigned char *)line
)[wlen
] > 32) wlen
+= 1;
6934 if (wlen
>= UFO_MAX_WORD_LENGTH
) ufoFatal("word name too long");
6935 if (wlen
> 2 && line
[0] == ':' && line
[wlen
- 1u] == ':') ufoFatal("invalid word name");
6936 memcpy(wname
, line
, wlen
);
6938 const uint32_t oldFlags
= ufoImgGetU32(ufoAddrNewWordFlags
);
6939 if (ufoMinInterpState
== UFO_MII_WORD_NAME_HIDDEN
) {
6940 ufoImgPutU32(ufoAddrNewWordFlags
, oldFlags
| UFW_FLAG_HIDDEN
);
6942 ufoDefineNative(wname
, ufoDoForthCFA
, (ufoMinInterpState
== UFO_MII_WORD_NAME_IMM
));
6943 ufoImgPutU32(ufoAddrNewWordFlags
, oldFlags
);
6944 ufoMinInterpState
= UFO_MII_IN_WORD
;
6945 // check for forward references
6946 lbl
= ufoFindLabel(line
, wlen
);
6948 if (lbl
->defined
|| !lbl
->word
) {
6949 ufoFatal("label/word conflict for '%.*s'", (unsigned)wlen
, line
);
6951 ufoFixLabelChainHere(lbl
);
6954 } else if ((line
[0] == ';' && line
[1] == ';') ||
6955 (line
[0] == '-' && line
[1] == '-') ||
6956 (line
[0] == '/' && line
[1] == '/') ||
6957 (line
[0] == '\\' && ((const unsigned char *)line
)[1] <= 32))
6959 ufoFatal("do not use single-line comments");
6960 } else if (line
[0] == '(' && ((const unsigned char *)line
)[1] <= 32) {
6961 while (*line
&& *line
!= ')') line
+= 1;
6962 if (*line
== ')') line
+= 1;
6966 while (((const unsigned char *)line
)[wlen
] > 32) wlen
+= 1;
6967 if (wlen
== 1 && (line
[0] == '"' || line
[0] == '`')) {
6969 const char qch
= line
[0];
6970 if (!line
[1]) ufoFatal("unterminated string literal");
6971 // skip quote and space
6972 if (((const unsigned char *)line
)[1] <= 32) line
+= 2u; else line
+= 1u;
6974 while (line
[wlen
] && line
[wlen
] != qch
) wlen
+= 1u;
6975 if (line
[wlen
] != qch
) ufoFatal("unterminated string literal");
6976 ufoCompileStrLitEx(line
, wlen
);
6977 line
+= wlen
+ 1u; // skip final quote
6978 } else if (wlen
== 1 && line
[0] == ':') {
6980 if (ufoMinInterpState
!= UFO_MII_NO_WORD
) ufoFatal("unexpected colon");
6981 ufoMinInterpState
= UFO_MII_WORD_NAME
;
6983 } else if (wlen
== 1 && line
[0] == ';') {
6985 if (ufoMinInterpState
!= UFO_MII_IN_WORD
) ufoFatal("unexpected semicolon");
6986 ufoImgEmitU32(ufoFindWordChecked("FORTH:(EXIT)"));
6987 ufoMinInterpState
= UFO_MII_NO_WORD
;
6989 } else if (wlen
== 2 && line
[0] == '!' && line
[1] == ':') {
6990 // new immediate word
6991 if (ufoMinInterpState
!= UFO_MII_NO_WORD
) ufoFatal("unexpected colon");
6992 ufoMinInterpState
= UFO_MII_WORD_NAME_IMM
;
6994 } else if (wlen
== 2 && line
[0] == '*' && line
[1] == ':') {
6996 if (ufoMinInterpState
!= UFO_MII_NO_WORD
) ufoFatal("unexpected colon");
6997 ufoMinInterpState
= UFO_MII_WORD_NAME_HIDDEN
;
6999 } else if (wlen
== 3 && memcmp(line
, "[']", 3) == 0) {
7001 if (ufoMinInterpState
!= UFO_MII_IN_WORD
) ufoFatal("unexpected immediate tick");
7002 ufoMinInterpState
= UFO_MII_WORD_CFA_LIT
;
7004 } else if (wlen
== 7 && ufoXStrEquCI("COMPILE", line
, wlen
)) {
7006 if (ufoMinInterpState
!= UFO_MII_IN_WORD
) ufoFatal("unexpected immediate tick");
7007 ufoMinInterpState
= UFO_MII_WORD_COMPILE
;
7009 } else if (wlen
== 9 && ufoXStrEquCI("[COMPILE]", line
, wlen
)) {
7011 if (ufoMinInterpState
!= UFO_MII_IN_WORD
) ufoFatal("unexpected immediate tick");
7012 ufoMinInterpState
= UFO_MII_WORD_COMPILE_IMM
;
7016 if (wlen
>= UFO_MAX_WORD_LENGTH
) ufoFatal("word name too long");
7017 memcpy(wname
, line
, wlen
);
7019 cfa
= ufoFindWord(wname
);
7023 } else if (ufoTrySimpleNumber(line
, wlen
, &num
)) {
7024 // compile numeric literal
7027 // unknown word, this may be a forward reference, or a label definition
7028 // label defintion starts with "$"
7029 // (there are no words starting with "$" in the initial image)
7030 if (line
[0] == '$') {
7031 if (wlen
== 1) ufoFatal("dollar what?");
7032 if (wlen
> 2 && line
[wlen
- 1u] == ':') {
7034 lbl
= ufoFindAddLabel(line
, wlen
- 1u);
7035 if (lbl
->defined
) ufoFatal("double label '%s' definition", lbl
->name
);
7036 ufoFixLabelChainHere(lbl
);
7039 lbl
= ufoFindAddLabel(line
, wlen
);
7041 ufoImgEmitU32(lbl
->addr
);
7043 ufoEmitLabelChain(lbl
);
7047 // forward reference
7048 lbl
= ufoFindAddLabel(line
, wlen
);
7049 if (lbl
->defined
|| (lbl
->word
== 0 && lbl
->addr
)) {
7050 ufoFatal("unknown word: '%s'", wname
);
7053 ufoEmitLabelChain(lbl
);
7063 //==========================================================================
7067 //==========================================================================
7068 UFO_DISABLE_INLINE
void ufoReset (void) {
7069 if (ufoCurrState
== NULL
) ufoFatal("no active execution state");
7071 ufoSP
= 0; ufoRP
= 0;
7072 ufoLP
= 0; ufoLBP
= 0;
7075 ufoVMStop
= 0; ufoVMAbort
= 0;
7080 const uint32_t tib
= ufoImgGetU32(ufoAddrTIBx
);
7081 const uint32_t tibDef
= ufoImgGetU32(ufoAddrDefTIB
);
7082 ufoInitStateUserVars(ufoCurrState
, 0);
7084 ufoImgPutU32(ufoAddrTIBx
, tib
);
7085 ufoImgPutU32(ufoAddrDefTIB
, tibDef
);
7086 ufoImgPutU32(ufoAddrRedefineWarning
, UFO_REDEF_WARN_NORMAL
);
7089 ufoImgPutU32(ufoAddrDPTemp
, 0);
7091 ufoImgPutU32(ufoAddrNewWordFlags
, 0);
7092 ufoVocSetOnlyDefs(ufoForthVocId
);
7096 //==========================================================================
7098 // ufoDefineEmitType
7100 //==========================================================================
7101 UFO_DISABLE_INLINE
void ufoDefineEmitType (void) {
7104 ufoInterpretLine(": EMIT ( ch -- ) (NORM-EMIT-CHAR) (EMIT) ;");
7108 ufoInterpretLine(": XEMIT ( ch -- ) (NORM-XEMIT-CHAR) (EMIT) ;");
7112 ufoInterpretLine(": CR ( -- ) NL (EMIT) ;");
7118 " LASTCR? FORTH:(TBRANCH) $endcr-exit CR "
7121 //ufoDecompileWord(ufoFindWordChecked("ENDCR"));
7125 ufoInterpretLine(": SPACE ( -- ) BL (EMIT) ;");
7130 ": SPACES ( count -- ) "
7132 " DUP 0> FORTH:(0BRANCH) $spaces-exit "
7134 " FORTH:(BRANCH) $spaces-again "
7140 // ( addr count -- )
7142 ": TYPE ( addr count -- ) "
7145 " DUP 0> FORTH:(0BRANCH) $type-exit "
7148 " FORTH:(BRANCH) $type-again "
7154 // ( addr count -- )
7156 ": XTYPE ( addr count -- ) "
7159 " DUP 0> FORTH:(0BRANCH) $xtype-exit "
7162 " FORTH:(BRANCH) $xtype-again "
7170 ": HERE ( -- here ) "
7171 " FORTH:(DP-TEMP) @ ?DUP "
7172 " FORTH:(TBRANCH) $here-exit "
7180 ": ALIGN-HERE ( -- ) "
7181 "$align-here-loop: "
7183 " FORTH:(0BRANCH) $align-here-exit "
7185 " FORTH:(BRANCH) $align-here-loop "
7186 "$align-here-exit: "
7190 // ( C:addr count -- ) ( E: -- addr count )
7192 ": STRLITERAL ( C:addr count -- ) ( E: -- addr count ) "
7193 " DUP 255 U> ` string literal too long` ?ERROR "
7194 " STATE @ FORTH:(0BRANCH) $strlit-exit "
7196 " ['] FORTH:(LITSTR8) COMPILE, "
7198 " ( compile length ) "
7200 " ( compile chars ) "
7202 " DUP 0<> FORTH:(0BRANCH) $strlit-loop-exit "
7204 " FORTH:(BRANCH) $strlit-loop "
7205 "$strlit-loop-exit: "
7207 " ( final 0: our counter is 0 here, so use it ) "
7213 // ( -- addr count )
7215 "!: \" ( -- addr count ) "
7216 " 34 PARSE ` string literal expected` ?NOT-ERROR "
7217 " COMPILER:(UNESCAPE) STRLITERAL "
7222 //==========================================================================
7224 // ufoDefineInterpret
7226 // define "INTERPRET" in Forth
7228 //==========================================================================
7229 UFO_DISABLE_INLINE
void ufoDefineInterpret (void) {
7230 UFWORDX("(UFO-INTERPRET-FINISHED-ACTION)", UFO_INTERPRET_FINISHED_ACTION
);
7232 // return "stop flag"
7234 "*: (UFO-INTERPRET-NEXT-LINE) ( -- continue? ) "
7235 " STATE @ FORTH:(TBRANCH) $ipn_incomp "
7236 " ( interpreter allowed to cross include boundary ) "
7237 " REFILL FORTH:(BRANCH) $ipn_done "
7239 " ( compiler is not allowed to cross include boundary ) "
7240 " REFILL-NOCROSS ` compiler cannot cross file boundaries` ?NOT-ERROR "
7245 ufoInterpNextLineCFA
= ufoFindWordChecked("FORTH:(UFO-INTERPRET-NEXT-LINE)");
7246 ufoInterpretLine("*: (INTERPRET-NEXT-LINE) (USER-INTERPRET-NEXT-LINE) @ EXECUTE-TAIL ;");
7248 // skip comments, parse name, refilling lines if necessary
7249 // returning FALSE as counter means: "no addr, exit INTERPRET"
7251 "*: (INTERPRET-PARSE-NAME) ( -- addr count / FALSE ) "
7252 "$label_ipn_again: "
7253 " TRUE (PARSE-SKIP-COMMENTS) PARSE-NAME "
7254 " DUP FORTH:(TBRANCH) $label_ipn_exit_fwd "
7255 " 2DROP (INTERPRET-NEXT-LINE) "
7256 " FORTH:(TBRANCH) $label_ipn_again "
7258 "$label_ipn_exit_fwd: "
7260 //ufoDecompileWord(ufoFindWordChecked("(INTERPRET-PARSE-NAME)"));
7265 " FORTH:(INTERPRET-PARSE-NAME) ( addr count / FALSE )"
7266 " ?DUP FORTH:(0BRANCH) $interp-done "
7267 " ( try defered checker ) "
7268 " ( addr count FALSE -- addr count FALSE / TRUE ) "
7269 " FALSE (INTERPRET-CHECK-WORD) FORTH:(TBRANCH) $interp-again "
7270 " 2DUP FIND-WORD ( addr count cfa TRUE / addr count FALSE ) "
7271 " FORTH:(0BRANCH) $interp-try-number "
7273 " NROT 2DROP ( drop word string ) "
7274 " STATE @ FORTH:(0BRANCH) $interp-exec "
7275 " ( compiling; check immediate bit ) "
7276 " DUP CFA->NFA @ COMPILER:(WFLAG-IMMEDIATE) AND FORTH:(TBRANCH) $interp-exec "
7278 " FORTH:COMPILE, FORTH:(BRANCH) $interp-again "
7281 " EXECUTE FORTH:(BRANCH) $interp-again "
7282 " ( not a word, try a number ) "
7283 "$interp-try-number: "
7284 " 2DUP TRUE BASE @ (BASED-NUMBER) ( addr count allowsign? base -- num TRUE / FALSE ) "
7285 " FORTH:(0BRANCH) $interp-number-error "
7287 " NROT 2DROP ( drop word string ) "
7288 " ( do we need to compile it? ) "
7289 " STATE @ FORTH:(0BRANCH) $interp-again "
7290 " COMPILE FORTH:(LIT) FORTH:, "
7291 " FORTH:(BRANCH) $interp-again "
7293 "$interp-number-error: "
7294 " ( addr count FALSE -- addr count FALSE / TRUE ) "
7295 " FALSE (INTERPRET-WORD-NOT-FOUND) FORTH:(TBRANCH) $interp-again "
7296 " ENDCR SPACE XTYPE ` -- wut?` TYPE CR "
7297 " ` unknown word` ERROR "
7300 //ufoDecompileWord(ufoFindWordChecked("INTERPRET"));
7304 //==========================================================================
7308 //==========================================================================
7309 UFO_DISABLE_INLINE
void ufoInitBaseDict (void) {
7310 uint32_t imgAddr
= 0;
7312 // reserve 32 bytes for nothing
7313 for (uint32_t f
= 0; f
< 32; f
+= 1) {
7314 ufoImgPutU8(imgAddr
, 0);
7318 while ((imgAddr
& 3) != 0) {
7319 ufoImgPutU8(imgAddr
, 0);
7324 ufoAddrDP
= imgAddr
;
7325 ufoImgPutU32(imgAddr
, 0); imgAddr
+= 4u;
7328 ufoAddrDPTemp
= imgAddr
;
7329 ufoImgPutU32(imgAddr
, 0); imgAddr
+= 4u;
7332 ufoAddrLastXFA
= imgAddr
;
7333 ufoImgPutU32(imgAddr
, 0); imgAddr
+= 4u;
7336 ufoAddrVocLink
= imgAddr
;
7337 ufoImgPutU32(imgAddr
, 0); imgAddr
+= 4u;
7340 ufoAddrNewWordFlags
= imgAddr
;
7341 ufoImgPutU32(imgAddr
, UFW_FLAG_PROTECTED
); imgAddr
+= 4u;
7343 // WORD-REDEFINE-WARN-MODE
7344 ufoAddrRedefineWarning
= imgAddr
;
7345 ufoImgPutU32(imgAddr
, UFO_REDEF_WARN_NORMAL
); imgAddr
+= 4u;
7347 // setup (DP) and (DP-TEMP)
7348 ufoImgPutU32(ufoAddrDP
, imgAddr
);
7349 ufoImgPutU32(ufoAddrDPTemp
, 0);
7352 fprintf(stderr
, "INITIAL HERE: 0x%08x (0x%08x)\n", imgAddr
, UFO_GET_DP());
7357 //==========================================================================
7359 // ufoInitStateUserVars
7361 //==========================================================================
7362 static void ufoInitStateUserVars (UfoState
*st
, uint32_t cfa
) {
7363 ufo_assert(st
!= NULL
);
7364 if (st
->imageTempSize
< 8192u) {
7365 uint32_t *itmp
= realloc(st
->imageTemp
, 8192);
7366 if (itmp
== NULL
) ufoFatal("out of memory for state user area");
7367 st
->imageTemp
= itmp
;
7368 memset((uint8_t *)st
->imageTemp
+ st
->imageTempSize
, 0, 8192u - st
->imageTempSize
);
7369 st
->imageTempSize
= 8192;
7371 st
->imageTemp
[(ufoAddrBASE
& UFO_ADDR_TEMP_MASK
) / 4u] = 10;
7372 st
->imageTemp
[(ufoAddrSTATE
& UFO_ADDR_TEMP_MASK
) / 4u] = 0;
7373 st
->imageTemp
[(ufoAddrUserVarUsed
& UFO_ADDR_TEMP_MASK
) / 4u] = ufoAddrUserVarUsed
;
7374 st
->imageTemp
[(ufoAddrDefTIB
& UFO_ADDR_TEMP_MASK
) / 4u] = UFO_DEF_TIB_ADDR
;
7375 st
->imageTemp
[(ufoAddrTIBx
& UFO_ADDR_TEMP_MASK
) / 4u] = UFO_DEF_TIB_ADDR
;
7376 st
->imageTemp
[(ufoAddrINx
& UFO_ADDR_TEMP_MASK
) / 4u] = 0;
7377 st
->imageTemp
[(ufoAddrContext
& UFO_ADDR_TEMP_MASK
) / 4u] = ufoForthVocId
;
7378 st
->imageTemp
[(ufoAddrCurrent
& UFO_ADDR_TEMP_MASK
) / 4u] = ufoForthVocId
;
7379 st
->imageTemp
[(ufoAddrSelf
& UFO_ADDR_TEMP_MASK
) / 4u] = 0;
7380 st
->imageTemp
[(ufoAddrInterNextLine
& UFO_ADDR_TEMP_MASK
) / 4u] = ufoInterpNextLineCFA
;
7381 st
->imageTemp
[(ufoAddrEP
& UFO_ADDR_TEMP_MASK
) / 4u] = 0;
7382 // init other things, because this procedure is used in `ufoReset()` too
7383 st
->SP
= 0; st
->RP
= 0; st
->RPTop
= 0; st
->regA
= 0;
7384 st
->LP
= 0; st
->LBP
= 0; st
->vmRPopCFA
= 0;
7389 st
->rStack
[0] = 0xdeadf00d; // dummy value
7390 st
->rStack
[1] = cfa
;
7396 //==========================================================================
7398 // ufoInitBasicWords
7400 //==========================================================================
7401 UFO_DISABLE_INLINE
void ufoInitBasicWords (void) {
7402 ufoDefineConstant("FALSE", 0);
7403 ufoDefineConstant("TRUE", ufoTrueValue
);
7405 ufoDefineConstant("BL", 32);
7406 ufoDefineConstant("NL", 10);
7409 ufoDefineUserVar("BASE", ufoAddrBASE
);
7410 ufoDefineUserVar("TIB", ufoAddrTIBx
);
7411 ufoDefineUserVar(">IN", ufoAddrINx
);
7412 ufoDefineUserVar("(STD-TIB-ADDR)", ufoAddrDefTIB
);
7413 ufoDefineUserVar("(USER-VAR-USED)", ufoAddrUserVarUsed
);
7414 ufoDefineConstant("(USER-VAR-ADDR)", UFO_ADDR_TEMP_BIT
);
7415 ufoDefineConstant("(USER-VAR-SIZE)", UFO_USER_AREA_SIZE
);
7416 ufoDefineConstant("(USER-TIB)", UFO_DEF_TIB_ADDR
);
7417 ufoDefineConstant("(USER-TIB-SIZE)", UFO_ADDR_HANDLE_OFS_MASK
);
7419 ufoDefineUserVar("STATE", ufoAddrSTATE
);
7420 ufoDefineConstant("CONTEXT", ufoAddrContext
);
7421 ufoDefineConstant("CURRENT", ufoAddrCurrent
);
7422 ufoDefineConstant("(SELF)", ufoAddrSelf
); // used in OOP implementations
7423 ufoDefineConstant("(USER-INTERPRET-NEXT-LINE)", ufoAddrInterNextLine
);
7424 ufoDefineConstant("(EXC-FRAME-PTR)", ufoAddrEP
);
7427 ufoDefineConstant("(LATEST-XFA)", ufoAddrLastXFA
);
7428 ufoDefineConstant("(VOC-LINK)", ufoAddrVocLink
);
7429 ufoDefineConstant("(NEW-WORD-FLAGS)", ufoAddrNewWordFlags
);
7430 ufoDefineConstant("(ADDR-TEMP-BIT)", UFO_ADDR_TEMP_BIT
);
7431 ufoDefineConstant("(ADDR-CFA-BIT)", UFO_ADDR_CFA_BIT
);
7432 ufoDefineConstant("(ADDR-HANDLE-BIT)", UFO_ADDR_HANDLE_BIT
);
7433 ufoDefineConstant("(MAX-HANDLE-OFS)", UFO_ADDR_HANDLE_OFS_MASK
);
7435 ufoDefineConstant("(PAD-ADDR)", UFO_PAD_ADDR
);
7436 ufoDefineConstant("(#BUF)", UFO_NBUF_ADDR
+ 4u); // reserve room for counter
7437 ufoDefineConstant("(#BUF-SIZE)", UFO_NBUF_SIZE
- 8u);
7439 ufoDefineConstant("(DP)", ufoAddrDP
);
7440 ufoDefineConstant("(DP-TEMP)", ufoAddrDPTemp
);
7443 //UFWORDX("(UFO-BUCKET-STATS)", PAR_UFO_BUCKET_STATS);
7444 UFWORDX("SP0!", SP0_STORE
);
7445 UFWORDX("RP0!", RP0_STORE
);
7447 UFWORDX("PAD", PAD
);
7450 UFWORDX("C@", CPEEK
);
7451 UFWORDX("W@", WPEEK
);
7454 UFWORDX("C!", CPOKE
);
7455 UFWORDX("W!", WPOKE
);
7457 UFWORDX(",", COMMA
);
7458 UFWORDX("C,", CCOMMA
);
7459 UFWORDX("W,", WCOMMA
);
7461 UFWORDX("A>", REGA_LOAD
);
7462 UFWORDX(">A", REGA_STORE
);
7463 UFWORDX("A-SWAP", REGA_SWAP
);
7464 UFWORDX("+1>A", REGA_INC
);
7465 UFWORDX("+4>A", REGA_INC_CELL
);
7466 UFWORDX("A>R", REGA_TO_R
);
7467 UFWORDX("R>A", R_TO_REGA
);
7469 UFWORDX("@A+", PEEK_REGA_IDX
);
7470 UFWORDX("C@A+", CPEEK_REGA_IDX
);
7471 UFWORDX("W@A+", WPEEK_REGA_IDX
);
7473 UFWORDX("!A+", POKE_REGA_IDX
);
7474 UFWORDX("C!A+", CPOKE_REGA_IDX
);
7475 UFWORDX("W!A+", WPOKE_REGA_IDX
);
7478 UFWORDX("(LIT)", PAR_LIT
); ufoSetLatestArgs(UFW_WARG_LIT
);
7479 UFWORDX("(LITCFA)", PAR_LITCFA
); ufoSetLatestArgs(UFW_WARG_CFA
);
7480 UFWORDX("(LITVOCID)", PAR_LITVOCID
); ufoSetLatestArgs(UFW_WARG_VOCID
);
7481 UFWORDX("(LITSTR8)", PAR_LITSTR8
); ufoSetLatestArgs(UFW_WARG_C1STRZ
);
7482 UFWORDX("(EXIT)", PAR_EXIT
);
7484 ufoLitStr8CFA
= ufoFindWordChecked("FORTH:(LITSTR8)");
7486 UFWORDX("(L-ENTER)", PAR_LENTER
); ufoSetLatestArgs(UFW_WARG_LIT
);
7487 UFWORDX("(L-LEAVE)", PAR_LLEAVE
);
7488 UFWORDX("(LOCAL@)", PAR_LOCAL_LOAD
);
7489 UFWORDX("(LOCAL!)", PAR_LOCAL_STORE
);
7491 UFWORDX("(BRANCH)", PAR_BRANCH
); ufoSetLatestArgs(UFW_WARG_BRANCH
);
7492 UFWORDX("(TBRANCH)", PAR_TBRANCH
); ufoSetLatestArgs(UFW_WARG_BRANCH
);
7493 UFWORDX("(0BRANCH)", PAR_0BRANCH
); ufoSetLatestArgs(UFW_WARG_BRANCH
);
7494 UFWORDX("(+0BRANCH)", PAR_P0BRANCH
); ufoSetLatestArgs(UFW_WARG_BRANCH
);
7495 UFWORDX("(+BRANCH)", PAR_PBRANCH
); ufoSetLatestArgs(UFW_WARG_BRANCH
);
7496 UFWORDX("(-0BRANCH)", PAR_M0BRANCH
); ufoSetLatestArgs(UFW_WARG_BRANCH
);
7497 UFWORDX("(-BRANCH)", PAR_MBRANCH
); ufoSetLatestArgs(UFW_WARG_BRANCH
);
7498 UFWORDX("(DATASKIP)", PAR_DATASKIP
); ufoSetLatestArgs(UFW_WARG_DATASKIP
);
7503 //==========================================================================
7505 // ufoInitBasicCompilerWords
7507 //==========================================================================
7508 UFO_DISABLE_INLINE
void ufoInitBasicCompilerWords (void) {
7509 // create "COMPILER" vocabulary
7510 ufoCompilerVocId
= ufoCreateVoc("COMPILER", 0, UFW_FLAG_PROTECTED
);
7511 ufoVocSetOnlyDefs(ufoCompilerVocId
);
7513 ufoDefineConstant("(CFAIDX-DO-FORTH)", ufoDoForthCFA
);
7514 ufoDefineConstant("(CFAIDX-DO-VAR)", ufoDoVariableCFA
);
7515 ufoDefineConstant("(CFAIDX-DO-VALUE)", ufoDoValueCFA
);
7516 ufoDefineConstant("(CFAIDX-DO-CONST)", ufoDoConstCFA
);
7517 ufoDefineConstant("(CFAIDX-DO-DEFER)", ufoDoDeferCFA
);
7518 ufoDefineConstant("(CFAIDX-DO-VOC)", ufoDoVocCFA
);
7519 ufoDefineConstant("(CFAIDX-DO-CREATE)", ufoDoCreateCFA
);
7520 ufoDefineConstant("(CFAIDX-DO-USER-VAR)", ufoDoUserVariableCFA
);
7522 ufoDefineConstant("(WFLAG-IMMEDIATE)", UFW_FLAG_IMMEDIATE
);
7523 ufoDefineConstant("(WFLAG-SMUDGE)", UFW_FLAG_SMUDGE
);
7524 ufoDefineConstant("(WFLAG-NORETURN)", UFW_FLAG_NORETURN
);
7525 ufoDefineConstant("(WFLAG-HIDDEN)", UFW_FLAG_HIDDEN
);
7526 ufoDefineConstant("(WFLAG-CBLOCK)", UFW_FLAG_CBLOCK
);
7527 ufoDefineConstant("(WFLAG-VOCAB)", UFW_FLAG_VOCAB
);
7528 ufoDefineConstant("(WFLAG-SCOLON)", UFW_FLAG_SCOLON
);
7529 ufoDefineConstant("(WFLAG-PROTECTED)", UFW_FLAG_PROTECTED
);
7531 ufoDefineConstant("(WARG-MASK)", UFW_WARG_MASK
);
7532 ufoDefineConstant("(WARG-NONE)", UFW_WARG_NONE
);
7533 ufoDefineConstant("(WARG-BRANCH)", UFW_WARG_BRANCH
);
7534 ufoDefineConstant("(WARG-LIT)", UFW_WARG_LIT
);
7535 ufoDefineConstant("(WARG-C4STRZ)", UFW_WARG_C4STRZ
);
7536 ufoDefineConstant("(WARG-CFA)", UFW_WARG_CFA
);
7537 ufoDefineConstant("(WARG-CBLOCK)", UFW_WARG_CBLOCK
);
7538 ufoDefineConstant("(WARG-VOCID)", UFW_WARG_VOCID
);
7539 ufoDefineConstant("(WARG-C1STRZ)", UFW_WARG_C1STRZ
);
7541 ufoDefineConstant("(VOCOFS-LATEST)", UFW_VOCAB_OFS_LATEST
);
7542 ufoDefineConstant("(VOCOFS-VOCLINK)", UFW_VOCAB_OFS_VOCLINK
);
7543 ufoDefineConstant("(VOCOFS-PARENT)", UFW_VOCAB_OFS_PARENT
);
7544 ufoDefineConstant("(VOCOFS-HEADER)", UFW_VOCAB_OFS_HEADER
);
7545 ufoDefineConstant("(VOCOFS-HTABLE)", UFW_VOCAB_OFS_HTABLE
);
7546 ufoDefineConstant("(VOC-HTABLE-SIZE)", UFO_HASHTABLE_SIZE
);
7547 ufoDefineConstant("(VOC-HTABLE-NOFLAG)", UFO_NO_HTABLE_FLAG
);
7549 ufoDefineConstant("(REDEFINE-WARN-DON'T-CARE)", UFO_REDEF_WARN_DONT_CARE
);
7550 ufoDefineConstant("(REDEFINE-WARN-NONE)", UFO_REDEF_WARN_NONE
);
7551 ufoDefineConstant("(REDEFINE-WARN-NORMAL)", UFO_REDEF_WARN_NORMAL
);
7552 ufoDefineConstant("(REDEFINE-WARN-PARENTS)", UFO_REDEF_WARN_PARENTS
);
7554 ufoDefineConstant("WORD-REDEFINE-WARN-MODE", ufoAddrRedefineWarning
);
7556 UFWORDX("(UNESCAPE)", PAR_UNESCAPE
);
7560 " FORTH:STATE FORTH:@ ` expecting interpretation mode` FORTH:?ERROR "
7565 " FORTH:STATE FORTH:@ ` expecting compilation mode` FORTH:?NOT-ERROR "
7568 UFWORDX("(CREATE-WORD-HEADER)", PAR_CREATE_WORD_HEADER
);
7569 UFWORDX("(CREATE-NAMELESS-WORD-HEADER)", PAR_CREATE_NAMELESS_WORD_HEADER
);
7571 ufoVocSetOnlyDefs(ufoForthVocId
);
7574 ufoInterpretLine("!: [ COMPILER:?COMP 0 STATE ! ;");
7576 ufoInterpretLine(": ] COMPILER:?EXEC 1 STATE ! ;");
7580 //==========================================================================
7584 //==========================================================================
7585 UFO_DISABLE_INLINE
void ufoInitMoreWords (void) {
7586 UFWORDX("COMPILE,", COMMA
); // just an alias, for clarity
7588 UFWORDX("CFA->PFA", CFA2PFA
);
7589 UFWORDX("CFA->NFA", CFA2NFA
);
7590 UFWORDX("CFA->LFA", CFA2LFA
);
7591 UFWORDX("CFA->WEND", CFA2WEND
);
7593 UFWORDX("PFA->CFA", PFA2CFA
);
7594 UFWORDX("PFA->NFA", PFA2NFA
);
7596 UFWORDX("NFA->CFA", NFA2CFA
);
7597 UFWORDX("NFA->PFA", NFA2PFA
);
7598 UFWORDX("NFA->LFA", NFA2LFA
);
7600 UFWORDX("LFA->CFA", LFA2CFA
);
7601 UFWORDX("LFA->PFA", LFA2PFA
);
7602 UFWORDX("LFA->BFA", LFA2BFA
);
7603 UFWORDX("LFA->XFA", LFA2XFA
);
7604 UFWORDX("LFA->YFA", LFA2YFA
);
7605 UFWORDX("LFA->NFA", LFA2NFA
);
7607 UFWORDX("(BASED-NUMBER)", PAR_BASED_NUMBER
);
7608 UFWORDX("FIND-WORD", FIND_WORD
);
7609 UFWORDX("(FIND-WORD-IN-VOC)", FIND_WORD_IN_VOC
);
7610 UFWORDX("(FIND-WORD-IN-VOC-AND-PARENTS)", FIND_WORD_IN_VOC_AND_PARENTS
);
7613 UFWORDX("EXECUTE-TAIL", EXECUTE_TAIL
);
7616 UFWORDX("?DUP", QDUP
);
7617 UFWORDX("2DUP", DDUP
);
7619 UFWORDX("2DROP", DDROP
);
7621 UFWORDX("2SWAP", DSWAP
);
7623 UFWORDX("2OVER", DOVER
);
7626 UFWORDX("PICK", PICK
);
7627 UFWORDX("ROLL", ROLL
);
7631 UFWORDX(">R", DTOR
);
7632 UFWORDX("R>", RTOD
);
7633 UFWORDX("R@", RPEEK
);
7634 UFWORDX("RPICK", RPICK
);
7635 UFWORDX("RROLL", RROLL
);
7636 UFWORDX("RSWAP", RSWAP
);
7637 UFWORDX("ROVER", ROVER
);
7638 UFWORDX("RROT", RROT
);
7639 UFWORDX("RNROT", RNROT
);
7641 UFWORDX("FLUSH-EMIT", FLUSH_EMIT
);
7642 UFWORDX("(EMIT)", PAR_EMIT
);
7643 UFWORDX("(NORM-EMIT-CHAR)", PAR_NORM_EMIT_CHAR
);
7644 UFWORDX("(NORM-XEMIT-CHAR)", PAR_NORM_XEMIT_CHAR
);
7645 UFWORDX("LASTCR?", LASTCRQ
);
7646 UFWORDX("LASTCR!", LASTCRSET
);
7650 UFWORDX("-", MINUS
);
7652 UFWORDX("U*", UMUL
);
7654 UFWORDX("U/", UDIV
);
7655 UFWORDX("MOD", MOD
);
7656 UFWORDX("UMOD", UMOD
);
7657 UFWORDX("/MOD", DIVMOD
);
7658 UFWORDX("U/MOD", UDIVMOD
);
7659 UFWORDX("*/", MULDIV
);
7660 UFWORDX("U*/", UMULDIV
);
7661 UFWORDX("*/MOD", MULDIVMOD
);
7662 UFWORDX("U*/MOD", UMULDIVMOD
);
7663 UFWORDX("M*", MMUL
);
7664 UFWORDX("UM*", UMMUL
);
7665 UFWORDX("M/MOD", MDIVMOD
);
7666 UFWORDX("UM/MOD", UMDIVMOD
);
7667 UFWORDX("UDS*", UDSMUL
);
7669 UFWORDX("SM/REM", SMREM
);
7670 UFWORDX("FM/MOD", FMMOD
);
7672 UFWORDX("D-", DMINUS
);
7673 UFWORDX("D+", DPLUS
);
7674 UFWORDX("D=", DEQU
);
7675 UFWORDX("D<", DLESS
);
7676 UFWORDX("D<=", DLESSEQU
);
7677 UFWORDX("DU<", DULESS
);
7678 UFWORDX("DU<=", DULESSEQU
);
7685 UFWORDX(">", GREAT
);
7686 UFWORDX("<=", LESSEQU
);
7687 UFWORDX(">=", GREATEQU
);
7688 UFWORDX("U<", ULESS
);
7689 UFWORDX("U>", UGREAT
);
7690 UFWORDX("U<=", ULESSEQU
);
7691 UFWORDX("U>=", UGREATEQU
);
7693 UFWORDX("<>", NOTEQU
);
7695 UFWORDX("0=", ZERO_EQU
);
7696 UFWORDX("0<>", ZERO_NOTEQU
);
7698 UFWORDX("NOT", ZERO_EQU
);
7699 UFWORDX("NOTNOT", ZERO_NOTEQU
);
7705 UFWORDX("LOGAND", LOGAND
);
7706 UFWORDX("LOGOR", LOGOR
);
7709 UFWORDX("(TIB-IN)", TIB_IN
);
7710 UFWORDX("TIB-PEEKCH", TIB_PEEKCH
);
7711 UFWORDX("TIB-PEEKCH-OFS", TIB_PEEKCH_OFS
);
7712 UFWORDX("TIB-GETCH", TIB_GETCH
);
7713 UFWORDX("TIB-SKIPCH", TIB_SKIPCH
);
7715 UFWORDX("REFILL", REFILL
);
7716 UFWORDX("REFILL-NOCROSS", REFILL_NOCROSS
);
7719 UFWORDX("(PARSE)", PAR_PARSE
);
7720 UFWORDX("(PARSE-SKIP-COMMENTS)", PAR_PARSE_SKIP_COMMENTS
);
7722 UFWORDX("PARSE-SKIP-BLANKS", PARSE_SKIP_BLANKS
);
7723 UFWORDX("PARSE-NAME", PARSE_NAME
);
7724 UFWORDX("PARSE-SKIP-LINE", PARSE_SKIP_LINE
);
7725 UFWORDX("PARSE", PARSE
);
7728 UFWORDX("(VSP@)", PAR_GET_VSP
);
7729 UFWORDX("(VSP!)", PAR_SET_VSP
);
7730 UFWORDX("(VSP-AT@)", PAR_VSP_LOAD
);
7731 UFWORDX("(VSP-AT!)", PAR_VSP_STORE
);
7732 ufoDefineConstant("(VSP-SIZE)", UFO_VOCSTACK_SIZE
);
7734 ufoDefineConstant("(SP-SIZE)", UFO_DSTACK_SIZE
);
7735 ufoDefineConstant("(RP-SIZE)", UFO_RSTACK_SIZE
);
7736 ufoDefineConstant("(LP-SIZE)", UFO_LSTACK_SIZE
);
7739 UFWORDX("ERROR", ERROR
);
7740 UFWORDX("FATAL-ERROR", ERROR
);
7742 ufoInterpretLine(": 1+ ( n -- n+1 ) 1 + ;");
7743 ufoInterpretLine(": 1- ( n -- n-1 ) 1 - ;");
7744 ufoInterpretLine(": 2+ ( n -- n+2 ) 2 + ;");
7745 ufoInterpretLine(": 2- ( n -- n-2 ) 2 - ;");
7746 ufoInterpretLine(": 4+ ( n -- n+4 ) 4 + ;");
7747 ufoInterpretLine(": 4- ( n -- n-4 ) 4 - ;");
7749 ufoInterpretLine(": 2* ( n -- n*2 ) 1 ASH ;");
7750 ufoInterpretLine(": 2/ ( n -- n/2 ) -1 ASH ;");
7751 ufoInterpretLine(": 4* ( n -- n*4 ) 2 ASH ;");
7752 ufoInterpretLine(": 4/ ( n -- n/4 ) -2 ASH ;");
7754 ufoInterpretLine(": 2U* ( u -- u*2 ) 1 LSH ;");
7755 ufoInterpretLine(": 2U/ ( u -- u/2 ) -1 LSH ;");
7756 ufoInterpretLine(": 4U* ( u -- u*4 ) 2 LSH ;");
7757 ufoInterpretLine(": 4U/ ( u -- u/4 ) -2 LSH ;");
7759 ufoInterpretLine(": 0< ( n -- n<0 ) 0 < ;");
7760 ufoInterpretLine(": 0> ( n -- n>0 ) 0 > ;");
7761 ufoInterpretLine(": 0<= ( n -- n<0 ) 0 <= ;");
7762 ufoInterpretLine(": 0>= ( n -- n>0 ) 0 >= ;");
7764 ufoInterpretLine(": @A ( idx -- v ) 0 @A+ ;");
7765 ufoInterpretLine(": C@A ( idx -- v ) 0 C@A+ ;");
7766 ufoInterpretLine(": W@A ( idx -- v ) 0 W@A+ ;");
7768 ufoInterpretLine(": !A ( idx -- v ) 0 !A+ ;");
7769 ufoInterpretLine(": C!A ( idx -- v ) 0 C!A+ ;");
7770 ufoInterpretLine(": W!A ( idx -- v ) 0 W!A+ ;");
7774 ufoInterpretLine(": ABORT ` \"ABORT\" called` ERROR ;");
7777 // ( errflag addr count -- )
7779 ": ?ERROR ( errflag addr count -- ) "
7780 " ROT FORTH:(0BRANCH) $qerr_skip ERROR "
7786 // ( errflag addr count -- )
7788 ": ?NOT-ERROR ( errflag addr count -- ) "
7789 " ROT FORTH:(TBRANCH) $qnoterr_skip ERROR "
7795 ": FIND-WORD-IN-VOC ( vocid addr count -- cfa TRUE / FALSE ) "
7796 " 0 (FIND-WORD-IN-VOC) ;");
7799 ": FIND-WORD-IN-VOC-AND-PARENTS ( vocid addr count -- cfa TRUE / FALSE ) "
7800 " 0 (FIND-WORD-IN-VOC-AND-PARENTS) ;");
7802 UFWORDX("GET-MSECS", GET_MSECS
);
7806 //==========================================================================
7808 // ufoInitHandleWords
7810 //==========================================================================
7811 UFO_DISABLE_INLINE
void ufoInitHandleWords (void) {
7812 // create "HANDLE" vocabulary
7813 const uint32_t handleVocId
= ufoCreateVoc("HANDLE", 0, UFW_FLAG_PROTECTED
);
7814 ufoVocSetOnlyDefs(handleVocId
);
7815 UFWORDX("NEW", PAR_NEW_HANDLE
);
7816 UFWORDX("FREE", PAR_FREE_HANDLE
);
7817 UFWORDX("TYPEID@", PAR_HANDLE_GET_TYPEID
);
7818 UFWORDX("TYPEID!", PAR_HANDLE_SET_TYPEID
);
7819 UFWORDX("SIZE@", PAR_HANDLE_GET_SIZE
);
7820 UFWORDX("SIZE!", PAR_HANDLE_SET_SIZE
);
7821 UFWORDX("USED@", PAR_HANDLE_GET_USED
);
7822 UFWORDX("USED!", PAR_HANDLE_SET_USED
);
7823 UFWORDX("C@", PAR_HANDLE_LOAD_BYTE
);
7824 UFWORDX("W@", PAR_HANDLE_LOAD_WORD
);
7825 UFWORDX("@", PAR_HANDLE_LOAD_CELL
);
7826 UFWORDX("C!", PAR_HANDLE_STORE_BYTE
);
7827 UFWORDX("W!", PAR_HANDLE_STORE_WORD
);
7828 UFWORDX("!", PAR_HANDLE_STORE_CELL
);
7829 UFWORDX("LOAD-FILE", PAR_HANDLE_LOAD_FILE
);
7830 ufoVocSetOnlyDefs(ufoForthVocId
);
7834 //==========================================================================
7836 // ufoInitHigherWords
7838 //==========================================================================
7839 UFO_DISABLE_INLINE
void ufoInitHigherWords (void) {
7840 UFWORDX("(INCLUDE)", PAR_INCLUDE
);
7842 UFWORDX("(INCLUDE-DEPTH)", PAR_INCLUDE_DEPTH
);
7843 UFWORDX("(INCLUDE-FILE-ID)", PAR_INCLUDE_FILE_ID
);
7844 UFWORDX("(INCLUDE-FILE-LINE)", PAR_INCLUDE_FILE_LINE
);
7845 UFWORDX("(INCLUDE-FILE-NAME)", PAR_INCLUDE_FILE_NAME
);
7847 UFWORDX("($DEFINED?)", PAR_DLR_DEFINEDQ
);
7848 UFWORDX("($DEFINE)", PAR_DLR_DEFINE
);
7849 UFWORDX("($UNDEF)", PAR_DLR_UNDEF
);
7851 UFWORDX_IMM("$INCLUDE", DLR_INCLUDE_IMM
);
7852 UFWORDX_IMM("$INCLUDE-ONCE", DLR_INCLUDE_ONCE_IMM
);
7856 //==========================================================================
7858 // ufoInitStringWords
7860 //==========================================================================
7861 UFO_DISABLE_INLINE
void ufoInitStringWords (void) {
7862 // create "STRING" vocabulary
7863 const uint32_t stringVocId
= ufoCreateVoc("STRING", 0, UFW_FLAG_PROTECTED
);
7864 ufoVocSetOnlyDefs(stringVocId
);
7865 UFWORDX("=", STREQU
);
7866 UFWORDX("=CI", STREQUCI
);
7867 UFWORDX("SEARCH", SEARCH
);
7868 UFWORDX("HASH", STRHASH
);
7869 UFWORDX("HASH-CI", STRHASHCI
);
7870 ufoVocSetOnlyDefs(ufoForthVocId
);
7874 //==========================================================================
7876 // ufoInitDebugWords
7878 //==========================================================================
7879 UFO_DISABLE_INLINE
void ufoInitDebugWords (void) {
7880 // create "DEBUG" vocabulary
7881 const uint32_t debugVocId
= ufoCreateVoc("DEBUG", 0, UFW_FLAG_PROTECTED
);
7882 ufoVocSetOnlyDefs(debugVocId
);
7883 UFWORDX("(DECOMPILE-CFA)", DEBUG_DECOMPILE_CFA
);
7884 UFWORDX("(DECOMPILE-MEM)", DEBUG_DECOMPILE_MEM
);
7885 UFWORDX("BACKTRACE", UFO_BACKTRACE
);
7886 UFWORDX("DUMP-STACK", DUMP_STACK
);
7887 UFWORDX("BACKTRACE-TASK", UFO_BACKTRACE_TASK
);
7888 UFWORDX("DUMP-STACK-TASK", DUMP_STACK_TASK
);
7889 UFWORDX("DUMP-RSTACK-TASK", DUMP_RSTACK_TASK
);
7890 UFWORDX("(BP)", MT_DEBUGGER_BP
);
7891 UFWORDX("IP->NFA", IP2NFA
);
7892 UFWORDX("IP->FILE/LINE", IP2FILELINE
);
7893 UFWORDX("IP->FILE-HASH/LINE", IP2FILEHASHLINE
);
7894 ufoVocSetOnlyDefs(ufoForthVocId
);
7898 //==========================================================================
7902 //==========================================================================
7903 UFO_DISABLE_INLINE
void ufoInitMTWords (void) {
7904 // create "MTASK" vocabulary
7905 const uint32_t mtVocId
= ufoCreateVoc("MTASK", 0, UFW_FLAG_PROTECTED
);
7906 ufoVocSetOnlyDefs(mtVocId
);
7907 UFWORDX("NEW-STATE", MT_NEW_STATE
);
7908 UFWORDX("FREE-STATE", MT_FREE_STATE
);
7909 UFWORDX("STATE-NAME@", MT_GET_STATE_NAME
);
7910 UFWORDX("STATE-NAME!", MT_SET_STATE_NAME
);
7911 UFWORDX("STATE-FIRST", MT_STATE_FIRST
);
7912 UFWORDX("STATE-NEXT", MT_STATE_NEXT
);
7913 UFWORDX("YIELD-TO", MT_YIELD_TO
);
7914 UFWORDX("SET-SELF-AS-DEBUGGER", MT_SET_SELF_AS_DEBUGGER
);
7915 UFWORDX("DEBUGGER-RESUME", MT_RESUME_DEBUGEE
);
7916 UFWORDX("DEBUGGER-SINGLE-STEP", MT_SINGLE_STEP_DEBUGEE
);
7917 UFWORDX("ACTIVE-STATE", MT_ACTIVE_STATE
);
7918 UFWORDX("STATE-IP@", MT_STATE_IP_GET
);
7919 UFWORDX("STATE-IP!", MT_STATE_IP_SET
);
7920 UFWORDX("STATE-A>", MT_STATE_REGA_GET
);
7921 UFWORDX("STATE->A", MT_STATE_REGA_SET
);
7922 UFWORDX("STATE-USER@", MT_STATE_USER_GET
);
7923 UFWORDX("STATE-USER!", MT_STATE_USER_SET
);
7924 UFWORDX("STATE-RPOPCFA@", MT_STATE_RPOPCFA_GET
);
7925 UFWORDX("STATE-RPOPCFA!", MT_STATE_RPOPCFA_SET
);
7926 UFWORDX("YIELDED-FROM", MT_YIELDED_FROM
);
7927 UFWORDX("STATE-SP@", MT_DSTACK_DEPTH_GET
);
7928 UFWORDX("STATE-RP@", MT_RSTACK_DEPTH_GET
);
7929 UFWORDX("STATE-LP@", MT_LP_GET
);
7930 UFWORDX("STATE-LBP@", MT_LBP_GET
);
7931 UFWORDX("STATE-SP!", MT_DSTACK_DEPTH_SET
);
7932 UFWORDX("STATE-RP!", MT_RSTACK_DEPTH_SET
);
7933 UFWORDX("STATE-LP!", MT_LP_SET
);
7934 UFWORDX("STATE-LBP!", MT_LBP_SET
);
7935 UFWORDX("STATE-DS@", MT_DSTACK_LOAD
);
7936 UFWORDX("STATE-RS@", MT_RSTACK_LOAD
);
7937 UFWORDX("STATE-LS@", MT_LSTACK_LOAD
);
7938 UFWORDX("STATE-DS!", MT_DSTACK_STORE
);
7939 UFWORDX("STATE-RS!", MT_RSTACK_STORE
);
7940 UFWORDX("STATE-LS!", MT_LSTACK_STORE
);
7941 ufoVocSetOnlyDefs(ufoForthVocId
);
7945 //==========================================================================
7949 //==========================================================================
7950 UFO_DISABLE_INLINE
void ufoInitTTYWords (void) {
7951 // create "TTY" vocabulary
7952 const uint32_t ttyVocId
= ufoCreateVoc("TTY", 0, UFW_FLAG_PROTECTED
);
7953 ufoVocSetOnlyDefs(ttyVocId
);
7954 UFWORDX("TTY?", TTY_TTYQ
);
7955 UFWORDX("RAW?", TTY_RAWQ
);
7956 UFWORDX("SIZE", TTY_SIZE
);
7957 UFWORDX("SET-RAW", TTY_SET_RAW
);
7958 UFWORDX("SET-COOKED", TTY_SET_COOKED
);
7959 UFWORDX("RAW-EMIT", TTY_RAW_EMIT
);
7960 UFWORDX("RAW-TYPE", TTY_RAW_TYPE
);
7961 UFWORDX("RAW-FLUSH", TTY_RAW_FLUSH
);
7962 UFWORDX("RAW-READCH", TTY_RAW_READCH
);
7963 UFWORDX("RAW-READY?", TTY_RAW_READYQ
);
7964 ufoVocSetOnlyDefs(ufoForthVocId
);
7968 //==========================================================================
7970 // ufoInitVeryVeryHighWords
7972 //==========================================================================
7973 UFO_DISABLE_INLINE
void ufoInitVeryVeryHighWords (void) {
7975 //ufoDefineDefer("INTERPRET", idumbCFA);
7977 ufoDefineEmitType();
7979 // ( addr count FALSE -- addr count FALSE / TRUE )
7980 ufoDefineSColonForth("(INTERPRET-CHECK-WORD)");
7982 // ( addr count FALSE -- addr count FALSE / TRUE )
7983 ufoDefineSColonForth("(INTERPRET-WORD-NOT-FOUND)");
7985 // ( -- ) -- called in "EXIT", before compiling "FORTH:(EXIT)"
7986 ufoDefineSColonForth("(EXIT-EXTENDER)");
7990 ufoInterpretLine("!: EXIT ( -- ) COMPILER:?COMP (EXIT-EXTENDER) COMPILE FORTH:(EXIT) ;");
7992 ufoDefineInterpret();
7994 //ufoDumpVocab(ufoCompilerVocId);
7997 ": RUN-INTERPRET-LOOP "
7998 "$run-interp-loop-again: "
7999 " RP0! INTERPRET (UFO-INTERPRET-FINISHED-ACTION) "
8000 " FORTH:(BRANCH) $run-interp-loop-again "
8004 #define UFO_ADD_DO_CFA(cfx_) do { \
8005 ufoDo##cfx_##CFA = ufoCFAsUsed | UFO_ADDR_CFA_BIT; \
8006 ufoForthCFAs[ufoCFAsUsed] = &ufoDo##cfx_; \
8011 //==========================================================================
8015 //==========================================================================
8016 UFO_DISABLE_INLINE
void ufoInitCommon (void) {
8018 ufoForthVocId
= 0; ufoCompilerVocId
= 0;
8020 ufoForthCFAs
= calloc(UFO_MAX_NATIVE_CFAS
, sizeof(ufoForthCFAs
[0]));
8022 // allocate default TIB handle
8023 //UfoHandle *tibh = ufoAllocHandle(0x69a029a6); // arbitrary number
8024 //ufoDefTIB = tibh->ufoHandle;
8026 ufoForthCFAs
[0] = NULL
; ufoCFAsUsed
= 1u;
8027 UFO_ADD_DO_CFA(Forth
);
8028 UFO_ADD_DO_CFA(Variable
);
8029 UFO_ADD_DO_CFA(Value
);
8030 UFO_ADD_DO_CFA(Const
);
8031 UFO_ADD_DO_CFA(Defer
);
8032 UFO_ADD_DO_CFA(Voc
);
8033 UFO_ADD_DO_CFA(Create
);
8034 UFO_ADD_DO_CFA(UserVariable
);
8036 //fprintf(stderr, "DO-FORTH-CFA: 0x%08x\n", ufoDoForthCFA);
8040 // create "FORTH" vocabulary (it should be the first one)
8041 ufoForthVocId
= ufoCreateVoc("FORTH", 0, UFW_FLAG_PROTECTED
);
8042 ufoVocSetOnlyDefs(ufoForthVocId
);
8044 // base low-level interpreter words
8045 ufoInitBasicWords();
8050 // some COMPILER words
8051 ufoInitBasicCompilerWords();
8053 // STRING vocabulary
8054 ufoInitStringWords();
8057 ufoInitDebugWords();
8062 // HANDLE vocabulary
8063 ufoInitHandleWords();
8068 // some higher-level FORTH words (includes, etc.)
8069 ufoInitHigherWords();
8071 // very-very high-level FORTH words
8072 ufoInitVeryVeryHighWords();
8074 ufoFinalLabelCheck();
8077 ufoDecompileWord(ufoFindWordChecked("RUN-INTERPRET-LOOP"));
8086 // ////////////////////////////////////////////////////////////////////////// //
8087 // virtual machine executor
8091 //==========================================================================
8095 // address interpreter
8097 //==========================================================================
8098 static void ufoRunVMCFA (uint32_t cfa
) {
8099 const uint32_t oldRPTop
= ufoRPTop
;
8101 #ifdef UFO_TRACE_VM_RUN
8102 fprintf(stderr
, "**VM-INITIAL**: cfa=%u\n", cfa
);
8108 // VM execution loop
8110 if (ufoVMAbort
) ufoFatal("user abort");
8111 if (ufoVMStop
) { ufoRP
= oldRPTop
; break; }
8112 if (ufoCurrState
== NULL
) ufoFatal("execution state is lost");
8113 if (ufoVMRPopCFA
== 0) {
8115 if (ufoIP
== 0) ufoFatal("IP is NULL");
8116 if (ufoIP
& UFO_ADDR_HANDLE_BIT
) ufoFatal("IP is a handle");
8117 cfa
= ufoImgGetU32(ufoIP
); ufoIP
+= 4u;
8119 cfa
= ufoRPop(); ufoVMRPopCFA
= 0;
8122 if (cfa
== 0) ufoFatal("EXECUTE: NULL CFA");
8123 if (cfa
& UFO_ADDR_HANDLE_BIT
) ufoFatal("cannot execute handle");
8124 // get next word CFAIDX, and check it
8125 uint32_t cfaidx
= ufoImgGetU32(cfa
);
8126 if (cfaidx
& UFO_ADDR_HANDLE_BIT
) ufoFatal("cannot execute CFAIDX-handle");
8127 #ifdef UFO_TRACE_VM_RUN
8128 fprintf(stderr
, "**VM**: IP=%u; cfa=%u; cfaidx=0x%08x\n", ufoIP
- 4u, cfa
, cfaidx
);
8130 ufoDumpWordHeader(UFO_CFA_TO_LFA(cfa
));
8131 fprintf(stderr
, "######################################\n");
8133 if (cfaidx
& UFO_ADDR_CFA_BIT
) {
8134 cfaidx
&= UFO_ADDR_CFA_MASK
;
8135 if (cfaidx
>= ufoCFAsUsed
|| ufoForthCFAs
[cfaidx
] == NULL
) {
8136 ufoFatal("tried to execute an unknown word: %u (max is %u); IP=%u",
8137 cfaidx
, ufoCFAsUsed
, ufoIP
- 4u);
8139 #ifdef UFO_TRACE_VM_RUN
8140 fprintf(stderr
, "**VM-NATIVE**: cfaidx=%u (doForth=%u)\n", cfaidx
,
8141 (ufoDoForthCFA
& UFO_ADDR_CFA_MASK
));
8143 ufoForthCFAs
[cfaidx
](UFO_CFA_TO_PFA(cfa
));
8145 // if CFA points somewhere inside a dict, this is "DOES>" word
8146 // IP points to PFA we need to push
8147 // CFA points to Forth word we need to jump to
8148 #ifdef UFO_TRACE_VM_DOER
8149 fprintf(stderr
, "*** DOER! IP=%u; cfa=%u; cfaidx=%u ***\n", ufoIP
, cfa
, cfaidx
);
8150 UFCALL(UFO_BACKTRACE
);
8152 ufoPush(UFO_CFA_TO_PFA(cfa
)); // push PFA
8153 ufoRPush(ufoIP
); // push IP
8154 ufoIP
= cfaidx
; // fix IP
8156 // that's all we need to activate the debugger
8157 if (ufoSingleStep
) {
8159 if (ufoSingleStep
== 0 && ufoDebuggerState
!= NULL
) {
8160 if (ufoCurrState
== ufoDebuggerState
) ufoFatal("debugger cannot debug itself");
8161 UfoState
*ost
= ufoCurrState
;
8162 ufoSwitchToState(ufoDebuggerState
); // always use API call for this!
8167 } while (ufoRP
!= oldRPTop
);
8172 // ////////////////////////////////////////////////////////////////////////// //
8176 //==========================================================================
8180 // register new word
8182 //==========================================================================
8183 uint32_t ufoRegisterWord (const char *wname
, ufoNativeCFA cfa
, uint32_t flags
) {
8184 ufo_assert(cfa
!= NULL
);
8185 ufo_assert(wname
!= NULL
&& wname
[0] != 0);
8186 uint32_t cfaidx
= ufoCFAsUsed
;
8187 if (cfaidx
>= UFO_MAX_NATIVE_CFAS
) ufoFatal("too many native words");
8188 ufoForthCFAs
[cfaidx
] = cfa
;
8190 //ufoDefineNative(wname, xcfa, 0);
8191 cfaidx
|= UFO_ADDR_CFA_BIT
;
8192 flags
&= 0xffffff00u
;
8193 ufoCreateWordHeader(wname
, flags
);
8194 const uint32_t res
= UFO_GET_DP();
8195 ufoImgEmitU32(cfaidx
);
8200 //==========================================================================
8202 // ufoRegisterDataWord
8204 //==========================================================================
8205 static uint32_t ufoRegisterDataWord (const char *wname
, uint32_t cfaidx
, uint32_t value
,
8208 ufo_assert(wname
!= NULL
&& wname
[0] != 0);
8209 flags
&= 0xffffff00u
;
8210 ufoCreateWordHeader(wname
, flags
);
8211 ufoImgEmitU32(cfaidx
);
8212 const uint32_t res
= UFO_GET_DP();
8213 ufoImgEmitU32(value
);
8218 //==========================================================================
8220 // ufoRegisterConstant
8222 //==========================================================================
8223 void ufoRegisterConstant (const char *wname
, uint32_t value
, uint32_t flags
) {
8224 (void)ufoRegisterDataWord(wname
, ufoDoConstCFA
, value
, flags
);
8228 //==========================================================================
8230 // ufoRegisterVariable
8232 //==========================================================================
8233 uint32_t ufoRegisterVariable (const char *wname
, uint32_t value
, uint32_t flags
) {
8234 return ufoRegisterDataWord(wname
, ufoDoVariableCFA
, value
, flags
);
8238 //==========================================================================
8242 //==========================================================================
8243 uint32_t ufoRegisterValue (const char *wname
, uint32_t value
, uint32_t flags
) {
8244 return ufoRegisterDataWord(wname
, ufoDoValueCFA
, value
, flags
);
8248 //==========================================================================
8252 //==========================================================================
8253 uint32_t ufoRegisterDefer (const char *wname
, uint32_t value
, uint32_t flags
) {
8254 return ufoRegisterDataWord(wname
, ufoDoDeferCFA
, value
, flags
);
8258 //==========================================================================
8260 // ufoFindWordInVocabulary
8262 // check if we have the corresponding word.
8263 // return CFA suitable for executing, or 0.
8265 //==========================================================================
8266 uint32_t ufoFindWordInVocabulary (const char *wname
, uint32_t vocid
) {
8267 if (wname
== NULL
|| wname
[0] == 0) return 0;
8268 size_t wlen
= strlen(wname
);
8269 if (wlen
>= UFO_MAX_WORD_LENGTH
) return 0;
8270 return ufoFindWordInVocAndParents(wname
, (uint32_t)wlen
, 0, vocid
, 0);
8274 //==========================================================================
8278 //==========================================================================
8279 uint32_t ufoGetIP (void) {
8284 //==========================================================================
8288 //==========================================================================
8289 void ufoSetIP (uint32_t newip
) {
8294 //==========================================================================
8298 //==========================================================================
8299 int ufoIsExecuting (void) {
8300 return (ufoImgGetU32(ufoAddrSTATE
) == 0);
8304 //==========================================================================
8308 //==========================================================================
8309 int ufoIsCompiling (void) {
8310 return (ufoImgGetU32(ufoAddrSTATE
) != 0);
8314 //==========================================================================
8318 //==========================================================================
8319 void ufoSetExecuting (void) {
8320 ufoImgPutU32(ufoAddrSTATE
, 0);
8324 //==========================================================================
8328 //==========================================================================
8329 void ufoSetCompiling (void) {
8330 ufoImgPutU32(ufoAddrSTATE
, 1);
8334 //==========================================================================
8338 //==========================================================================
8339 uint32_t ufoGetHere () {
8340 return UFO_GET_DP();
8344 //==========================================================================
8348 //==========================================================================
8349 uint32_t ufoGetPad () {
8355 //==========================================================================
8359 //==========================================================================
8360 uint8_t ufoTIBPeekCh (uint32_t ofs
) {
8361 return ufoTibPeekChOfs(ofs
);
8365 //==========================================================================
8369 //==========================================================================
8370 uint8_t ufoTIBGetCh (void) {
8371 return ufoTibGetCh();
8375 //==========================================================================
8379 //==========================================================================
8380 void ufoTIBSkipCh (void) {
8385 //==========================================================================
8391 //==========================================================================
8392 int ufoTIBSRefill (int allowCrossIncludes
) {
8393 return ufoLoadNextLine(allowCrossIncludes
);
8397 //==========================================================================
8401 //==========================================================================
8402 uint32_t ufoPeekData (void) {
8407 //==========================================================================
8411 //==========================================================================
8412 uint32_t ufoPopData (void) {
8417 //==========================================================================
8421 //==========================================================================
8422 void ufoPushData (uint32_t value
) {
8423 return ufoPush(value
);
8427 //==========================================================================
8431 //==========================================================================
8432 void ufoPushBoolData (int val
) {
8437 //==========================================================================
8441 //==========================================================================
8442 uint32_t ufoPeekRet (void) {
8447 //==========================================================================
8451 //==========================================================================
8452 uint32_t ufoPopRet (void) {
8457 //==========================================================================
8461 //==========================================================================
8462 void ufoPushRet (uint32_t value
) {
8463 return ufoRPush(value
);
8467 //==========================================================================
8471 //==========================================================================
8472 void ufoPushBoolRet (int val
) {
8473 ufoRPush(val
? ufoTrueValue
: 0);
8477 //==========================================================================
8481 //==========================================================================
8482 uint8_t ufoPeekByte (uint32_t addr
) {
8483 return ufoImgGetU8Ext(addr
);
8487 //==========================================================================
8491 //==========================================================================
8492 uint16_t ufoPeekWord (uint32_t addr
) {
8499 //==========================================================================
8503 //==========================================================================
8504 uint32_t ufoPeekCell (uint32_t addr
) {
8511 //==========================================================================
8515 //==========================================================================
8516 void ufoPokeByte (uint32_t addr
, uint32_t value
) {
8517 ufoImgPutU8(addr
, value
);
8521 //==========================================================================
8525 //==========================================================================
8526 void ufoPokeWord (uint32_t addr
, uint32_t value
) {
8533 //==========================================================================
8537 //==========================================================================
8538 void ufoPokeCell (uint32_t addr
, uint32_t value
) {
8545 //==========================================================================
8549 //==========================================================================
8550 void ufoEmitByte (uint32_t value
) {
8551 ufoImgEmitU8(value
);
8555 //==========================================================================
8559 //==========================================================================
8560 void ufoEmitWord (uint32_t value
) {
8561 ufoImgEmitU8(value
& 0xff);
8562 ufoImgEmitU8((value
>> 8) & 0xff);
8566 //==========================================================================
8570 //==========================================================================
8571 void ufoEmitCell (uint32_t value
) {
8572 ufoImgEmitU32(value
);
8576 //==========================================================================
8580 //==========================================================================
8581 int ufoIsInited (void) {
8582 return (ufoMode
!= UFO_MODE_NONE
);
8586 static void (*ufoUserPostInitCB
) (void);
8589 //==========================================================================
8591 // ufoSetUserPostInit
8593 // called after main initialisation
8595 //==========================================================================
8596 void ufoSetUserPostInit (void (*cb
) (void)) {
8597 ufoUserPostInitCB
= cb
;
8601 //==========================================================================
8605 //==========================================================================
8606 void ufoInit (void) {
8607 if (ufoMode
!= UFO_MODE_NONE
) return;
8608 ufoMode
= UFO_MODE_NATIVE
;
8611 ufoInFileName
= NULL
; ufoInFileNameLen
= 0; ufoInFileNameHash
= 0;
8613 ufoLastIncPath
= NULL
; ufoLastSysIncPath
= NULL
;
8615 for (uint32_t f
= 0; f
< UFO_MAX_STATES
; f
+= 1u) ufoStateMap
[f
] = NULL
;
8616 memset(ufoStateUsedBitmap
, 0, sizeof(ufoStateUsedBitmap
));
8618 ufoCurrState
= ufoNewState();
8619 strcpy(ufoCurrState
->name
, "MAIN");
8620 ufoInitStateUserVars(ufoCurrState
, 0);
8621 ufoImgPutU32(ufoAddrDefTIB
, 0); // create TIB handle
8622 ufoImgPutU32(ufoAddrTIBx
, 0); // create TIB handle
8624 ufoYieldedState
= NULL
;
8625 ufoDebuggerState
= NULL
;
8628 #ifdef UFO_DEBUG_STARTUP_TIMES
8629 uint32_t stt
= ufo_get_msecs();
8630 ufoCondDefine("UFO-DEBUG-STARTUP-TIMES");
8633 #ifdef UFO_DEBUG_STARTUP_TIMES
8634 uint32_t ett
= ufo_get_msecs();
8635 fprintf(stderr
, "UrForth init time: %u msecs\n", (unsigned)(ett
- stt
));
8640 if (ufoUserPostInitCB
) {
8641 ufoUserPostInitCB();
8646 char *ufmname
= ufoCreateIncludeName("init", 1, NULL
);
8648 FILE *ufl
= fopen(ufmname
, "rb");
8650 FILE *ufl
= fopen(ufmname
, "r");
8654 ufoSetInFileNameReuse(ufmname
);
8656 ufoFileId
= ufoLastUsedFileId
;
8657 setLastIncPath(ufoInFileName
, 1);
8660 ufoFatal("cannot load init code");
8663 if (ufoInFile
!= NULL
) {
8664 ufoRunInterpretLoop();
8669 //==========================================================================
8673 //==========================================================================
8674 void ufoFinishVM (void) {
8679 //==========================================================================
8683 // check if VM was exited due to `ufoFinishVM()`
8685 //==========================================================================
8686 int ufoWasVMFinished (void) {
8687 return (ufoVMStop
!= 0);
8691 //==========================================================================
8695 // ( -- addr count TRUE / FALSE )
8696 // does base TIB parsing; never copies anything.
8697 // as our reader is line-based, returns FALSE on EOL.
8698 // EOL is detected after skipping leading delimiters.
8699 // passing -1 as delimiter skips the whole line, and always returns FALSE.
8700 // trailing delimiter is always skipped.
8701 // result is on the data stack.
8703 //==========================================================================
8704 void ufoCallParseIntr (uint32_t delim
, int skipLeading
) {
8705 ufoPush(delim
); ufoPushBool(skipLeading
);
8709 //==========================================================================
8713 // ( -- addr count )
8714 // parse with leading blanks skipping. doesn't copy anything.
8715 // return empty string on EOL.
8717 //==========================================================================
8718 void ufoCallParseName (void) {
8723 //==========================================================================
8727 // ( -- addr count TRUE / FALSE )
8728 // parse without skipping delimiters; never copies anything.
8729 // as our reader is line-based, returns FALSE on EOL.
8730 // passing 0 as delimiter skips the whole line, and always returns FALSE.
8731 // trailing delimiter is always skipped.
8733 //==========================================================================
8734 void ufoCallParse (uint32_t delim
) {
8740 //==========================================================================
8742 // ufoCallParseSkipBlanks
8744 //==========================================================================
8745 void ufoCallParseSkipBlanks (void) {
8746 UFCALL(PARSE_SKIP_BLANKS
);
8750 //==========================================================================
8752 // ufoCallParseSkipComments
8754 //==========================================================================
8755 void ufoCallParseSkipComments (void) {
8756 ufoPushBool(1); UFCALL(PAR_PARSE_SKIP_COMMENTS
);
8760 //==========================================================================
8762 // ufoCallParseSkipLineComments
8764 //==========================================================================
8765 void ufoCallParseSkipLineComments (void) {
8766 ufoPushBool(0); UFCALL(PAR_PARSE_SKIP_COMMENTS
);
8770 //==========================================================================
8772 // ufoCallParseSkipLine
8774 // to the end of line; doesn't refill
8776 //==========================================================================
8777 void ufoCallParseSkipLine (void) {
8778 UFCALL(PARSE_SKIP_LINE
);
8782 //==========================================================================
8784 // ufoCallBasedNumber
8786 // convert number from addrl+1
8787 // returns address of the first inconvertible char
8788 // (BASED-NUMBER) ( addr count allowsign? base -- num TRUE / FALSE )
8790 //==========================================================================
8791 void ufoCallBasedNumber (uint32_t addr
, uint32_t count
, int allowSign
, int base
) {
8792 ufoPush(addr
); ufoPush(count
); ufoPushBool(allowSign
);
8793 if (base
< 0) ufoPush(0); else ufoPush((uint32_t)base
);
8794 UFCALL(PAR_BASED_NUMBER
);
8798 //==========================================================================
8802 //==========================================================================
8803 void ufoRunWord (uint32_t cfa
) {
8805 if (ufoMode
== UFO_MODE_NONE
) ufoFatal("UrForth is not properly inited");
8806 if (ufoInRunWord
) ufoFatal("`ufoRunWord` cannot be called recursively");
8807 ufoMode
= UFO_MODE_NATIVE
;
8815 //==========================================================================
8819 //==========================================================================
8820 void ufoRunMacroWord (uint32_t cfa
) {
8822 if (ufoMode
== UFO_MODE_NONE
) ufoFatal("UrForth is not properly inited");
8823 if (ufoInRunWord
) ufoFatal("`ufoRunWord` cannot be called recursively");
8824 ufoMode
= UFO_MODE_MACRO
;
8825 const uint32_t oisp
= ufoFileStackPos
;
8828 (void)ufoLoadNextUserLine();
8833 ufo_assert(ufoFileStackPos
== oisp
); // sanity check
8838 //==========================================================================
8842 // check if we are currently in "MACRO" mode.
8843 // should be called from registered words.
8845 //==========================================================================
8846 int ufoIsInMacroMode (void) {
8847 return (ufoMode
== UFO_MODE_MACRO
);
8851 //==========================================================================
8853 // ufoRunInterpretLoop
8855 // run default interpret loop.
8857 //==========================================================================
8858 void ufoRunInterpretLoop (void) {
8859 if (ufoMode
== UFO_MODE_NONE
) {
8862 const uint32_t cfa
= ufoFindWord("RUN-INTERPRET-LOOP");
8863 if (cfa
== 0) ufoFatal("'RUN-INTERPRET-LOOP' word not found");
8865 ufoMode
= UFO_MODE_NATIVE
;
8869 while (ufoFileStackPos
!= 0) ufoPopInFile();
8873 //==========================================================================
8877 //==========================================================================
8878 void ufoRunFile (const char *fname
) {
8879 if (ufoMode
== UFO_MODE_NONE
) {
8882 if (ufoInRunWord
) ufoFatal("`ufoRunFile` cannot be called recursively");
8883 ufoMode
= UFO_MODE_NATIVE
;
8886 char *ufmname
= ufoCreateIncludeName(fname
, 0, ".");
8888 FILE *ufl
= fopen(ufmname
, "rb");
8890 FILE *ufl
= fopen(ufmname
, "r");
8894 ufoSetInFileNameReuse(ufmname
);
8896 ufoFileId
= ufoLastUsedFileId
;
8897 setLastIncPath(ufoInFileName
, 0);
8900 ufoFatal("cannot load source file '%s'", fname
);
8902 ufoRunInterpretLoop();