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: *UNUSED* unsigned byte
261 ;; 9: *UNUSED* signed byte
262 ;; 10: *UNUSED* unsigned word
263 ;; 11: *UNUSED* signed word
266 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
267 ;; wordlist structure (at PFA)
268 ;; -4: wordlist type id (used by structs, for example)
270 ;; dd voclink (voclink always points here)
271 ;; dd parent (if not zero, all parent words are visible)
272 ;; dd header-nfa (can be 0 for anonymous wordlists)
273 ;; hashtable (if enabled), or ~0U if no hash table
277 // ////////////////////////////////////////////////////////////////////////// //
278 #define UFO_BFA_TO_LFA(bfa_) ((bfa_) + 1u * 4u)
279 #define UFO_LFA_TO_XFA(lfa_) ((lfa_) - 3u * 4u)
280 #define UFO_LFA_TO_YFA(lfa_) ((lfa_) - 2u * 4u)
281 #define UFO_LFA_TO_BFA(lfa_) ((lfa_) - 1u * 4u)
282 #define UFO_LFA_TO_NFA(lfa_) ((lfa_) + 2u * 4u)
283 #define UFO_LFA_TO_CFA(lfa_) UFO_ALIGN4((lfa_) + 3u * 4u + 1u + ufoImgGetU8((lfa_) + 2u * 4u))
284 #define UFO_LFA_TO_NHASH(lfa_) ((lfa_) + 1u * 4u)
285 #define UFO_CFA_TO_NFA(cfa_) ((cfa_) - 1u - 4u - ufoImgGetU8((cfa_) - 1u))
286 #define UFO_CFA_TO_LFA(cfa_) ((cfa_) - 1u - 4u * 3u - ufoImgGetU8((cfa_) - 1u))
287 #define UFO_CFA_TO_PFA(cfa_) ((cfa_) + 1u * 4u)
288 #define UFO_PFA_TO_CFA(pfa_) ((pfa_) - 1u * 4u)
289 #define UFO_NFA_TO_CFA(nfa_) UFO_ALIGN4((nfa_) + 4u + 1u + ufoImgGetU8((nfa_)))
290 #define UFO_NFA_TO_LFA(nfa_) ((nfa_) - 2u * 4u)
291 #define UFO_XFA_TO_YFA(xfa_) ((xfa_) + 4u)
292 #define UFO_YFA_TO_XFA(yfa_) ((xfa_) - 4u)
293 #define UFO_XFA_TO_WST(xfa_) ((xfa_) - 4u)
294 #define UFO_YFA_TO_WST(yfa_) ((yfa_) - 2u * 4u)
295 #define UFO_YFA_TO_NFA(yfa_) ((yfa_) + 4u * 4u)
298 // ////////////////////////////////////////////////////////////////////////// //
299 //#define UFW_WARG_U8 (8u<<8)
300 //#define UFW_WARG_S8 (9u<<8)
301 //#define UFW_WARG_U16 (10u<<8)
302 //#define UFW_WARG_S16 (11u<<8)
304 #define UFW_VOCAB_OFS_LATEST (0u * 4u)
305 #define UFW_VOCAB_OFS_VOCLINK (1u * 4u)
306 #define UFW_VOCAB_OFS_PARENT (2u * 4u)
307 #define UFW_VOCAB_OFS_HEADER (3u * 4u)
308 #define UFW_VOCAB_OFS_HTABLE (4u * 4u)
310 #define UFO_HASHTABLE_SIZE (256)
312 #define UFO_NO_HTABLE_FLAG (~(uint32_t)0)
314 #define UFO_MAX_NATIVE_CFAS (1024u)
315 static ufoNativeCFA
*ufoForthCFAs
= NULL
;
316 static uint32_t ufoCFAsUsed
= 0;
318 static uint32_t ufoDoForthCFA
;
319 static uint32_t ufoDoVariableCFA
;
320 static uint32_t ufoDoValueCFA
;
321 static uint32_t ufoDoConstCFA
;
322 static uint32_t ufoDoDeferCFA
;
323 static uint32_t ufoDoVocCFA
;
324 static uint32_t ufoDoCreateCFA
;
325 static uint32_t ufoDoUserVariableCFA
;
327 static uint32_t ufoLitStr8CFA
;
329 // special address types:
330 #define UFO_ADDR_CFA_BIT ((uint32_t)1<<31)
331 #define UFO_ADDR_CFA_MASK (UFO_ADDR_CFA_BIT-1u)
333 // handles are somewhat special: first 12 bits can be used as offset for "@", and are ignored
334 #define UFO_ADDR_HANDLE_BIT ((uint32_t)1<<30)
335 #define UFO_ADDR_HANDLE_MASK ((UFO_ADDR_HANDLE_BIT-1u)&~((uint32_t)0xfff))
336 #define UFO_ADDR_HANDLE_SHIFT (12)
337 #define UFO_ADDR_HANDLE_OFS_MASK ((uint32_t)((1 << UFO_ADDR_HANDLE_SHIFT) - 1))
339 // temporary area is 1MB buffer out of the main image
340 #define UFO_ADDR_TEMP_BIT ((uint32_t)1<<29)
341 #define UFO_ADDR_TEMP_MASK (UFO_ADDR_TEMP_BIT-1u)
343 #define UFO_ADDR_SPECIAL_BITS_MASK (UFO_ADDR_CFA_BIT|UFO_ADDR_HANDLE_BIT|UFO_ADDR_TEMP_BIT)
346 static uint32_t *ufoImage
= NULL
;
347 static uint32_t ufoImageSize
= 0;
349 static uint8_t *ufoDebugImage
= NULL
;
350 static uint32_t ufoDebugImageUsed
= 0; // in bytes
351 static uint32_t ufoDebugImageSize
= 0; // in bytes
352 static uint32_t ufoDebugFileNameHash
= 0; // current file name hash
353 static uint32_t ufoDebugFileNameLen
= 0; // current file name length
354 static uint32_t ufoDebugLastLine
= 0;
355 static uint32_t ufoDebugLastLinePCOfs
= 0;
356 static uint32_t ufoDebugLastLineDP
= 0;
357 static uint32_t ufoDebugCurrDP
= 0;
359 static uint32_t ufoInRunWord
= 0;
361 static volatile int ufoVMAbort
= 0;
362 static volatile int ufoVMStop
= 0;
364 #define ufoTrueValue (~(uint32_t)0)
368 UFO_MODE_NATIVE
= 0, // executing forth code
369 UFO_MODE_MACRO
= 1, // executing forth asm macro
371 static uint32_t ufoMode
= UFO_MODE_NONE
;
373 #define UFO_DSTACK_SIZE (8192)
374 #define UFO_RSTACK_SIZE (4096)
375 #define UFO_LSTACK_SIZE (4096)
376 #define UFO_MAX_TASK_NAME (127)
377 #define UFO_VOCSTACK_SIZE (16u)
379 // to support multitasking (required for the debugger),
380 // our virtual machine state is encapsulated in a struct.
381 typedef struct UfoState_t
{
383 uint32_t dStack
[UFO_DSTACK_SIZE
];
384 uint32_t rStack
[UFO_RSTACK_SIZE
];
385 uint32_t lStack
[UFO_LSTACK_SIZE
];
386 uint32_t IP
; // in image
387 uint32_t SP
; // points AFTER the last value pushed
388 uint32_t RP
; // points AFTER the last value pushed
389 uint32_t RPTop
; // stop when RP is this
397 uint32_t vocStack
[UFO_VOCSTACK_SIZE
]; // cfas
401 uint32_t imageTempSize
;
402 // linked list of all allocated states (tasks)
403 char name
[UFO_MAX_TASK_NAME
+ 1];
407 #define UFO_MAX_STATES (8192)
409 // this is indexed by id
410 static UfoState
*ufoStateMap
[UFO_MAX_STATES
] = {NULL
};
411 static uint32_t ufoStateUsedBitmap
[UFO_MAX_STATES
/32] = {0};
413 // currently active execution state
414 static UfoState
*ufoCurrState
= NULL
;
415 // state we're yielded from
416 static UfoState
*ufoYieldedState
= NULL
;
417 // if debug state is not NULL, VM will switch to it
418 // after executing one instruction from the current state.
419 // it will store current state in `ufoDebugeeState`.
420 static UfoState
*ufoDebuggerState
= NULL
;
421 static uint32_t ufoSingleStep
= 0;
423 #define ufoDStack (ufoCurrState->dStack)
424 #define ufoRStack (ufoCurrState->rStack)
425 #define ufoLStack (ufoCurrState->lStack)
426 #define ufoIP (ufoCurrState->IP)
427 #define ufoSP (ufoCurrState->SP)
428 #define ufoRP (ufoCurrState->RP)
429 #define ufoRPTop (ufoCurrState->RPTop)
430 #define ufoLP (ufoCurrState->LP)
431 #define ufoLBP (ufoCurrState->LBP)
432 #define ufoRegA (ufoCurrState->regA)
433 #define ufoImageTemp (ufoCurrState->imageTemp)
434 #define ufoImageTempSize (ufoCurrState->imageTempSize)
435 #define ufoVMRPopCFA (ufoCurrState->vmRPopCFA)
436 #define ufoVocStack (ufoCurrState->vocStack)
437 #define ufoVSP (ufoCurrState->VSP)
439 // 256 bytes for user variables
440 #define UFO_USER_AREA_ADDR UFO_ADDR_TEMP_BIT
441 #define UFO_USER_AREA_SIZE (256u)
442 #define UFO_NBUF_ADDR UFO_USER_AREA_ADDR + UFO_USER_AREA_SIZE
443 #define UFO_NBUF_SIZE (256u)
444 #define UFO_PAD_ADDR (UFO_NBUF_ADDR + UFO_NBUF_SIZE)
445 #define UFO_DEF_TIB_ADDR (UFO_PAD_ADDR + 2048u)
447 // dynamically allocated text input buffer
448 // always ends with zero (this is word name too)
449 static const uint32_t ufoAddrTIBx
= UFO_ADDR_TEMP_BIT
+ 0u * 4u; // TIB
450 static const uint32_t ufoAddrINx
= UFO_ADDR_TEMP_BIT
+ 1u * 4u; // >IN
451 static const uint32_t ufoAddrDefTIB
= UFO_ADDR_TEMP_BIT
+ 2u * 4u; // default TIB (handle); user cannot change it
452 static const uint32_t ufoAddrBASE
= UFO_ADDR_TEMP_BIT
+ 3u * 4u;
453 static const uint32_t ufoAddrSTATE
= UFO_ADDR_TEMP_BIT
+ 4u * 4u;
454 static const uint32_t ufoAddrContext
= UFO_ADDR_TEMP_BIT
+ 5u * 4u; // CONTEXT
455 static const uint32_t ufoAddrCurrent
= UFO_ADDR_TEMP_BIT
+ 6u * 4u; // CURRENT (definitions will go there)
456 static const uint32_t ufoAddrSelf
= UFO_ADDR_TEMP_BIT
+ 7u * 4u; // CURRENT (definitions will go there)
457 static const uint32_t ufoAddrInterNextLine
= UFO_ADDR_TEMP_BIT
+ 8u * 4u; // (INTERPRET-NEXT-LINE)
458 static const uint32_t ufoAddrEP
= UFO_ADDR_TEMP_BIT
+ 9u * 4u; // (EP) -- exception frame pointer
459 static const uint32_t ufoAddrUserVarUsed
= UFO_ADDR_TEMP_BIT
+ 10u * 4u;
461 static uint32_t ufoAddrVocLink
;
462 static uint32_t ufoAddrDP
;
463 static uint32_t ufoAddrDPTemp
;
464 static uint32_t ufoAddrNewWordFlags
;
465 static uint32_t ufoAddrRedefineWarning
;
466 static uint32_t ufoAddrLastXFA
;
468 static uint32_t ufoForthVocId
;
469 static uint32_t ufoCompilerVocId
;
470 static uint32_t ufoInterpNextLineCFA
;
472 // allows to redefine even protected words
473 #define UFO_REDEF_WARN_DONT_CARE (~(uint32_t)0)
474 // do not warn about ordinary words, allow others
475 #define UFO_REDEF_WARN_NONE (0)
476 // do warn (or fail on protected)
477 #define UFO_REDEF_WARN_NORMAL (1)
478 // do warn (or fail on protected) for parent dicts too
479 #define UFO_REDEF_WARN_PARENTS (2)
481 #define UFO_GET_DP() (ufoImgGetU32(ufoAddrDPTemp) ?: ufoImgGetU32(ufoAddrDP))
482 //#define UFO_SET_DP(val_) ufoImgPutU32(ufoAddrDP, (val_))
484 #define UFO_MAX_NESTED_INCLUDES (32)
491 uint32_t id
; // non-zero unique id
494 static UFOFileStackEntry ufoFileStack
[UFO_MAX_NESTED_INCLUDES
];
495 static uint32_t ufoFileStackPos
; // after the last used item
497 static FILE *ufoInFile
= NULL
;
498 static uint32_t ufoInFileNameLen
= 0;
499 static uint32_t ufoInFileNameHash
= 0;
500 static char *ufoInFileName
= NULL
;
501 static char *ufoLastIncPath
= NULL
;
502 static char *ufoLastSysIncPath
= NULL
;
503 static int ufoInFileLine
= 0;
504 static uint32_t ufoFileId
= 0;
505 static uint32_t ufoLastUsedFileId
= 0;
506 static int ufoLastEmitWasCR
= 1;
508 // dynamic memory handles
509 typedef struct UHandleInfo_t
{
516 struct UHandleInfo_t
*next
;
519 static UfoHandle
*ufoHandleFreeList
= NULL
;
520 static UfoHandle
**ufoHandles
= NULL
;
521 static uint32_t ufoHandlesUsed
= 0;
522 static uint32_t ufoHandlesAlloted
= 0;
524 #define UFO_HANDLE_FREE (~(uint32_t)0)
526 static char ufoCurrFileLine
[520];
529 static uint32_t ufoInBacktrace
= 0;
532 // ////////////////////////////////////////////////////////////////////////// //
533 static void ufoClearCondDefines (void);
535 static void ufoRunVMCFA (uint32_t cfa
);
537 static void ufoBacktrace (uint32_t ip
, int showDataStack
);
539 static void ufoClearCondDefines (void);
541 static UfoState
*ufoNewState (void);
542 static void ufoInitStateUserVars (UfoState
*st
, uint32_t cfa
);
543 static void ufoFreeState (UfoState
*st
);
544 static UfoState
*ufoFindState (uint32_t stid
);
545 static void ufoSwitchToState (UfoState
*newst
);
547 __attribute__((unused
)) static void ufoDumpWordHeader (const uint32_t lfa
);
550 static void ufoDisableRaw (void);
551 static void ufoTTYRawFlush (void);
553 static int ufoIsGoodTTY (void);
555 #ifdef UFO_DEBUG_DEBUG
556 static void ufoDumpDebugImage (void);
560 // ////////////////////////////////////////////////////////////////////////// //
561 #define UFWORD(name_) \
562 static void ufoWord_##name_ (uint32_t mypfa)
564 #define UFCALL(name_) ufoWord_##name_(0)
565 #define UFCFA(name_) (&ufoWord_##name_)
568 UFWORD(CPEEK_REGA_IDX
);
569 UFWORD(CPOKE_REGA_IDX
);
572 UFWORD(PAR_HANDLE_LOAD_BYTE
);
573 UFWORD(PAR_HANDLE_LOAD_WORD
);
574 UFWORD(PAR_HANDLE_LOAD_CELL
);
575 UFWORD(PAR_HANDLE_STORE_BYTE
);
576 UFWORD(PAR_HANDLE_STORE_WORD
);
577 UFWORD(PAR_HANDLE_STORE_CELL
);
580 //==========================================================================
584 //==========================================================================
585 static void ufoFlushOutput (void) {
593 //==========================================================================
597 // if `reuse` is not 0, reuse/free `fname`
599 //==========================================================================
600 static void ufoSetInFileNameEx (const char *fname
, int reuse
) {
601 ufo_assert(fname
== NULL
|| (fname
!= ufoInFileName
));
602 if (fname
== NULL
|| fname
[0] == 0) {
603 if (ufoInFileName
) { free(ufoInFileName
); ufoInFileName
= NULL
; }
604 ufoInFileNameLen
= 0;
605 ufoInFileNameHash
= 0;
606 if (reuse
&& fname
!= NULL
) free((void *)fname
);
608 const uint32_t fnlen
= (uint32_t)strlen(fname
);
609 const uint32_t fnhash
= joaatHashBuf(fname
, fnlen
, 0);
610 if (ufoInFileNameLen
!= fnlen
|| ufoInFileNameHash
!= fnhash
) {
611 if (ufoInFileName
) { free(ufoInFileName
); ufoInFileName
= NULL
; }
613 ufoInFileName
= (char *)fname
;
615 ufoInFileName
= strdup(fname
);
616 if (ufoInFileName
== NULL
) ufoFatal("out of memory for filename info");
618 ufoInFileNameLen
= fnlen
;
619 ufoInFileNameHash
= fnhash
;
621 if (reuse
&& fname
!= NULL
) free((void *)fname
);
627 //==========================================================================
631 //==========================================================================
632 UFO_FORCE_INLINE
void ufoSetInFileName (const char *fname
) {
633 ufoSetInFileNameEx(fname
, 0);
637 //==========================================================================
639 // ufoSetInFileNameReuse
641 //==========================================================================
642 UFO_FORCE_INLINE
void ufoSetInFileNameReuse (const char *fname
) {
643 ufoSetInFileNameEx(fname
, 1);
647 //==========================================================================
651 //==========================================================================
652 void ufoSetUserAbort (void) {
657 //==========================================================================
661 //==========================================================================
662 static UfoHandle
*ufoAllocHandle (uint32_t typeid) {
663 ufo_assert(typeid != UFO_HANDLE_FREE
);
664 UfoHandle
*newh
= ufoHandleFreeList
;
666 if (ufoHandlesUsed
== ufoHandlesAlloted
) {
667 uint32_t newsz
= ufoHandlesAlloted
+ 16384;
668 // due to offsets, this is the maximum number of handles we can have
669 if (newsz
> 0x1ffffU
) {
670 if (ufoHandlesAlloted
> 0x1ffffU
) ufoFatal("too many dynamic handles");
671 newsz
= 0x1ffffU
+ 1U;
672 ufo_assert(newsz
> ufoHandlesAlloted
);
674 UfoHandle
**nh
= realloc(ufoHandles
, sizeof(ufoHandles
[0]) * newsz
);
675 if (nh
== NULL
) ufoFatal("out of memory for handle table");
677 ufoHandlesAlloted
= newsz
;
679 newh
= calloc(1, sizeof(UfoHandle
));
680 if (newh
== NULL
) ufoFatal("out of memory for handle info");
681 ufoHandles
[ufoHandlesUsed
] = newh
;
682 // setup new handle info
683 newh
->ufoHandle
= (ufoHandlesUsed
<< UFO_ADDR_HANDLE_SHIFT
) | UFO_ADDR_HANDLE_BIT
;
686 ufo_assert(newh
->typeid == UFO_HANDLE_FREE
);
687 ufoHandleFreeList
= newh
->next
;
689 // setup new handle info
690 newh
->typeid = typeid;
699 //==========================================================================
703 //==========================================================================
704 static void ufoFreeHandle (UfoHandle
*hh
) {
706 ufo_assert(hh
->typeid != UFO_HANDLE_FREE
);
707 if (hh
->data
) free(hh
->data
);
708 hh
->typeid = UFO_HANDLE_FREE
;
712 hh
->next
= ufoHandleFreeList
;
713 ufoHandleFreeList
= hh
;
718 //==========================================================================
722 //==========================================================================
723 static UfoHandle
*ufoGetHandle (uint32_t hh
) {
725 if (hh
!= 0 && (hh
& UFO_ADDR_HANDLE_BIT
) != 0) {
726 hh
= (hh
& UFO_ADDR_HANDLE_MASK
) >> UFO_ADDR_HANDLE_SHIFT
;
727 if (hh
< ufoHandlesUsed
) {
728 res
= ufoHandles
[hh
];
729 if (res
->typeid == UFO_HANDLE_FREE
) res
= NULL
;
740 //==========================================================================
744 //==========================================================================
745 static void setLastIncPath (const char *fname
, int system
) {
746 if (fname
== NULL
|| fname
[0] == 0) {
748 if (ufoLastSysIncPath
) free(ufoLastIncPath
);
749 ufoLastSysIncPath
= NULL
;
751 if (ufoLastIncPath
) free(ufoLastIncPath
);
752 ufoLastIncPath
= strdup(".");
758 if (ufoLastSysIncPath
) free(ufoLastSysIncPath
);
759 ufoLastSysIncPath
= strdup(fname
);
760 lslash
= ufoLastSysIncPath
;
761 cpos
= ufoLastSysIncPath
;
763 if (ufoLastIncPath
) free(ufoLastIncPath
);
764 ufoLastIncPath
= strdup(fname
);
765 lslash
= ufoLastIncPath
;
766 cpos
= ufoLastIncPath
;
770 if (*cpos
== '/' || *cpos
== '\\') lslash
= cpos
;
772 if (*cpos
== '/') lslash
= cpos
;
781 //==========================================================================
783 // ufoClearIncludePath
785 // required for UrAsm
787 //==========================================================================
788 void ufoClearIncludePath (void) {
789 if (ufoLastIncPath
!= NULL
) {
790 free(ufoLastIncPath
);
791 ufoLastIncPath
= NULL
;
793 if (ufoLastSysIncPath
!= NULL
) {
794 free(ufoLastSysIncPath
);
795 ufoLastSysIncPath
= NULL
;
800 //==========================================================================
804 //==========================================================================
805 static void ufoErrorPrintFile (FILE *fo
, const char *errwarn
) {
806 if (ufoInFileName
!= NULL
) {
807 fprintf(fo
, "UFO %s at file %s, line %d: ", errwarn
, ufoInFileName
, ufoInFileLine
);
809 fprintf(fo
, "UFO %s somewhere in time: ", errwarn
);
814 //==========================================================================
818 //==========================================================================
819 static void ufoErrorMsgV (const char *errwarn
, const char *fmt
, va_list ap
) {
821 if (!ufoLastEmitWasCR
) { printf("\n"); ufoLastEmitWasCR
= 1; }
822 ufoErrorPrintFile(stderr
, errwarn
);
823 vfprintf(stderr
, fmt
, ap
);
830 //==========================================================================
834 //==========================================================================
835 __attribute__((format(printf
, 1, 2)))
836 void ufoWarning (const char *fmt
, ...) {
839 ufoErrorMsgV("WARNING", fmt
, ap
);
843 //==========================================================================
847 //==========================================================================
848 __attribute__((noreturn
)) __attribute__((format(printf
, 1, 2)))
849 void ufoFatal (const char *fmt
, ...) {
855 ufoErrorMsgV("ERROR", fmt
, ap
);
856 if (!ufoInBacktrace
) {
858 ufoBacktrace(ufoIP
, 1);
861 fprintf(stderr
, "DOUBLE FATAL: error in backtrace!\n");
864 #ifdef UFO_DEBUG_FATAL_ABORT
871 // ////////////////////////////////////////////////////////////////////////// //
872 // working with the stacks
873 UFO_FORCE_INLINE
void ufoPush (uint32_t v
) { if (ufoSP
>= UFO_DSTACK_SIZE
) ufoFatal("data stack overflow"); ufoDStack
[ufoSP
++] = v
; }
874 UFO_FORCE_INLINE
void ufoDrop (void) { if (ufoSP
== 0) ufoFatal("data stack underflow"); --ufoSP
; }
875 UFO_FORCE_INLINE
uint32_t ufoPop (void) { if (ufoSP
== 0) { ufoFatal("data stack underflow"); } return ufoDStack
[--ufoSP
]; }
876 UFO_FORCE_INLINE
uint32_t ufoPeek (void) { if (ufoSP
== 0) ufoFatal("data stack underflow"); return ufoDStack
[ufoSP
-1u]; }
877 UFO_FORCE_INLINE
void ufoDup (void) { if (ufoSP
== 0) ufoFatal("data stack underflow"); ufoPush(ufoDStack
[ufoSP
-1u]); }
878 UFO_FORCE_INLINE
void ufoOver (void) { if (ufoSP
< 2u) ufoFatal("data stack underflow"); ufoPush(ufoDStack
[ufoSP
-2u]); }
879 UFO_FORCE_INLINE
void ufoSwap (void) { if (ufoSP
< 2u) ufoFatal("data stack underflow"); const uint32_t t
= ufoDStack
[ufoSP
-1u]; ufoDStack
[ufoSP
-1u] = ufoDStack
[ufoSP
-2u]; ufoDStack
[ufoSP
-2u] = t
; }
880 UFO_FORCE_INLINE
void ufoRot (void) { if (ufoSP
< 3u) ufoFatal("data stack underflow"); const uint32_t t
= ufoDStack
[ufoSP
-3u]; ufoDStack
[ufoSP
-3u] = ufoDStack
[ufoSP
-2u]; ufoDStack
[ufoSP
-2u] = ufoDStack
[ufoSP
-1u]; ufoDStack
[ufoSP
-1u] = t
; }
881 UFO_FORCE_INLINE
void ufoNRot (void) { if (ufoSP
< 3u) ufoFatal("data stack underflow"); const uint32_t t
= ufoDStack
[ufoSP
-1u]; ufoDStack
[ufoSP
-1u] = ufoDStack
[ufoSP
-2u]; ufoDStack
[ufoSP
-2u] = ufoDStack
[ufoSP
-3u]; ufoDStack
[ufoSP
-3u] = t
; }
883 UFO_FORCE_INLINE
void ufo2Dup (void) { ufoOver(); ufoOver(); }
884 UFO_FORCE_INLINE
void ufo2Drop (void) { ufoDrop(); ufoDrop(); }
885 UFO_FORCE_INLINE
void ufo2Over (void) { if (ufoSP
< 4u) ufoFatal("data stack underflow"); const uint32_t n0
= ufoDStack
[ufoSP
-4u]; const uint32_t n1
= ufoDStack
[ufoSP
-3u]; ufoPush(n0
); ufoPush(n1
); }
886 UFO_FORCE_INLINE
void ufo2Swap (void) { if (ufoSP
< 4u) ufoFatal("data stack underflow"); const uint32_t n0
= ufoDStack
[ufoSP
-4u]; const uint32_t n1
= ufoDStack
[ufoSP
-3u]; ufoDStack
[ufoSP
-4u] = ufoDStack
[ufoSP
-2u]; ufoDStack
[ufoSP
-3u] = ufoDStack
[ufoSP
-1u]; ufoDStack
[ufoSP
-2u] = n0
; ufoDStack
[ufoSP
-1u] = n1
; }
888 UFO_FORCE_INLINE
void ufoRPush (uint32_t v
) { if (ufoRP
>= UFO_RSTACK_SIZE
) ufoFatal("return stack overflow"); ufoRStack
[ufoRP
++] = v
; }
889 UFO_FORCE_INLINE
void ufoRDrop (void) { if (ufoRP
== 0 || ufoRP
== ufoRPTop
) ufoFatal("return stack underflow"); --ufoRP
; }
890 UFO_FORCE_INLINE
uint32_t ufoRPop (void) { if (ufoRP
== 0 || ufoRP
== ufoRPTop
) ufoFatal("return stack underflow"); return ufoRStack
[--ufoRP
]; }
891 UFO_FORCE_INLINE
uint32_t ufoRPeek (void) { if (ufoRP
== 0 || ufoRP
== ufoRPTop
) ufoFatal("return stack underflow"); return ufoRStack
[ufoRP
-1u]; }
892 UFO_FORCE_INLINE
void ufoRDup (void) { if (ufoRP
== 0 || ufoRP
== ufoRPTop
) ufoFatal("return stack underflow"); ufoPush(ufoRStack
[ufoRP
-1u]); }
894 UFO_FORCE_INLINE
void ufoPushBool (int v
) { ufoPush(v
? ufoTrueValue
: 0u); }
897 //==========================================================================
901 //==========================================================================
902 static void ufoImgEnsureSize (uint32_t addr
) {
903 if ((addr
& UFO_ADDR_SPECIAL_BITS_MASK
) != 0) ufoFatal("ufoImgEnsureSize: internal error");
904 if (addr
>= ufoImageSize
) {
905 // 64MB should be enough for everyone!
906 if (addr
>= 0x04000000U
) {
907 ufoFatal("image grown too big (addr=0%08XH)", addr
);
909 const const uint32_t osz
= ufoImageSize
;
911 const uint32_t nsz
= (addr
|0x000fffffU
) + 1U;
912 ufo_assert(nsz
> addr
);
913 uint32_t *nimg
= realloc(ufoImage
, nsz
);
915 ufoFatal("out of memory for UFO image (%u -> %u MBs)",
916 ufoImageSize
/ 1024u / 1024u,
917 nsz
/ 1024u / 1024u);
921 memset((char *)ufoImage
+ osz
, 0, (nsz
- osz
));
926 //==========================================================================
930 //==========================================================================
931 static void ufoImgEnsureTemp (uint32_t addr
) {
932 if ((addr
& UFO_ADDR_SPECIAL_BITS_MASK
) != 0) ufoFatal("ufoImgEnsureTemp: internal error");
933 if (addr
>= ufoImageTempSize
) {
934 if (addr
>= 1024u * 1024u) {
935 ufoFatal("Forth segmentation fault at address 0x%08X", addr
| UFO_ADDR_TEMP_BIT
);
937 const uint32_t osz
= ufoImageTempSize
;
939 const uint32_t nsz
= (addr
|0x00001fffU
) + 1U;
940 uint32_t *nimg
= realloc(ufoImageTemp
, nsz
);
942 ufoFatal("out of memory for temp UFO image (%u -> %u KBs)",
943 ufoImageTempSize
/ 1024u,
947 ufoImageTempSize
= nsz
;
948 memset((char *)ufoImageTemp
+ osz
, 0, (nsz
- osz
));
953 #ifdef UFO_FAST_MEM_ACCESS
954 //==========================================================================
960 //==========================================================================
961 UFO_FORCE_INLINE
void ufoImgPutU8 (uint32_t addr
, const uint32_t value
) {
962 if ((addr
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) {
963 if (addr
>= ufoImageSize
) ufoImgEnsureSize(addr
);
964 *((uint8_t *)ufoImage
+ addr
) = (uint8_t)value
;
965 } else if (addr
& UFO_ADDR_TEMP_BIT
) {
966 addr
&= UFO_ADDR_TEMP_MASK
;
967 if (addr
>= ufoImageTempSize
) ufoImgEnsureTemp(addr
);
968 *((uint8_t *)ufoImageTemp
+ addr
) = (uint8_t)value
;
970 ufoFatal("Forth segmentation fault at address 0x%08X", addr
);
975 //==========================================================================
981 //==========================================================================
982 UFO_FORCE_INLINE
void ufoImgPutU16 (uint32_t addr
, const uint32_t value
) {
983 if ((addr
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) {
984 if (addr
+ 1u >= ufoImageSize
) ufoImgEnsureSize(addr
+ 1u);
985 *(uint16_t *)((uint8_t *)ufoImage
+ addr
) = (uint16_t)value
;
986 } else if (addr
& UFO_ADDR_TEMP_BIT
) {
987 addr
&= UFO_ADDR_TEMP_MASK
;
988 if (addr
+ 1u >= ufoImageTempSize
) ufoImgEnsureTemp(addr
+ 1u);
989 *(uint16_t *)((uint8_t *)ufoImageTemp
+ addr
) = (uint16_t)value
;
991 ufoFatal("Forth segmentation fault at address 0x%08X", addr
);
996 //==========================================================================
1002 //==========================================================================
1003 UFO_FORCE_INLINE
void ufoImgPutU32 (uint32_t addr
, const uint32_t value
) {
1004 if ((addr
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) {
1005 if (addr
+ 3u >= ufoImageSize
) ufoImgEnsureSize(addr
+ 3u);
1006 *(uint32_t *)((uint8_t *)ufoImage
+ addr
) = value
;
1007 } else if (addr
& UFO_ADDR_TEMP_BIT
) {
1008 addr
&= UFO_ADDR_TEMP_MASK
;
1009 if (addr
+ 3u >= ufoImageTempSize
) ufoImgEnsureTemp(addr
+ 3u);
1010 *(uint32_t *)((uint8_t *)ufoImageTemp
+ addr
) = value
;
1012 ufoFatal("Forth segmentation fault at address 0x%08X", addr
);
1017 //==========================================================================
1023 //==========================================================================
1024 UFO_FORCE_INLINE
uint32_t ufoImgGetU8 (uint32_t addr
) {
1025 if ((addr
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) {
1026 if (addr
>= ufoImageSize
) {
1027 // accessing unallocated image area is segmentation fault
1028 ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr
);
1030 return *((const uint8_t *)ufoImage
+ addr
);
1031 } else if (addr
& UFO_ADDR_TEMP_BIT
) {
1032 addr
&= UFO_ADDR_TEMP_MASK
;
1033 if (addr
>= ufoImageTempSize
) {
1034 // accessing unallocated image area is segmentation fault
1035 ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr
| UFO_ADDR_TEMP_BIT
);
1037 return *((const uint8_t *)ufoImageTemp
+ addr
);
1039 ufoFatal("Forth segmentation fault at address 0x%08X", addr
);
1044 //==========================================================================
1050 //==========================================================================
1051 UFO_FORCE_INLINE
uint32_t ufoImgGetU16 (uint32_t addr
) {
1052 if ((addr
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) {
1053 if (addr
+ 1u >= ufoImageSize
) {
1054 // accessing unallocated image area is segmentation fault
1055 ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr
);
1057 return *(const uint16_t *)((const uint8_t *)ufoImage
+ addr
);
1058 } else if (addr
& UFO_ADDR_TEMP_BIT
) {
1059 addr
&= UFO_ADDR_TEMP_MASK
;
1060 if (addr
+ 1u >= ufoImageTempSize
) {
1061 // accessing unallocated image area is segmentation fault
1062 ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr
| UFO_ADDR_TEMP_BIT
);
1064 return *(const uint16_t *)((const uint8_t *)ufoImageTemp
+ addr
);
1066 ufoFatal("Forth segmentation fault at address 0x%08X", addr
);
1071 //==========================================================================
1077 //==========================================================================
1078 UFO_FORCE_INLINE
uint32_t ufoImgGetU32 (uint32_t addr
) {
1079 if ((addr
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) {
1080 if (addr
+ 3u >= ufoImageSize
) {
1081 // accessing unallocated image area is segmentation fault
1082 ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr
);
1084 return *(const uint32_t *)((const uint8_t *)ufoImage
+ addr
);
1085 } else if (addr
& UFO_ADDR_TEMP_BIT
) {
1086 addr
&= UFO_ADDR_TEMP_MASK
;
1087 if (addr
+ 3u >= ufoImageTempSize
) {
1088 // accessing unallocated image area is segmentation fault
1089 ufoFatal("Forth segmentation fault (unallocated access) at address 0x%08X", addr
| UFO_ADDR_TEMP_BIT
);
1091 return *(const uint32_t *)((const uint8_t *)ufoImageTemp
+ addr
);
1093 ufoFatal("Forth segmentation fault at address 0x%08X", addr
);
1099 //==========================================================================
1105 //==========================================================================
1106 UFO_FORCE_INLINE
void ufoImgPutU8 (uint32_t addr
, const uint32_t value
) {
1108 if ((addr
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) {
1109 if (addr
>= ufoImageSize
) ufoImgEnsureSize(addr
);
1110 imgptr
= &ufoImage
[addr
/4u];
1111 } else if (addr
& UFO_ADDR_TEMP_BIT
) {
1112 addr
&= UFO_ADDR_TEMP_MASK
;
1113 if (addr
>= ufoImageTempSize
) ufoImgEnsureTemp(addr
);
1114 imgptr
= &ufoImageTemp
[addr
/4u];
1116 ufoFatal("Forth segmentation fault at address 0x%08X", addr
);
1118 const uint8_t val
= (uint8_t)value
;
1119 memcpy((uint8_t *)imgptr
+ (addr
&3), &val
, 1);
1123 //==========================================================================
1129 //==========================================================================
1130 UFO_FORCE_INLINE
void ufoImgPutU16 (uint32_t addr
, const uint32_t value
) {
1131 ufoImgPutU8(addr
, value
&0xffU
);
1132 ufoImgPutU8(addr
+ 1u, (value
>>8)&0xffU
);
1136 //==========================================================================
1142 //==========================================================================
1143 UFO_FORCE_INLINE
void ufoImgPutU32 (uint32_t addr
, const uint32_t value
) {
1144 ufoImgPutU16(addr
, value
&0xffffU
);
1145 ufoImgPutU16(addr
+ 2u, (value
>>16)&0xffffU
);
1149 //==========================================================================
1155 //==========================================================================
1156 UFO_FORCE_INLINE
uint32_t ufoImgGetU8 (uint32_t addr
) {
1158 if ((addr
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) {
1159 if (addr
>= ufoImageSize
) return 0;
1160 imgptr
= &ufoImage
[addr
/4u];
1161 } else if (addr
& UFO_ADDR_TEMP_BIT
) {
1162 addr
&= UFO_ADDR_TEMP_MASK
;
1163 if (addr
>= ufoImageTempSize
) return 0;
1164 imgptr
= &ufoImageTemp
[addr
/4u];
1166 ufoFatal("Forth segmentation fault at address 0x%08X", addr
);
1169 memcpy(&val
, (uint8_t *)imgptr
+ (addr
&3), 1);
1170 return (uint32_t)val
;
1174 //==========================================================================
1180 //==========================================================================
1181 UFO_FORCE_INLINE
uint32_t ufoImgGetU16 (uint32_t addr
) {
1182 return ufoImgGetU8(addr
) | (ufoImgGetU8(addr
+ 1u) << 8);
1186 //==========================================================================
1192 //==========================================================================
1193 UFO_FORCE_INLINE
uint32_t ufoImgGetU32 (uint32_t addr
) {
1194 return ufoImgGetU16(addr
) | (ufoImgGetU16(addr
+ 2u) << 16);
1199 //==========================================================================
1201 // ufoEnsureDebugSize
1203 //==========================================================================
1204 UFO_DISABLE_INLINE
void ufoEnsureDebugSize (uint32_t sdelta
) {
1205 ufo_assert(sdelta
!= 0);
1206 if (ufoDebugImageUsed
!= 0) {
1207 if (ufoDebugImageUsed
+ sdelta
>= 0x40000000U
) ufoFatal("debug info too big");
1208 if (ufoDebugImageUsed
+ sdelta
> ufoDebugImageSize
) {
1209 // grow by 32KB, this should be more than enough
1210 const uint32_t newsz
= ((ufoDebugImageUsed
+ sdelta
) | 0x7fffU
) + 1u;
1211 uint8_t *ndb
= realloc(ufoDebugImage
, newsz
);
1212 if (ndb
== NULL
) ufoFatal("out of memory for debug info");
1213 ufoDebugImage
= ndb
;
1214 ufoDebugImageSize
= newsz
;
1217 // initial allocation: 32KB, quite a lot
1218 ufoDebugImageSize
= 1024 * 32;
1219 ufoDebugImage
= malloc(ufoDebugImageSize
);
1220 if (ufoDebugImage
== NULL
) ufoFatal("out of memory for debug info");
1225 #define UFO_DBG_PUT_U4(val_) do { \
1226 const uint32_t vv_ = (val_); \
1227 *((uint32_t *)(ufoDebugImage + ufoDebugImageUsed)) = vv_; \
1228 ufoDebugImageUsed += 4u; \
1235 ...first line info header...
1236 line info header (or reset):
1237 db 0 ; zero line delta
1238 dw followFileInfoSize ; either it, or 0 if reused
1239 dd fileInfoOfs ; present only if reused
1247 dd nameLen ; without terminating 0
1248 ...name... (0-terminated)
1250 we will never compare file names: length and hash should provide
1251 good enough unique identifier.
1253 static uint8_t *ufoDebugImage = NULL;
1254 static uint32_t ufoDebugImageUsed = 0; // in bytes
1255 static uint32_t ufoDebugImageSize = 0; // in bytes
1256 static uint32_t ufoDebugFileNameHash = 0; // current file name hash
1257 static uint32_t ufoDebugFileNameLen = 0; // current file name length
1258 static uint32_t ufoDebugCurrDP = 0;
1262 //==========================================================================
1264 // ufoSkipDebugVarInt
1266 //==========================================================================
1267 static __attribute__((unused
)) uint32_t ufoSkipDebugVarInt (uint32_t ofs
) {
1270 if (ofs
>= ufoDebugImageUsed
) ufoFatal("invalid debug data");
1271 byte
= ufoDebugImage
[ofs
]; ofs
+= 1u;
1272 } while (byte
>= 0x80);
1277 //==========================================================================
1279 // ufoCalcDebugVarIntSize
1281 //==========================================================================
1282 UFO_FORCE_INLINE
uint8_t ufoCalcDebugVarIntSize (uint32_t v
) {
1292 //==========================================================================
1294 // ufoGetDebugVarInt
1296 //==========================================================================
1297 static __attribute__((unused
)) uint32_t ufoGetDebugVarInt (uint32_t ofs
) {
1302 if (ofs
>= ufoDebugImageUsed
) ufoFatal("invalid debug data");
1303 byte
= ufoDebugImage
[ofs
];
1304 v
|= (uint32_t)(byte
& 0x7f) << shift
;
1309 } while (byte
>= 0x80);
1314 //==========================================================================
1316 // ufoPutDebugVarInt
1318 //==========================================================================
1319 UFO_FORCE_INLINE
void ufoPutDebugVarInt (uint32_t v
) {
1320 ufoEnsureDebugSize(5u); // maximum size
1323 ufoDebugImage
[ufoDebugImageUsed
] = (uint8_t)(v
| 0x80u
);
1325 ufoDebugImage
[ufoDebugImageUsed
] = (uint8_t)v
;
1327 ufoDebugImageUsed
+= 1;
1333 #ifdef UFO_DEBUG_DEBUG
1334 //==========================================================================
1338 //==========================================================================
1339 static void ufoDumpDebugImage (void) {
1341 uint32_t dbgpos
= 4u; // first line header info
1342 uint32_t lastline
= 0;
1343 uint32_t lastdp
= 0;
1344 while (dbgpos
< ufoDebugImageUsed
) {
1345 if (ufoDebugImage
[dbgpos
] == 0) {
1347 dbgpos
+= 1u; // skip flag
1348 const uint32_t fhdrSize
= *(const uint16_t *)(ufoDebugImage
+ dbgpos
); dbgpos
+= 2u;
1349 lastdp
= ufoGetDebugVarInt(dbgpos
);
1350 dbgpos
= ufoSkipDebugVarInt(dbgpos
);
1351 if (fhdrSize
== 0) {
1353 const uint32_t infoOfs
= *(const uint32_t *)(ufoDebugImage
+ dbgpos
); dbgpos
+= 4u;
1354 fprintf(stderr
, "*** OLD FILE: %s\n", (const char *)(ufoDebugImage
+ infoOfs
+ 3u * 4u));
1355 fprintf(stderr
, "FILE NAME LEN: %u\n", ((const uint32_t *)(ufoDebugImage
+ infoOfs
))[2]);
1356 fprintf(stderr
, "FILE NAME HASH: 0x%08x\n", ((const uint32_t *)(ufoDebugImage
+ infoOfs
))[1]);
1359 fprintf(stderr
, "*** NEW FILE: %s\n", (const char *)(ufoDebugImage
+ dbgpos
+ 3u * 4u));
1360 fprintf(stderr
, "FILE NAME LEN: %u\n", ((const uint32_t *)(ufoDebugImage
+ dbgpos
))[2]);
1361 fprintf(stderr
, "FILE NAME HASH: 0x%08x\n", ((const uint32_t *)(ufoDebugImage
+ dbgpos
))[1]);
1364 fprintf(stderr
, "LINES-OFS: 0x%08x (hsz: %u -- 0x%08x)\n", dbgpos
, fhdrSize
, fhdrSize
);
1365 lastline
= ~(uint32_t)0;
1367 const uint32_t ln
= ufoGetDebugVarInt(dbgpos
);
1368 dbgpos
= ufoSkipDebugVarInt(dbgpos
);
1369 ufo_assert(ln
!= 0);
1371 const uint32_t edp
= ufoGetDebugVarInt(dbgpos
);
1372 dbgpos
= ufoSkipDebugVarInt(dbgpos
);
1374 fprintf(stderr
, " line %6u: edp=%u\n", lastline
, lastdp
);
1382 //==========================================================================
1384 // ufoRecordDebugCheckFile
1386 // if we moved to the new file:
1387 // put "line info header"
1388 // put new file info (or reuse old)
1390 //==========================================================================
1391 UFO_FORCE_INLINE
void ufoRecordDebugCheckFile (void) {
1392 if (ufoDebugImageUsed
== 0 ||
1393 ufoDebugFileNameLen
!= ufoInFileNameLen
||
1394 ufoDebugFileNameHash
!= ufoInFileNameHash
)
1396 // new file record (or reuse old one)
1397 const int initial
= (ufoDebugImageUsed
== 0);
1398 uint32_t fileRec
= 0;
1399 // try to find and old one
1401 fileRec
= *(const uint32_t *)ufoDebugImage
;
1403 fprintf(stderr
, "*** NEW-FILE(%u): 0x%08x: <%s> (frec=0x%08x)\n", ufoInFileNameLen
,
1404 ufoInFileNameHash
, ufoInFileName
, fileRec
);
1406 while (fileRec
!= 0 &&
1407 (ufoInFileNameLen
!= ((const uint32_t *)(ufoDebugImage
+ fileRec
))[1] ||
1408 ufoInFileNameHash
!= ((const uint32_t *)(ufoDebugImage
+ fileRec
))[2]))
1411 fprintf(stderr
, "*** FRCHECK: 0x%08x\n", fileRec
);
1412 fprintf(stderr
, " FILE NAME: %s\n", (const char *)(ufoDebugImage
+ fileRec
+ 3u * 4u));
1413 fprintf(stderr
, " FILE NAME LEN: %u\n", ((const uint32_t *)(ufoDebugImage
+ fileRec
))[2]);
1414 fprintf(stderr
, " FILE NAME HASH: 0x%08x\n", ((const uint32_t *)(ufoDebugImage
+ fileRec
))[1]);
1415 fprintf(stderr
, " FILE PREV: 0x%08x\n", *(const uint32_t *)(ufoDebugImage
+ fileRec
));
1417 fileRec
= *(const uint32_t *)(ufoDebugImage
+ fileRec
);
1420 fprintf(stderr
, "*** FRCHECK-DONE: 0x%08x\n", fileRec
);
1422 fprintf(stderr
, " FILE NAME: %s\n", (const char *)(ufoDebugImage
+ fileRec
+ 3u * 4u));
1423 fprintf(stderr
, " FILE NAME LEN: %u\n", ((const uint32_t *)(ufoDebugImage
+ fileRec
))[2]);
1424 fprintf(stderr
, " FILE NAME HASH: 0x%08x\n", ((const uint32_t *)(ufoDebugImage
+ fileRec
))[1]);
1425 fprintf(stderr
, " FILE PREV: 0x%08x\n", *(const uint32_t *)(ufoDebugImage
+ fileRec
));
1429 ufoEnsureDebugSize(8u);
1430 *(uint32_t *)ufoDebugImage
= 0;
1432 // write "line info header"
1434 ufoEnsureDebugSize(32u);
1435 ufoDebugImage
[ufoDebugImageUsed
] = 0; ufoDebugImageUsed
+= 1u; // header flag (0 delta)
1436 // file record size: 0 (reused)
1437 *((uint16_t *)(ufoDebugImage
+ ufoDebugImageUsed
)) = 0; ufoDebugImageUsed
+= 2u;
1439 ufoPutDebugVarInt(ufoDebugCurrDP
);
1441 UFO_DBG_PUT_U4(fileRec
);
1443 // name, trailing 0 byte, 3 dword fields
1444 const uint32_t finfoSize
= ufoInFileNameLen
+ 1u + 3u * 4u;
1445 ufo_assert(finfoSize
< 65536u);
1446 ufoEnsureDebugSize(finfoSize
+ 32u);
1448 *(uint32_t *)ufoDebugImage
= 0;
1449 ufoDebugImageUsed
= 4;
1451 ufoDebugImage
[ufoDebugImageUsed
] = 0; ufoDebugImageUsed
+= 1u; // header flag (0 delta)
1453 *((uint16_t *)(ufoDebugImage
+ ufoDebugImageUsed
)) = (uint16_t)finfoSize
; ufoDebugImageUsed
+= 2u;
1455 ufoPutDebugVarInt(ufoDebugCurrDP
);
1456 // file record follows
1457 // fix file info offsets
1458 uint32_t lastOfs
= *(const uint32_t *)ufoDebugImage
;
1459 *(uint32_t *)ufoDebugImage
= ufoDebugImageUsed
;
1460 UFO_DBG_PUT_U4(lastOfs
);
1461 // save file info hash
1462 UFO_DBG_PUT_U4(ufoInFileNameHash
);
1463 // save file info length
1464 UFO_DBG_PUT_U4(ufoInFileNameLen
);
1466 if (ufoInFileNameLen
!= 0) {
1467 memcpy(ufoDebugImage
+ ufoDebugImageUsed
, ufoInFileName
, ufoInFileNameLen
+ 1u);
1468 ufoDebugImageUsed
+= ufoInFileNameLen
+ 1u;
1470 ufoDebugImage
[ufoDebugImageUsed
] = 0; ufoDebugImageUsed
+= 1u;
1473 ufoDebugFileNameLen
= ufoInFileNameLen
;
1474 ufoDebugFileNameHash
= ufoInFileNameHash
;
1475 ufoDebugLastLine
= ~(uint32_t)0;
1476 ufoDebugLastLinePCOfs
= 0;
1477 ufoDebugLastLineDP
= ufoDebugCurrDP
;
1482 //==========================================================================
1484 // ufoRecordDebugRecordLine
1486 //==========================================================================
1487 UFO_FORCE_INLINE
void ufoRecordDebugRecordLine (uint32_t line
, uint32_t newhere
) {
1488 if (line
== ufoDebugLastLine
) {
1489 ufo_assert(ufoDebugLastLinePCOfs
!= 0);
1490 ufoDebugImageUsed
= ufoDebugLastLinePCOfs
;
1493 fprintf(stderr
, "FL-NEW-LINE(0x%08x): <%s>; new line: %u (old: %u)\n",
1495 ufoInFileName
, line
, ufoDebugLastLine
);
1497 ufoPutDebugVarInt(line
- ufoDebugLastLine
);
1498 ufoDebugLastLinePCOfs
= ufoDebugImageUsed
;
1499 ufoDebugLastLine
= line
;
1500 ufoDebugLastLineDP
= ufoDebugCurrDP
;
1502 ufoPutDebugVarInt(newhere
- ufoDebugLastLineDP
);
1503 ufoDebugCurrDP
= newhere
;
1507 //==========================================================================
1511 //==========================================================================
1512 UFO_DISABLE_INLINE
void ufoRecordDebug (uint32_t newhere
) {
1513 if (newhere
> ufoDebugCurrDP
) {
1514 uint32_t ln
= (uint32_t)ufoInFileLine
;
1515 if (ln
== ~(uint32_t)0) ln
= 0;
1517 fprintf(stderr
, "FL: <%s>; line: %d\n", ufoInFileName
, ufoInFileLine
);
1519 ufoRecordDebugCheckFile();
1520 ufoRecordDebugRecordLine(ln
, newhere
);
1525 //==========================================================================
1527 // ufoGetWordEndAddrYFA
1529 //==========================================================================
1530 static uint32_t ufoGetWordEndAddrYFA (uint32_t yfa
) {
1532 const uint32_t oyfa
= yfa
;
1533 yfa
= ufoImgGetU32(yfa
);
1535 if ((oyfa
& UFO_ADDR_TEMP_BIT
) == 0) {
1537 if ((yfa
& UFO_ADDR_TEMP_BIT
) != 0) {
1538 yfa
= UFO_CFA_TO_PFA(UFO_NFA_TO_CFA(UFO_YFA_TO_NFA(oyfa
)));
1541 yfa
= UFO_CFA_TO_PFA(UFO_NFA_TO_CFA(UFO_YFA_TO_NFA(oyfa
)));
1544 yfa
= UFO_YFA_TO_WST(yfa
);
1553 //==========================================================================
1555 // ufoGetWordEndAddr
1557 //==========================================================================
1558 static uint32_t ufoGetWordEndAddr (const uint32_t cfa
) {
1560 return ufoGetWordEndAddrYFA(UFO_LFA_TO_YFA(UFO_CFA_TO_LFA(cfa
)));
1567 //==========================================================================
1573 // WARNING: this is SLOW!
1575 //==========================================================================
1576 static uint32_t ufoFindWordForIP (const uint32_t ip
) {
1579 //fprintf(stderr, "ufoFindWordForIP:000: ip=0x%08x\n", ip);
1580 // iterate over all words
1581 uint32_t xfa
= ufoImgGetU32(ufoAddrLastXFA
);
1582 //fprintf(stderr, "ufoFindWordForIP:001: xfa=0x%08x\n", xfa);
1584 while (res
== 0 && xfa
!= 0) {
1585 const uint32_t yfa
= UFO_XFA_TO_YFA(xfa
);
1586 const uint32_t wst
= UFO_YFA_TO_WST(yfa
);
1587 //fprintf(stderr, "ufoFindWordForIP:002: yfa=0x%08x; wst=0x%08x\n", yfa, wst);
1588 const uint32_t wend
= ufoGetWordEndAddrYFA(yfa
);
1589 if (ip
>= wst
&& ip
< wend
) {
1590 res
= UFO_YFA_TO_NFA(yfa
);
1592 xfa
= ufoImgGetU32(xfa
);
1601 //==========================================================================
1605 // return file name or `NULL`
1607 // WARNING: this is SLOW!
1609 //==========================================================================
1610 static const char *ufoFindFileForIP (uint32_t ip
, uint32_t *line
,
1611 uint32_t *nlen
, uint32_t *nhash
)
1613 if (ip
!= 0 && ufoDebugImageUsed
!= 0) {
1614 const char *filename
= NULL
;
1615 uint32_t dbgpos
= 4u; // first line header info
1616 uint32_t lastline
= 0;
1617 uint32_t lastdp
= 0;
1618 uint32_t namelen
= 0;
1619 uint32_t namehash
= 0;
1620 while (dbgpos
< ufoDebugImageUsed
) {
1621 if (ufoDebugImage
[dbgpos
] == 0) {
1623 dbgpos
+= 1u; // skip flag
1624 const uint32_t fhdrSize
= *(const uint16_t *)(ufoDebugImage
+ dbgpos
); dbgpos
+= 2u;
1625 lastdp
= ufoGetDebugVarInt(dbgpos
);
1626 dbgpos
= ufoSkipDebugVarInt(dbgpos
);
1628 if (fhdrSize
== 0) {
1630 infoOfs
= *(const uint32_t *)(ufoDebugImage
+ dbgpos
); dbgpos
+= 4u;
1635 filename
= (const char *)(ufoDebugImage
+ infoOfs
+ 3u * 4u);
1636 namelen
= ((const uint32_t *)(ufoDebugImage
+ infoOfs
))[2];
1637 namehash
= ((const uint32_t *)(ufoDebugImage
+ infoOfs
))[1];
1638 if (filename
[0] == 0) filename
= NULL
;
1640 lastline
= ~(uint32_t)0;
1642 const uint32_t ln
= ufoGetDebugVarInt(dbgpos
);
1643 dbgpos
= ufoSkipDebugVarInt(dbgpos
);
1644 ufo_assert(ln
!= 0);
1646 const uint32_t edp
= ufoGetDebugVarInt(dbgpos
);
1647 dbgpos
= ufoSkipDebugVarInt(dbgpos
);
1648 if (ip
>= lastdp
&& ip
< lastdp
+ edp
) {
1649 if (line
) *line
= lastline
;
1650 if (nlen
) *nlen
= namelen
;
1651 if (nhash
) *nhash
= namehash
;
1658 if (line
) *line
= 0;
1659 if (nlen
) *nlen
= 0;
1660 if (nhash
) *nlen
= 0;
1665 //==========================================================================
1669 //==========================================================================
1670 UFO_FORCE_INLINE
void ufoBumpDP (uint32_t delta
) {
1671 uint32_t dp
= ufoImgGetU32(ufoAddrDPTemp
);
1673 dp
= ufoImgGetU32(ufoAddrDP
);
1674 if ((dp
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) ufoRecordDebug(dp
+ delta
);
1676 ufoImgPutU32(ufoAddrDP
, dp
);
1678 dp
= ufoImgGetU32(ufoAddrDPTemp
);
1679 if ((dp
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) ufoRecordDebug(dp
+ delta
);
1681 ufoImgPutU32(ufoAddrDPTemp
, dp
);
1686 //==========================================================================
1690 //==========================================================================
1691 UFO_FORCE_INLINE
void ufoImgEmitU8 (uint32_t value
) {
1692 ufoImgPutU8(UFO_GET_DP(), value
);
1697 //==========================================================================
1701 //==========================================================================
1702 UFO_FORCE_INLINE
void ufoImgEmitU32 (uint32_t value
) {
1703 ufoImgPutU32(UFO_GET_DP(), value
);
1708 #ifdef UFO_FAST_MEM_ACCESS
1710 //==========================================================================
1712 // ufoImgEmitU32_NoInline
1716 //==========================================================================
1717 UFO_FORCE_INLINE
void ufoImgEmitU32_NoInline (uint32_t value
) {
1718 ufoImgPutU32(UFO_GET_DP(), value
);
1724 //==========================================================================
1726 // ufoImgEmitU32_NoInline
1730 //==========================================================================
1731 UFO_DISABLE_INLINE
void ufoImgEmitU32_NoInline (uint32_t value
) {
1732 ufoImgPutU32(UFO_GET_DP(), value
);
1739 //==========================================================================
1743 // this understands handle addresses
1745 //==========================================================================
1746 UFO_FORCE_INLINE
uint32_t ufoImgGetU8Ext (uint32_t addr
) {
1747 if ((addr
& UFO_ADDR_HANDLE_BIT
) == 0) {
1748 return ufoImgGetU8(addr
);
1752 UFCALL(PAR_HANDLE_LOAD_BYTE
);
1758 //==========================================================================
1762 // this understands handle addresses
1764 //==========================================================================
1765 UFO_FORCE_INLINE
void ufoImgPutU8Ext (uint32_t addr
, uint32_t value
) {
1766 if ((addr
& UFO_ADDR_HANDLE_BIT
) == 0) {
1767 ufoImgPutU8(addr
, value
);
1772 UFCALL(PAR_HANDLE_STORE_BYTE
);
1777 //==========================================================================
1781 //==========================================================================
1782 UFO_FORCE_INLINE
void ufoImgEmitAlign (void) {
1783 while ((UFO_GET_DP() & 3) != 0) ufoImgEmitU8(0);
1787 //==========================================================================
1791 //==========================================================================
1792 UFO_FORCE_INLINE
void ufoResetTib (void) {
1793 uint32_t defTIB
= ufoImgGetU32(ufoAddrDefTIB
);
1794 //fprintf(stderr, "ufoResetTib(%p): defTIB=0x%08x\n", ufoCurrState, defTIB);
1796 // create new TIB handle
1797 UfoHandle
*tibh
= ufoAllocHandle(0x69a029a6); // arbitrary number
1798 defTIB
= tibh
->ufoHandle
;
1799 ufoImgPutU32(ufoAddrDefTIB
, defTIB
);
1801 if ((defTIB
& UFO_ADDR_HANDLE_BIT
) != 0) {
1802 UfoHandle
*hh
= ufoGetHandle(defTIB
);
1803 if (hh
== NULL
) ufoFatal("default TIB is not allocated");
1804 if (hh
->size
== 0) {
1805 ufo_assert(hh
->data
== NULL
);
1806 hh
->data
= calloc(1, UFO_ADDR_HANDLE_OFS_MASK
+ 1);
1807 if (hh
->data
== NULL
) ufoFatal("out of memory for default TIB");
1808 hh
->size
= UFO_ADDR_HANDLE_OFS_MASK
+ 1;
1811 const uint32_t oldA
= ufoRegA
;
1812 ufoImgPutU32(ufoAddrTIBx
, defTIB
);
1813 ufoImgPutU32(ufoAddrINx
, 0);
1815 ufoPush(0); // value
1816 ufoPush(0); // offset
1817 UFCALL(CPOKE_REGA_IDX
);
1822 //==========================================================================
1826 //==========================================================================
1827 UFO_DISABLE_INLINE
void ufoTibEnsureSize (uint32_t size
) {
1828 if (size
> 1024u * 1024u * 256u) ufoFatal("TIB size too big");
1829 const uint32_t tib
= ufoImgGetU32(ufoAddrTIBx
);
1830 //fprintf(stderr, "ufoTibEnsureSize: TIB=0x%08x; size=%u\n", tib, size);
1831 if ((tib
& UFO_ADDR_HANDLE_BIT
) != 0) {
1832 UfoHandle
*hh
= ufoGetHandle(tib
);
1834 ufoFatal("cannot resize TIB, TIB is not a handle");
1836 if (hh
->size
< size
) {
1837 const uint32_t newsz
= (size
| 0xfffU
) + 1u;
1838 uint8_t *nx
= realloc(hh
->data
, newsz
);
1839 if (nx
== NULL
) ufoFatal("out of memory for restored TIB");
1846 ufoFatal("cannot resize TIB, TIB is not a handle (0x%08x)", tib
);
1852 //==========================================================================
1856 //==========================================================================
1858 UFO_DISABLE_INLINE uint32_t ufoTibGetSize (void) {
1859 const uint32_t tib = ufoImgGetU32(ufoAddrTIBx);
1860 if ((tib & UFO_ADDR_HANDLE_BIT) == 0) {
1861 ufoFatal("cannot query TIB, TIB is not a handle");
1863 UfoHandle *hh = ufoGetHandle(tib);
1865 ufoFatal("cannot query TIB, TIB is not a handle");
1872 //==========================================================================
1876 //==========================================================================
1877 UFO_FORCE_INLINE
uint8_t ufoTibPeekCh (void) {
1878 return (uint8_t)ufoImgGetU8Ext(ufoImgGetU32(ufoAddrTIBx
) + ufoImgGetU32(ufoAddrINx
));
1882 //==========================================================================
1886 //==========================================================================
1887 UFO_FORCE_INLINE
uint8_t ufoTibPeekChOfs (uint32_t ofs
) {
1888 const uint32_t tib
= ufoImgGetU32(ufoAddrTIBx
);
1889 if (ofs
<= UFO_ADDR_HANDLE_OFS_MASK
|| (tib
& UFO_ADDR_HANDLE_BIT
) == 0) {
1890 return (uint8_t)ufoImgGetU8Ext(tib
+ ufoImgGetU32(ufoAddrINx
) + ofs
);
1897 //==========================================================================
1901 //==========================================================================
1902 UFO_DISABLE_INLINE
void ufoTibPokeChOfs (uint8_t ch
, uint32_t ofs
) {
1903 const uint32_t oldA
= ufoRegA
;
1904 ufoRegA
= ufoImgGetU32(ufoAddrTIBx
);
1906 ufoPush(ufoImgGetU32(ufoAddrINx
) + ofs
);
1907 UFCALL(CPOKE_REGA_IDX
);
1912 //==========================================================================
1916 //==========================================================================
1917 UFO_FORCE_INLINE
uint8_t ufoTibGetCh (void) {
1918 const uint8_t ch
= ufoTibPeekCh();
1919 if (ch
) ufoImgPutU32(ufoAddrINx
, ufoImgGetU32(ufoAddrINx
) + 1u);
1924 //==========================================================================
1928 //==========================================================================
1929 UFO_FORCE_INLINE
void ufoTibSkipCh (void) {
1930 (void)ufoTibGetCh();
1934 // ////////////////////////////////////////////////////////////////////////// //
1935 // native CFA implementations
1938 //==========================================================================
1942 //==========================================================================
1943 static void ufoDoForth (uint32_t pfa
) {
1949 //==========================================================================
1953 //==========================================================================
1954 static void ufoDoVariable (uint32_t pfa
) {
1959 //==========================================================================
1961 // ufoDoUserVariable
1963 //==========================================================================
1964 static void ufoDoUserVariable (uint32_t pfa
) {
1965 ufoPush(ufoImgGetU32(pfa
));
1969 //==========================================================================
1973 //==========================================================================
1974 static void ufoDoValue (uint32_t pfa
) {
1975 ufoPush(ufoImgGetU32(pfa
));
1979 //==========================================================================
1983 //==========================================================================
1984 static void ufoDoConst (uint32_t pfa
) {
1985 ufoPush(ufoImgGetU32(pfa
));
1989 //==========================================================================
1993 //==========================================================================
1994 static void ufoDoDefer (uint32_t pfa
) {
1995 const uint32_t cfa
= ufoImgGetU32(pfa
);
2003 //==========================================================================
2007 //==========================================================================
2008 static void ufoDoVoc (uint32_t pfa
) {
2009 ufoImgPutU32(ufoAddrContext
, ufoImgGetU32(pfa
));
2013 //==========================================================================
2017 //==========================================================================
2018 static void ufoDoCreate (uint32_t pfa
) {
2023 //==========================================================================
2027 // this also increments last used file id
2029 //==========================================================================
2030 static void ufoPushInFile (void) {
2031 if (ufoFileStackPos
>= UFO_MAX_NESTED_INCLUDES
) ufoFatal("too many includes");
2032 UFOFileStackEntry
*stk
= &ufoFileStack
[ufoFileStackPos
];
2033 stk
->fl
= ufoInFile
;
2034 stk
->fname
= ufoInFileName
;
2035 stk
->fline
= ufoInFileLine
;
2036 stk
->id
= ufoFileId
;
2037 stk
->incpath
= (ufoLastIncPath
? strdup(ufoLastIncPath
) : NULL
);
2038 stk
->sysincpath
= (ufoLastSysIncPath
? strdup(ufoLastSysIncPath
) : NULL
);
2039 ufoFileStackPos
+= 1;
2041 ufoInFileName
= NULL
; ufoInFileNameLen
= 0; ufoInFileNameHash
= 0;
2043 ufoLastUsedFileId
+= 1;
2044 ufo_assert(ufoLastUsedFileId
!= 0); // just in case ;-)
2045 //ufoLastIncPath = NULL;
2049 //==========================================================================
2051 // ufoWipeIncludeStack
2053 //==========================================================================
2054 static void ufoWipeIncludeStack (void) {
2055 if (ufoInFileName
) { free(ufoInFileName
); ufoInFileName
= NULL
; }
2056 if (ufoInFile
) { fclose(ufoInFile
); ufoInFile
= NULL
; }
2057 if (ufoLastIncPath
) { free(ufoLastIncPath
); ufoLastIncPath
= NULL
; }
2058 if (ufoLastSysIncPath
) { free(ufoLastSysIncPath
); ufoLastSysIncPath
= NULL
; }
2059 while (ufoFileStackPos
!= 0) {
2060 ufoFileStackPos
-= 1;
2061 UFOFileStackEntry
*stk
= &ufoFileStack
[ufoFileStackPos
];
2062 if (stk
->fl
) fclose(stk
->fl
);
2063 if (stk
->fname
) free(stk
->fname
);
2064 if (stk
->incpath
) free(stk
->incpath
);
2069 //==========================================================================
2073 //==========================================================================
2074 static void ufoPopInFile (void) {
2075 if (ufoFileStackPos
== 0) ufoFatal("trying to pop include from empty stack");
2076 if (ufoInFileName
) { free(ufoInFileName
); ufoInFileName
= NULL
; }
2077 if (ufoInFile
) { fclose(ufoInFile
); ufoInFile
= NULL
; }
2078 if (ufoLastIncPath
) { free(ufoLastIncPath
); ufoLastIncPath
= NULL
; }
2079 if (ufoLastSysIncPath
) { free(ufoLastSysIncPath
); ufoLastSysIncPath
= NULL
; }
2080 ufoFileStackPos
-= 1;
2081 UFOFileStackEntry
*stk
= &ufoFileStack
[ufoFileStackPos
];
2082 ufoInFile
= stk
->fl
;
2083 ufoSetInFileNameReuse(stk
->fname
);
2084 ufoInFileLine
= stk
->fline
;
2085 ufoLastIncPath
= stk
->incpath
;
2086 ufoLastSysIncPath
= stk
->sysincpath
;
2087 ufoFileId
= stk
->id
;
2089 #ifdef UFO_DEBUG_INCLUDE
2090 if (ufoInFileName
== NULL
) {
2091 fprintf(stderr
, "INC-POP: no more files.\n");
2093 fprintf(stderr
, "INC-POP: fname: %s\n", ufoInFileName
);
2099 //==========================================================================
2103 //==========================================================================
2104 void ufoDeinit (void) {
2105 #ifdef UFO_DEBUG_WRITE_MAIN_IMAGE
2107 FILE *fo
= fopen("zufo_main.img", "w");
2108 uint32_t dpTemp
= ufoImgGetU32(ufoAddrDPTemp
);
2109 uint32_t dpMain
= ufoImgGetU32(ufoAddrDP
);
2110 if ((dpMain
& UFO_ADDR_SPECIAL_BITS_MASK
) != 0) dpMain
= ufoImageSize
;
2111 if (dpTemp
!= 0 && (dpTemp
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) {
2112 if (dpTemp
> dpMain
) dpMain
= dpTemp
;
2114 fwrite(ufoImage
, dpMain
, 1, fo
);
2119 #ifdef UFO_DEBUG_WRITE_DEBUG_IMAGE
2121 FILE *fo
= fopen("zufo_debug.img", "w");
2122 fwrite(ufoDebugImage
, ufoDebugImageUsed
, 1, fo
);
2127 #ifdef UFO_DEBUG_DEBUG
2129 uint32_t dpTemp
= ufoImgGetU32(ufoAddrDPTemp
);
2130 uint32_t dpMain
= ufoImgGetU32(ufoAddrDP
);
2131 if ((dpMain
& UFO_ADDR_SPECIAL_BITS_MASK
) != 0) dpMain
= ufoImageSize
;
2132 if (dpTemp
!= 0 && (dpTemp
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) {
2133 if (dpTemp
> dpMain
) dpMain
= dpTemp
;
2135 fprintf(stderr
, "UFO: image used: %u; size: %u\n",
2136 dpMain
, ufoImageSize
);
2137 fprintf(stderr
, "UFO: debug image used: %u; size: %u\n",
2138 ufoDebugImageUsed
, ufoDebugImageSize
);
2139 ufoDumpDebugImage();
2144 ufoCurrState
= NULL
;
2145 ufoYieldedState
= NULL
;
2146 ufoDebuggerState
= NULL
;
2147 for (uint32_t fidx
= 0; fidx
< (uint32_t)(UFO_MAX_STATES
/32); fidx
+= 1u) {
2148 uint32_t bmp
= ufoStateUsedBitmap
[fidx
];
2150 uint32_t stid
= fidx
* 32u;
2152 if ((bmp
& 0x01) != 0) ufoFreeState(ufoStateMap
[stid
]);
2153 stid
+= 1u; bmp
>>= 1;
2158 free(ufoDebugImage
);
2159 ufoDebugImage
= NULL
;
2160 ufoDebugImageUsed
= 0;
2161 ufoDebugImageSize
= 0;
2162 ufoDebugFileNameHash
= 0;
2163 ufoDebugFileNameLen
= 0;
2164 ufoDebugLastLine
= 0;
2165 ufoDebugLastLinePCOfs
= 0;
2166 ufoDebugLastLineDP
= 0;
2170 ufoClearCondDefines();
2171 ufoWipeIncludeStack();
2173 // release all includes
2175 if (ufoInFileName
) free(ufoInFileName
);
2176 if (ufoLastIncPath
) free(ufoLastIncPath
);
2177 if (ufoLastSysIncPath
) free(ufoLastSysIncPath
);
2178 ufoInFileName
= NULL
; ufoLastIncPath
= NULL
; ufoLastSysIncPath
= NULL
;
2179 ufoInFileNameHash
= 0; ufoInFileNameLen
= 0;
2183 ufoForthCFAs
= NULL
;
2190 ufoMode
= UFO_MODE_NATIVE
;
2191 ufoForthVocId
= 0; ufoCompilerVocId
= 0;
2195 for (uint32_t f
= 0; f
< ufoHandlesUsed
; f
+= 1) {
2196 UfoHandle
*hh
= ufoHandles
[f
];
2198 if (hh
->data
!= NULL
) free(hh
->data
);
2202 if (ufoHandles
!= NULL
) free(ufoHandles
);
2203 ufoHandles
= NULL
; ufoHandlesUsed
= 0; ufoHandlesAlloted
= 0;
2204 ufoHandleFreeList
= NULL
;
2206 ufoLastEmitWasCR
= 1;
2208 ufoClearCondDefines();
2212 //==========================================================================
2214 // ufoDumpWordHeader
2216 //==========================================================================
2217 __attribute__((unused
)) static void ufoDumpWordHeader (const uint32_t lfa
) {
2218 fprintf(stderr
, "=== WORD: LFA: 0x%08x ===\n", lfa
);
2220 fprintf(stderr
, " (XFA): 0x%08x\n", ufoImgGetU32(UFO_LFA_TO_XFA(lfa
)));
2221 fprintf(stderr
, " (YFA): 0x%08x\n", ufoImgGetU32(UFO_LFA_TO_YFA(lfa
)));
2222 fprintf(stderr
, " (BFA): 0x%08x\n", ufoImgGetU32(UFO_LFA_TO_BFA(lfa
)));
2223 fprintf(stderr
, " (LFA): 0x%08x\n", ufoImgGetU32(lfa
));
2224 fprintf(stderr
, " (NHH): 0x%08x\n", ufoImgGetU32(UFO_LFA_TO_NHASH(lfa
)));
2225 const uint32_t cfa
= UFO_LFA_TO_CFA(lfa
);
2226 fprintf(stderr
, " CFA: 0x%08x\n", cfa
);
2227 fprintf(stderr
, " PFA: 0x%08x\n", UFO_CFA_TO_PFA(cfa
));
2228 fprintf(stderr
, " (CFA): 0x%08x\n", ufoImgGetU32(cfa
));
2229 const uint32_t nfa
= UFO_LFA_TO_NFA(lfa
);
2230 const uint32_t nlen
= ufoImgGetU8(nfa
);
2231 fprintf(stderr
, " NFA: 0x%08x (nlen: %u)\n", nfa
, nlen
);
2232 const uint32_t flags
= ufoImgGetU32(nfa
);
2233 fprintf(stderr
, " FLAGS: 0x%08x\n", flags
);
2234 if ((flags
& 0xffff0000U
) != 0) {
2235 fprintf(stderr
, " FLAGS:");
2236 if (flags
& UFW_FLAG_IMMEDIATE
) fprintf(stderr
, " IMM");
2237 if (flags
& UFW_FLAG_SMUDGE
) fprintf(stderr
, " SMUDGE");
2238 if (flags
& UFW_FLAG_NORETURN
) fprintf(stderr
, " NORET");
2239 if (flags
& UFW_FLAG_HIDDEN
) fprintf(stderr
, " HIDDEN");
2240 if (flags
& UFW_FLAG_CBLOCK
) fprintf(stderr
, " CBLOCK");
2241 if (flags
& UFW_FLAG_VOCAB
) fprintf(stderr
, " VOCAB");
2242 if (flags
& UFW_FLAG_SCOLON
) fprintf(stderr
, " SCOLON");
2243 if (flags
& UFW_FLAG_PROTECTED
) fprintf(stderr
, " PROTECTED");
2244 fputc('\n', stderr
);
2246 if ((flags
& 0xff00U
) != 0) {
2247 fprintf(stderr
, " ARGS: ");
2248 switch (flags
& UFW_WARG_MASK
) {
2249 case UFW_WARG_NONE
: fprintf(stderr
, "NONE"); break;
2250 case UFW_WARG_BRANCH
: fprintf(stderr
, "BRANCH"); break;
2251 case UFW_WARG_LIT
: fprintf(stderr
, "LIT"); break;
2252 case UFW_WARG_C4STRZ
: fprintf(stderr
, "C4STRZ"); break;
2253 case UFW_WARG_CFA
: fprintf(stderr
, "CFA"); break;
2254 case UFW_WARG_CBLOCK
: fprintf(stderr
, "CBLOCK"); break;
2255 case UFW_WARG_VOCID
: fprintf(stderr
, "VOCID"); break;
2256 case UFW_WARG_C1STRZ
: fprintf(stderr
, "C1STRZ"); break;
2257 default: fprintf(stderr
, "wtf?!"); break;
2259 fputc('\n', stderr
);
2261 fprintf(stderr
, " BACKLEN: %u (nfa at 0x%08x)\n", ufoImgGetU8(cfa
- 1u), UFO_CFA_TO_NFA(cfa
));
2262 fprintf(stderr
, " NAME(%u): ", nlen
);
2263 for (uint32_t f
= 0; f
< nlen
; f
+= 1) {
2264 const uint8_t ch
= ufoImgGetU8(nfa
+ 4u + f
);
2265 if (ch
<= 32 || ch
>= 127) {
2266 fprintf(stderr
, "\\x%02x", ch
);
2268 fprintf(stderr
, "%c", (char)ch
);
2271 fprintf(stderr
, "\n");
2272 ufo_assert(UFO_CFA_TO_LFA(cfa
) == lfa
);
2277 //==========================================================================
2283 //==========================================================================
2284 static uint32_t ufoVocCheckName (uint32_t lfa
, const void *wname
, uint32_t wnlen
, uint32_t hash
,
2288 #ifdef UFO_DEBUG_FIND_WORD
2289 fprintf(stderr
, "CHECK-NAME: %.*s; LFA: 0x%08x; hash: 0x%08x (wname: 0x%08x)\n",
2290 (unsigned) wnlen
, (const char *)wname
,
2291 lfa
, (lfa
!= 0 ? ufoImgGetU32(UFO_LFA_TO_NHASH(lfa
)) : 0), hash
);
2292 ufoDumpWordHeader(lfa
);
2294 if (lfa
!= 0 && ufoImgGetU32(UFO_LFA_TO_NHASH(lfa
)) == hash
) {
2295 const uint32_t lenflags
= ufoImgGetU32(UFO_LFA_TO_NFA(lfa
));
2296 if ((lenflags
& UFW_FLAG_SMUDGE
) == 0 &&
2297 (allowvochid
|| (lenflags
& UFW_FLAG_HIDDEN
) == 0))
2299 const uint32_t nlen
= lenflags
&0xffU
;
2300 if (nlen
== wnlen
) {
2301 uint32_t naddr
= UFO_LFA_TO_NFA(lfa
) + 4u;
2303 while (pos
< nlen
) {
2304 uint8_t c0
= ((const unsigned char *)wname
)[pos
];
2305 if (c0
>= 'a' && c0
<= 'z') c0
= c0
- 'a' + 'A';
2306 uint8_t c1
= ufoImgGetU8(naddr
+ pos
);
2307 if (c1
>= 'a' && c1
<= 'z') c1
= c1
- 'a' + 'A';
2308 if (c0
!= c1
) break;
2314 res
= UFO_ALIGN4(naddr
);
2323 //==========================================================================
2329 //==========================================================================
2330 static uint32_t ufoFindWordInVoc (const void *wname
, uint32_t wnlen
, uint32_t hash
,
2331 uint32_t vocid
, int allowvochid
)
2334 if (wname
== NULL
) ufo_assert(wnlen
== 0);
2335 if (wnlen
!= 0 && vocid
!= 0) {
2336 if (hash
== 0) hash
= joaatHashBufCI(wname
, wnlen
);
2337 #if defined(UFO_DEBUG_FIND_WORD) || defined(UFO_DEBUG_FIND_WORD_IN_VOC)
2338 fprintf(stderr
, "IN-VOC: %.*s; VOCID: 0x%08x; whash: 0x%08x; htbl[0]: 0x%08x\n",
2339 (unsigned) wnlen
, (const char *)wname
,
2340 vocid
, hash
, ufoImgGetU32(vocid
+ UFW_VOCAB_OFS_HTABLE
));
2342 const uint32_t htbl
= vocid
+ UFW_VOCAB_OFS_HTABLE
;
2343 if (ufoImgGetU32(htbl
) != UFO_NO_HTABLE_FLAG
) {
2344 // hash table present, use it
2345 uint32_t bfa
= htbl
+ (hash
% (uint32_t)UFO_HASHTABLE_SIZE
) * 4u;
2346 bfa
= ufoImgGetU32(bfa
);
2347 while (res
== 0 && bfa
!= 0) {
2348 #if defined(UFO_DEBUG_FIND_WORD) || defined(UFO_DEBUG_FIND_WORD_IN_VOC)
2349 fprintf(stderr
, "IN-VOC: bfa: 0x%08x\n", bfa
);
2351 res
= ufoVocCheckName(UFO_BFA_TO_LFA(bfa
), wname
, wnlen
, hash
, allowvochid
);
2352 bfa
= ufoImgGetU32(bfa
);
2355 // no hash table, use linear search
2356 uint32_t lfa
= vocid
+ UFW_VOCAB_OFS_LATEST
;
2357 lfa
= ufoImgGetU32(lfa
);
2358 while (res
== 0 && lfa
!= 0) {
2359 res
= ufoVocCheckName(lfa
, wname
, wnlen
, hash
, allowvochid
);
2360 lfa
= ufoImgGetU32(lfa
);
2368 //==========================================================================
2372 // return part after the colon, or `NULL`
2374 //==========================================================================
2375 static const void *ufoFindColon (const void *wname
, uint32_t wnlen
) {
2376 const void *res
= NULL
;
2378 ufo_assert(wname
!= NULL
);
2379 const char *str
= (const char *)wname
;
2380 while (wnlen
!= 0 && str
[0] != ':') {
2381 str
+= 1; wnlen
-= 1;
2384 res
= (const void *)(str
+ 1); // skip colon
2391 //==========================================================================
2393 // ufoFindWordInVocAndParents
2395 //==========================================================================
2396 static uint32_t ufoFindWordInVocAndParents (const void *wname
, uint32_t wnlen
, uint32_t hash
,
2397 uint32_t vocid
, int allowvochid
)
2400 if (hash
== 0) hash
= joaatHashBufCI(wname
, wnlen
);
2401 while (res
== 0 && vocid
!= 0) {
2402 res
= ufoFindWordInVoc(wname
, wnlen
, hash
, vocid
, allowvochid
);
2403 vocid
= ufoImgGetU32(vocid
+ UFW_VOCAB_OFS_PARENT
);
2409 //==========================================================================
2411 // ufoFindWordNameRes
2413 // find with name resolution
2417 //==========================================================================
2418 static uint32_t ufoFindWordNameRes (const void *wname
, uint32_t wnlen
) {
2420 if (wnlen
!= 0 && *(const char *)wname
!= ':') {
2421 ufo_assert(wname
!= NULL
);
2423 const void *stx
= wname
;
2424 wname
= ufoFindColon(wname
, wnlen
);
2425 if (wname
!= NULL
) {
2426 // look in all vocabs (excluding hidden ones)
2427 uint32_t xlen
= (uint32_t)(ptrdiff_t)(wname
- stx
) - 1u;
2428 ufo_assert(xlen
> 0 && xlen
< 255);
2429 uint32_t xhash
= joaatHashBufCI(stx
, xlen
);
2430 uint32_t voclink
= ufoImgGetU32(ufoAddrVocLink
);
2431 #ifdef UFO_DEBUG_FIND_WORD_COLON
2432 fprintf(stderr
, "COLON-FIND: first voc: {%.*s}; xhash=0x%08x; voc-link: 0x%08x\n",
2433 (unsigned)xlen
, (const char *)stx
, xhash
, voclink
);
2435 while (res
== 0 && voclink
!= 0) {
2436 const uint32_t vhdraddr
= voclink
- UFW_VOCAB_OFS_VOCLINK
+ UFW_VOCAB_OFS_HEADER
;
2437 const uint32_t vhdr
= ufoImgGetU32(vhdraddr
);
2439 res
= ufoVocCheckName(UFO_NFA_TO_LFA(vhdr
), stx
, xlen
, xhash
, 0);
2441 if (res
== 0) voclink
= ufoImgGetU32(voclink
);
2444 uint32_t vocid
= voclink
- UFW_VOCAB_OFS_VOCLINK
;
2445 ufo_assert(voclink
!= 0);
2447 #ifdef UFO_DEBUG_FIND_WORD_COLON
2448 fprintf(stderr
, "searching {%.*s}(%u) in {%.*s}\n",
2449 (unsigned)wnlen
, wname
, wnlen
, (unsigned)xlen
, stx
);
2451 while (res
!= 0 && wname
!= NULL
) {
2452 // first, the whole rest
2453 res
= ufoFindWordInVocAndParents(wname
, wnlen
, 0, vocid
, 1);
2458 wname
= ufoFindColon(wname
, wnlen
);
2459 if (wname
== NULL
) xlen
= wnlen
; else xlen
= (uint32_t)(ptrdiff_t)(wname
- stx
) - 1u;
2460 ufo_assert(xlen
> 0 && xlen
< 255);
2461 res
= ufoFindWordInVocAndParents(stx
, xlen
, 0, vocid
, 1);
2464 if (wname
!= NULL
) {
2465 // it should be a vocabulary
2466 const uint32_t nfa
= UFO_CFA_TO_NFA(res
);
2467 if ((ufoImgGetU32(nfa
) & UFW_FLAG_VOCAB
) != 0) {
2468 vocid
= ufoImgGetU32(UFO_CFA_TO_PFA(res
)); // pfa points to vocabulary
2484 //==========================================================================
2488 // doesn't look in CURRENT, does name resolution ("a:b" is word "b" in "a")
2492 //==========================================================================
2493 static uint32_t ufoFindWord (const char *wname
) {
2495 if (wname
&& wname
[0] != 0) {
2496 const size_t wnlen
= strlen(wname
);
2497 ufo_assert(wnlen
< 8192);
2498 uint32_t ctx
= ufoImgGetU32(ufoAddrContext
);
2499 const uint32_t hash
= joaatHashBufCI(wname
, (uint32_t)wnlen
);
2501 //fprintf(stderr, "FIND-WORD: whash: 0x%08x; name:{%s}\n", hash, wname);
2503 // first search in context
2504 res
= ufoFindWordInVocAndParents(wname
, (uint32_t)wnlen
, hash
, ctx
, (ctx
== ufoImgGetU32(ufoAddrCurrent
)));
2506 // now try vocabulary stack
2507 uint32_t vstp
= ufoVSP
;
2508 while (res
== 0 && vstp
!= 0) {
2510 ctx
= ufoVocStack
[vstp
];
2511 res
= ufoFindWordInVocAndParents(wname
, (uint32_t)wnlen
, hash
, ctx
, (ctx
== ufoImgGetU32(ufoAddrCurrent
)));
2514 // if not found, try name resolution
2515 if (res
== 0) res
= ufoFindWordNameRes(wname
, (uint32_t)wnlen
);
2522 //==========================================================================
2524 // ufoCreateWordHeader
2526 // create word header up to CFA, link to the current dictionary
2528 //==========================================================================
2529 static void ufoCreateWordHeader (const char *wname
, uint32_t flags
) {
2530 if (wname
== NULL
) wname
= "";
2531 const size_t wnlen
= strlen(wname
);
2532 ufo_assert(wnlen
< UFO_MAX_WORD_LENGTH
);
2533 const uint32_t hash
= joaatHashBufCI(wname
, (uint32_t)wnlen
);
2534 const uint32_t curr
= ufoImgGetU32(ufoAddrCurrent
);
2535 ufo_assert(curr
!= 0);
2537 const uint32_t warn
= ufoImgGetU32(ufoAddrRedefineWarning
);
2538 if (wnlen
!= 0 && warn
!= UFO_REDEF_WARN_DONT_CARE
) {
2540 if (warn
!= UFO_REDEF_WARN_PARENTS
) {
2541 cfa
= ufoFindWordInVoc(wname
, wnlen
, hash
, curr
, 1);
2543 cfa
= ufoFindWordInVocAndParents(wname
, wnlen
, hash
, curr
, 1);
2546 const uint32_t nfa
= UFO_CFA_TO_NFA(cfa
);
2547 const uint32_t flags
= ufoImgGetU32(nfa
);
2548 if ((flags
& UFW_FLAG_PROTECTED
) != 0) {
2549 ufoFatal("trying to redefine protected word '%s'", wname
);
2550 } else if (warn
!= UFO_REDEF_WARN_NONE
) {
2551 ufoWarning("redefining word '%s'", wname
);
2555 //fprintf(stderr, "000: HERE: 0x%08x\n", UFO_GET_DP());
2556 const uint32_t bkt
= (hash
% (uint32_t)UFO_HASHTABLE_SIZE
) * 4u;
2557 const uint32_t htbl
= curr
+ UFW_VOCAB_OFS_HTABLE
;
2559 const uint32_t xfaAddr
= UFO_GET_DP();
2560 if ((xfaAddr
& UFO_ADDR_TEMP_BIT
) == 0) {
2561 // link previous yfa here
2562 const uint32_t lastxfa
= ufoImgGetU32(ufoAddrLastXFA
);
2563 // fix YFA of the previous word
2565 ufoImgPutU32(UFO_XFA_TO_YFA(lastxfa
), UFO_XFA_TO_YFA(xfaAddr
));
2567 // our XFA points to the previous XFA
2568 ufoImgEmitU32(lastxfa
); // xfa
2570 ufoImgPutU32(ufoAddrLastXFA
, xfaAddr
);
2572 ufoImgEmitU32(0); // xfa
2574 ufoImgEmitU32(0); // yfa
2575 // bucket link (bfa)
2576 if (wnlen
== 0 || ufoImgGetU32(htbl
) == UFO_NO_HTABLE_FLAG
) {
2579 #ifdef UFO_DEBUG_DUMP_NEW_HEADERS
2580 fprintf(stderr
, "NEW HEADER: %s; curr: 0x%08x; htbl: 0x%08x; bkt: 0x%08x\n",
2581 wname
, curr
, htbl
, bkt
);
2582 fprintf(stderr
, " [bkt]: 0x%08x; nbk: 0x%08x\n", ufoImgGetU32(htbl
+ bkt
), UFO_GET_DP());
2584 // bfa points to bfa
2585 const uint32_t bfa
= UFO_GET_DP();
2586 ufoImgEmitU32(ufoImgGetU32(htbl
+ bkt
));
2587 ufoImgPutU32(htbl
+ bkt
, bfa
);
2590 const uint32_t lfa
= UFO_GET_DP();
2591 ufoImgEmitU32(ufoImgGetU32(curr
+ UFW_VOCAB_OFS_LATEST
));
2593 ufoImgPutU32(curr
+ UFW_VOCAB_OFS_LATEST
, lfa
);
2595 ufoImgEmitU32(hash
);
2597 const uint32_t nfa
= UFO_GET_DP();
2598 ufoImgEmitU32(((uint32_t)wnlen
&0xffU
) | (flags
& 0xffffff00U
));
2599 const uint32_t nstart
= UFO_GET_DP();
2601 for (size_t f
= 0; f
< wnlen
; f
+= 1) {
2602 ufoImgEmitU8(((const unsigned char *)wname
)[f
]);
2604 while ((UFO_GET_DP() & 3) != 3) ufoImgEmitU8(0);
2605 const uint32_t nend
= UFO_GET_DP(); // length byte itself is not included
2606 // name length, again
2607 ufo_assert(nend
- nstart
<= 255);
2608 ufoImgEmitU8((uint8_t)(nend
- nstart
));
2609 ufo_assert((UFO_GET_DP() & 3) == 0);
2610 ufo_assert(UFO_CFA_TO_NFA(UFO_GET_DP()) == nfa
);
2611 if ((nend
& UFO_ADDR_SPECIAL_BITS_MASK
) == 0) ufoRecordDebug(nend
);
2612 #ifdef UFO_DEBUG_DUMP_NEW_HEADERS
2613 fprintf(stderr
, "*** NEW HEADER ***\n");
2614 fprintf(stderr
, "CFA: 0x%08x\n", UFO_GET_DP());
2615 fprintf(stderr
, "NSTART: 0x%08x\n", nstart
);
2616 fprintf(stderr
, "NEND: 0x%08x\n", nend
);
2617 fprintf(stderr
, "NLEN: %u (%u)\n", nend
- nstart
, ufoImgGetU8(UFO_GET_DP() - 1u));
2618 ufoDumpWordHeader(lfa
);
2621 fprintf(stderr
, "NEW WORD CFA 0x%08x: %s\n", UFO_GET_DP(), wname
);
2626 //==========================================================================
2630 //==========================================================================
2631 static void ufoDecompilePart (uint32_t addr
, uint32_t eaddr
, int indent
) {
2634 while (addr
< eaddr
) {
2635 uint32_t cfa
= ufoImgGetU32(addr
);
2636 for (int n
= 0; n
< indent
; n
+= 1) fputc(' ', fo
);
2637 fprintf(fo
, "%6u: 0x%08x: ", addr
, cfa
);
2638 uint32_t nfa
= UFO_CFA_TO_NFA(cfa
);
2639 uint32_t flags
= ufoImgGetU32(nfa
);
2640 //fprintf(fo, "[0x%08x] ", flags & UFW_WARG_MASK);
2641 uint32_t nlen
= flags
& 0xffU
;
2642 for (uint32_t f
= 0; f
< nlen
; f
+= 1) {
2643 const uint8_t ch
= ufoImgGetU8(nfa
+ 4u + f
);
2644 if (ch
<= 32 || ch
>= 127) {
2645 fprintf(fo
, "\\x%02x", ch
);
2647 fprintf(fo
, "%c", (char)ch
);
2651 switch (flags
& UFW_WARG_MASK
) {
2654 case UFW_WARG_BRANCH
:
2655 fprintf(fo
, " @%u", ufoImgGetU32(addr
)); addr
+= 4u;
2658 fprintf(fo
, " %u : %d : 0x%08x", ufoImgGetU32(addr
),
2659 (int32_t)ufoImgGetU32(addr
), ufoImgGetU32(addr
)); addr
+= 4u;
2661 case UFW_WARG_C4STRZ
:
2662 count
= ufoImgGetU32(addr
); addr
+= 4;
2664 fprintf(fo
, " str:");
2665 for (int f
= 0; f
< count
; f
+= 1) {
2666 const uint8_t ch
= ufoImgGetU8(addr
); addr
+= 1u;
2667 if (ch
<= 32 || ch
>= 127) {
2668 fprintf(fo
, "\\x%02x", ch
);
2670 fprintf(fo
, "%c", (char)ch
);
2673 addr
+= 1u; // skip zero byte
2674 addr
= UFO_ALIGN4(addr
);
2677 cfa
= ufoImgGetU32(addr
); addr
+= 4u;
2678 fprintf(fo
, " CFA:%u: ", cfa
);
2679 nfa
= UFO_CFA_TO_NFA(cfa
);
2680 nlen
= ufoImgGetU8(nfa
);
2681 for (uint32_t f
= 0; f
< nlen
; f
+= 1) {
2682 const uint8_t ch
= ufoImgGetU8(nfa
+ 4u + f
);
2683 if (ch
<= 32 || ch
>= 127) {
2684 fprintf(fo
, "\\x%02x", ch
);
2686 fprintf(fo
, "%c", (char)ch
);
2690 case UFW_WARG_CBLOCK
:
2691 fprintf(fo
, " CBLOCK:%u", ufoImgGetU32(addr
)); addr
+= 4u;
2693 case UFW_WARG_VOCID
:
2694 fprintf(fo
, " VOCID:%u", ufoImgGetU32(addr
)); addr
+= 4u;
2696 case UFW_WARG_C1STRZ
:
2697 count
= ufoImgGetU8(addr
); addr
+= 1;
2701 fprintf(fo, " ubyte:%u", ufoImgGetU8(addr)); addr += 1u;
2704 fprintf(fo, " sbyte:%u", ufoImgGetU8(addr)); addr += 1u;
2707 fprintf(fo, " uword:%u", ufoImgGetU16(addr)); addr += 2u;
2710 fprintf(fo, " sword:%u", ufoImgGetU16(addr)); addr += 2u;
2714 fprintf(fo
, " -- WTF?!\n");
2722 //==========================================================================
2726 //==========================================================================
2727 static void ufoDecompileWord (const uint32_t cfa
) {
2729 const uint32_t lfa
= UFO_CFA_TO_LFA(cfa
);
2730 fprintf(stdout
, "#### DECOMPILING CFA %u ###\n", cfa
);
2731 ufoDumpWordHeader(lfa
);
2732 const uint32_t yfa
= ufoGetWordEndAddr(cfa
);
2733 if (ufoImgGetU32(cfa
) == ufoDoForthCFA
) {
2734 fprintf(stdout
, "--- DECOMPILED CODE ---\n");
2735 ufoDecompilePart(UFO_CFA_TO_PFA(cfa
), yfa
, 0);
2736 fprintf(stdout
, "=======================\n");
2742 //==========================================================================
2744 // ufoBTShowWordName
2746 //==========================================================================
2747 static void ufoBTShowWordName (uint32_t nfa
) {
2749 uint32_t len
= ufoImgGetU8(nfa
); nfa
+= 4u;
2750 //fprintf(stderr, "(0x%08x)", ufoImgGetU32(nfa - 4u));
2752 uint8_t ch
= ufoImgGetU8(nfa
); nfa
+= 1u; len
-= 1u;
2753 if (ch
<= 32 || ch
>= 127) {
2754 fprintf(stderr
, "\\x%02x", ch
);
2756 fprintf(stderr
, "%c", (char)ch
);
2763 //==========================================================================
2767 //==========================================================================
2768 static void ufoBacktrace (uint32_t ip
, int showDataStack
) {
2769 // dump data stack (top 16)
2771 if (!ufoLastEmitWasCR
) { printf("\n"); ufoLastEmitWasCR
= 1; }
2773 if (showDataStack
) {
2774 fprintf(stderr
, "***UFO STACK DEPTH: %u\n", ufoSP
);
2775 uint32_t xsp
= ufoSP
;
2776 if (xsp
> 16) xsp
= 16;
2777 for (uint32_t sp
= 0; sp
< xsp
; ++sp
) {
2778 fprintf(stderr
, " %2u: 0x%08x %d%s\n",
2779 sp
, ufoDStack
[xsp
- sp
- 1], (int32_t)ufoDStack
[xsp
- sp
- 1],
2780 (sp
== 0 ? " -- TOS" : ""));
2782 if (ufoSP
> 16) fprintf(stderr
, " ...more...\n");
2785 // dump return stack (top 32)
2790 fprintf(stderr
, "***UFO RETURN STACK DEPTH: %u\n", ufoRP
);
2792 nfa
= ufoFindWordForIP(ip
);
2794 fprintf(stderr
, " **: %8u -- ", ip
);
2795 ufoBTShowWordName(nfa
);
2796 fname
= ufoFindFileForIP(ip
, &fline
, NULL
, NULL
);
2797 if (fname
!= NULL
) { fprintf(stderr
, " (at %s:%u)", fname
, fline
); }
2798 fputc('\n', stderr
);
2801 uint32_t rp
= ufoRP
;
2802 uint32_t rscount
= 0;
2803 if (rp
> UFO_RSTACK_SIZE
) rp
= UFO_RSTACK_SIZE
;
2804 while (rscount
!= 32 && rp
!= 0) {
2806 const uint32_t val
= ufoRStack
[rp
];
2807 nfa
= ufoFindWordForIP(val
);
2809 fprintf(stderr
, " %2u: %8u -- ", ufoRP
- rp
- 1u, val
);
2810 ufoBTShowWordName(nfa
);
2811 fname
= ufoFindFileForIP(val
- 4u, &fline
, NULL
, NULL
);
2812 if (fname
!= NULL
) { fprintf(stderr
, " (at %s:%u)", fname
, fline
); }
2813 fputc('\n', stderr
);
2815 fprintf(stderr
, " %2u: 0x%08x %d\n", ufoRP
- rp
- 1u, val
, (int32_t)val
);
2819 if (ufoRP
> 32) fprintf(stderr
, " ...more...\n");
2825 //==========================================================================
2829 //==========================================================================
2831 static void ufoDumpVocab (uint32_t vocid) {
2833 fprintf(stderr, "*** VOCID: 0x%08x ***\n", vocid);
2834 uint32_t vochdr = vocid + UFW_VOCAB_OFS_HEADER;
2835 vochdr = ufoImgGetU32(vochdr);
2837 fprintf(stderr, "--- HEADER ---\n");
2838 ufoDumpWordHeader(UFO_NFA_TO_LFA(vochdr));
2839 fprintf(stderr, "========\n");
2840 uint32_t htbl = vocid + UFW_VOCAB_OFS_HTABLE;
2841 if (ufoImgGetU32(htbl) != UFO_NO_HTABLE_FLAG) {
2842 fprintf(stderr, "--- HASH TABLE ---\n");
2843 for (int f = 0; f < UFO_HASHTABLE_SIZE; f += 1) {
2844 uint32_t bfa = ufoImgGetU32(htbl);
2846 fprintf(stderr, "**** %2d: 0x%08x\n", f, bfa);
2848 ufoDumpWordHeader(UFO_BFA_TO_LFA(bfa));
2849 bfa = ufoImgGetU32(bfa);
2861 // if set, this will be used when we are out of include files. intended for UrAsm.
2862 // return 0 if there is no more lines, otherwise the string should be copied
2863 // to buffer, `*fname` and `*fline` should be properly set.
2864 int (*ufoFileReadLine
) (void *buf
, size_t bufsize
, const char **fname
, int *fline
) = NULL
;
2867 //==========================================================================
2869 // ufoLoadNextUserLine
2871 //==========================================================================
2872 static int ufoLoadNextUserLine (void) {
2873 uint32_t tibPos
= 0;
2874 const char *fname
= NULL
;
2877 if (ufoFileReadLine
!= NULL
&& ufoFileReadLine(ufoCurrFileLine
, 510, &fname
, &fline
) != 0) {
2878 ufoCurrFileLine
[510] = 0;
2879 uint32_t slen
= (uint32_t)strlen(ufoCurrFileLine
);
2880 while (slen
!= 0 && (ufoCurrFileLine
[slen
- 1u] == 10 || ufoCurrFileLine
[slen
- 1u] == 13)) {
2883 if (tibPos
+ slen
+ 1u > UFO_ADDR_HANDLE_OFS_MASK
) {
2884 ufoFatal("input text line too long (at least %u bytes)", tibPos
+ slen
);
2886 ufoTibEnsureSize(tibPos
+ slen
+ 1u);
2887 for (uint32_t f
= 0; f
< slen
; f
+= 1) {
2888 ufoTibPokeChOfs(((const unsigned char *)ufoCurrFileLine
)[f
], tibPos
+ f
);
2890 ufoTibPokeChOfs(0, tibPos
+ slen
);
2892 if (fname
== NULL
) fname
= "<user>";
2893 ufoSetInFileName(fname
);
2894 ufoInFileLine
= fline
;
2902 //==========================================================================
2904 // ufoLoadNextLine_NativeMode
2906 // load next file line into TIB
2907 // always strips final '\n'
2909 // return 0 on EOF, 1 on success
2911 //==========================================================================
2912 static int ufoLoadNextLine (int crossInclude
) {
2914 uint32_t tibPos
= 0;
2917 if (ufoMode
== UFO_MODE_MACRO
) {
2918 //fprintf(stderr, "***MAC!\n");
2922 while (ufoInFile
!= NULL
&& !done
) {
2923 if (fgets(ufoCurrFileLine
, 510, ufoInFile
) != NULL
) {
2924 // check for a newline
2925 // if there is no newline char at the end, the string was truncated
2926 ufoCurrFileLine
[510] = 0;
2927 const uint32_t slen
= (uint32_t)strlen(ufoCurrFileLine
);
2928 if (tibPos
+ slen
+ 1u > UFO_ADDR_HANDLE_OFS_MASK
) {
2929 ufoFatal("input text line too long (at least %u bytes)", tibPos
+ slen
);
2931 ufoTibEnsureSize(tibPos
+ slen
+ 1u);
2932 for (uint32_t f
= 0; f
< slen
; f
+= 1) {
2933 ufoTibPokeChOfs(((const unsigned char *)ufoCurrFileLine
)[f
], tibPos
+ f
);
2935 ufoTibPokeChOfs(0, tibPos
+ slen
);
2937 if (slen
!= 0 && (ufoCurrFileLine
[slen
- 1u] == 13 || ufoCurrFileLine
[slen
- 1u] == 10)) {
2941 // continuation, nothing to do
2944 // if we read nothing, this is EOF
2945 if (tibPos
== 0 && crossInclude
) {
2946 // we read nothing, and allowed to cross include boundaries
2955 // eof, try user-supplied input
2956 if (ufoFileStackPos
== 0) {
2957 return ufoLoadNextUserLine();
2962 // if we read at least something, this is not EOF
2968 // ////////////////////////////////////////////////////////////////////////// //
2973 UFWORD(DUMP_STACK
) {
2974 if (!ufoLastEmitWasCR
) { printf("\n"); ufoLastEmitWasCR
= 1; }
2975 printf("***UFO STACK DEPTH: %u\n", ufoSP
);
2976 uint32_t xsp
= ufoSP
;
2977 if (xsp
> 16) xsp
= 16;
2978 for (uint32_t sp
= 0; sp
< xsp
; ++sp
) {
2979 printf(" %2u: 0x%08x %d%s\n",
2980 sp
, ufoDStack
[xsp
- sp
- 1], (int32_t)ufoDStack
[xsp
- sp
- 1],
2981 (sp
== 0 ? " -- TOS" : ""));
2983 if (ufoSP
> 16) printf(" ...more...\n");
2984 ufoLastEmitWasCR
= 1;
2989 UFWORD(UFO_BACKTRACE
) {
2991 if (!ufoLastEmitWasCR
) { printf("\n"); ufoLastEmitWasCR
= 1; }
2992 if (ufoInFile
!= NULL
) {
2993 fprintf(stderr
, "*** at file %s, line %d ***\n", ufoInFileName
, ufoInFileLine
);
2995 fprintf(stderr
, "*** somewhere in time ***\n");
2997 ufoBacktrace(ufoIP
, 1);
3002 UFWORD(DUMP_STACK_TASK
) {
3003 UfoState
*st
= ufoFindState(ufoPop());
3004 if (st
== NULL
) ufoFatal("invalid state id");
3005 // temporarily switch the task
3006 UfoState
*oldst
= ufoCurrState
; ufoCurrState
= st
;
3008 if (!ufoLastEmitWasCR
) { printf("\n"); ufoLastEmitWasCR
= 1; }
3009 printf("***UFO STACK DEPTH: %u\n", ufoSP
);
3010 uint32_t xsp
= ufoSP
;
3011 if (xsp
> 16) xsp
= 16;
3012 for (uint32_t sp
= 0; sp
< xsp
; ++sp
) {
3013 printf(" %2u: 0x%08x %d%s\n",
3014 sp
, ufoDStack
[xsp
- sp
- 1], (int32_t)ufoDStack
[xsp
- sp
- 1],
3015 (sp
== 0 ? " -- TOS" : ""));
3017 if (ufoSP
> 16) printf(" ...more...\n");
3018 ufoLastEmitWasCR
= 1;
3020 ufoCurrState
= oldst
;
3025 UFWORD(DUMP_RSTACK_TASK
) {
3026 UfoState
*st
= ufoFindState(ufoPop());
3027 if (st
== NULL
) ufoFatal("invalid state id");
3028 // temporarily switch the task
3029 UfoState
*oldst
= ufoCurrState
; ufoCurrState
= st
;
3032 if (!ufoLastEmitWasCR
) { printf("\n"); ufoLastEmitWasCR
= 1; }
3033 if (ufoInFile
!= NULL
) {
3034 fprintf(stderr
, "*** at file %s, line %d ***\n", ufoInFileName
, ufoInFileLine
);
3036 fprintf(stderr
, "*** somewhere in time ***\n");
3038 ufoBacktrace(ufoIP
, 0);
3040 ufoCurrState
= oldst
;
3045 UFWORD(UFO_BACKTRACE_TASK
) {
3046 UfoState
*st
= ufoFindState(ufoPop());
3047 if (st
== NULL
) ufoFatal("invalid state id");
3048 // temporarily switch the task
3049 UfoState
*oldst
= ufoCurrState
; ufoCurrState
= st
;
3052 if (!ufoLastEmitWasCR
) { printf("\n"); ufoLastEmitWasCR
= 1; }
3053 if (ufoInFile
!= NULL
) {
3054 fprintf(stderr
, "*** at file %s, line %d ***\n", ufoInFileName
, ufoInFileLine
);
3056 fprintf(stderr
, "*** somewhere in time ***\n");
3058 ufoBacktrace(ufoIP
, 1);
3060 ufoCurrState
= oldst
;
3064 // ////////////////////////////////////////////////////////////////////////// //
3065 // some init words, and PAD
3070 UFWORD(SP0_STORE
) { ufoSP
= 0; }
3075 if (ufoRP
!= ufoRPTop
) {
3077 // we need to push a dummy value
3078 ufoRPush(0xdeadf00d);
3084 // PAD is at the beginning of temp area
3086 ufoPush(UFO_PAD_ADDR
);
3090 // ////////////////////////////////////////////////////////////////////////// //
3091 // peeks and pokes with address register
3102 UFWORD(REGA_STORE
) {
3110 const uint32_t newa
= ufoPop();
3123 UFWORD(REGA_INC_CELL
) {
3136 ufoRegA
= ufoRPop();
3140 // ////////////////////////////////////////////////////////////////////////// //
3141 // useful to work with handles and normal addreses uniformly
3146 UFWORD(CPEEK_REGA_IDX
) {
3147 if ((ufoRegA
& UFO_ADDR_HANDLE_BIT
) == 0) {
3148 const uint32_t idx
= ufoPop();
3149 const uint32_t newaddr
= ufoRegA
+ idx
;
3150 if ((ufoRegA
& UFO_ADDR_SPECIAL_BITS_MASK
) == (newaddr
& UFO_ADDR_SPECIAL_BITS_MASK
)) {
3151 ufoPush(ufoImgGetU8Ext(newaddr
));
3153 ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
3154 ufoRegA
, idx
, newaddr
);
3158 UFCALL(PAR_HANDLE_LOAD_BYTE
);
3164 UFWORD(WPEEK_REGA_IDX
) {
3165 if ((ufoRegA
& UFO_ADDR_HANDLE_BIT
) == 0) {
3166 const uint32_t idx
= ufoPop();
3167 const uint32_t newaddr
= ufoRegA
+ idx
;
3168 if ((ufoRegA
& UFO_ADDR_SPECIAL_BITS_MASK
) == (newaddr
& UFO_ADDR_SPECIAL_BITS_MASK
) &&
3169 (ufoRegA
& UFO_ADDR_SPECIAL_BITS_MASK
) == ((newaddr
+ 1u) & UFO_ADDR_SPECIAL_BITS_MASK
))
3171 ufoPush(ufoImgGetU16(newaddr
));
3173 ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
3174 ufoRegA
, idx
, newaddr
);
3178 UFCALL(PAR_HANDLE_LOAD_WORD
);
3184 UFWORD(PEEK_REGA_IDX
) {
3185 if ((ufoRegA
& UFO_ADDR_HANDLE_BIT
) == 0) {
3186 const uint32_t idx
= ufoPop();
3187 const uint32_t newaddr
= ufoRegA
+ idx
;
3188 if ((ufoRegA
& UFO_ADDR_SPECIAL_BITS_MASK
) == (newaddr
& UFO_ADDR_SPECIAL_BITS_MASK
) &&
3189 (ufoRegA
& UFO_ADDR_SPECIAL_BITS_MASK
) == ((newaddr
+ 3u) & UFO_ADDR_SPECIAL_BITS_MASK
))
3191 ufoPush(ufoImgGetU32(newaddr
));
3193 ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
3194 ufoRegA
, idx
, newaddr
);
3198 UFCALL(PAR_HANDLE_LOAD_CELL
);
3204 UFWORD(CPOKE_REGA_IDX
) {
3205 if ((ufoRegA
& UFO_ADDR_HANDLE_BIT
) == 0) {
3206 const uint32_t idx
= ufoPop();
3207 const uint32_t newaddr
= ufoRegA
+ idx
;
3208 if ((ufoRegA
& UFO_ADDR_SPECIAL_BITS_MASK
) == (newaddr
& UFO_ADDR_SPECIAL_BITS_MASK
)) {
3209 const uint32_t value
= ufoPop();
3210 ufoImgPutU8(newaddr
, value
);
3212 ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
3213 ufoRegA
, idx
, newaddr
);
3217 UFCALL(PAR_HANDLE_STORE_BYTE
);
3223 UFWORD(WPOKE_REGA_IDX
) {
3224 if ((ufoRegA
& UFO_ADDR_HANDLE_BIT
) == 0) {
3225 const uint32_t idx
= ufoPop();
3226 const uint32_t newaddr
= ufoRegA
+ idx
;
3227 if ((ufoRegA
& UFO_ADDR_SPECIAL_BITS_MASK
) == (newaddr
& UFO_ADDR_SPECIAL_BITS_MASK
) &&
3228 (ufoRegA
& UFO_ADDR_SPECIAL_BITS_MASK
) == ((newaddr
+ 1u) & UFO_ADDR_SPECIAL_BITS_MASK
))
3230 const uint32_t value
= ufoPop();
3231 ufoImgPutU16(newaddr
, value
);
3233 ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
3234 ufoRegA
, idx
, newaddr
);
3238 UFCALL(PAR_HANDLE_STORE_WORD
);
3244 UFWORD(POKE_REGA_IDX
) {
3245 if ((ufoRegA
& UFO_ADDR_HANDLE_BIT
) == 0) {
3246 const uint32_t idx
= ufoPop();
3247 const uint32_t newaddr
= ufoRegA
+ idx
;
3248 if ((ufoRegA
& UFO_ADDR_SPECIAL_BITS_MASK
) == (newaddr
& UFO_ADDR_SPECIAL_BITS_MASK
) &&
3249 (ufoRegA
& UFO_ADDR_SPECIAL_BITS_MASK
) == ((newaddr
+ 3u) & UFO_ADDR_SPECIAL_BITS_MASK
))
3251 const uint32_t value
= ufoPop();
3252 ufoImgPutU32(newaddr
, value
);
3254 ufoFatal("address offset out of range; addr=0x%08x; offset=%u; res=0x%08x",
3255 ufoRegA
, idx
, newaddr
);
3259 UFCALL(PAR_HANDLE_STORE_CELL
);
3264 // ////////////////////////////////////////////////////////////////////////// //
3269 // ( addr -- value8 )
3271 ufoPush(ufoImgGetU8Ext(ufoPop()));
3275 // ( addr -- value16 )
3277 const uint32_t addr
= ufoPop();
3278 if ((addr
& UFO_ADDR_HANDLE_BIT
) == 0) {
3279 ufoPush(ufoImgGetU16(addr
));
3283 UFCALL(PAR_HANDLE_LOAD_WORD
);
3288 // ( addr -- value32 )
3290 const uint32_t addr
= ufoPop();
3291 if ((addr
& UFO_ADDR_HANDLE_BIT
) == 0) {
3292 ufoPush(ufoImgGetU32(addr
));
3296 UFCALL(PAR_HANDLE_LOAD_CELL
);
3303 const uint32_t addr
= ufoPop();
3304 const uint32_t val
= ufoPop();
3305 ufoImgPutU8Ext(addr
, val
);
3309 // ( val16 addr -- )
3311 const uint32_t addr
= ufoPop();
3312 const uint32_t val
= ufoPop();
3313 if ((addr
& UFO_ADDR_HANDLE_BIT
) == 0) {
3314 ufoImgPutU16(addr
, val
);
3319 UFCALL(PAR_HANDLE_STORE_WORD
);
3324 // ( val32 addr -- )
3326 const uint32_t addr
= ufoPop();
3327 const uint32_t val
= ufoPop();
3328 if ((addr
& UFO_ADDR_HANDLE_BIT
) == 0) {
3329 ufoImgPutU32(addr
, val
);
3334 UFCALL(PAR_HANDLE_STORE_CELL
);
3339 // ////////////////////////////////////////////////////////////////////////// //
3340 // dictionary emitters
3345 UFWORD(CCOMMA
) { const uint32_t val
= ufoPop(); ufoImgEmitU8(val
); }
3349 UFWORD(WCOMMA
) { const uint32_t val
= ufoPop(); ufoImgEmitU8(val
&0xffU
); ufoImgEmitU8((val
>> 8)&0xffU
); }
3353 UFWORD(COMMA
) { const uint32_t val
= ufoPop(); ufoImgEmitU32(val
); }
3356 // ////////////////////////////////////////////////////////////////////////// //
3362 const uint32_t v
= ufoImgGetU32(ufoIP
); ufoIP
+= 4;
3366 // (LITCFA) ( -- n )
3367 UFWORD(PAR_LITCFA
) {
3368 const uint32_t v
= ufoImgGetU32(ufoIP
); ufoIP
+= 4;
3372 // (LITVOCID) ( -- n )
3373 UFWORD(PAR_LITVOCID
) {
3374 const uint32_t v
= ufoImgGetU32(ufoIP
); ufoIP
+= 4;
3379 UFWORD(PAR_LITSTR8
) {
3380 const uint32_t count
= ufoImgGetU8(ufoIP
); ufoIP
+= 1;
3383 ufoIP
+= count
+ 1; // 1 for terminating 0
3385 ufoIP
= UFO_ALIGN4(ufoIP
);
3389 // ////////////////////////////////////////////////////////////////////////// //
3394 UFWORD(PAR_BRANCH
) {
3395 ufoIP
= ufoImgGetU32(ufoIP
);
3398 // (TBRANCH) ( flag )
3399 UFWORD(PAR_TBRANCH
) {
3401 ufoIP
= ufoImgGetU32(ufoIP
);
3407 // (0BRANCH) ( flag )
3408 UFWORD(PAR_0BRANCH
) {
3410 ufoIP
= ufoImgGetU32(ufoIP
);
3416 // (+0BRANCH) ( flag )
3417 UFWORD(PAR_P0BRANCH
) {
3418 if ((ufoPop() & 0x80000000u
) == 0) {
3419 ufoIP
= ufoImgGetU32(ufoIP
);
3425 // (+BRANCH) ( flag )
3426 UFWORD(PAR_PBRANCH
) {
3427 const uint32_t v
= ufoPop();
3428 if (v
> 0 && v
< 0x80000000u
) {
3429 ufoIP
= ufoImgGetU32(ufoIP
);
3435 // (-0BRANCH) ( flag )
3436 UFWORD(PAR_M0BRANCH
) {
3437 const uint32_t v
= ufoPop();
3438 if (v
== 0 || v
>= 0x80000000u
) {
3439 ufoIP
= ufoImgGetU32(ufoIP
);
3445 // (-BRANCH) ( flag )
3446 UFWORD(PAR_MBRANCH
) {
3447 if ((ufoPop() & 0x80000000u
) != 0) {
3448 ufoIP
= ufoImgGetU32(ufoIP
);
3455 // ////////////////////////////////////////////////////////////////////////// //
3456 // execute words by CFA
3465 // EXECUTE-TAIL ( cfa )
3466 UFWORD(EXECUTE_TAIL
) {
3473 // ////////////////////////////////////////////////////////////////////////// //
3474 // word termination, locals support
3484 UFWORD(PAR_LENTER
) {
3485 // low byte of loccount is total number of locals
3486 // high byte is the number of args
3487 uint32_t lcount
= ufoImgGetU32(ufoIP
); ufoIP
+= 4u;
3488 uint32_t acount
= (lcount
>> 8) & 0xff;
3490 if (lcount
== 0 || lcount
< acount
) ufoFatal("invalid call to (L-ENTER)");
3491 if ((ufoLBP
!= 0 && ufoLBP
>= ufoLP
) || UFO_LSTACK_SIZE
- ufoLP
<= lcount
+ 2) {
3492 ufoFatal("out of locals stack");
3495 if (ufoLP
== 0) { ufoLP
= 1; newbp
= 1; } else newbp
= ufoLP
;
3496 //fprintf(stderr, "LP: %u; LBP: %u; locs: %u; word: %s\n", ufoLP, ufoLBP, fw->locs, fw->name);
3497 ufoLStack
[ufoLP
] = ufoLBP
; ufoLP
+= 1;
3498 ufoLBP
= newbp
; ufoLP
+= lcount
;
3501 while (newbp
!= ufoLBP
) {
3502 ufoLStack
[newbp
] = ufoPop();
3508 UFWORD(PAR_LLEAVE
) {
3509 if (ufoLBP
== 0) ufoFatal("(L-LEAVE) with empty locals stack");
3510 if (ufoLBP
>= ufoLP
) ufoFatal("(L-LEAVE) broken locals stack");
3512 ufoLBP
= ufoLStack
[ufoLBP
];
3515 //==========================================================================
3519 //==========================================================================
3520 UFO_FORCE_INLINE
void ufoLoadLocal (const uint32_t lidx
) {
3521 if (lidx
== 0 || lidx
>= UFO_LSTACK_SIZE
) ufoFatal("invalid local index");
3522 if (ufoLBP
== 0 || ufoLBP
>= ufoLP
|| ufoLP
- ufoLBP
<= lidx
) ufoFatal("invalid local index");
3523 ufoPush(ufoLStack
[ufoLBP
+ lidx
]);
3526 //==========================================================================
3530 //==========================================================================
3531 UFO_FORCE_INLINE
void ufoStoreLocal (const uint32_t lidx
) {
3532 const uint32_t value
= ufoPop();
3533 if (lidx
== 0 || lidx
>= UFO_LSTACK_SIZE
) ufoFatal("invalid local index");
3534 if (ufoLBP
== 0 || ufoLBP
>= ufoLP
|| ufoLP
- ufoLBP
<= lidx
) ufoFatal("invalid local index");
3535 ufoLStack
[ufoLBP
+ lidx
] = value
;
3540 UFWORD(PAR_LOCAL_LOAD
) { ufoLoadLocal(ufoPop()); }
3544 UFWORD(PAR_LOCAL_STORE
) { ufoStoreLocal(ufoPop()); }
3547 // ////////////////////////////////////////////////////////////////////////// //
3548 // stack manipulation
3553 UFWORD(DUP
) { ufoDup(); }
3555 // ( n -- n n ) | ( 0 -- 0 )
3556 UFWORD(QDUP
) { if (ufoPeek()) ufoDup(); }
3558 // ( n0 n1 -- n0 n1 n0 n1 )
3559 UFWORD(DDUP
) { ufo2Dup(); }
3562 UFWORD(DROP
) { ufoDrop(); }
3565 UFWORD(DDROP
) { ufo2Drop(); }
3567 // ( n0 n1 -- n1 n0 )
3568 UFWORD(SWAP
) { ufoSwap(); }
3570 // ( n0 n1 -- n1 n0 )
3571 UFWORD(DSWAP
) { ufo2Swap(); }
3573 // ( n0 n1 -- n0 n1 n0 )
3574 UFWORD(OVER
) { ufoOver(); }
3576 // ( n0 n1 -- n0 n1 n0 )
3577 UFWORD(DOVER
) { ufo2Over(); }
3579 // ( n0 n1 n2 -- n1 n2 n0 )
3580 UFWORD(ROT
) { ufoRot(); }
3582 // ( n0 n1 n2 -- n2 n0 n1 )
3583 UFWORD(NROT
) { ufoNRot(); }
3587 UFWORD(RDUP
) { ufoRDup(); }
3590 UFWORD(RDROP
) { ufoRDrop(); }
3594 UFWORD(DTOR
) { ufoRPush(ufoPop()); }
3597 UFWORD(RTOD
) { ufoPush(ufoRPop()); }
3600 UFWORD(RPEEK
) { ufoPush(ufoRPeek()); }
3605 const uint32_t n
= ufoPop();
3606 if (n
>= ufoSP
) ufoFatal("invalid PICK index %u", n
);
3607 ufoPush(ufoDStack
[ufoSP
- n
- 1u]);
3613 const uint32_t n
= ufoPop();
3614 if (n
>= ufoRP
- ufoRPTop
) ufoFatal("invalid RPICK index %u", n
);
3615 const uint32_t rp
= ufoRP
- n
- 1u;
3616 ufoPush(ufoRStack
[rp
]);
3622 const uint32_t n
= ufoPop();
3623 if (n
>= ufoSP
) ufoFatal("invalid ROLL index %u", n
);
3625 case 0: break; // do nothing
3626 case 1: ufoSwap(); break;
3627 case 2: ufoRot(); break;
3630 const uint32_t val
= ufoDStack
[ufoSP
- n
- 1u];
3631 for (uint32_t f
= ufoSP
- n
; f
< ufoSP
; f
+= 1) ufoDStack
[f
- 1] = ufoDStack
[f
];
3632 ufoDStack
[ufoSP
- 1u] = val
;
3641 const uint32_t n
= ufoPop();
3642 if (n
>= ufoRP
- ufoRPTop
) ufoFatal("invalid RROLL index %u", n
);
3644 const uint32_t rp
= ufoRP
- n
- 1u;
3645 const uint32_t val
= ufoRStack
[rp
];
3646 for (uint32_t f
= rp
+ 1u; f
< ufoRP
; f
+= 1u) ufoRStack
[f
- 1u] = ufoRStack
[f
];
3647 ufoRStack
[ufoRP
- 1u] = val
;
3652 // ( | a b -- | b a )
3654 const uint32_t b
= ufoRPop();
3655 const uint32_t a
= ufoRPop();
3656 ufoRPush(b
); ufoRPush(a
);
3660 // ( | a b -- | a b a )
3662 const uint32_t b
= ufoRPop();
3663 const uint32_t a
= ufoRPop();
3664 ufoRPush(a
); ufoRPush(b
); ufoRPush(a
);
3668 // ( | a b c -- | b c a )
3670 const uint32_t c
= ufoRPop();
3671 const uint32_t b
= ufoRPop();
3672 const uint32_t a
= ufoRPop();
3673 ufoRPush(b
); ufoRPush(c
); ufoRPush(a
);
3677 // ( | a b c -- | c a b )
3679 const uint32_t c
= ufoRPop();
3680 const uint32_t b
= ufoRPop();
3681 const uint32_t a
= ufoRPop();
3682 ufoRPush(c
); ufoRPush(a
); ufoRPush(b
);
3686 // ////////////////////////////////////////////////////////////////////////// //
3693 ufoPushBool(ufoLoadNextLine(1));
3698 UFWORD(REFILL_NOCROSS
) {
3699 ufoPushBool(ufoLoadNextLine(0));
3705 ufoPush(ufoImgGetU32(ufoAddrTIBx
) + ufoImgGetU32(ufoAddrINx
));
3710 UFWORD(TIB_PEEKCH
) {
3711 ufoPush(ufoTibPeekCh());
3716 UFWORD(TIB_PEEKCH_OFS
) {
3717 const uint32_t ofs
= ufoPop();
3718 ufoPush(ufoTibPeekChOfs(ofs
));
3724 ufoPush(ufoTibGetCh());
3729 UFWORD(TIB_SKIPCH
) {
3734 // ////////////////////////////////////////////////////////////////////////// //
3738 //==========================================================================
3742 //==========================================================================
3743 UFO_FORCE_INLINE
int ufoIsDelim (uint8_t ch
, uint8_t delim
) {
3744 return (delim
== 32 ? (ch
<= 32) : (ch
== delim
));
3748 // ( delim skip-leading-delim? -- addr count TRUE / FALSE )
3749 // does base TIB parsing; never copies anything.
3750 // as our reader is line-based, returns FALSE on EOL.
3751 // EOL is detected after skipping leading delimiters.
3752 // passing -1 as delimiter skips the whole line, and always returns FALSE.
3753 // trailing delimiter is always skipped.
3755 const uint32_t skipDelim
= ufoPop();
3756 const uint32_t delim
= ufoPop();
3759 if (delim
== 0 || delim
> 0xffU
) {
3761 while (ufoTibGetCh() != 0) {}
3764 ch
= ufoTibPeekCh();
3765 // skip initial delimiters
3767 while (ch
!= 0 && ufoIsDelim(ch
, delim
)) {
3769 ch
= ufoTibPeekCh();
3776 const uint32_t staddr
= ufoImgGetU32(ufoAddrTIBx
) + ufoImgGetU32(ufoAddrINx
);
3778 while (ch
!= 0 && !ufoIsDelim(ch
, delim
)) {
3781 ch
= ufoTibPeekCh();
3784 if (ch
!= 0) ufoTibSkipCh();
3792 // PARSE-SKIP-BLANKS
3794 UFWORD(PARSE_SKIP_BLANKS
) {
3795 uint8_t ch
= ufoTibPeekCh();
3796 while (ch
!= 0 && ch
<= 32) {
3798 ch
= ufoTibPeekCh();
3802 //==========================================================================
3804 // ufoParseMLComment
3806 // initial two chars are skipped
3808 //==========================================================================
3809 static void ufoParseMLComment (uint32_t allowMulti
, int nested
) {
3812 while (level
!= 0) {
3816 UFCALL(REFILL_NOCROSS
);
3817 if (ufoPop() == 0) ufoFatal("unexpected end of file in comment");
3819 ufoFatal("unexpected end of line in comment");
3822 ch1
= ufoTibPeekCh();
3823 if (nested
&& ch
== '(' && ch1
== '(') { ufoTibSkipCh(); level
+= 1; }
3824 else if (nested
&& ch
== ')' && ch1
== ')') { ufoTibSkipCh(); level
-= 1; }
3825 else if (!nested
&& ch
== '*' && ch1
== ')') { ufo_assert(level
== 1); ufoTibSkipCh(); level
= 0; }
3830 // (PARSE-SKIP-COMMENTS)
3831 // ( allow-multiline? -- )
3832 // skip all blanks and comments
3833 UFWORD(PAR_PARSE_SKIP_COMMENTS
) {
3834 const uint32_t allowMulti
= ufoPop();
3836 ch
= ufoTibPeekCh();
3838 fprintf(stderr
, "(PARSE-SKIP-COMMENTS): first-ch:'%c'\n", (char)ch
);
3843 ch
= ufoTibPeekCh();
3845 fprintf(stderr
, "(PARSE-SKIP-COMMENTS): blank-ch:'%c'\n", (char)ch
);
3847 } else if (ch
== '(') {
3849 fprintf(stderr
, "(PARSE-SKIP-COMMENTS): ch:'%c'; ch1:'%c' ('%c')\n", (char)ch
, (char)ch1
,
3850 ufoTibPeekChOfs(0));
3852 ch1
= ufoTibPeekChOfs(1);
3854 // single-line comment
3855 do { ch
= ufoTibGetCh(); } while (ch
!= 0 && ch
!= ')');
3856 ch
= ufoTibPeekCh();
3857 } else if ((ch1
== '*' || ch1
== '(') && ufoTibPeekChOfs(2) <= 32) {
3858 // possibly multiline
3859 ufoTibSkipCh(); ufoTibSkipCh(); // skip opening
3860 ufoParseMLComment(allowMulti
, (ch1
== '('));
3861 ch
= ufoTibPeekCh();
3865 } else if (ch
== '\\' && ufoTibPeekChOfs(1) <= 32) {
3866 // single-line comment
3867 while (ch
!= 0) ch
= ufoTibGetCh();
3868 } else if ((ch
== ';' || ch
== '-' || ch
== '/') && (ufoTibPeekChOfs(1) == ch
)) {
3870 while (ch
!= 0) ch
= ufoTibGetCh();
3876 fprintf(stderr
, "(PARSE-SKIP-COMMENTS): end-ch:'%c'\n", ufoTibPeekCh());
3882 UFWORD(PARSE_SKIP_LINE
) {
3883 ufoPush(0); ufoPushBool(0); UFCALL(PAR_PARSE
);
3884 if (ufoPop() != 0) {
3890 // ( -- addr count )
3891 // parse with leading blanks skipping. doesn't copy anything.
3892 // return empty string on EOL.
3893 UFWORD(PARSE_NAME
) {
3894 ufoPush(32); ufoPushBool(1); UFCALL(PAR_PARSE
);
3895 if (ufoPop() == 0) {
3902 // ( delim -- addr count TRUE / FALSE )
3903 // parse without skipping delimiters; never copies anything.
3904 // as our reader is line-based, returns FALSE on EOL.
3905 // passing 0 as delimiter skips the whole line, and always returns FALSE.
3906 // trailing delimiter is always skipped.
3908 ufoPushBool(0); UFCALL(PAR_PARSE
);
3912 // ////////////////////////////////////////////////////////////////////////// //
3918 UFWORD(PAR_NORM_EMIT_CHAR
) {
3919 uint32_t ch
= ufoPop()&0xffU
;
3920 if (ch
< 32 || ch
== 127) {
3921 if (ch
!= 9 && ch
!= 10 && ch
!= 13) ch
= '?';
3926 // (NORM-XEMIT-CHAR)
3928 UFWORD(PAR_NORM_XEMIT_CHAR
) {
3929 uint32_t ch
= ufoPop()&0xffU
;
3930 if (ch
< 32 || ch
== 127) ch
= '?';
3937 uint32_t ch
= ufoPop()&0xffU
;
3938 ufoLastEmitWasCR
= (ch
== 10);
3945 ufoPushBool(ufoLastEmitWasCR
);
3951 ufoLastEmitWasCR
= !!ufoPop();
3956 UFWORD(FLUSH_EMIT
) {
3961 // ////////////////////////////////////////////////////////////////////////// //
3965 #define UF_UMATH(name_,op_) \
3967 const uint32_t a = ufoPop(); \
3971 #define UF_BMATH(name_,op_) \
3973 const uint32_t b = ufoPop(); \
3974 const uint32_t a = ufoPop(); \
3978 #define UF_BDIV(name_,op_) \
3980 const uint32_t b = ufoPop(); \
3981 const uint32_t a = ufoPop(); \
3982 if (b == 0) ufoFatal("division by zero"); \
3986 #define UFO_POP_U64() ({ \
3987 const uint32_t hi_ = ufoPop(); \
3988 const uint32_t lo_ = ufoPop(); \
3989 (((uint64_t)hi_ << 32) | lo_); \
3992 // this is UB by the idiotic C standard. i don't care.
3993 #define UFO_POP_I64() ((int64_t)UFO_POP_U64())
3995 #define UFO_PUSH_U64(vn_) do { \
3996 ufoPush((uint32_t)(vn_)); \
3997 ufoPush((uint32_t)((vn_) >> 32)); \
4000 // this is UB by the idiotic C standard. i don't care.
4001 #define UFO_PUSH_I64(vn_) UFO_PUSH_U64((uint64_t)(vn_))
4005 UF_BMATH(PLUS
, a
+ b
);
4009 UF_BMATH(MINUS
, a
- b
);
4013 UF_BMATH(MUL
, (uint32_t)((int32_t)a
* (int32_t)b
));
4017 UF_BMATH(UMUL
, a
* b
);
4021 UF_BDIV(DIV
, (uint32_t)((int32_t)a
/ (int32_t)b
));
4025 UF_BDIV(UDIV
, a
/ b
);
4029 UF_BDIV(MOD
, (uint32_t)((int32_t)a
% (int32_t)b
));
4033 UF_BDIV(UMOD
, a
% b
);
4036 // ( a b -- a/b, a%b )
4038 const int32_t b
= (int32_t)ufoPop();
4039 const int32_t a
= (int32_t)ufoPop();
4040 if (b
== 0) ufoFatal("division by zero");
4041 ufoPush((uint32_t)(a
/b
));
4042 ufoPush((uint32_t)(a
%b
));
4046 // ( a b -- a/b, a%b )
4048 const uint32_t b
= ufoPop();
4049 const uint32_t a
= ufoPop();
4050 if (b
== 0) ufoFatal("division by zero");
4051 ufoPush((uint32_t)(a
/b
));
4052 ufoPush((uint32_t)(a
%b
));
4056 // ( a b c -- a*b/c )
4057 // this uses 64-bit intermediate value
4059 const int32_t c
= (int32_t)ufoPop();
4060 const int32_t b
= (int32_t)ufoPop();
4061 const int32_t a
= (int32_t)ufoPop();
4062 if (c
== 0) ufoFatal("division by zero");
4063 int64_t xval
= a
; xval
*= b
; xval
/= c
;
4064 ufoPush((uint32_t)(int32_t)xval
);
4068 // ( a b c -- a*b/c )
4069 // this uses 64-bit intermediate value
4071 const uint32_t c
= ufoPop();
4072 const uint32_t b
= ufoPop();
4073 const uint32_t a
= ufoPop();
4074 if (c
== 0) ufoFatal("division by zero");
4075 uint64_t xval
= a
; xval
*= b
; xval
/= c
;
4076 ufoPush((uint32_t)xval
);
4080 // ( a b c -- a*b/c a*b%c )
4081 // this uses 64-bit intermediate value
4083 const int32_t c
= (int32_t)ufoPop();
4084 const int32_t b
= (int32_t)ufoPop();
4085 const int32_t a
= (int32_t)ufoPop();
4086 if (c
== 0) ufoFatal("division by zero");
4087 int64_t xval
= a
; xval
*= b
;
4088 ufoPush((uint32_t)(int32_t)(xval
/ c
));
4089 ufoPush((uint32_t)(int32_t)(xval
% c
));
4093 // ( a b c -- a*b/c )
4094 // this uses 64-bit intermediate value
4095 UFWORD(UMULDIVMOD
) {
4096 const uint32_t c
= ufoPop();
4097 const uint32_t b
= ufoPop();
4098 const uint32_t a
= ufoPop();
4099 if (c
== 0) ufoFatal("division by zero");
4100 uint64_t xval
= a
; xval
*= b
;
4101 ufoPush((uint32_t)(xval
/ c
));
4102 ufoPush((uint32_t)(xval
% c
));
4106 // ( a b -- lo(a*b) hi(a*b) )
4107 // this leaves 64-bit result
4109 const int32_t b
= (int32_t)ufoPop();
4110 const int32_t a
= (int32_t)ufoPop();
4111 int64_t xval
= a
; xval
*= b
;
4116 // ( a b -- lo(a*b) hi(a*b) )
4117 // this leaves 64-bit result
4119 const uint32_t b
= ufoPop();
4120 const uint32_t a
= ufoPop();
4121 uint64_t xval
= a
; xval
*= b
;
4126 // ( alo ahi b -- a/b a%b )
4128 const int32_t b
= (int32_t)ufoPop();
4129 if (b
== 0) ufoFatal("division by zero");
4130 int64_t a
= UFO_POP_I64();
4131 int32_t adiv
= (int32_t)(a
/ b
);
4132 int32_t amod
= (int32_t)(a
% b
);
4133 ufoPush((uint32_t)adiv
);
4134 ufoPush((uint32_t)amod
);
4138 // ( alo ahi b -- a/b a%b )
4140 const uint32_t b
= ufoPop();
4141 if (b
== 0) ufoFatal("division by zero");
4142 uint64_t a
= UFO_POP_U64();
4143 uint32_t adiv
= (uint32_t)(a
/ b
);
4144 uint32_t amod
= (uint32_t)(a
% b
);
4150 // ( alo ahi u -- lo hi )
4152 const uint32_t b
= ufoPop();
4153 uint64_t a
= UFO_POP_U64();
4159 // ( lo0 hi0 lo1 hi1 -- lo hi )
4161 uint64_t n1
= UFO_POP_U64();
4162 uint64_t n0
= UFO_POP_U64();
4168 // ( lo0 hi0 lo1 hi1 -- lo hi )
4170 uint64_t n1
= UFO_POP_U64();
4171 uint64_t n0
= UFO_POP_U64();
4177 // ( lo0 hi0 lo1 hi1 -- bool )
4179 uint64_t n1
= UFO_POP_U64();
4180 uint64_t n0
= UFO_POP_U64();
4181 ufoPushBool(n0
== n1
);
4185 // ( lo0 hi0 lo1 hi1 -- bool )
4187 int64_t n1
= UFO_POP_I64();
4188 int64_t n0
= UFO_POP_I64();
4189 ufoPushBool(n0
< n1
);
4193 // ( lo0 hi0 lo1 hi1 -- bool )
4195 int64_t n1
= UFO_POP_I64();
4196 int64_t n0
= UFO_POP_I64();
4197 ufoPushBool(n0
<= n1
);
4201 // ( lo0 hi0 lo1 hi1 -- bool )
4203 uint64_t n1
= UFO_POP_U64();
4204 uint64_t n0
= UFO_POP_U64();
4205 ufoPushBool(n0
< n1
);
4209 // ( lo0 hi0 lo1 hi1 -- bool )
4211 uint64_t n1
= UFO_POP_U64();
4212 uint64_t n0
= UFO_POP_U64();
4213 ufoPushBool(n0
<= n1
);
4217 // ( dlo dhi n -- nmod ndiv )
4218 // rounds toward zero
4220 const int32_t n
= (int32_t)ufoPop();
4221 if (n
== 0) ufoFatal("division by zero");
4222 int64_t d
= UFO_POP_I64();
4223 int32_t ndiv
= (int32_t)(d
/ n
);
4224 int32_t nmod
= (int32_t)(d
% n
);
4230 // ( dlo dhi n -- nmod ndiv )
4231 // rounds toward negative infinity
4233 const int32_t n
= (int32_t)ufoPop();
4234 if (n
== 0) ufoFatal("division by zero");
4235 int64_t d
= UFO_POP_I64();
4236 int32_t ndiv
= (int32_t)(d
/ n
);
4237 int32_t nmod
= (int32_t)(d
% n
);
4238 if (nmod
!= 0 && ((uint32_t)n
^ (uint32_t)(d
>> 32)) >= 0x80000000u
) {
4247 // ////////////////////////////////////////////////////////////////////////// //
4248 // simple logic and bit manipulation
4251 #define UF_CMP(name_,op_) \
4253 const uint32_t b = ufoPop(); \
4254 const uint32_t a = ufoPop(); \
4260 UF_CMP(LESS
, (int32_t)a
< (int32_t)b
);
4264 UF_CMP(ULESS
, a
< b
);
4268 UF_CMP(GREAT
, (int32_t)a
> (int32_t)b
);
4272 UF_CMP(UGREAT
, a
> b
);
4276 UF_CMP(LESSEQU
, (int32_t)a
<= (int32_t)b
);
4280 UF_CMP(ULESSEQU
, a
<= b
);
4284 UF_CMP(GREATEQU
, (int32_t)a
>= (int32_t)b
);
4288 UF_CMP(UGREATEQU
, a
>= b
);
4292 UF_CMP(EQU
, a
== b
);
4296 UF_CMP(NOTEQU
, a
!= b
);
4301 const uint32_t a
= ufoPop();
4302 ufoPushBool(a
== 0);
4307 UFWORD(ZERO_NOTEQU
) {
4308 const uint32_t a
= ufoPop();
4309 ufoPushBool(a
!= 0);
4314 UF_CMP(LOGAND
, a
&& b
);
4318 UF_CMP(LOGOR
, a
|| b
);
4323 const uint32_t b
= ufoPop();
4324 const uint32_t a
= ufoPop();
4331 const uint32_t b
= ufoPop();
4332 const uint32_t a
= ufoPop();
4339 const uint32_t b
= ufoPop();
4340 const uint32_t a
= ufoPop();
4347 const uint32_t a
= ufoPop();
4353 // arithmetic shift; positive `n` shifts to the left
4355 int32_t c
= (int32_t)ufoPop();
4358 int32_t n
= (int32_t)ufoPop();
4360 if (n
< 0) n
= -1; else n
= 0;
4362 n
>>= (uint8_t)(-c
);
4364 ufoPush((uint32_t)n
);
4367 uint32_t u
= ufoPop();
4379 // logical shift; positive `n` shifts to the left
4381 int32_t c
= (int32_t) ufoPop();
4382 uint32_t u
= ufoPop();
4388 u
>>= (uint8_t)(-c
);
4402 // ////////////////////////////////////////////////////////////////////////// //
4403 // string unescaping
4407 // ( addr count -- addr count )
4408 UFWORD(PAR_UNESCAPE
) {
4409 const uint32_t count
= ufoPop();
4410 const uint32_t addr
= ufoPeek();
4411 if ((count
& ((uint32_t)1<<31)) == 0) {
4412 const uint32_t eaddr
= addr
+ count
;
4413 uint32_t caddr
= addr
;
4414 uint32_t daddr
= addr
;
4415 while (caddr
!= eaddr
) {
4416 uint8_t ch
= ufoImgGetU8Ext(caddr
); caddr
+= 1u;
4417 if (ch
== '\\' && caddr
!= eaddr
) {
4418 ch
= ufoImgGetU8Ext(caddr
); caddr
+= 1u;
4420 case 'r': ch
= '\r'; break;
4421 case 'n': ch
= '\n'; break;
4422 case 't': ch
= '\t'; break;
4423 case 'e': ch
= '\x1b'; break;
4424 case '`': ch
= '"'; break; // special escape to insert double-quote
4425 case '"': ch
= '"'; break;
4426 case '\\': ch
= '\\'; break;
4428 if (eaddr
- daddr
>= 1) {
4429 const int dg0
= digitInBase((char)(ufoImgGetU8Ext(caddr
)), 16);
4430 if (dg0
< 0) ufoFatal("invalid hex string escape");
4431 if (eaddr
- daddr
>= 2) {
4432 const int dg1
= digitInBase((char)(ufoImgGetU8Ext(caddr
+ 1u)), 16);
4433 if (dg1
< 0) ufoFatal("invalid hex string escape");
4434 ch
= (uint8_t)(dg0
* 16 + dg1
);
4441 ufoFatal("invalid hex string escape");
4444 default: ufoFatal("invalid string escape");
4447 ufoImgPutU8Ext(daddr
, ch
); daddr
+= 1u;
4449 ufoPush(daddr
- addr
);
4456 // ////////////////////////////////////////////////////////////////////////// //
4457 // numeric conversions
4460 // (BASED-NUMBER) ( addr count allowsign? base -- num TRUE / FALSE )
4461 UFWORD(PAR_BASED_NUMBER
) {
4462 const uint32_t xbase
= ufoPop();
4463 const uint32_t allowSign
= ufoPop();
4464 int32_t count
= (int32_t)ufoPop();
4465 uint32_t addr
= ufoPop();
4471 if (allowSign
&& count
> 1) {
4472 ch
= ufoImgGetU8Ext(addr
);
4473 if (ch
== '-') { neg
= 1; addr
+= 1u; count
-= 1; }
4474 else if (ch
== '+') { neg
= 0; addr
+= 1u; count
-= 1; }
4477 // special-based numbers
4478 if (count
>= 3 && ufoImgGetU8Ext(addr
) == '0') {
4479 switch (ufoImgGetU8Ext(addr
+ 1u)) {
4480 case 'x': case 'X': base
= 16; break;
4481 case 'o': case 'O': base
= 8; break;
4482 case 'b': case 'B': base
= 2; break;
4483 case 'd': case 'D': base
= 10; break;
4486 if (base
) { addr
+= 2; count
-= 2; }
4487 } else if (count
>= 2 && ufoImgGetU8Ext(addr
) == '$') {
4489 addr
+= 1; count
-= 1;
4490 } else if (count
>= 2 && ufoImgGetU8Ext(addr
) == '#') {
4492 addr
+= 1; count
-= 1;
4493 } else if (count
>= 2 && ufoImgGetU8Ext(addr
) == '%') {
4495 addr
+= 1; count
-= 1;
4496 } else if (count
>= 3 && ufoImgGetU8Ext(addr
) == '&') {
4497 switch (ufoImgGetU8Ext(addr
+ 1u)) {
4498 case 'h': case 'H': base
= 16; break;
4499 case 'o': case 'O': base
= 8; break;
4500 case 'b': case 'B': base
= 2; break;
4501 case 'd': case 'D': base
= 10; break;
4504 if (base
) { addr
+= 2; count
-= 2; }
4505 } else if (xbase
< 12 && count
> 2 && toUpperU8(ufoImgGetU8Ext(addr
+ (uint32_t)count
- 1u)) == 'B') {
4508 } else if (xbase
< 18 && count
> 2 && toUpperU8(ufoImgGetU8Ext(addr
+ (uint32_t)count
- 1u)) == 'H') {
4511 } else if (xbase
< 25 && count
> 2 && toUpperU8(ufoImgGetU8Ext(addr
+ (uint32_t)count
- 1u)) == 'O') {
4517 if (!base
&& xbase
< 255) base
= xbase
;
4519 if (count
<= 0 || base
< 1 || base
> 36) {
4523 int wasDig
= 0, wasUnder
= 1, error
= 0, dig
;
4524 while (!error
&& count
!= 0) {
4525 ch
= ufoImgGetU8Ext(addr
); addr
+= 1u; count
-= 1;
4527 error
= 1; wasUnder
= 0; wasDig
= 1;
4528 dig
= digitInBase((char)ch
, (int)base
);
4530 nc
= n
* (uint32_t)base
;
4532 nc
+= (uint32_t)dig
;
4545 if (!error
&& wasDig
&& !wasUnder
) {
4546 if (allowSign
&& neg
) n
= ~n
+ 1u;
4556 // ////////////////////////////////////////////////////////////////////////// //
4557 // compiler-related, dictionary-related
4560 static char ufoWNameBuf
[256];
4562 // (CREATE-WORD-HEADER)
4563 // ( addr count word-flags -- )
4564 UFWORD(PAR_CREATE_WORD_HEADER
) {
4565 const uint32_t flags
= ufoPop();
4566 const uint32_t wlen
= ufoPop();
4567 const uint32_t waddr
= ufoPop();
4568 if (wlen
== 0) ufoFatal("word name expected");
4569 if (wlen
>= UFO_MAX_WORD_LENGTH
) ufoFatal("word name too long");
4570 // copy to separate buffer
4571 for (uint32_t f
= 0; f
< wlen
; f
+= 1) {
4572 ufoWNameBuf
[f
] = (char)ufoImgGetU8Ext(waddr
+ f
);
4574 ufoWNameBuf
[wlen
] = 0;
4575 ufoCreateWordHeader(ufoWNameBuf
, flags
);
4578 // (CREATE-NAMELESS-WORD-HEADER)
4579 // ( word-flags -- )
4580 UFWORD(PAR_CREATE_NAMELESS_WORD_HEADER
) {
4581 const uint32_t flags
= ufoPop();
4582 ufoCreateWordHeader("", flags
);
4586 // ( addr count -- cfa TRUE / FALSE)
4588 const uint32_t wlen
= ufoPop();
4589 const uint32_t waddr
= ufoPop();
4590 if (wlen
> 0 && wlen
< UFO_MAX_WORD_LENGTH
) {
4591 // copy to separate buffer
4592 for (uint32_t f
= 0; f
< wlen
; f
+= 1) {
4593 ufoWNameBuf
[f
] = (char)ufoImgGetU8Ext(waddr
+ f
);
4595 ufoWNameBuf
[wlen
] = 0;
4596 const uint32_t cfa
= ufoFindWord(ufoWNameBuf
);
4608 // (FIND-WORD-IN-VOC)
4609 // ( addr count vocid allowhidden -- cfa TRUE / FALSE)
4610 // find only in the given voc; no name resolution
4611 UFWORD(FIND_WORD_IN_VOC
) {
4612 const uint32_t allowHidden
= ufoPop();
4613 const uint32_t vocid
= ufoPop();
4614 const uint32_t wlen
= ufoPop();
4615 const uint32_t waddr
= ufoPop();
4616 if (wlen
> 0 && wlen
< UFO_MAX_WORD_LENGTH
) {
4617 // copy to separate buffer
4618 for (uint32_t f
= 0; f
< wlen
; f
+= 1) {
4619 ufoWNameBuf
[f
] = (char)ufoImgGetU8Ext(waddr
+ f
);
4621 ufoWNameBuf
[wlen
] = 0;
4622 const uint32_t cfa
= ufoFindWordInVoc(ufoWNameBuf
, wlen
, 0, vocid
, (allowHidden
? 1 : 0));
4634 // (FIND-WORD-IN-VOC-AND-PARENTS)
4635 // ( addr count vocid allowhidden -- cfa TRUE / FALSE)
4636 // find only in the given voc; no name resolution
4637 UFWORD(FIND_WORD_IN_VOC_AND_PARENTS
) {
4638 const uint32_t allowHidden
= ufoPop();
4639 const uint32_t vocid
= ufoPop();
4640 const uint32_t wlen
= ufoPop();
4641 const uint32_t waddr
= ufoPop();
4642 if (wlen
> 0 && wlen
< UFO_MAX_WORD_LENGTH
) {
4643 // copy to separate buffer
4644 for (uint32_t f
= 0; f
< wlen
; f
+= 1) {
4645 ufoWNameBuf
[f
] = (char)ufoImgGetU8Ext(waddr
+ f
);
4647 ufoWNameBuf
[wlen
] = 0;
4648 const uint32_t cfa
= ufoFindWordInVocAndParents(ufoWNameBuf
, wlen
, 0, vocid
, (allowHidden
? 1 : 0));
4661 // ////////////////////////////////////////////////////////////////////////// //
4662 // more compiler words
4665 // ////////////////////////////////////////////////////////////////////////// //
4666 // vocabulary and wordlist utilities
4671 UFWORD(PAR_GET_VSP
) {
4677 UFWORD(PAR_SET_VSP
) {
4678 const uint32_t vsp
= ufoPop();
4679 if (vsp
>= UFO_VOCSTACK_SIZE
) ufoFatal("VSP %u out of range (%u)", vsp
, UFO_VOCSTACK_SIZE
);
4685 UFWORD(PAR_VSP_LOAD
) {
4686 const uint32_t vsp
= ufoPop();
4687 if (vsp
>= UFO_VOCSTACK_SIZE
) ufoFatal("VSP %u out of range (%u)", vsp
, UFO_VOCSTACK_SIZE
);
4688 ufoPush(ufoVocStack
[vsp
]);
4693 UFWORD(PAR_VSP_STORE
) {
4694 const uint32_t vsp
= ufoPop();
4695 const uint32_t value
= ufoPop();
4696 if (vsp
> UFO_VOCSTACK_SIZE
) ufoFatal("VSP %u out of range (%u)", vsp
, UFO_VOCSTACK_SIZE
);
4697 ufoVocStack
[vsp
] = value
;
4701 // ////////////////////////////////////////////////////////////////////////// //
4702 // word field address conversion
4708 const uint32_t cfa
= ufoPop();
4709 ufoPush(UFO_CFA_TO_PFA(cfa
));
4715 const uint32_t cfa
= ufoPop();
4716 ufoPush(UFO_CFA_TO_NFA(cfa
));
4722 const uint32_t cfa
= ufoPop();
4723 ufoPush(UFO_CFA_TO_LFA(cfa
));
4727 // ( cfa -- wend-addr )
4729 const uint32_t cfa
= ufoPop();
4730 ufoPush(ufoGetWordEndAddr(cfa
));
4736 const uint32_t pfa
= ufoPop();
4737 ufoPush(UFO_PFA_TO_CFA(pfa
));
4743 const uint32_t pfa
= ufoPop();
4744 const uint32_t cfa
= UFO_PFA_TO_CFA(pfa
);
4745 ufoPush(UFO_CFA_TO_NFA(cfa
));
4751 const uint32_t nfa
= ufoPop();
4752 ufoPush(UFO_NFA_TO_CFA(nfa
));
4758 const uint32_t nfa
= ufoPop();
4759 const uint32_t cfa
= UFO_NFA_TO_CFA(nfa
);
4760 ufoPush(UFO_CFA_TO_PFA(cfa
));
4766 const uint32_t nfa
= ufoPop();
4767 ufoPush(UFO_NFA_TO_LFA(nfa
));
4773 const uint32_t lfa
= ufoPop();
4774 ufoPush(UFO_LFA_TO_CFA(lfa
));
4780 const uint32_t lfa
= ufoPop();
4781 const uint32_t cfa
= UFO_LFA_TO_CFA(lfa
);
4782 ufoPush(UFO_CFA_TO_PFA(cfa
));
4788 const uint32_t lfa
= ufoPop();
4789 ufoPush(UFO_LFA_TO_BFA(lfa
));
4795 const uint32_t lfa
= ufoPop();
4796 ufoPush(UFO_LFA_TO_XFA(lfa
));
4802 const uint32_t lfa
= ufoPop();
4803 ufoPush(UFO_LFA_TO_YFA(lfa
));
4809 const uint32_t lfa
= ufoPop();
4810 ufoPush(UFO_LFA_TO_NFA(lfa
));
4814 // ( ip -- nfa / 0 )
4816 const uint32_t ip
= ufoPop();
4817 ufoPush(ufoFindWordForIP(ip
));
4821 // ( ip -- addr count line TRUE / FALSE )
4822 // name is at PAD; it is safe to use PAD, because each task has its own temp image
4823 UFWORD(IP2FILELINE
) {
4824 const uint32_t ip
= ufoPop();
4826 const char *fname
= ufoFindFileForIP(ip
, &fline
, NULL
, NULL
);
4827 if (fname
!= NULL
) {
4829 uint32_t addr
= ufoPeek();
4831 while (*fname
!= 0) {
4832 ufoImgPutU8(addr
, *(const unsigned char *)fname
);
4833 fname
+= 1u; addr
+= 1u; count
+= 1u;
4835 ufoImgPutU8(addr
, 0); // just in case
4845 // IP->FILE-HASH/LINE
4846 // ( ip -- len hash line TRUE / FALSE )
4847 UFWORD(IP2FILEHASHLINE
) {
4848 const uint32_t ip
= ufoPop();
4849 uint32_t fline
, fhash
, flen
;
4850 const char *fname
= ufoFindFileForIP(ip
, &fline
, &flen
, &fhash
);
4851 if (fname
!= NULL
) {
4862 // ////////////////////////////////////////////////////////////////////////// //
4863 // string operations
4866 UFO_FORCE_INLINE
uint32_t ufoHashBuf (uint32_t addr
, uint32_t size
, uint8_t orbyte
) {
4867 uint32_t hash
= 0x29a;
4868 if ((size
& ((uint32_t)1<<31)) == 0) {
4870 hash
+= ufoImgGetU8Ext(addr
) | orbyte
;
4873 addr
+= 1u; size
-= 1u;
4883 //==========================================================================
4887 //==========================================================================
4888 UFO_FORCE_INLINE
int ufoBufEqu (uint32_t addr0
, uint32_t addr1
, uint32_t count
) {
4890 if ((count
& ((uint32_t)1<<31)) == 0) {
4892 while (res
!= 0 && count
!= 0) {
4893 res
= (toUpperU8(ufoImgGetU8Ext(addr0
)) == toUpperU8(ufoImgGetU8Ext(addr1
)));
4894 addr0
+= 1u; addr1
+= 1u; count
-= 1u;
4903 // ( a0 c0 a1 c1 -- bool )
4905 int32_t c1
= (int32_t)ufoPop();
4906 uint32_t a1
= ufoPop();
4907 int32_t c0
= (int32_t)ufoPop();
4908 uint32_t a0
= ufoPop();
4913 while (res
!= 0 && c0
!= 0) {
4914 res
= (ufoImgGetU8Ext(a0
) == ufoImgGetU8Ext(a1
));
4915 a0
+= 1; a1
+= 1; c0
-= 1;
4924 // ( a0 c0 a1 c1 -- bool )
4926 int32_t c1
= (int32_t)ufoPop();
4927 uint32_t a1
= ufoPop();
4928 int32_t c0
= (int32_t)ufoPop();
4929 uint32_t a0
= ufoPop();
4934 while (res
!= 0 && c0
!= 0) {
4935 res
= (toUpperU8(ufoImgGetU8Ext(a0
)) == toUpperU8(ufoImgGetU8Ext(a1
)));
4936 a0
+= 1; a1
+= 1; c0
-= 1;
4944 // search the string specified by c-addr1 u1 for the string specified by c-addr2 u2.
4945 // if flag is true, a match was found at c-addr3 with u3 characters remaining.
4946 // if flag is false there was no match and c-addr3 is c-addr1 and u3 is u1.
4947 // ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 flag )
4949 const uint32_t pcount
= ufoPop();
4950 const uint32_t paddr
= ufoPop();
4951 const uint32_t tcount
= ufoPop();
4952 const uint32_t taddr
= ufoPop();
4953 if ((pcount
& ((uint32_t)1 << 31)) == 0 && (tcount
& ((uint32_t)1 << 31)) == 0) {
4954 for (uint32_t f
= 0; tcount
- f
>= pcount
; f
+= 1) {
4955 if (ufoBufEqu(taddr
+ f
, paddr
, pcount
)) {
4957 ufoPush(tcount
- f
);
4969 // ( addr count -- hash )
4971 uint32_t count
= ufoPop();
4972 uint32_t addr
= ufoPop();
4973 ufoPush(ufoHashBuf(addr
, count
, 0));
4977 // ( addr count -- hash )
4979 uint32_t count
= ufoPop();
4980 uint32_t addr
= ufoPop();
4981 ufoPush(ufoHashBuf(addr
, count
, 0x20));
4985 // ////////////////////////////////////////////////////////////////////////// //
4986 // conditional defines
4989 typedef struct UForthCondDefine_t UForthCondDefine
;
4990 struct UForthCondDefine_t
{
4994 UForthCondDefine
*next
;
4997 static UForthCondDefine
*ufoCondDefines
= NULL
;
4998 static char ufoErrMsgBuf
[4096];
5001 //==========================================================================
5005 //==========================================================================
5006 UFO_DISABLE_INLINE
int ufoStrEquCI (const void *str0
, const void *str1
) {
5007 const unsigned char *s0
= (const unsigned char *)str0
;
5008 const unsigned char *s1
= (const unsigned char *)str1
;
5009 while (*s0
&& *s1
) {
5010 if (toUpperU8(*s0
) != toUpperU8(*s1
)) return 0;
5013 return (*s0
== 0 && *s1
== 0);
5017 //==========================================================================
5021 //==========================================================================
5022 UFO_FORCE_INLINE
int ufoBufEquCI (uint32_t addr
, uint32_t count
, const void *buf
) {
5024 if ((count
& ((uint32_t)1<<31)) == 0) {
5025 const unsigned char *src
= (const unsigned char *)buf
;
5027 while (res
!= 0 && count
!= 0) {
5028 res
= (toUpperU8(*src
) == toUpperU8(ufoImgGetU8Ext(addr
)));
5029 src
+= 1; addr
+= 1u; count
-= 1u;
5038 //==========================================================================
5040 // ufoClearCondDefines
5042 //==========================================================================
5043 static void ufoClearCondDefines (void) {
5044 while (ufoCondDefines
) {
5045 UForthCondDefine
*df
= ufoCondDefines
;
5046 ufoCondDefines
= df
->next
;
5047 if (df
->name
) free(df
->name
);
5053 //==========================================================================
5057 //==========================================================================
5058 int ufoHasCondDefine (const char *name
) {
5060 if (name
!= NULL
&& name
[0] != 0) {
5061 const size_t nlen
= strlen(name
);
5063 const uint32_t hash
= joaatHashBufCI(name
, nlen
);
5064 UForthCondDefine
*dd
= ufoCondDefines
;
5065 while (res
== 0 && dd
!= NULL
) {
5066 if (dd
->hash
== hash
&& dd
->namelen
== (uint32_t)nlen
) {
5067 res
= ufoStrEquCI(name
, dd
->name
);
5077 //==========================================================================
5081 //==========================================================================
5082 void ufoCondDefine (const char *name
) {
5083 if (name
!= NULL
&& name
[0] != 0) {
5084 const size_t nlen
= strlen(name
);
5085 if (nlen
> 255) ufoFatal("conditional define name too long");
5086 const uint32_t hash
= joaatHashBufCI(name
, nlen
);
5087 UForthCondDefine
*dd
= ufoCondDefines
;
5089 while (res
== 0 && dd
!= NULL
) {
5090 if (dd
->hash
== hash
&& dd
->namelen
== (uint32_t)nlen
) {
5091 res
= ufoStrEquCI(name
, dd
->name
);
5097 dd
= calloc(1, sizeof(UForthCondDefine
));
5098 if (dd
== NULL
) ufoFatal("out of memory for defines");
5099 dd
->name
= strdup(name
);
5100 if (dd
->name
== NULL
) { free(dd
); ufoFatal("out of memory for defines"); }
5101 dd
->namelen
= (uint32_t)nlen
;
5103 dd
->next
= ufoCondDefines
;
5104 ufoCondDefines
= dd
;
5110 //==========================================================================
5114 //==========================================================================
5115 void ufoCondUndef (const char *name
) {
5116 if (name
!= NULL
&& name
[0] != 0) {
5117 const size_t nlen
= strlen(name
);
5119 const uint32_t hash
= joaatHashBufCI(name
, nlen
);
5120 UForthCondDefine
*dd
= ufoCondDefines
;
5121 UForthCondDefine
*prev
= NULL
;
5122 while (dd
!= NULL
) {
5123 if (dd
->hash
== hash
&& dd
->namelen
== (uint32_t)nlen
) {
5124 if (ufoStrEquCI(name
, dd
->name
)) {
5125 if (prev
!= NULL
) prev
->next
= dd
->next
; else ufoCondDefines
= dd
->next
;
5131 if (dd
!= NULL
) { prev
= dd
; dd
= dd
->next
; }
5139 // ( addr count -- )
5140 UFWORD(PAR_DLR_DEFINE
) {
5141 uint32_t count
= ufoPop();
5142 uint32_t addr
= ufoPop();
5143 if (count
== 0) ufoFatal("empty define");
5144 if (count
>= UFO_MAX_WORD_LENGTH
) ufoFatal("define too long");
5145 const uint32_t hash
= ufoHashBuf(addr
, count
, 0x20);
5146 UForthCondDefine
*dd
;
5147 for (dd
= ufoCondDefines
; dd
!= NULL
; dd
= dd
->next
) {
5148 if (dd
->hash
== hash
&& dd
->namelen
== count
) {
5149 if (ufoBufEquCI(addr
, count
, dd
->name
)) return;
5153 dd
= calloc(1, sizeof(UForthCondDefine
));
5154 if (dd
== NULL
) ufoFatal("out of memory for defines");
5155 dd
->name
= calloc(1, count
+ 1u);
5156 if (dd
->name
== NULL
) { free(dd
); ufoFatal("out of memory for defines"); }
5157 for (uint32_t f
= 0; f
< count
; f
+= 1) {
5158 ((unsigned char *)dd
->name
)[f
] = ufoImgGetU8Ext(addr
+ f
);
5160 dd
->namelen
= count
;
5162 dd
->next
= ufoCondDefines
;
5163 ufoCondDefines
= dd
;
5167 // ( addr count -- )
5168 UFWORD(PAR_DLR_UNDEF
) {
5169 uint32_t count
= ufoPop();
5170 uint32_t addr
= ufoPop();
5171 if (count
== 0) ufoFatal("empty define");
5172 if (count
>= UFO_MAX_WORD_LENGTH
) ufoFatal("define too long");
5173 const uint32_t hash
= ufoHashBuf(addr
, count
, 0x20);
5174 UForthCondDefine
*prev
= NULL
;
5175 UForthCondDefine
*dd
;
5176 for (dd
= ufoCondDefines
; dd
!= NULL
; prev
= dd
, dd
= dd
->next
) {
5177 if (dd
->hash
== hash
&& dd
->namelen
== count
) {
5178 if (ufoBufEquCI(addr
, count
, dd
->name
)) {
5179 if (prev
== NULL
) ufoCondDefines
= dd
->next
; else prev
->next
= dd
->next
;
5189 // ( addr count -- bool )
5190 UFWORD(PAR_DLR_DEFINEDQ
) {
5191 uint32_t count
= ufoPop();
5192 uint32_t addr
= ufoPop();
5193 if (count
== 0) ufoFatal("empty define");
5194 if (count
>= UFO_MAX_WORD_LENGTH
) ufoFatal("define too long");
5195 const uint32_t hash
= ufoHashBuf(addr
, count
, 0x20);
5197 UForthCondDefine
*dd
= ufoCondDefines
;
5198 while (!found
&& dd
!= NULL
) {
5199 if (dd
->hash
== hash
&& dd
->namelen
== count
) {
5200 found
= ufoBufEquCI(addr
, count
, dd
->name
);
5208 // ////////////////////////////////////////////////////////////////////////// //
5213 // ( addr count -- )
5215 uint32_t count
= ufoPop();
5216 uint32_t addr
= ufoPop();
5217 if (count
& (1u<<31)) ufoFatal("invalid error message");
5218 if (count
== 0) ufoFatal("some error");
5219 if (count
> (uint32_t)sizeof(ufoErrMsgBuf
) - 1u) count
= (uint32_t)sizeof(ufoErrMsgBuf
) - 1u;
5220 for (uint32_t f
= 0; f
< count
; f
+= 1) {
5221 ufoErrMsgBuf
[f
] = (char)ufoImgGetU8Ext(addr
+ f
);
5223 ufoErrMsgBuf
[count
] = 0;
5224 ufoFatal("%s", ufoErrMsgBuf
);
5227 // ////////////////////////////////////////////////////////////////////////// //
5231 static char ufoFNameBuf
[4096];
5234 //==========================================================================
5236 // ufoScanIncludeFileName
5238 // `*psys` and `*psoft` must be initialised!
5240 //==========================================================================
5241 static void ufoScanIncludeFileName (uint32_t addr
, uint32_t count
, char *dest
, size_t destsz
,
5242 uint32_t *psys
, uint32_t *psoft
)
5246 ufo_assert(dest
!= NULL
);
5247 ufo_assert(destsz
> 0);
5249 while (count
!= 0) {
5250 ch
= ufoImgGetU8Ext(addr
);
5252 //if (system) ufoFatal("invalid file name (duplicate system mark)");
5254 } else if (ch
== '?') {
5255 //if (softinclude) ufoFatal("invalid file name (duplicate soft mark)");
5261 addr
+= 1; count
-= 1;
5262 ch
= ufoImgGetU8Ext(addr
);
5263 } while (ch
<= 32 && count
!= 0);
5266 if (count
== 0) ufoFatal("empty include file name");
5267 if (count
>= destsz
) ufoFatal("include file name too long");
5270 while (count
!= 0) {
5271 dest
[dpos
] = (char)ufoImgGetU8Ext(addr
); dpos
+= 1;
5272 addr
+= 1; count
-= 1;
5280 // return number of items in include stack
5281 UFWORD(PAR_INCLUDE_DEPTH
) {
5282 ufoPush(ufoFileStackPos
);
5285 // (INCLUDE-FILE-ID)
5286 // ( isp -- id ) -- isp 0 is current, then 1, etc.
5287 // each include file has unique non-zero id.
5288 UFWORD(PAR_INCLUDE_FILE_ID
) {
5289 const uint32_t isp
= ufoPop();
5292 } else if (isp
<= ufoFileStackPos
) {
5293 UFOFileStackEntry
*stk
= &ufoFileStack
[ufoFileStackPos
- isp
];
5296 ufoFatal("invalid include stack index");
5300 // (INCLUDE-FILE-LINE)
5302 UFWORD(PAR_INCLUDE_FILE_LINE
) {
5303 const uint32_t isp
= ufoPop();
5305 ufoPush(ufoInFileLine
);
5306 } else if (isp
<= ufoFileStackPos
) {
5307 UFOFileStackEntry
*stk
= &ufoFileStack
[ufoFileStackPos
- isp
];
5308 ufoPush(stk
->fline
);
5310 ufoFatal("invalid include stack index");
5312 ufoPush(ufoInFileLine
);
5315 // (INCLUDE-FILE-NAME)
5316 // ( isp -- addr count )
5317 // current file name; at PAD
5318 UFWORD(PAR_INCLUDE_FILE_NAME
) {
5319 const uint32_t isp
= ufoPop();
5320 const char *fname
= NULL
;
5322 fname
= ufoInFileName
;
5323 } else if (isp
<= ufoFileStackPos
) {
5324 UFOFileStackEntry
*stk
= &ufoFileStack
[ufoFileStackPos
- isp
];
5327 ufoFatal("invalid include stack index");
5330 uint32_t addr
= ufoPop();
5332 while (fname
[count
] != 0) {
5333 ufoImgPutU8Ext(addr
+ count
, ((const unsigned char *)fname
)[count
]);
5336 ufoImgPutU8Ext(addr
+ count
, 0);
5342 // ( addr count soft? system? -- )
5343 UFWORD(PAR_INCLUDE
) {
5344 uint32_t system
= ufoPop();
5345 uint32_t softinclude
= ufoPop();
5346 uint32_t count
= ufoPop();
5347 uint32_t addr
= ufoPop();
5349 if (ufoMode
== UFO_MODE_MACRO
) ufoFatal("macros cannot include files");
5351 if ((count
& ((uint32_t)1<<31)) != 0) ufoFatal("invalid include name");
5353 ufoScanIncludeFileName(addr
, count
, ufoFNameBuf
, sizeof(ufoFNameBuf
),
5354 &system
, &softinclude
);
5356 char *ffn
= ufoCreateIncludeName(ufoFNameBuf
, system
, (system
? ufoLastSysIncPath
: ufoLastIncPath
));
5358 FILE *fl
= fopen(ffn
, "rb");
5360 FILE *fl
= fopen(ffn
, "r");
5363 if (softinclude
) { free(ffn
); return; }
5364 ufoFatal("include file '%s' not found", ffn
);
5366 #ifdef UFO_DEBUG_INCLUDE
5367 fprintf(stderr
, "INC-PUSH: new fname: %s\n", ffn
);
5372 ufoSetInFileNameReuse(ffn
);
5373 ufoFileId
= ufoLastUsedFileId
;
5374 setLastIncPath(ufoInFileName
, system
);
5375 // trigger next line loading
5377 if (!ufoPop()) ufoFatal("(INCLUDE) internal error");
5381 UFWORD(DLR_INCLUDE_IMM
) {
5382 int soft
= 0, system
= 0;
5383 // parse include filename
5384 //UFCALL(PARSE_SKIP_BLANKS);
5385 ufoPushBool(0); UFCALL(PAR_PARSE_SKIP_COMMENTS
);
5386 uint8_t ch
= ufoTibPeekCh();
5388 ufoTibSkipCh(); // skip quote
5390 } else if (ch
== '<') {
5391 ufoTibSkipCh(); // skip quote
5395 ufoFatal("expected quoted string");
5398 if (!ufoPop()) ufoFatal("file name expected");
5399 ufoPushBool(0); UFCALL(PAR_PARSE_SKIP_COMMENTS
);
5400 if (ufoTibPeekCh() != 0) {
5401 ufoFatal("$INCLUDE doesn't accept extra args yet");
5403 // ( addr count soft? system? -- )
5404 ufoPushBool(soft
); ufoPushBool(system
); UFCALL(PAR_INCLUDE
);
5408 //==========================================================================
5410 // ufoCreateFileGuard
5412 //==========================================================================
5413 static const char *ufoCreateFileGuard (const char *fname
) {
5414 if (fname
== NULL
|| fname
[0] == 0) return NULL
;
5415 char *rp
= ufoRealPath(fname
);
5416 if (rp
== NULL
) return NULL
;
5418 for (char *s
= rp
; *s
; s
+= 1) if (*s
== '\\') *s
= '/';
5420 // hash the buffer; extract file name; create string with path len, file name, and hash
5421 const size_t orgplen
= strlen(rp
);
5422 const uint32_t phash
= joaatHashBuf(rp
, orgplen
, 0);
5423 size_t plen
= orgplen
;
5424 while (plen
!= 0 && rp
[plen
- 1u] != '/') plen
-= 1;
5425 snprintf(ufoRealPathHashBuf
, sizeof(ufoRealPathHashBuf
),
5426 "__INCLUDE_GUARD_%08X_%08X_%s__", phash
, (uint32_t)orgplen
, rp
+ plen
);
5427 return ufoRealPathHashBuf
;
5431 // $INCLUDE-ONCE "str"
5432 // includes file only once; unreliable on shitdoze, i believe
5433 UFWORD(DLR_INCLUDE_ONCE_IMM
) {
5434 uint32_t softinclude
= 0, system
= 0;
5435 // parse include filename
5436 //UFCALL(PARSE_SKIP_BLANKS);
5437 ufoPushBool(0); UFCALL(PAR_PARSE_SKIP_COMMENTS
);
5438 uint8_t ch
= ufoTibPeekCh();
5440 ufoTibSkipCh(); // skip quote
5442 } else if (ch
== '<') {
5443 ufoTibSkipCh(); // skip quote
5447 ufoFatal("expected quoted string");
5450 if (!ufoPop()) ufoFatal("file name expected");
5451 const uint32_t count
= ufoPop();
5452 const uint32_t addr
= ufoPop();
5453 ufoPushBool(0); UFCALL(PAR_PARSE_SKIP_COMMENTS
);
5454 if (ufoTibPeekCh() != 0) {
5455 ufoFatal("$REQUIRE doesn't accept extra args yet");
5457 ufoScanIncludeFileName(addr
, count
, ufoRealPathHashBuf
, sizeof(ufoRealPathHashBuf
),
5458 &system
, &softinclude
);
5459 char *incfname
= ufoCreateIncludeName(ufoRealPathHashBuf
, system
, (system
? ufoLastSysIncPath
: ufoLastIncPath
));
5460 if (incfname
== NULL
) ufoFatal("cannot resolve include file '%s'", ufoRealPathHashBuf
);
5461 //fprintf(stderr, "?:%d;!:%d;%s|%s\n", softinclude, system, ufoRealPathHashBuf, incfname);
5462 // this will overwrite `ufoRealPathHashBuf`
5463 const char *guard
= ufoCreateFileGuard(incfname
);
5465 if (guard
== NULL
) {
5466 if (!softinclude
) ufoFatal("cannot include file '%s'", ufoRealPathHashBuf
);
5470 fprintf(stderr
, "GUARD: <%s>\n", guard
);
5472 // now check for the guard
5473 const uint32_t glen
= (uint32_t)strlen(guard
);
5474 const uint32_t ghash
= joaatHashBuf(guard
, glen
, 0);
5475 UForthCondDefine
*dd
;
5476 for (dd
= ufoCondDefines
; dd
!= NULL
; dd
= dd
->next
) {
5477 if (dd
->hash
== ghash
&& dd
->namelen
== glen
&& strcmp(guard
, dd
->name
) == 0) {
5478 // nothing to do: already included
5483 dd
= calloc(1, sizeof(UForthCondDefine
));
5484 if (dd
== NULL
) ufoFatal("out of memory for defines");
5485 dd
->name
= calloc(1, glen
+ 1u);
5486 if (dd
->name
== NULL
) { free(dd
); ufoFatal("out of memory for defines"); }
5487 strcpy(dd
->name
, guard
);
5490 dd
->next
= ufoCondDefines
;
5491 ufoCondDefines
= dd
;
5492 // ( addr count soft? system? -- )
5493 ufoPush(addr
); ufoPush(count
); ufoPushBool(softinclude
); ufoPushBool(system
);
5494 UFCALL(PAR_INCLUDE
);
5498 // ////////////////////////////////////////////////////////////////////////// //
5504 UFWORD(PAR_NEW_HANDLE
) {
5505 const uint32_t typeid = ufoPop();
5506 if (typeid == UFO_HANDLE_FREE
) ufoFatal("invalid handle typeid");
5507 UfoHandle
*hh
= ufoAllocHandle(typeid);
5508 ufoPush(hh
->ufoHandle
);
5513 UFWORD(PAR_FREE_HANDLE
) {
5514 const uint32_t hx
= ufoPop();
5516 if ((hx
& UFO_ADDR_HANDLE_BIT
) == 0) ufoFatal("trying to free something that is not a handle");
5517 UfoHandle
*hh
= ufoGetHandle(hx
);
5518 if (hh
== NULL
) ufoFatal("trying to free invalid handle");
5525 UFWORD(PAR_HANDLE_GET_TYPEID
) {
5526 const uint32_t hx
= ufoPop();
5527 if ((hx
& UFO_ADDR_HANDLE_BIT
) == 0) ufoFatal("not a handle");
5528 UfoHandle
*hh
= ufoGetHandle(hx
);
5529 if (hh
== NULL
) ufoFatal("invalid handle");
5530 ufoPush(hh
->typeid);
5535 UFWORD(PAR_HANDLE_SET_TYPEID
) {
5536 const uint32_t hx
= ufoPop();
5537 const uint32_t typeid = ufoPop();
5538 if ((hx
& UFO_ADDR_HANDLE_BIT
) == 0) ufoFatal("not a handle");
5539 if (typeid == UFO_HANDLE_FREE
) ufoFatal("invalid handle typeid");
5540 UfoHandle
*hh
= ufoGetHandle(hx
);
5541 if (hh
== NULL
) ufoFatal("invalid handle");
5542 hh
->typeid = typeid;
5547 UFWORD(PAR_HANDLE_GET_SIZE
) {
5548 const uint32_t hx
= ufoPop();
5550 if ((hx
& UFO_ADDR_HANDLE_BIT
) == 0) ufoFatal("not a handle");
5551 UfoHandle
*hh
= ufoGetHandle(hx
);
5552 if (hh
== NULL
) ufoFatal("invalid handle");
5561 UFWORD(PAR_HANDLE_SET_SIZE
) {
5562 const uint32_t hx
= ufoPop();
5563 const uint32_t size
= ufoPop();
5564 if (size
> 0x04000000) ufoFatal("invalid handle size");
5565 if ((hx
& UFO_ADDR_HANDLE_BIT
) == 0) ufoFatal("not a handle");
5566 UfoHandle
*hh
= ufoGetHandle(hx
);
5567 if (hh
== NULL
) ufoFatal("invalid handle");
5568 if (hh
->size
!= size
) {
5573 uint8_t *nx
= realloc(hh
->data
, size
* sizeof(hh
->data
[0]));
5574 if (nx
== NULL
) ufoFatal("out of memory for handle of size %u", size
);
5576 if (size
> hh
->size
) memset(hh
->data
, 0, size
- hh
->size
);
5579 if (hh
->used
> size
) hh
->used
= size
;
5585 UFWORD(PAR_HANDLE_GET_USED
) {
5586 const uint32_t hx
= ufoPop();
5588 if ((hx
& UFO_ADDR_HANDLE_BIT
) == 0) ufoFatal("not a handle");
5589 UfoHandle
*hh
= ufoGetHandle(hx
);
5590 if (hh
== NULL
) ufoFatal("invalid handle");
5599 UFWORD(PAR_HANDLE_SET_USED
) {
5600 const uint32_t hx
= ufoPop();
5601 const uint32_t used
= ufoPop();
5602 if (used
> 0x04000000) ufoFatal("invalid handle used");
5603 if ((hx
& UFO_ADDR_HANDLE_BIT
) == 0) ufoFatal("not a handle");
5604 UfoHandle
*hh
= ufoGetHandle(hx
);
5605 if (hh
== NULL
) ufoFatal("invalid handle");
5606 if (used
> hh
->size
) ufoFatal("handle used %u out of range (%u)", used
, hh
->size
);
5610 #define POP_PREPARE_HANDLE() \
5611 const uint32_t hx = ufoPop(); \
5612 uint32_t idx = ufoPop(); \
5613 if ((hx & UFO_ADDR_HANDLE_BIT) == 0) ufoFatal("not a handle"); \
5614 if (idx > 0x1fffffffU - UFO_ADDR_HANDLE_OFS_MASK) ufoFatal("handle index %u out of range", idx); \
5615 idx += (hx & UFO_ADDR_HANDLE_OFS_MASK); \
5616 UfoHandle *hh = ufoGetHandle(hx); \
5617 if (hh == NULL) ufoFatal("invalid handle")
5620 // ( idx hx -- value )
5621 UFWORD(PAR_HANDLE_LOAD_BYTE
) {
5622 POP_PREPARE_HANDLE();
5623 if (idx
>= hh
->size
) ufoFatal("handle index %u out of range (%u)", idx
, hh
->size
);
5624 ufoPush(hh
->data
[idx
]);
5628 // ( idx hx -- value )
5629 UFWORD(PAR_HANDLE_LOAD_WORD
) {
5630 POP_PREPARE_HANDLE();
5631 if (idx
>= hh
->size
|| hh
->size
- idx
< 2u) {
5632 ufoFatal("handle index %u out of range (%u)", idx
, hh
->size
);
5634 #ifdef UFO_FAST_MEM_ACCESS
5635 ufoPush(*(const uint16_t *)(hh
->data
+ idx
));
5637 uint32_t res
= hh
->data
[idx
];
5638 res
|= hh
->data
[idx
+ 1u] << 8;
5644 // ( idx hx -- value )
5645 UFWORD(PAR_HANDLE_LOAD_CELL
) {
5646 POP_PREPARE_HANDLE();
5647 if (idx
>= hh
->size
|| hh
->size
- idx
< 4u) {
5648 ufoFatal("handle index %u out of range (%u)", idx
, hh
->size
);
5650 #ifdef UFO_FAST_MEM_ACCESS
5651 ufoPush(*(const uint32_t *)(hh
->data
+ idx
));
5653 uint32_t res
= hh
->data
[idx
];
5654 res
|= hh
->data
[idx
+ 1u] << 8;
5655 res
|= hh
->data
[idx
+ 2u] << 16;
5656 res
|= hh
->data
[idx
+ 3u] << 24;
5662 // ( value idx hx -- value )
5663 UFWORD(PAR_HANDLE_STORE_BYTE
) {
5664 POP_PREPARE_HANDLE();
5665 const uint32_t value
= ufoPop();
5666 if (idx
>= hh
->size
) ufoFatal("handle index %u out of range (%u)", idx
, hh
->size
);
5667 hh
->data
[idx
] = value
;
5671 // ( value idx hx -- )
5672 UFWORD(PAR_HANDLE_STORE_WORD
) {
5673 POP_PREPARE_HANDLE();
5674 const uint32_t value
= ufoPop();
5675 if (idx
>= hh
->size
|| hh
->size
- idx
< 2u) {
5676 ufoFatal("handle index %u out of range (%u)", idx
, hh
->size
);
5678 #ifdef UFO_FAST_MEM_ACCESS
5679 *(uint16_t *)(hh
->data
+ idx
) = (uint16_t)value
;
5681 hh
->data
[idx
] = (uint8_t)value
;
5682 hh
->data
[idx
+ 1u] = (uint8_t)(value
>> 8);
5687 // ( value idx hx -- )
5688 UFWORD(PAR_HANDLE_STORE_CELL
) {
5689 POP_PREPARE_HANDLE();
5690 const uint32_t value
= ufoPop();
5691 if (idx
>= hh
->size
|| hh
->size
- idx
< 4u) {
5692 ufoFatal("handle index %u out of range (%u)", idx
, hh
->size
);
5694 #ifdef UFO_FAST_MEM_ACCESS
5695 *(uint32_t *)(hh
->data
+ idx
) = value
;
5697 hh
->data
[idx
] = (uint8_t)value
;
5698 hh
->data
[idx
+ 1u] = (uint8_t)(value
>> 8);
5699 hh
->data
[idx
+ 2u] = (uint8_t)(value
>> 16);
5700 hh
->data
[idx
+ 3u] = (uint8_t)(value
>> 24);
5706 // ( addr count -- stx / FALSE )
5707 UFWORD(PAR_HANDLE_LOAD_FILE
) {
5708 uint32_t count
= ufoPop();
5709 uint32_t addr
= ufoPop();
5711 if ((count
& ((uint32_t)1<<31)) != 0) ufoFatal("invalid file name");
5713 uint8_t *dest
= (uint8_t *)ufoFNameBuf
;
5714 while (count
!= 0 && dest
< (uint8_t *)ufoFNameBuf
+ sizeof(ufoFNameBuf
)) {
5715 uint8_t ch
= ufoImgGetU8Ext(addr
);
5717 dest
+= 1u; addr
+= 1u; count
-= 1u;
5719 if (dest
== (uint8_t *)ufoFNameBuf
+ sizeof(ufoFNameBuf
)) ufoFatal("file name too long");
5722 if (*ufoFNameBuf
== 0) ufoFatal("empty file name");
5724 char *ffn
= ufoCreateIncludeName(ufoFNameBuf
, 0/*system*/, ufoLastIncPath
);
5726 FILE *fl
= fopen(ffn
, "rb");
5728 FILE *fl
= fopen(ffn
, "r");
5736 if (fseek(fl
, 0, SEEK_END
) != 0) {
5738 ufoFatal("seek error in file '%s'", ffn
);
5741 long sz
= ftell(fl
);
5742 if (sz
< 0 || sz
>= 1024 * 1024 * 64) {
5744 ufoFatal("tell error in file '%s' (or too big)", ffn
);
5747 if (fseek(fl
, 0, SEEK_SET
) != 0) {
5749 ufoFatal("seek error in file '%s'", ffn
);
5752 UfoHandle
*hh
= ufoAllocHandle(0);
5754 hh
->data
= malloc((uint32_t)sz
);
5755 if (hh
->data
== NULL
) {
5757 ufoFatal("out of memory for file '%s'", ffn
);
5759 hh
->size
= (uint32_t)sz
;
5760 if (fread(hh
->data
, (uint32_t)sz
, 1, fl
) != 1) {
5762 ufoFatal("error reading file '%s'", ffn
);
5768 ufoPush(hh
->ufoHandle
);
5772 // ////////////////////////////////////////////////////////////////////////// //
5776 // DEBUG:(DECOMPILE-CFA)
5778 UFWORD(DEBUG_DECOMPILE_CFA
) {
5779 const uint32_t cfa
= ufoPop();
5781 ufoDecompileWord(cfa
);
5784 // DEBUG:(DECOMPILE-MEM)
5785 // ( addr-start addr-end -- )
5786 UFWORD(DEBUG_DECOMPILE_MEM
) {
5787 const uint32_t end
= ufoPop();
5788 const uint32_t start
= ufoPop();
5790 ufoDecompilePart(start
, end
, 0);
5796 ufoPush((uint32_t)ufo_get_msecs());
5799 // this is called by INTERPRET when it is out of input stream
5800 UFWORD(UFO_INTERPRET_FINISHED_ACTION
) {
5806 UFWORD(MT_NEW_STATE
) {
5807 UfoState
*st
= ufoNewState();
5808 ufoInitStateUserVars(st
, ufoPop());
5814 UFWORD(MT_FREE_STATE
) {
5815 UfoState
*st
= ufoFindState(ufoPop());
5816 if (st
== NULL
) ufoFatal("cannot free unknown state");
5817 if (st
== ufoCurrState
) ufoFatal("cannot free current state");
5821 // MTASK:STATE-NAME@
5822 // ( stid -- addr count )
5824 UFWORD(MT_GET_STATE_NAME
) {
5825 UfoState
*st
= ufoFindState(ufoPop());
5826 if (st
== NULL
) ufoFatal("unknown state");
5828 uint32_t addr
= ufoPop();
5830 while (st
->name
[count
] != 0) {
5831 ufoImgPutU8Ext(addr
+ count
, ((const unsigned char *)st
->name
)[count
]);
5834 ufoImgPutU8Ext(addr
+ count
, 0);
5839 // MTASK:STATE-NAME!
5840 // ( addr count stid -- )
5841 UFWORD(MT_SET_STATE_NAME
) {
5842 UfoState
*st
= ufoFindState(ufoPop());
5843 if (st
== NULL
) ufoFatal("unknown state");
5844 uint32_t count
= ufoPop();
5845 uint32_t addr
= ufoPop();
5846 if ((count
& ((uint32_t)1 << 31)) == 0) {
5847 if (count
> UFO_MAX_TASK_NAME
) ufoFatal("task name too long");
5848 for (uint32_t f
= 0; f
< count
; f
+= 1u) {
5849 ((unsigned char *)st
->name
)[f
] = ufoImgGetU8Ext(addr
+ f
);
5851 st
->name
[count
] = 0;
5855 // MTASK:STATE-FIRST
5857 UFWORD(MT_STATE_FIRST
) {
5859 while (fidx
!= (uint32_t)(UFO_MAX_STATES
/32) && ufoStateUsedBitmap
[fidx
] == 0) fidx
+= 1u;
5860 // there should be at least one allocated state
5861 ufo_assert(fidx
!= (uint32_t)(UFO_MAX_STATES
/32));
5862 uint32_t bmp
= ufoStateUsedBitmap
[fidx
];
5864 while ((bmp
& 0x01) == 0) { fidx
+= 1u; bmp
>>= 1; }
5869 // ( stid -- stid / 0 )
5870 UFWORD(MT_STATE_NEXT
) {
5871 uint32_t stid
= ufoPop();
5872 if (stid
!= 0 && stid
< (uint32_t)(UFO_MAX_STATES
/32)) {
5873 // it is already incremented for us, yay!
5874 uint32_t fidx
= stid
/ 32u;
5875 uint8_t fofs
= stid
& 0x1f;
5876 while (fidx
< (uint32_t)(UFO_MAX_STATES
/32)) {
5877 const uint32_t bmp
= ufoStateUsedBitmap
[fidx
];
5879 while (fofs
!= 32u) {
5880 if ((bmp
& ((uint32_t)1 << (fofs
& 0x1f))) == 0) fofs
+= 1u;
5883 ufoPush(fidx
* 32u + fofs
+ 1u);
5887 fidx
+= 1u; fofs
= 0;
5895 // ( ... argc stid -- )
5896 UFWORD(MT_YIELD_TO
) {
5897 UfoState
*st
= ufoFindState(ufoPop());
5898 if (st
== NULL
) ufoFatal("cannot yield to unknown state");
5899 //if (st == ufoDebuggerState) ufoFatal("cannot yield to debugger"); // why not?
5900 const uint32_t argc
= ufoPop();
5901 if (argc
> 256) ufoFatal("too many YIELD-TO arguments");
5902 UfoState
*curst
= ufoCurrState
;
5903 if (st
!= ufoCurrState
) {
5904 for (uint32_t f
= 0; f
< argc
; f
+= 1) {
5905 ufoCurrState
= curst
;
5906 const uint32_t n
= ufoPop();
5910 ufoCurrState
= curst
; // we need to use API call to switch states
5912 ufoSwitchToState(st
); // always use API call for this!
5917 // MTASK:SET-SELF-AS-DEBUGGER
5919 UFWORD(MT_SET_SELF_AS_DEBUGGER
) {
5920 ufoDebuggerState
= ufoCurrState
;
5925 // debugger task receives debugge stid on the data stack, and -1 as argc.
5926 // i.e. debugger stask is: ( -1 old-stid )
5927 UFWORD(MT_DEBUGGER_BP
) {
5928 if (ufoDebuggerState
!= NULL
&& ufoCurrState
!= ufoDebuggerState
&& ufoIsGoodTTY()) {
5929 UfoState
*st
= ufoCurrState
;
5930 ufoSwitchToState(ufoDebuggerState
); // always use API call for this!
5935 UFCALL(UFO_BACKTRACE
);
5939 // MTASK:DEBUGGER-RESUME
5941 UFWORD(MT_RESUME_DEBUGEE
) {
5942 if (ufoCurrState
!= ufoDebuggerState
) ufoFatal("cannot resume from non-debugger");
5943 UfoState
*st
= ufoFindState(ufoPop());
5944 if (st
== NULL
) ufoFatal("cannot yield to unknown state");
5945 if (st
== ufoCurrState
) ufoFatal("cannot resume into debugger itself");
5946 ufoSwitchToState(st
); // always use API call for this!
5950 // MTASK:DEBUGGER-SINGLE-STEP
5952 UFWORD(MT_SINGLE_STEP_DEBUGEE
) {
5953 if (ufoCurrState
!= ufoDebuggerState
) ufoFatal("cannot resume from non-debugger");
5954 UfoState
*st
= ufoFindState(ufoPop());
5955 if (st
== NULL
) ufoFatal("cannot yield to unknown state");
5956 if (st
== ufoCurrState
) ufoFatal("cannot resume into debugger itself");
5957 ufoSwitchToState(st
); // always use API call for this!
5958 ufoSingleStep
= 2; // it will be decremented after returning from this word
5963 UFWORD(MT_STATE_IP_GET
) {
5964 UfoState
*st
= ufoFindState(ufoPop());
5965 if (st
== NULL
) ufoFatal("unknown state");
5971 UFWORD(MT_STATE_IP_SET
) {
5972 UfoState
*st
= ufoFindState(ufoPop());
5973 if (st
== NULL
) ufoFatal("unknown state");
5979 UFWORD(MT_STATE_REGA_GET
) {
5980 UfoState
*st
= ufoFindState(ufoPop());
5981 if (st
== NULL
) ufoFatal("unknown state");
5987 UFWORD(MT_STATE_REGA_SET
) {
5988 UfoState
*st
= ufoFindState(ufoPop());
5989 if (st
== NULL
) ufoFatal("unknown state");
5990 st
->regA
= ufoPop();
5993 // MTASK:STATE-USER@
5994 // ( addr stid -- value )
5995 UFWORD(MT_STATE_USER_GET
) {
5996 UfoState
*st
= ufoFindState(ufoPop());
5997 if (st
== NULL
) ufoFatal("unknown state");
5998 const uint32_t addr
= ufoPop();
5999 if ((addr
& UFO_ADDR_TEMP_BIT
) != 0 && (addr
& UFO_ADDR_TEMP_MASK
) + 3u < st
->imageTempSize
) {
6000 uint32_t v
= *(const uint32_t *)((const uint8_t *)st
->imageTemp
+ (addr
& UFO_ADDR_TEMP_MASK
));
6003 ufoFatal("invalid user area address");
6007 // MTASK:STATE-USER!
6008 // ( value addr stid -- )
6009 UFWORD(MT_STATE_USER_SET
) {
6010 UfoState
*st
= ufoFindState(ufoPop());
6011 if (st
== NULL
) ufoFatal("unknown state");
6012 const uint32_t addr
= ufoPop();
6013 const uint32_t value
= ufoPop();
6014 if ((addr
& UFO_ADDR_TEMP_BIT
) != 0 && (addr
& UFO_ADDR_TEMP_MASK
) + 3u < st
->imageTempSize
) {
6015 *(uint32_t *)((const uint8_t *)st
->imageTemp
+ (addr
& UFO_ADDR_TEMP_MASK
)) = value
;
6017 ufoFatal("invalid user area address");
6021 // MTASK:STATE-RPOPCFA@
6023 UFWORD(MT_STATE_RPOPCFA_GET
) {
6024 UfoState
*st
= ufoFindState(ufoPop());
6025 if (st
== NULL
) ufoFatal("unknown state");
6026 ufoPush(st
->vmRPopCFA
);
6029 // MTASK:STATE-RPOPCFA!
6031 UFWORD(MT_STATE_RPOPCFA_SET
) {
6032 UfoState
*st
= ufoFindState(ufoPop());
6033 if (st
== NULL
) ufoFatal("unknown state");
6034 st
->vmRPopCFA
= ufoPop();
6037 // MTASK:ACTIVE-STATE
6039 UFWORD(MT_ACTIVE_STATE
) {
6040 ufoPush(ufoCurrState
->id
);
6043 // MTASK:YIELDED-FROM
6045 UFWORD(MT_YIELDED_FROM
) {
6046 if (ufoYieldedState
!= NULL
) {
6047 ufoPush(ufoYieldedState
->id
);
6054 // ( stid -- depth )
6055 UFWORD(MT_DSTACK_DEPTH_GET
) {
6056 UfoState
*st
= ufoFindState(ufoPop());
6057 if (st
== NULL
) ufoFatal("unknown state");
6062 // ( stid -- depth )
6063 UFWORD(MT_RSTACK_DEPTH_GET
) {
6064 UfoState
*st
= ufoFindState(ufoPop());
6065 if (st
== NULL
) ufoFatal("unknown state");
6066 ufoPush(st
->RP
- st
->RPTop
);
6072 UfoState
*st
= ufoFindState(ufoPop());
6073 if (st
== NULL
) ufoFatal("unknown state");
6079 UFWORD(MT_LBP_GET
) {
6080 UfoState
*st
= ufoFindState(ufoPop());
6081 if (st
== NULL
) ufoFatal("unknown state");
6086 // ( depth stid -- )
6087 UFWORD(MT_DSTACK_DEPTH_SET
) {
6088 UfoState
*st
= ufoFindState(ufoPop());
6089 if (st
== NULL
) ufoFatal("unknown state");
6090 const uint32_t idx
= ufoPop();
6091 if (idx
>= UFO_DSTACK_SIZE
) ufoFatal("invalid stack index %u (%u)", idx
, UFO_DSTACK_SIZE
);
6096 // ( depth stid -- )
6097 UFWORD(MT_RSTACK_DEPTH_SET
) {
6098 UfoState
*st
= ufoFindState(ufoPop());
6099 if (st
== NULL
) ufoFatal("unknown state");
6100 const uint32_t idx
= ufoPop();
6101 const uint32_t left
= UFO_RSTACK_SIZE
- st
->RPTop
;
6102 if (idx
>= left
) ufoFatal("invalid rstack index %u (%u)", idx
, left
);
6103 st
->RP
= st
->RPTop
+ idx
;
6109 UfoState
*st
= ufoFindState(ufoPop());
6110 if (st
== NULL
) ufoFatal("unknown state");
6116 UFWORD(MT_LBP_SET
) {
6117 UfoState
*st
= ufoFindState(ufoPop());
6118 if (st
== NULL
) ufoFatal("unknown state");
6123 // ( idx stid -- value )
6124 UFWORD(MT_DSTACK_LOAD
) {
6125 UfoState
*st
= ufoFindState(ufoPop());
6126 if (st
== NULL
) ufoFatal("unknown state");
6127 const uint32_t idx
= ufoPop();
6128 if (idx
>= st
->SP
) ufoFatal("invalid stack index %u (%u)", idx
, st
->SP
);
6129 ufoPush(st
->dStack
[st
->SP
- idx
- 1u]);
6133 // ( idx stid -- value )
6134 UFWORD(MT_RSTACK_LOAD
) {
6135 UfoState
*st
= ufoFindState(ufoPop());
6136 if (st
== NULL
) ufoFatal("unknown state");
6137 const uint32_t idx
= ufoPop();
6138 if (idx
>= st
->RP
- st
->RPTop
) ufoFatal("invalid stack index %u (%u)", idx
, st
->RP
- st
->RPTop
);
6139 ufoPush(st
->dStack
[st
->RP
- idx
- 1u]);
6143 // ( idx stid -- value )
6144 UFWORD(MT_LSTACK_LOAD
) {
6145 UfoState
*st
= ufoFindState(ufoPop());
6146 if (st
== NULL
) ufoFatal("unknown state");
6147 const uint32_t idx
= ufoPop();
6148 if (idx
>= st
->LP
) ufoFatal("invalid lstack index %u (%u)", idx
, st
->LP
);
6149 ufoPush(st
->lStack
[st
->LP
- idx
- 1u]);
6153 // ( value idx stid -- )
6154 UFWORD(MT_DSTACK_STORE
) {
6155 UfoState
*st
= ufoFindState(ufoPop());
6156 if (st
== NULL
) ufoFatal("unknown state");
6157 const uint32_t idx
= ufoPop();
6158 const uint32_t value
= ufoPop();
6159 if (idx
>= st
->SP
) ufoFatal("invalid stack index %u (%u)", idx
, st
->SP
);
6160 st
->dStack
[st
->SP
- idx
- 1u] = value
;
6164 // ( value idx stid -- )
6165 UFWORD(MT_RSTACK_STORE
) {
6166 UfoState
*st
= ufoFindState(ufoPop());
6167 if (st
== NULL
) ufoFatal("unknown state");
6168 const uint32_t idx
= ufoPop();
6169 const uint32_t value
= ufoPop();
6170 if (idx
>= st
->RP
- st
->RPTop
) ufoFatal("invalid stack index %u (%u)", idx
, st
->RP
- st
->RPTop
);
6171 st
->dStack
[st
->RP
- idx
- 1u] = value
;
6175 // ( value idx stid -- )
6176 UFWORD(MT_LSTACK_STORE
) {
6177 UfoState
*st
= ufoFindState(ufoPop());
6178 if (st
== NULL
) ufoFatal("unknown state");
6179 const uint32_t idx
= ufoPop();
6180 const uint32_t value
= ufoPop();
6181 if (idx
>= st
->LP
) ufoFatal("invalid stack index %u (%u)", idx
, st
->LP
);
6182 st
->dStack
[st
->LP
- idx
- 1u] = value
;
6186 #include "urforth_tty.c"
6189 // ////////////////////////////////////////////////////////////////////////// //
6193 //==========================================================================
6197 // create a new state, its execution will start from the given CFA.
6198 // state is not automatically activated.
6200 //==========================================================================
6201 static UfoState
*ufoNewState (void) {
6202 // find free state id
6204 uint32_t bmp
= ufoStateUsedBitmap
[0];
6205 while (fidx
!= (uint32_t)(UFO_MAX_STATES
/32) && bmp
== ~(uint32_t)0) {
6207 bmp
= ufoStateUsedBitmap
[fidx
];
6209 if (fidx
== (uint32_t)(UFO_MAX_STATES
/32)) ufoFatal("too many execution states");
6210 //fprintf(stderr, "NST:000: fidx=%u; bmp=0x%08x\n", fidx, bmp);
6212 while ((bmp
& 0x01) != 0) { fidx
+= 1u; bmp
>>= 1; }
6213 ufo_assert(fidx
< UFO_MAX_STATES
);
6214 ufo_assert((ufoStateUsedBitmap
[fidx
/ 32u] & ((uint32_t)1 << (fidx
& 0x1f))) == 0);
6215 ufo_assert(ufoStateMap
[fidx
] == NULL
);
6216 UfoState
*st
= calloc(1, sizeof(UfoState
));
6217 if (st
== NULL
) ufoFatal("out of memory for states");
6219 ufoStateMap
[fidx
] = st
;
6220 ufoStateUsedBitmap
[fidx
/ 32u] |= ((uint32_t)1 << (fidx
& 0x1f));
6221 //fprintf(stderr, "NST: fidx=%u; 0x%08x\n", fidx, ufoStateUsedBitmap[fidx / 32u]);
6226 //==========================================================================
6230 // free all memory used for the state, remove it from state list.
6231 // WARNING! never free current state!
6233 //==========================================================================
6234 static void ufoFreeState (UfoState
*st
) {
6236 if (st
== ufoCurrState
) ufoFatal("cannot free active state");
6237 if (ufoYieldedState
== st
) ufoYieldedState
= NULL
;
6238 if (ufoDebuggerState
== st
) ufoDebuggerState
= NULL
;
6239 const uint32_t fidx
= st
->id
- 1u;
6240 //fprintf(stderr, "FST: fidx=%u; 0x%08x\n", fidx, ufoStateUsedBitmap[fidx / 32u]);
6241 ufo_assert(fidx
< UFO_MAX_STATES
);
6242 ufo_assert((ufoStateUsedBitmap
[fidx
/ 32u] & (1u << (fidx
& 0x1f))) != 0);
6243 ufo_assert(ufoStateMap
[fidx
] == st
);
6244 // free default TIB handle
6245 UfoState
*oldst
= ufoCurrState
;
6247 const uint32_t tib
= ufoImgGetU32(ufoAddrDefTIB
);
6248 if ((tib
& UFO_ADDR_TEMP_BIT
) != 0) {
6249 UfoHandle
*tibh
= ufoGetHandle(tib
);
6250 if (tibh
!= NULL
) ufoFreeHandle(tibh
);
6252 ufoCurrState
= oldst
;
6254 if (st
->imageTemp
!= NULL
) free(st
->imageTemp
);
6256 ufoStateMap
[fidx
] = NULL
;
6257 ufoStateUsedBitmap
[fidx
/ 32u] &= ~((uint32_t)1 << (fidx
& 0x1f));
6262 //==========================================================================
6266 //==========================================================================
6267 static UfoState
*ufoFindState (uint32_t stid
) {
6268 UfoState
*res
= NULL
;
6269 if (stid
>= 0 && stid
<= UFO_MAX_STATES
) {
6272 ufo_assert(ufoCurrState
!= NULL
);
6273 stid
= ufoCurrState
->id
- 1u;
6277 res
= ufoStateMap
[stid
];
6279 ufo_assert((ufoStateUsedBitmap
[stid
/ 32u] & (1u << (stid
& 0x1f))) != 0);
6280 ufo_assert(res
->id
== stid
+ 1u);
6282 ufo_assert((ufoStateUsedBitmap
[stid
/ 32u] & (1u << (stid
& 0x1f))) == 0);
6289 //==========================================================================
6293 //==========================================================================
6294 static void ufoSwitchToState (UfoState
*newst
) {
6295 ufo_assert(newst
!= NULL
);
6296 if (newst
!= ufoCurrState
) {
6297 ufoCurrState
= newst
;
6303 // ////////////////////////////////////////////////////////////////////////// //
6304 // initial dictionary definitions
6309 #define UFWORD(name_) do { \
6310 const uint32_t xcfa_ = ufoCFAsUsed; \
6311 ufo_assert(xcfa_ < UFO_MAX_NATIVE_CFAS); \
6312 ufoForthCFAs[xcfa_] = &ufoWord_##name_; \
6314 ufoDefineNative(""#name_, xcfa_, 0); \
6317 #define UFWORDX(strname_,name_) do { \
6318 const uint32_t xcfa_ = ufoCFAsUsed; \
6319 ufo_assert(xcfa_ < UFO_MAX_NATIVE_CFAS); \
6320 ufoForthCFAs[xcfa_] = &ufoWord_##name_; \
6322 ufoDefineNative(strname_, xcfa_, 0); \
6325 #define UFWORD_IMM(name_) do { \
6326 const uint32_t xcfa_ = ufoCFAsUsed; \
6327 ufo_assert(xcfa_ < UFO_MAX_NATIVE_CFAS); \
6328 ufoForthCFAs[xcfa_] = &ufoWord_##name_; \
6330 ufoDefineNative(""#name_, xcfa_, 1); \
6333 #define UFWORDX_IMM(strname_,name_) do { \
6334 const uint32_t xcfa_ = ufoCFAsUsed; \
6335 ufo_assert(xcfa_ < UFO_MAX_NATIVE_CFAS); \
6336 ufoForthCFAs[xcfa_] = &ufoWord_##name_; \
6338 ufoDefineNative(strname_, xcfa_, 1); \
6341 #define UFC(name_) ufoImgEmitU32_NoInline(ufoFindWordChecked(name_))
6344 //==========================================================================
6346 // ufoFindWordChecked
6348 //==========================================================================
6349 UFO_DISABLE_INLINE
uint32_t ufoFindWordChecked (const char *wname
) {
6350 const uint32_t cfa
= ufoFindWord(wname
);
6351 if (cfa
== 0) ufoFatal("word '%s' not found", wname
);
6356 //==========================================================================
6360 // get "FORTH" vocid
6362 //==========================================================================
6363 uint32_t ufoGetForthVocId (void) {
6364 return ufoForthVocId
;
6368 //==========================================================================
6370 // ufoVocSetOnlyDefs
6372 //==========================================================================
6373 void ufoVocSetOnlyDefs (uint32_t vocid
) {
6374 ufoImgPutU32(ufoAddrCurrent
, vocid
);
6375 ufoImgPutU32(ufoAddrContext
, vocid
);
6379 //==========================================================================
6383 // return voc PFA (vocid)
6385 //==========================================================================
6386 uint32_t ufoCreateVoc (const char *wname
, uint32_t parentvocid
, uint32_t flags
) {
6387 // create wordlist struct
6388 // typeid, used by Forth code (structs and such)
6389 ufoImgEmitU32(0); // typeid
6390 // vocid points here, to "LATEST-LFA"
6391 const uint32_t vocid
= UFO_GET_DP();
6392 //fprintf(stderr, "NEW VOCID (%s): 0x%08x\n", wname, vocid);
6393 ufoImgEmitU32(0); // latest
6394 const uint32_t vlink
= UFO_GET_DP();
6395 if ((vocid
& UFO_ADDR_TEMP_BIT
) == 0) {
6396 ufoImgEmitU32(ufoImgGetU32(ufoAddrVocLink
)); // voclink
6397 ufoImgPutU32(ufoAddrVocLink
, vlink
); // update voclink
6402 ufoImgEmitU32(parentvocid
); // parent
6403 const uint32_t hdraddr
= UFO_GET_DP();
6404 ufoImgEmitU32(0); // word header
6405 // create empty hash table
6406 for (int f
= 0; f
< UFO_HASHTABLE_SIZE
; f
+= 1) ufoImgEmitU32(0);
6407 // update CONTEXT and CURRENT if this is the first wordlist ever
6408 if (ufoImgGetU32(ufoAddrContext
) == 0) {
6409 ufoImgPutU32(ufoAddrContext
, vocid
);
6411 if (ufoImgGetU32(ufoAddrCurrent
) == 0) {
6412 ufoImgPutU32(ufoAddrCurrent
, vocid
);
6414 // create word header
6415 if (wname
!= NULL
&& wname
[0] != 0) {
6417 uint32_t flags = ufoImgGetU32(ufoAddrNewWordFlags);
6419 //UFW_FLAG_IMMEDIATE|
6421 //UFW_FLAG_NORETURN|
6427 flags |= UFW_FLAG_VOCAB;
6429 flags
&= 0xffffff00u
;
6430 flags
|= UFW_FLAG_VOCAB
;
6431 ufoCreateWordHeader(wname
, flags
);
6432 const uint32_t cfa
= UFO_GET_DP();
6433 ufoImgEmitU32(ufoDoVocCFA
); // cfa
6434 ufoImgEmitU32(vocid
); // pfa
6435 // update vocab header pointer
6436 const uint32_t lfa
= UFO_CFA_TO_LFA(cfa
);
6437 ufoImgPutU32(hdraddr
, UFO_LFA_TO_NFA(lfa
));
6438 #ifdef UFO_DEBUG_DUMP_NEW_HEADERS
6439 ufoDumpWordHeader(lfa
);
6446 //==========================================================================
6450 //==========================================================================
6451 static void ufoSetLatestArgs (uint32_t warg
) {
6452 const uint32_t curr
= ufoImgGetU32(ufoAddrCurrent
);
6453 const uint32_t lfa
= ufoImgGetU32(curr
);
6454 const uint32_t nfa
= UFO_LFA_TO_NFA(lfa
);
6455 uint32_t flags
= ufoImgGetU32(nfa
);
6456 //fprintf(stderr, "OLD FLAGS: 0x%08x\n", flags);
6457 flags
&= ~UFW_WARG_MASK
;
6458 flags
|= warg
& UFW_WARG_MASK
;
6459 //fprintf(stderr, "NEW FLAGS: 0x%08x\n", flags);
6460 ufoImgPutU32(nfa
, flags
);
6461 #ifdef UFO_DEBUG_DUMP_NEW_HEADERS
6462 ufoDumpWordHeader(lfa
);
6467 //==========================================================================
6471 //==========================================================================
6472 static void ufoDefineNative (const char *wname
, uint32_t cfaidx
, int immed
) {
6473 cfaidx
|= UFO_ADDR_CFA_BIT
;
6474 uint32_t flags
= ufoImgGetU32(ufoAddrNewWordFlags
);
6476 //UFW_FLAG_IMMEDIATE|
6478 //UFW_FLAG_NORETURN|
6484 if (immed
) flags
|= UFW_FLAG_IMMEDIATE
;
6485 ufoCreateWordHeader(wname
, flags
);
6486 ufoImgEmitU32(cfaidx
);
6490 //==========================================================================
6492 // ufoDefineConstant
6494 //==========================================================================
6495 static void ufoDefineConstant (const char *name
, uint32_t value
) {
6496 ufoDefineNative(name
, ufoDoConstCFA
, 0);
6497 ufoImgEmitU32(value
);
6501 //==========================================================================
6505 //==========================================================================
6506 static void ufoDefineUserVar (const char *name
, uint32_t addr
) {
6507 ufoDefineNative(name
, ufoDoUserVariableCFA
, 0);
6508 ufoImgEmitU32(addr
);
6512 //==========================================================================
6516 //==========================================================================
6518 static void ufoDefineVar (const char *name, uint32_t value) {
6519 ufoDefineNative(name, ufoDoVarCFA, 0);
6520 ufoImgEmitU32(value);
6525 //==========================================================================
6529 //==========================================================================
6531 static void ufoDefineDefer (const char *name, uint32_t value) {
6532 ufoDefineNative(name, ufoDoDeferCFA, 0);
6533 ufoImgEmitU32(value);
6538 //==========================================================================
6542 //==========================================================================
6543 static void ufoHiddenWords (void) {
6544 const uint32_t flags
= ufoImgGetU32(ufoAddrNewWordFlags
);
6545 ufoImgPutU32(ufoAddrNewWordFlags
, flags
| UFW_FLAG_HIDDEN
);
6549 //==========================================================================
6553 //==========================================================================
6554 static void ufoPublicWords (void) {
6555 const uint32_t flags
= ufoImgGetU32(ufoAddrNewWordFlags
);
6556 ufoImgPutU32(ufoAddrNewWordFlags
, flags
& ~UFW_FLAG_HIDDEN
);
6560 //==========================================================================
6564 //==========================================================================
6566 static void ufoDefineForth (const char *name) {
6567 ufoDefineNative(name, ufoDoForthCFA, 0);
6572 //==========================================================================
6574 // ufoDefineForthImm
6576 //==========================================================================
6578 static void ufoDefineForthImm (const char *name) {
6579 ufoDefineNative(name, ufoDoForthCFA, 1);
6584 //==========================================================================
6586 // ufoDefineForthHidden
6588 //==========================================================================
6590 static void ufoDefineForthHidden (const char *name) {
6591 const uint32_t flags = ufoImgGetU32(ufoAddrNewWordFlags);
6592 ufoImgPutU32(ufoAddrNewWordFlags, flags | UFW_FLAG_HIDDEN);
6593 ufoDefineNative(name, ufoDoForthCFA, 0);
6594 ufoImgPutU32(ufoAddrNewWordFlags, flags);
6599 //==========================================================================
6601 // ufoDefineSColonForth
6603 // create word suitable for scattered colon extension
6605 //==========================================================================
6606 static void ufoDefineSColonForth (const char *name
) {
6607 ufoDefineNative(name
, ufoDoForthCFA
, 0);
6608 // placeholder for scattered colon
6609 // it will compile two branches:
6610 // the first branch will jump to the first "..:" word (or over the two branches)
6611 // the second branch is never taken, and works as a pointer to the latest branch addr in the list
6612 // this way, each extension word will simply fix the last branch address, and update list tail
6613 // at the creation time, second branch points to the first branch
6614 UFC("FORTH:(BRANCH)");
6615 const uint32_t xjmp
= UFO_GET_DP();
6617 UFC("FORTH:(BRANCH)"); ufoImgEmitU32(xjmp
);
6618 ufoImgPutU32(xjmp
, UFO_GET_DP());
6622 //==========================================================================
6626 //==========================================================================
6627 UFO_FORCE_INLINE
void ufoDoneForth (void) {
6628 UFC("FORTH:(EXIT)");
6632 //==========================================================================
6636 // compile string literal, the same as QUOTE_IMM
6638 //==========================================================================
6639 static void ufoCompileStrLitEx (const char *str
, const uint32_t slen
) {
6640 if (str
== NULL
) str
= "";
6641 if (slen
> 255) ufoFatal("string literal too long");
6642 UFC("FORTH:(LITSTR8)");
6643 ufoImgEmitU8((uint8_t)slen
);
6644 for (size_t f
= 0; f
< slen
; f
+= 1) {
6645 ufoImgEmitU8(((const unsigned char *)str
)[f
]);
6652 //==========================================================================
6656 //==========================================================================
6658 static void ufoCompileStrLit (const char *str) {
6659 ufoCompileStrLitEx(str, (uint32_t)strlen(str));
6664 //==========================================================================
6668 //==========================================================================
6669 static void ufoCompileLit (uint32_t value
) {
6671 ufoImgEmitU32(value
);
6675 //==========================================================================
6679 //==========================================================================
6681 static void ufoCompileCFALit (const char *wname) {
6682 UFC("FORTH:(LITCFA)");
6683 const uint32_t cfa = ufoFindWordChecked(wname);
6689 //==========================================================================
6693 //==========================================================================
6694 static int ufoXStrEquCI (const char *word
, const char *text
, uint32_t tlen
) {
6695 while (tlen
!= 0 && *word
) {
6696 if (toUpper(*word
) != toUpper(*text
)) return 0;
6697 word
+= 1u; text
+= 1u; tlen
-= 1u;
6699 return (tlen
== 0 && *word
== 0);
6703 #define UFO_MAX_LABEL_NAME (63)
6704 typedef struct UfoLabel_t
{
6707 char name
[UFO_MAX_LABEL_NAME
];
6708 uint32_t addr
; // jump chain tail, or address
6710 uint32_t word
; // is this a forward word definition?
6711 struct UfoLabel_t
*next
;
6714 static UfoLabel
*ufoLabels
= NULL
;
6717 //==========================================================================
6719 // ufoFindAddLabelEx
6721 //==========================================================================
6722 static UfoLabel
*ufoFindAddLabelEx (const char *name
, uint32_t namelen
, int allowAdd
) {
6723 if (namelen
== 0 || namelen
> UFO_MAX_LABEL_NAME
) ufoFatal("invalid label name");
6724 const uint32_t hash
= joaatHashBufCI(name
, namelen
);
6725 UfoLabel
*lbl
= ufoLabels
;
6726 while (lbl
!= NULL
) {
6727 if (lbl
->hash
== hash
&& lbl
->namelen
== namelen
) {
6730 while (ok
&& sidx
!= namelen
) {
6731 ok
= (toUpper(name
[sidx
]) == toUpper(lbl
->name
[sidx
]));
6740 lbl
= calloc(1, sizeof(UfoLabel
));
6742 lbl
->namelen
= namelen
;
6743 memcpy(lbl
->name
, name
, namelen
);
6744 lbl
->name
[namelen
] = 0;
6745 lbl
->next
= ufoLabels
;
6754 //==========================================================================
6758 //==========================================================================
6759 static UfoLabel
*ufoFindAddLabel (const char *name
, uint32_t namelen
) {
6760 return ufoFindAddLabelEx(name
, namelen
, 1);
6764 //==========================================================================
6768 //==========================================================================
6769 static UfoLabel
*ufoFindLabel (const char *name
, uint32_t namelen
) {
6770 return ufoFindAddLabelEx(name
, namelen
, 0);
6774 //==========================================================================
6776 // ufoTrySimpleNumber
6778 // only decimal and C-like hexes; with an optional sign
6780 //==========================================================================
6781 static int ufoTrySimpleNumber (const char *text
, uint32_t tlen
, uint32_t *num
) {
6784 if (tlen
!= 0 && *text
== '+') { text
+= 1u; tlen
-= 1u; }
6785 else if (tlen
!= 0 && *text
== '-') { neg
= 1; text
+= 1u; tlen
-= 1u; }
6787 int base
= 10; // default base
6788 if (tlen
> 2 && text
[0] == '0' && toUpper(text
[1]) == 'X') {
6791 text
+= 2u; tlen
-= 2u;
6794 if (tlen
== 0 || digitInBase(*text
, base
) < 0) return 0;
6801 if (!wasDigit
) return 0;
6804 dig
= digitInBase(*text
, base
);
6805 if (dig
< 0) return 0;
6807 n
= n
* (uint32_t)base
+ (uint32_t)dig
;
6809 text
+= 1u; tlen
-= 1u;
6812 if (!wasDigit
) return 0;
6813 if (neg
) n
= ~n
+ 1u;
6819 //==========================================================================
6821 // ufoEmitLabelChain
6823 //==========================================================================
6824 static void ufoEmitLabelChain (UfoLabel
*lbl
) {
6825 ufo_assert(lbl
!= NULL
);
6826 ufo_assert(lbl
->defined
== 0);
6827 const uint32_t here
= UFO_GET_DP();
6828 ufoImgEmitU32(lbl
->addr
);
6833 //==========================================================================
6835 // ufoFixLabelChainHere
6837 //==========================================================================
6838 static void ufoFixLabelChainHere (UfoLabel
*lbl
) {
6839 ufo_assert(lbl
!= NULL
);
6840 ufo_assert(lbl
->defined
== 0);
6841 const uint32_t here
= UFO_GET_DP();
6842 while (lbl
->addr
!= 0) {
6843 const uint32_t aprev
= ufoImgGetU32(lbl
->addr
);
6844 ufoImgPutU32(lbl
->addr
, here
);
6852 #define UFO_MII_WORD_COMPILE_IMM (-4)
6853 #define UFO_MII_WORD_CFA_LIT (-3)
6854 #define UFO_MII_WORD_COMPILE (-2)
6855 #define UFO_MII_IN_WORD (-1)
6856 #define UFO_MII_NO_WORD (0)
6857 #define UFO_MII_WORD_NAME (1)
6858 #define UFO_MII_WORD_NAME_IMM (2)
6859 #define UFO_MII_WORD_NAME_HIDDEN (3)
6861 static int ufoMinInterpState
= UFO_MII_NO_WORD
;
6864 //==========================================================================
6866 // ufoFinalLabelCheck
6868 //==========================================================================
6869 static void ufoFinalLabelCheck (void) {
6871 if (ufoMinInterpState
!= UFO_MII_NO_WORD
) {
6872 ufoFatal("missing semicolon");
6874 while (ufoLabels
!= NULL
) {
6875 UfoLabel
*lbl
= ufoLabels
; ufoLabels
= lbl
->next
;
6876 if (!lbl
->defined
) {
6877 fprintf(stderr
, "UFO ERROR: label '%s' is not defined!\n", lbl
->name
);
6882 if (errorCount
!= 0) {
6883 ufoFatal("%d undefined label%s", errorCount
, (errorCount
!= 1 ? "s" : ""));
6888 //==========================================================================
6892 // this is so i could write Forth definitions more easily
6895 // $name -- reference
6896 // $name: -- definition
6898 //==========================================================================
6899 UFO_DISABLE_INLINE
void ufoInterpretLine (const char *line
) {
6900 char wname
[UFO_MAX_WORD_LENGTH
];
6901 uint32_t wlen
, num
, cfa
;
6904 if (*(const unsigned char *)line
<= 32) {
6906 } else if (ufoMinInterpState
== UFO_MII_WORD_CFA_LIT
||
6907 ufoMinInterpState
== UFO_MII_WORD_COMPILE
||
6908 ufoMinInterpState
== UFO_MII_WORD_COMPILE_IMM
)
6910 // "[']"/"COMPILE"/"[COMPILE]" argument
6912 while (((const unsigned char *)line
)[wlen
] > 32) wlen
+= 1;
6913 if (wlen
>= UFO_MAX_WORD_LENGTH
) ufoFatal("word name too long");
6914 memcpy(wname
, line
, wlen
);
6916 switch (ufoMinInterpState
) {
6917 case UFO_MII_WORD_CFA_LIT
: UFC("FORTH:(LITCFA)"); break;
6918 case UFO_MII_WORD_COMPILE
: UFC("FORTH:(LITCFA)"); break;
6919 case UFO_MII_WORD_COMPILE_IMM
: break;
6920 default: ufo_assert(0);
6922 cfa
= ufoFindWord(wname
);
6926 // forward reference
6927 lbl
= ufoFindAddLabel(line
, wlen
);
6928 if (lbl
->defined
|| (lbl
->word
== 0 && lbl
->addr
)) {
6929 ufoFatal("unknown word: '%s'", wname
);
6932 ufoEmitLabelChain(lbl
);
6934 switch (ufoMinInterpState
) {
6935 case UFO_MII_WORD_CFA_LIT
: break;
6936 case UFO_MII_WORD_COMPILE
: UFC("FORTH:COMPILE,"); break;
6937 case UFO_MII_WORD_COMPILE_IMM
: break;
6938 default: ufo_assert(0);
6940 ufoMinInterpState
= UFO_MII_IN_WORD
;
6942 } else if (ufoMinInterpState
> UFO_MII_NO_WORD
) {
6945 while (((const unsigned char *)line
)[wlen
] > 32) wlen
+= 1;
6946 if (wlen
>= UFO_MAX_WORD_LENGTH
) ufoFatal("word name too long");
6947 if (wlen
> 2 && line
[0] == ':' && line
[wlen
- 1u] == ':') ufoFatal("invalid word name");
6948 memcpy(wname
, line
, wlen
);
6950 const uint32_t oldFlags
= ufoImgGetU32(ufoAddrNewWordFlags
);
6951 if (ufoMinInterpState
== UFO_MII_WORD_NAME_HIDDEN
) {
6952 ufoImgPutU32(ufoAddrNewWordFlags
, oldFlags
| UFW_FLAG_HIDDEN
);
6954 ufoDefineNative(wname
, ufoDoForthCFA
, (ufoMinInterpState
== UFO_MII_WORD_NAME_IMM
));
6955 ufoImgPutU32(ufoAddrNewWordFlags
, oldFlags
);
6956 ufoMinInterpState
= UFO_MII_IN_WORD
;
6957 // check for forward references
6958 lbl
= ufoFindLabel(line
, wlen
);
6960 if (lbl
->defined
|| !lbl
->word
) {
6961 ufoFatal("label/word conflict for '%.*s'", (unsigned)wlen
, line
);
6963 ufoFixLabelChainHere(lbl
);
6966 } else if ((line
[0] == ';' && line
[1] == ';') ||
6967 (line
[0] == '-' && line
[1] == '-') ||
6968 (line
[0] == '/' && line
[1] == '/') ||
6969 (line
[0] == '\\' && ((const unsigned char *)line
)[1] <= 32))
6971 ufoFatal("do not use single-line comments");
6972 } else if (line
[0] == '(' && ((const unsigned char *)line
)[1] <= 32) {
6973 while (*line
&& *line
!= ')') line
+= 1;
6974 if (*line
== ')') line
+= 1;
6978 while (((const unsigned char *)line
)[wlen
] > 32) wlen
+= 1;
6979 if (wlen
== 1 && (line
[0] == '"' || line
[0] == '`')) {
6981 const char qch
= line
[0];
6982 if (!line
[1]) ufoFatal("unterminated string literal");
6983 // skip quote and space
6984 if (((const unsigned char *)line
)[1] <= 32) line
+= 2u; else line
+= 1u;
6986 while (line
[wlen
] && line
[wlen
] != qch
) wlen
+= 1u;
6987 if (line
[wlen
] != qch
) ufoFatal("unterminated string literal");
6988 ufoCompileStrLitEx(line
, wlen
);
6989 line
+= wlen
+ 1u; // skip final quote
6990 } else if (wlen
== 1 && line
[0] == ':') {
6992 if (ufoMinInterpState
!= UFO_MII_NO_WORD
) ufoFatal("unexpected colon");
6993 ufoMinInterpState
= UFO_MII_WORD_NAME
;
6995 } else if (wlen
== 1 && line
[0] == ';') {
6997 if (ufoMinInterpState
!= UFO_MII_IN_WORD
) ufoFatal("unexpected semicolon");
6998 ufoImgEmitU32(ufoFindWordChecked("FORTH:(EXIT)"));
6999 ufoMinInterpState
= UFO_MII_NO_WORD
;
7001 } else if (wlen
== 2 && line
[0] == '!' && line
[1] == ':') {
7002 // new immediate word
7003 if (ufoMinInterpState
!= UFO_MII_NO_WORD
) ufoFatal("unexpected colon");
7004 ufoMinInterpState
= UFO_MII_WORD_NAME_IMM
;
7006 } else if (wlen
== 2 && line
[0] == '*' && line
[1] == ':') {
7008 if (ufoMinInterpState
!= UFO_MII_NO_WORD
) ufoFatal("unexpected colon");
7009 ufoMinInterpState
= UFO_MII_WORD_NAME_HIDDEN
;
7011 } else if (wlen
== 3 && memcmp(line
, "[']", 3) == 0) {
7013 if (ufoMinInterpState
!= UFO_MII_IN_WORD
) ufoFatal("unexpected immediate tick");
7014 ufoMinInterpState
= UFO_MII_WORD_CFA_LIT
;
7016 } else if (wlen
== 7 && ufoXStrEquCI("COMPILE", line
, wlen
)) {
7018 if (ufoMinInterpState
!= UFO_MII_IN_WORD
) ufoFatal("unexpected immediate tick");
7019 ufoMinInterpState
= UFO_MII_WORD_COMPILE
;
7021 } else if (wlen
== 9 && ufoXStrEquCI("[COMPILE]", line
, wlen
)) {
7023 if (ufoMinInterpState
!= UFO_MII_IN_WORD
) ufoFatal("unexpected immediate tick");
7024 ufoMinInterpState
= UFO_MII_WORD_COMPILE_IMM
;
7028 if (wlen
>= UFO_MAX_WORD_LENGTH
) ufoFatal("word name too long");
7029 memcpy(wname
, line
, wlen
);
7031 cfa
= ufoFindWord(wname
);
7035 } else if (ufoTrySimpleNumber(line
, wlen
, &num
)) {
7036 // compile numeric literal
7039 // unknown word, this may be a forward reference, or a label definition
7040 // label defintion starts with "$"
7041 // (there are no words starting with "$" in the initial image)
7042 if (line
[0] == '$') {
7043 if (wlen
== 1) ufoFatal("dollar what?");
7044 if (wlen
> 2 && line
[wlen
- 1u] == ':') {
7046 lbl
= ufoFindAddLabel(line
, wlen
- 1u);
7047 if (lbl
->defined
) ufoFatal("double label '%s' definition", lbl
->name
);
7048 ufoFixLabelChainHere(lbl
);
7051 lbl
= ufoFindAddLabel(line
, wlen
);
7053 ufoImgEmitU32(lbl
->addr
);
7055 ufoEmitLabelChain(lbl
);
7059 // forward reference
7060 lbl
= ufoFindAddLabel(line
, wlen
);
7061 if (lbl
->defined
|| (lbl
->word
== 0 && lbl
->addr
)) {
7062 ufoFatal("unknown word: '%s'", wname
);
7065 ufoEmitLabelChain(lbl
);
7075 //==========================================================================
7079 //==========================================================================
7080 UFO_DISABLE_INLINE
void ufoReset (void) {
7081 if (ufoCurrState
== NULL
) ufoFatal("no active execution state");
7083 ufoSP
= 0; ufoRP
= 0;
7084 ufoLP
= 0; ufoLBP
= 0;
7087 ufoVMStop
= 0; ufoVMAbort
= 0;
7092 const uint32_t tib
= ufoImgGetU32(ufoAddrTIBx
);
7093 const uint32_t tibDef
= ufoImgGetU32(ufoAddrDefTIB
);
7094 ufoInitStateUserVars(ufoCurrState
, 0);
7096 ufoImgPutU32(ufoAddrTIBx
, tib
);
7097 ufoImgPutU32(ufoAddrDefTIB
, tibDef
);
7098 ufoImgPutU32(ufoAddrRedefineWarning
, UFO_REDEF_WARN_NORMAL
);
7101 ufoImgPutU32(ufoAddrDPTemp
, 0);
7103 ufoImgPutU32(ufoAddrNewWordFlags
, 0);
7104 ufoVocSetOnlyDefs(ufoForthVocId
);
7108 //==========================================================================
7110 // ufoDefineEmitType
7112 //==========================================================================
7113 UFO_DISABLE_INLINE
void ufoDefineEmitType (void) {
7116 ufoInterpretLine(": EMIT ( ch -- ) (NORM-EMIT-CHAR) (EMIT) ;");
7120 ufoInterpretLine(": XEMIT ( ch -- ) (NORM-XEMIT-CHAR) (EMIT) ;");
7124 ufoInterpretLine(": CR ( -- ) NL (EMIT) ;");
7130 " LASTCR? FORTH:(TBRANCH) $endcr-exit CR "
7133 //ufoDecompileWord(ufoFindWordChecked("ENDCR"));
7137 ufoInterpretLine(": SPACE ( -- ) BL (EMIT) ;");
7142 ": SPACES ( count -- ) "
7144 " DUP 0> FORTH:(0BRANCH) $spaces-exit "
7146 " FORTH:(BRANCH) $spaces-again "
7152 // ( addr count -- )
7154 ": TYPE ( addr count -- ) "
7157 " DUP 0> FORTH:(0BRANCH) $type-exit "
7160 " FORTH:(BRANCH) $type-again "
7166 // ( addr count -- )
7168 ": XTYPE ( addr count -- ) "
7171 " DUP 0> FORTH:(0BRANCH) $xtype-exit "
7174 " FORTH:(BRANCH) $xtype-again "
7182 ": HERE ( -- here ) "
7183 " FORTH:(DP-TEMP) @ ?DUP "
7184 " FORTH:(TBRANCH) $here-exit "
7192 ": ALIGN-HERE ( -- ) "
7193 "$align-here-loop: "
7195 " FORTH:(0BRANCH) $align-here-exit "
7197 " FORTH:(BRANCH) $align-here-loop "
7198 "$align-here-exit: "
7202 // ( C:addr count -- ) ( E: -- addr count )
7204 ": STRLITERAL ( C:addr count -- ) ( E: -- addr count ) "
7205 " DUP 255 U> ` string literal too long` ?ERROR "
7206 " STATE @ FORTH:(0BRANCH) $strlit-exit "
7208 " ['] FORTH:(LITSTR8) COMPILE, "
7210 " ( compile length ) "
7212 " ( compile chars ) "
7214 " DUP 0<> FORTH:(0BRANCH) $strlit-loop-exit "
7216 " FORTH:(BRANCH) $strlit-loop "
7217 "$strlit-loop-exit: "
7219 " ( final 0: our counter is 0 here, so use it ) "
7225 // ( -- addr count )
7227 "!: \" ( -- addr count ) "
7228 " 34 PARSE ` string literal expected` ?NOT-ERROR "
7229 " COMPILER:(UNESCAPE) STRLITERAL "
7234 //==========================================================================
7236 // ufoDefineInterpret
7238 // define "INTERPRET" in Forth
7240 //==========================================================================
7241 UFO_DISABLE_INLINE
void ufoDefineInterpret (void) {
7242 UFWORDX("(UFO-INTERPRET-FINISHED-ACTION)", UFO_INTERPRET_FINISHED_ACTION
);
7244 // return "stop flag"
7246 "*: (UFO-INTERPRET-NEXT-LINE) ( -- continue? ) "
7247 " STATE @ FORTH:(TBRANCH) $ipn_incomp "
7248 " ( interpreter allowed to cross include boundary ) "
7249 " REFILL FORTH:(BRANCH) $ipn_done "
7251 " ( compiler is not allowed to cross include boundary ) "
7252 " REFILL-NOCROSS ` compiler cannot cross file boundaries` ?NOT-ERROR "
7257 ufoInterpNextLineCFA
= ufoFindWordChecked("FORTH:(UFO-INTERPRET-NEXT-LINE)");
7258 ufoInterpretLine("*: (INTERPRET-NEXT-LINE) (USER-INTERPRET-NEXT-LINE) @ EXECUTE-TAIL ;");
7260 // skip comments, parse name, refilling lines if necessary
7261 // returning FALSE as counter means: "no addr, exit INTERPRET"
7263 "*: (INTERPRET-PARSE-NAME) ( -- addr count / FALSE ) "
7264 "$label_ipn_again: "
7265 " TRUE (PARSE-SKIP-COMMENTS) PARSE-NAME "
7266 " DUP FORTH:(TBRANCH) $label_ipn_exit_fwd "
7267 " 2DROP (INTERPRET-NEXT-LINE) "
7268 " FORTH:(TBRANCH) $label_ipn_again "
7270 "$label_ipn_exit_fwd: "
7272 //ufoDecompileWord(ufoFindWordChecked("(INTERPRET-PARSE-NAME)"));
7277 " FORTH:(INTERPRET-PARSE-NAME) ( addr count / FALSE )"
7278 " ?DUP FORTH:(0BRANCH) $interp-done "
7279 " ( try defered checker ) "
7280 " ( addr count FALSE -- addr count FALSE / TRUE ) "
7281 " FALSE (INTERPRET-CHECK-WORD) FORTH:(TBRANCH) $interp-again "
7282 " 2DUP FIND-WORD ( addr count cfa TRUE / addr count FALSE ) "
7283 " FORTH:(0BRANCH) $interp-try-number "
7285 " NROT 2DROP ( drop word string ) "
7286 " STATE @ FORTH:(0BRANCH) $interp-exec "
7287 " ( compiling; check immediate bit ) "
7288 " DUP CFA->NFA @ COMPILER:(WFLAG-IMMEDIATE) AND FORTH:(TBRANCH) $interp-exec "
7290 " FORTH:COMPILE, FORTH:(BRANCH) $interp-again "
7293 " EXECUTE FORTH:(BRANCH) $interp-again "
7294 " ( not a word, try a number ) "
7295 "$interp-try-number: "
7296 " 2DUP TRUE BASE @ (BASED-NUMBER) ( addr count allowsign? base -- num TRUE / FALSE ) "
7297 " FORTH:(0BRANCH) $interp-number-error "
7299 " NROT 2DROP ( drop word string ) "
7300 " ( do we need to compile it? ) "
7301 " STATE @ FORTH:(0BRANCH) $interp-again "
7302 " COMPILE FORTH:(LIT) FORTH:, "
7303 " FORTH:(BRANCH) $interp-again "
7305 "$interp-number-error: "
7306 " ( addr count FALSE -- addr count FALSE / TRUE ) "
7307 " FALSE (INTERPRET-WORD-NOT-FOUND) FORTH:(TBRANCH) $interp-again "
7308 " ENDCR SPACE XTYPE ` -- wut?` TYPE CR "
7309 " ` unknown word` ERROR "
7312 //ufoDecompileWord(ufoFindWordChecked("INTERPRET"));
7316 //==========================================================================
7320 //==========================================================================
7321 UFO_DISABLE_INLINE
void ufoInitBaseDict (void) {
7322 uint32_t imgAddr
= 0;
7324 // reserve 32 bytes for nothing
7325 for (uint32_t f
= 0; f
< 32; f
+= 1) {
7326 ufoImgPutU8(imgAddr
, 0);
7330 while ((imgAddr
& 3) != 0) {
7331 ufoImgPutU8(imgAddr
, 0);
7336 ufoAddrDP
= imgAddr
;
7337 ufoImgPutU32(imgAddr
, 0); imgAddr
+= 4u;
7340 ufoAddrDPTemp
= imgAddr
;
7341 ufoImgPutU32(imgAddr
, 0); imgAddr
+= 4u;
7344 ufoAddrLastXFA
= imgAddr
;
7345 ufoImgPutU32(imgAddr
, 0); imgAddr
+= 4u;
7348 ufoAddrVocLink
= imgAddr
;
7349 ufoImgPutU32(imgAddr
, 0); imgAddr
+= 4u;
7352 ufoAddrNewWordFlags
= imgAddr
;
7353 ufoImgPutU32(imgAddr
, UFW_FLAG_PROTECTED
); imgAddr
+= 4u;
7355 // WORD-REDEFINE-WARN-MODE
7356 ufoAddrRedefineWarning
= imgAddr
;
7357 ufoImgPutU32(imgAddr
, UFO_REDEF_WARN_NORMAL
); imgAddr
+= 4u;
7359 // setup (DP) and (DP-TEMP)
7360 ufoImgPutU32(ufoAddrDP
, imgAddr
);
7361 ufoImgPutU32(ufoAddrDPTemp
, 0);
7364 fprintf(stderr
, "INITIAL HERE: 0x%08x (0x%08x)\n", imgAddr
, UFO_GET_DP());
7369 //==========================================================================
7371 // ufoInitStateUserVars
7373 //==========================================================================
7374 static void ufoInitStateUserVars (UfoState
*st
, uint32_t cfa
) {
7375 ufo_assert(st
!= NULL
);
7376 if (st
->imageTempSize
< 8192u) {
7377 uint32_t *itmp
= realloc(st
->imageTemp
, 8192);
7378 if (itmp
== NULL
) ufoFatal("out of memory for state user area");
7379 st
->imageTemp
= itmp
;
7380 memset((uint8_t *)st
->imageTemp
+ st
->imageTempSize
, 0, 8192u - st
->imageTempSize
);
7381 st
->imageTempSize
= 8192;
7383 st
->imageTemp
[(ufoAddrBASE
& UFO_ADDR_TEMP_MASK
) / 4u] = 10;
7384 st
->imageTemp
[(ufoAddrSTATE
& UFO_ADDR_TEMP_MASK
) / 4u] = 0;
7385 st
->imageTemp
[(ufoAddrUserVarUsed
& UFO_ADDR_TEMP_MASK
) / 4u] = ufoAddrUserVarUsed
;
7386 st
->imageTemp
[(ufoAddrDefTIB
& UFO_ADDR_TEMP_MASK
) / 4u] = UFO_DEF_TIB_ADDR
;
7387 st
->imageTemp
[(ufoAddrTIBx
& UFO_ADDR_TEMP_MASK
) / 4u] = UFO_DEF_TIB_ADDR
;
7388 st
->imageTemp
[(ufoAddrINx
& UFO_ADDR_TEMP_MASK
) / 4u] = 0;
7389 st
->imageTemp
[(ufoAddrContext
& UFO_ADDR_TEMP_MASK
) / 4u] = ufoForthVocId
;
7390 st
->imageTemp
[(ufoAddrCurrent
& UFO_ADDR_TEMP_MASK
) / 4u] = ufoForthVocId
;
7391 st
->imageTemp
[(ufoAddrSelf
& UFO_ADDR_TEMP_MASK
) / 4u] = 0;
7392 st
->imageTemp
[(ufoAddrInterNextLine
& UFO_ADDR_TEMP_MASK
) / 4u] = ufoInterpNextLineCFA
;
7393 st
->imageTemp
[(ufoAddrEP
& UFO_ADDR_TEMP_MASK
) / 4u] = 0;
7394 // init other things, because this procedure is used in `ufoReset()` too
7395 st
->SP
= 0; st
->RP
= 0; st
->RPTop
= 0; st
->regA
= 0;
7396 st
->LP
= 0; st
->LBP
= 0; st
->vmRPopCFA
= 0;
7401 st
->rStack
[0] = 0xdeadf00d; // dummy value
7402 st
->rStack
[1] = cfa
;
7408 //==========================================================================
7410 // ufoInitBasicWords
7412 //==========================================================================
7413 UFO_DISABLE_INLINE
void ufoInitBasicWords (void) {
7414 ufoDefineConstant("FALSE", 0);
7415 ufoDefineConstant("TRUE", ufoTrueValue
);
7417 ufoDefineConstant("BL", 32);
7418 ufoDefineConstant("NL", 10);
7421 ufoDefineUserVar("BASE", ufoAddrBASE
);
7422 ufoDefineUserVar("TIB", ufoAddrTIBx
);
7423 ufoDefineUserVar(">IN", ufoAddrINx
);
7424 ufoDefineUserVar("(STD-TIB-ADDR)", ufoAddrDefTIB
);
7425 ufoDefineUserVar("(USER-VAR-USED)", ufoAddrUserVarUsed
);
7426 ufoDefineConstant("(USER-VAR-ADDR)", UFO_ADDR_TEMP_BIT
);
7427 ufoDefineConstant("(USER-VAR-SIZE)", UFO_USER_AREA_SIZE
);
7428 ufoDefineConstant("(USER-TIB)", UFO_DEF_TIB_ADDR
);
7429 ufoDefineConstant("(USER-TIB-SIZE)", UFO_ADDR_HANDLE_OFS_MASK
);
7431 ufoDefineUserVar("STATE", ufoAddrSTATE
);
7432 ufoDefineConstant("CONTEXT", ufoAddrContext
);
7433 ufoDefineConstant("CURRENT", ufoAddrCurrent
);
7434 ufoDefineConstant("(SELF)", ufoAddrSelf
); // used in OOP implementations
7435 ufoDefineConstant("(USER-INTERPRET-NEXT-LINE)", ufoAddrInterNextLine
);
7436 ufoDefineConstant("(EXC-FRAME-PTR)", ufoAddrEP
);
7439 ufoDefineConstant("(LATEST-XFA)", ufoAddrLastXFA
);
7440 ufoDefineConstant("(VOC-LINK)", ufoAddrVocLink
);
7441 ufoDefineConstant("(NEW-WORD-FLAGS)", ufoAddrNewWordFlags
);
7442 ufoDefineConstant("(ADDR-TEMP-BIT)", UFO_ADDR_TEMP_BIT
);
7443 ufoDefineConstant("(ADDR-CFA-BIT)", UFO_ADDR_CFA_BIT
);
7444 ufoDefineConstant("(ADDR-HANDLE-BIT)", UFO_ADDR_HANDLE_BIT
);
7445 ufoDefineConstant("(MAX-HANDLE-OFS)", UFO_ADDR_HANDLE_OFS_MASK
);
7447 ufoDefineConstant("(PAD-ADDR)", UFO_PAD_ADDR
);
7448 ufoDefineConstant("(#BUF)", UFO_NBUF_ADDR
+ 4u); // reserve room for counter
7449 ufoDefineConstant("(#BUF-SIZE)", UFO_NBUF_SIZE
- 8u);
7451 ufoDefineConstant("(DP)", ufoAddrDP
);
7452 ufoDefineConstant("(DP-TEMP)", ufoAddrDPTemp
);
7455 //UFWORDX("(UFO-BUCKET-STATS)", PAR_UFO_BUCKET_STATS);
7456 UFWORDX("SP0!", SP0_STORE
);
7457 UFWORDX("RP0!", RP0_STORE
);
7459 UFWORDX("PAD", PAD
);
7462 UFWORDX("C@", CPEEK
);
7463 UFWORDX("W@", WPEEK
);
7466 UFWORDX("C!", CPOKE
);
7467 UFWORDX("W!", WPOKE
);
7469 UFWORDX(",", COMMA
);
7470 UFWORDX("C,", CCOMMA
);
7471 UFWORDX("W,", WCOMMA
);
7473 UFWORDX("A>", REGA_LOAD
);
7474 UFWORDX(">A", REGA_STORE
);
7475 UFWORDX("A-SWAP", REGA_SWAP
);
7476 UFWORDX("+1>A", REGA_INC
);
7477 UFWORDX("+4>A", REGA_INC_CELL
);
7478 UFWORDX("A>R", REGA_TO_R
);
7479 UFWORDX("R>A", R_TO_REGA
);
7481 UFWORDX("@A+", PEEK_REGA_IDX
);
7482 UFWORDX("C@A+", CPEEK_REGA_IDX
);
7483 UFWORDX("W@A+", WPEEK_REGA_IDX
);
7485 UFWORDX("!A+", POKE_REGA_IDX
);
7486 UFWORDX("C!A+", CPOKE_REGA_IDX
);
7487 UFWORDX("W!A+", WPOKE_REGA_IDX
);
7490 UFWORDX("(LIT)", PAR_LIT
); ufoSetLatestArgs(UFW_WARG_LIT
);
7491 UFWORDX("(LITCFA)", PAR_LITCFA
); ufoSetLatestArgs(UFW_WARG_CFA
);
7492 UFWORDX("(LITVOCID)", PAR_LITVOCID
); ufoSetLatestArgs(UFW_WARG_VOCID
);
7493 UFWORDX("(LITSTR8)", PAR_LITSTR8
); ufoSetLatestArgs(UFW_WARG_C1STRZ
);
7494 UFWORDX("(EXIT)", PAR_EXIT
);
7496 ufoLitStr8CFA
= ufoFindWordChecked("FORTH:(LITSTR8)");
7498 UFWORDX("(L-ENTER)", PAR_LENTER
); ufoSetLatestArgs(UFW_WARG_LIT
);
7499 UFWORDX("(L-LEAVE)", PAR_LLEAVE
);
7500 UFWORDX("(LOCAL@)", PAR_LOCAL_LOAD
);
7501 UFWORDX("(LOCAL!)", PAR_LOCAL_STORE
);
7503 UFWORDX("(BRANCH)", PAR_BRANCH
); ufoSetLatestArgs(UFW_WARG_BRANCH
);
7504 UFWORDX("(TBRANCH)", PAR_TBRANCH
); ufoSetLatestArgs(UFW_WARG_BRANCH
);
7505 UFWORDX("(0BRANCH)", PAR_0BRANCH
); ufoSetLatestArgs(UFW_WARG_BRANCH
);
7506 UFWORDX("(+0BRANCH)", PAR_P0BRANCH
); ufoSetLatestArgs(UFW_WARG_BRANCH
);
7507 UFWORDX("(+BRANCH)", PAR_PBRANCH
); ufoSetLatestArgs(UFW_WARG_BRANCH
);
7508 UFWORDX("(-0BRANCH)", PAR_M0BRANCH
); ufoSetLatestArgs(UFW_WARG_BRANCH
);
7509 UFWORDX("(-BRANCH)", PAR_MBRANCH
); ufoSetLatestArgs(UFW_WARG_BRANCH
);
7514 //==========================================================================
7516 // ufoInitBasicCompilerWords
7518 //==========================================================================
7519 UFO_DISABLE_INLINE
void ufoInitBasicCompilerWords (void) {
7520 // create "COMPILER" vocabulary
7521 ufoCompilerVocId
= ufoCreateVoc("COMPILER", 0, UFW_FLAG_PROTECTED
);
7522 ufoVocSetOnlyDefs(ufoCompilerVocId
);
7524 ufoDefineConstant("(CFAIDX-DO-FORTH)", ufoDoForthCFA
);
7525 ufoDefineConstant("(CFAIDX-DO-VAR)", ufoDoVariableCFA
);
7526 ufoDefineConstant("(CFAIDX-DO-VALUE)", ufoDoValueCFA
);
7527 ufoDefineConstant("(CFAIDX-DO-CONST)", ufoDoConstCFA
);
7528 ufoDefineConstant("(CFAIDX-DO-DEFER)", ufoDoDeferCFA
);
7529 ufoDefineConstant("(CFAIDX-DO-VOC)", ufoDoVocCFA
);
7530 ufoDefineConstant("(CFAIDX-DO-CREATE)", ufoDoCreateCFA
);
7531 ufoDefineConstant("(CFAIDX-DO-USER-VAR)", ufoDoUserVariableCFA
);
7533 ufoDefineConstant("(WFLAG-IMMEDIATE)", UFW_FLAG_IMMEDIATE
);
7534 ufoDefineConstant("(WFLAG-SMUDGE)", UFW_FLAG_SMUDGE
);
7535 ufoDefineConstant("(WFLAG-NORETURN)", UFW_FLAG_NORETURN
);
7536 ufoDefineConstant("(WFLAG-HIDDEN)", UFW_FLAG_HIDDEN
);
7537 ufoDefineConstant("(WFLAG-CBLOCK)", UFW_FLAG_CBLOCK
);
7538 ufoDefineConstant("(WFLAG-VOCAB)", UFW_FLAG_VOCAB
);
7539 ufoDefineConstant("(WFLAG-SCOLON)", UFW_FLAG_SCOLON
);
7540 ufoDefineConstant("(WFLAG-PROTECTED)", UFW_FLAG_PROTECTED
);
7542 ufoDefineConstant("(WARG-MASK)", UFW_WARG_MASK
);
7543 ufoDefineConstant("(WARG-NONE)", UFW_WARG_NONE
);
7544 ufoDefineConstant("(WARG-BRANCH)", UFW_WARG_BRANCH
);
7545 ufoDefineConstant("(WARG-LIT)", UFW_WARG_LIT
);
7546 ufoDefineConstant("(WARG-C4STRZ)", UFW_WARG_C4STRZ
);
7547 ufoDefineConstant("(WARG-CFA)", UFW_WARG_CFA
);
7548 ufoDefineConstant("(WARG-CBLOCK)", UFW_WARG_CBLOCK
);
7549 ufoDefineConstant("(WARG-VOCID)", UFW_WARG_VOCID
);
7550 ufoDefineConstant("(WARG-C1STRZ)", UFW_WARG_C1STRZ
);
7552 ufoDefineConstant("(VOCOFS-LATEST)", UFW_VOCAB_OFS_LATEST
);
7553 ufoDefineConstant("(VOCOFS-VOCLINK)", UFW_VOCAB_OFS_VOCLINK
);
7554 ufoDefineConstant("(VOCOFS-PARENT)", UFW_VOCAB_OFS_PARENT
);
7555 ufoDefineConstant("(VOCOFS-HEADER)", UFW_VOCAB_OFS_HEADER
);
7556 ufoDefineConstant("(VOCOFS-HTABLE)", UFW_VOCAB_OFS_HTABLE
);
7557 ufoDefineConstant("(VOC-HTABLE-SIZE)", UFO_HASHTABLE_SIZE
);
7558 ufoDefineConstant("(VOC-HTABLE-NOFLAG)", UFO_NO_HTABLE_FLAG
);
7560 ufoDefineConstant("(REDEFINE-WARN-DON'T-CARE)", UFO_REDEF_WARN_DONT_CARE
);
7561 ufoDefineConstant("(REDEFINE-WARN-NONE)", UFO_REDEF_WARN_NONE
);
7562 ufoDefineConstant("(REDEFINE-WARN-NORMAL)", UFO_REDEF_WARN_NORMAL
);
7563 ufoDefineConstant("(REDEFINE-WARN-PARENTS)", UFO_REDEF_WARN_PARENTS
);
7565 ufoDefineConstant("WORD-REDEFINE-WARN-MODE", ufoAddrRedefineWarning
);
7567 UFWORDX("(UNESCAPE)", PAR_UNESCAPE
);
7571 " FORTH:STATE FORTH:@ ` expecting interpretation mode` FORTH:?ERROR "
7576 " FORTH:STATE FORTH:@ ` expecting compilation mode` FORTH:?NOT-ERROR "
7579 UFWORDX("(CREATE-WORD-HEADER)", PAR_CREATE_WORD_HEADER
);
7580 UFWORDX("(CREATE-NAMELESS-WORD-HEADER)", PAR_CREATE_NAMELESS_WORD_HEADER
);
7582 ufoVocSetOnlyDefs(ufoForthVocId
);
7585 ufoInterpretLine("!: [ COMPILER:?COMP 0 STATE ! ;");
7587 ufoInterpretLine(": ] COMPILER:?EXEC 1 STATE ! ;");
7591 //==========================================================================
7595 //==========================================================================
7596 UFO_DISABLE_INLINE
void ufoInitMoreWords (void) {
7597 UFWORDX("COMPILE,", COMMA
); // just an alias, for clarity
7599 UFWORDX("CFA->PFA", CFA2PFA
);
7600 UFWORDX("CFA->NFA", CFA2NFA
);
7601 UFWORDX("CFA->LFA", CFA2LFA
);
7602 UFWORDX("CFA->WEND", CFA2WEND
);
7604 UFWORDX("PFA->CFA", PFA2CFA
);
7605 UFWORDX("PFA->NFA", PFA2NFA
);
7607 UFWORDX("NFA->CFA", NFA2CFA
);
7608 UFWORDX("NFA->PFA", NFA2PFA
);
7609 UFWORDX("NFA->LFA", NFA2LFA
);
7611 UFWORDX("LFA->CFA", LFA2CFA
);
7612 UFWORDX("LFA->PFA", LFA2PFA
);
7613 UFWORDX("LFA->BFA", LFA2BFA
);
7614 UFWORDX("LFA->XFA", LFA2XFA
);
7615 UFWORDX("LFA->YFA", LFA2YFA
);
7616 UFWORDX("LFA->NFA", LFA2NFA
);
7618 UFWORDX("(BASED-NUMBER)", PAR_BASED_NUMBER
);
7619 UFWORDX("FIND-WORD", FIND_WORD
);
7620 UFWORDX("(FIND-WORD-IN-VOC)", FIND_WORD_IN_VOC
);
7621 UFWORDX("(FIND-WORD-IN-VOC-AND-PARENTS)", FIND_WORD_IN_VOC_AND_PARENTS
);
7624 UFWORDX("EXECUTE-TAIL", EXECUTE_TAIL
);
7627 UFWORDX("?DUP", QDUP
);
7628 UFWORDX("2DUP", DDUP
);
7630 UFWORDX("2DROP", DDROP
);
7632 UFWORDX("2SWAP", DSWAP
);
7634 UFWORDX("2OVER", DOVER
);
7637 UFWORDX("PICK", PICK
);
7638 UFWORDX("ROLL", ROLL
);
7642 UFWORDX(">R", DTOR
);
7643 UFWORDX("R>", RTOD
);
7644 UFWORDX("R@", RPEEK
);
7645 UFWORDX("RPICK", RPICK
);
7646 UFWORDX("RROLL", RROLL
);
7647 UFWORDX("RSWAP", RSWAP
);
7648 UFWORDX("ROVER", ROVER
);
7649 UFWORDX("RROT", RROT
);
7650 UFWORDX("RNROT", RNROT
);
7652 UFWORDX("FLUSH-EMIT", FLUSH_EMIT
);
7653 UFWORDX("(EMIT)", PAR_EMIT
);
7654 UFWORDX("(NORM-EMIT-CHAR)", PAR_NORM_EMIT_CHAR
);
7655 UFWORDX("(NORM-XEMIT-CHAR)", PAR_NORM_XEMIT_CHAR
);
7656 UFWORDX("LASTCR?", LASTCRQ
);
7657 UFWORDX("LASTCR!", LASTCRSET
);
7661 UFWORDX("-", MINUS
);
7663 UFWORDX("U*", UMUL
);
7665 UFWORDX("U/", UDIV
);
7666 UFWORDX("MOD", MOD
);
7667 UFWORDX("UMOD", UMOD
);
7668 UFWORDX("/MOD", DIVMOD
);
7669 UFWORDX("U/MOD", UDIVMOD
);
7670 UFWORDX("*/", MULDIV
);
7671 UFWORDX("U*/", UMULDIV
);
7672 UFWORDX("*/MOD", MULDIVMOD
);
7673 UFWORDX("U*/MOD", UMULDIVMOD
);
7674 UFWORDX("M*", MMUL
);
7675 UFWORDX("UM*", UMMUL
);
7676 UFWORDX("M/MOD", MDIVMOD
);
7677 UFWORDX("UM/MOD", UMDIVMOD
);
7678 UFWORDX("UDS*", UDSMUL
);
7680 UFWORDX("SM/REM", SMREM
);
7681 UFWORDX("FM/MOD", FMMOD
);
7683 UFWORDX("D-", DMINUS
);
7684 UFWORDX("D+", DPLUS
);
7685 UFWORDX("D=", DEQU
);
7686 UFWORDX("D<", DLESS
);
7687 UFWORDX("D<=", DLESSEQU
);
7688 UFWORDX("DU<", DULESS
);
7689 UFWORDX("DU<=", DULESSEQU
);
7696 UFWORDX(">", GREAT
);
7697 UFWORDX("<=", LESSEQU
);
7698 UFWORDX(">=", GREATEQU
);
7699 UFWORDX("U<", ULESS
);
7700 UFWORDX("U>", UGREAT
);
7701 UFWORDX("U<=", ULESSEQU
);
7702 UFWORDX("U>=", UGREATEQU
);
7704 UFWORDX("<>", NOTEQU
);
7706 UFWORDX("0=", ZERO_EQU
);
7707 UFWORDX("0<>", ZERO_NOTEQU
);
7709 UFWORDX("NOT", ZERO_EQU
);
7710 UFWORDX("NOTNOT", ZERO_NOTEQU
);
7716 UFWORDX("LOGAND", LOGAND
);
7717 UFWORDX("LOGOR", LOGOR
);
7720 UFWORDX("(TIB-IN)", TIB_IN
);
7721 UFWORDX("TIB-PEEKCH", TIB_PEEKCH
);
7722 UFWORDX("TIB-PEEKCH-OFS", TIB_PEEKCH_OFS
);
7723 UFWORDX("TIB-GETCH", TIB_GETCH
);
7724 UFWORDX("TIB-SKIPCH", TIB_SKIPCH
);
7726 UFWORDX("REFILL", REFILL
);
7727 UFWORDX("REFILL-NOCROSS", REFILL_NOCROSS
);
7730 UFWORDX("(PARSE)", PAR_PARSE
);
7731 UFWORDX("(PARSE-SKIP-COMMENTS)", PAR_PARSE_SKIP_COMMENTS
);
7733 UFWORDX("PARSE-SKIP-BLANKS", PARSE_SKIP_BLANKS
);
7734 UFWORDX("PARSE-NAME", PARSE_NAME
);
7735 UFWORDX("PARSE-SKIP-LINE", PARSE_SKIP_LINE
);
7736 UFWORDX("PARSE", PARSE
);
7739 UFWORDX("(VSP@)", PAR_GET_VSP
);
7740 UFWORDX("(VSP!)", PAR_SET_VSP
);
7741 UFWORDX("(VSP-AT@)", PAR_VSP_LOAD
);
7742 UFWORDX("(VSP-AT!)", PAR_VSP_STORE
);
7743 ufoDefineConstant("(VSP-SIZE)", UFO_VOCSTACK_SIZE
);
7745 ufoDefineConstant("(SP-SIZE)", UFO_DSTACK_SIZE
);
7746 ufoDefineConstant("(RP-SIZE)", UFO_RSTACK_SIZE
);
7747 ufoDefineConstant("(LP-SIZE)", UFO_LSTACK_SIZE
);
7750 UFWORDX("ERROR", ERROR
);
7751 UFWORDX("FATAL-ERROR", ERROR
);
7753 ufoInterpretLine(": 1+ ( n -- n+1 ) 1 + ;");
7754 ufoInterpretLine(": 1- ( n -- n-1 ) 1 - ;");
7755 ufoInterpretLine(": 2+ ( n -- n+2 ) 2 + ;");
7756 ufoInterpretLine(": 2- ( n -- n-2 ) 2 - ;");
7757 ufoInterpretLine(": 4+ ( n -- n+4 ) 4 + ;");
7758 ufoInterpretLine(": 4- ( n -- n-4 ) 4 - ;");
7760 ufoInterpretLine(": 2* ( n -- n*2 ) 1 ASH ;");
7761 ufoInterpretLine(": 2/ ( n -- n/2 ) -1 ASH ;");
7762 ufoInterpretLine(": 4* ( n -- n*4 ) 2 ASH ;");
7763 ufoInterpretLine(": 4/ ( n -- n/4 ) -2 ASH ;");
7765 ufoInterpretLine(": 2U* ( u -- u*2 ) 1 LSH ;");
7766 ufoInterpretLine(": 2U/ ( u -- u/2 ) -1 LSH ;");
7767 ufoInterpretLine(": 4U* ( u -- u*4 ) 2 LSH ;");
7768 ufoInterpretLine(": 4U/ ( u -- u/4 ) -2 LSH ;");
7770 ufoInterpretLine(": 0< ( n -- n<0 ) 0 < ;");
7771 ufoInterpretLine(": 0> ( n -- n>0 ) 0 > ;");
7772 ufoInterpretLine(": 0<= ( n -- n<0 ) 0 <= ;");
7773 ufoInterpretLine(": 0>= ( n -- n>0 ) 0 >= ;");
7775 ufoInterpretLine(": @A ( idx -- v ) 0 @A+ ;");
7776 ufoInterpretLine(": C@A ( idx -- v ) 0 C@A+ ;");
7777 ufoInterpretLine(": W@A ( idx -- v ) 0 W@A+ ;");
7779 ufoInterpretLine(": !A ( idx -- v ) 0 !A+ ;");
7780 ufoInterpretLine(": C!A ( idx -- v ) 0 C!A+ ;");
7781 ufoInterpretLine(": W!A ( idx -- v ) 0 W!A+ ;");
7785 ufoInterpretLine(": ABORT ` \"ABORT\" called` ERROR ;");
7788 // ( errflag addr count -- )
7790 ": ?ERROR ( errflag addr count -- ) "
7791 " ROT FORTH:(0BRANCH) $qerr_skip ERROR "
7797 // ( errflag addr count -- )
7799 ": ?NOT-ERROR ( errflag addr count -- ) "
7800 " ROT FORTH:(TBRANCH) $qnoterr_skip ERROR "
7806 ": FIND-WORD-IN-VOC ( vocid addr count -- cfa TRUE / FALSE ) "
7807 " 0 (FIND-WORD-IN-VOC) ;");
7810 ": FIND-WORD-IN-VOC-AND-PARENTS ( vocid addr count -- cfa TRUE / FALSE ) "
7811 " 0 (FIND-WORD-IN-VOC-AND-PARENTS) ;");
7813 UFWORDX("GET-MSECS", GET_MSECS
);
7817 //==========================================================================
7819 // ufoInitHandleWords
7821 //==========================================================================
7822 UFO_DISABLE_INLINE
void ufoInitHandleWords (void) {
7823 // create "HANDLE" vocabulary
7824 const uint32_t handleVocId
= ufoCreateVoc("HANDLE", 0, UFW_FLAG_PROTECTED
);
7825 ufoVocSetOnlyDefs(handleVocId
);
7826 UFWORDX("NEW", PAR_NEW_HANDLE
);
7827 UFWORDX("FREE", PAR_FREE_HANDLE
);
7828 UFWORDX("TYPEID@", PAR_HANDLE_GET_TYPEID
);
7829 UFWORDX("TYPEID!", PAR_HANDLE_SET_TYPEID
);
7830 UFWORDX("SIZE@", PAR_HANDLE_GET_SIZE
);
7831 UFWORDX("SIZE!", PAR_HANDLE_SET_SIZE
);
7832 UFWORDX("USED@", PAR_HANDLE_GET_USED
);
7833 UFWORDX("USED!", PAR_HANDLE_SET_USED
);
7834 UFWORDX("C@", PAR_HANDLE_LOAD_BYTE
);
7835 UFWORDX("W@", PAR_HANDLE_LOAD_WORD
);
7836 UFWORDX("@", PAR_HANDLE_LOAD_CELL
);
7837 UFWORDX("C!", PAR_HANDLE_STORE_BYTE
);
7838 UFWORDX("W!", PAR_HANDLE_STORE_WORD
);
7839 UFWORDX("!", PAR_HANDLE_STORE_CELL
);
7840 UFWORDX("LOAD-FILE", PAR_HANDLE_LOAD_FILE
);
7841 ufoVocSetOnlyDefs(ufoForthVocId
);
7845 //==========================================================================
7847 // ufoInitHigherWords
7849 //==========================================================================
7850 UFO_DISABLE_INLINE
void ufoInitHigherWords (void) {
7851 UFWORDX("(INCLUDE)", PAR_INCLUDE
);
7853 UFWORDX("(INCLUDE-DEPTH)", PAR_INCLUDE_DEPTH
);
7854 UFWORDX("(INCLUDE-FILE-ID)", PAR_INCLUDE_FILE_ID
);
7855 UFWORDX("(INCLUDE-FILE-LINE)", PAR_INCLUDE_FILE_LINE
);
7856 UFWORDX("(INCLUDE-FILE-NAME)", PAR_INCLUDE_FILE_NAME
);
7858 UFWORDX("($DEFINED?)", PAR_DLR_DEFINEDQ
);
7859 UFWORDX("($DEFINE)", PAR_DLR_DEFINE
);
7860 UFWORDX("($UNDEF)", PAR_DLR_UNDEF
);
7862 UFWORDX_IMM("$INCLUDE", DLR_INCLUDE_IMM
);
7863 UFWORDX_IMM("$INCLUDE-ONCE", DLR_INCLUDE_ONCE_IMM
);
7867 //==========================================================================
7869 // ufoInitStringWords
7871 //==========================================================================
7872 UFO_DISABLE_INLINE
void ufoInitStringWords (void) {
7873 // create "STRING" vocabulary
7874 const uint32_t stringVocId
= ufoCreateVoc("STRING", 0, UFW_FLAG_PROTECTED
);
7875 ufoVocSetOnlyDefs(stringVocId
);
7876 UFWORDX("=", STREQU
);
7877 UFWORDX("=CI", STREQUCI
);
7878 UFWORDX("SEARCH", SEARCH
);
7879 UFWORDX("HASH", STRHASH
);
7880 UFWORDX("HASH-CI", STRHASHCI
);
7881 ufoVocSetOnlyDefs(ufoForthVocId
);
7885 //==========================================================================
7887 // ufoInitDebugWords
7889 //==========================================================================
7890 UFO_DISABLE_INLINE
void ufoInitDebugWords (void) {
7891 // create "DEBUG" vocabulary
7892 const uint32_t debugVocId
= ufoCreateVoc("DEBUG", 0, UFW_FLAG_PROTECTED
);
7893 ufoVocSetOnlyDefs(debugVocId
);
7894 UFWORDX("(DECOMPILE-CFA)", DEBUG_DECOMPILE_CFA
);
7895 UFWORDX("(DECOMPILE-MEM)", DEBUG_DECOMPILE_MEM
);
7896 UFWORDX("BACKTRACE", UFO_BACKTRACE
);
7897 UFWORDX("DUMP-STACK", DUMP_STACK
);
7898 UFWORDX("BACKTRACE-TASK", UFO_BACKTRACE_TASK
);
7899 UFWORDX("DUMP-STACK-TASK", DUMP_STACK_TASK
);
7900 UFWORDX("DUMP-RSTACK-TASK", DUMP_RSTACK_TASK
);
7901 UFWORDX("(BP)", MT_DEBUGGER_BP
);
7902 UFWORDX("IP->NFA", IP2NFA
);
7903 UFWORDX("IP->FILE/LINE", IP2FILELINE
);
7904 UFWORDX("IP->FILE-HASH/LINE", IP2FILEHASHLINE
);
7905 ufoVocSetOnlyDefs(ufoForthVocId
);
7909 //==========================================================================
7913 //==========================================================================
7914 UFO_DISABLE_INLINE
void ufoInitMTWords (void) {
7915 // create "MTASK" vocabulary
7916 const uint32_t mtVocId
= ufoCreateVoc("MTASK", 0, UFW_FLAG_PROTECTED
);
7917 ufoVocSetOnlyDefs(mtVocId
);
7918 UFWORDX("NEW-STATE", MT_NEW_STATE
);
7919 UFWORDX("FREE-STATE", MT_FREE_STATE
);
7920 UFWORDX("STATE-NAME@", MT_GET_STATE_NAME
);
7921 UFWORDX("STATE-NAME!", MT_SET_STATE_NAME
);
7922 UFWORDX("STATE-FIRST", MT_STATE_FIRST
);
7923 UFWORDX("STATE-NEXT", MT_STATE_NEXT
);
7924 UFWORDX("YIELD-TO", MT_YIELD_TO
);
7925 UFWORDX("SET-SELF-AS-DEBUGGER", MT_SET_SELF_AS_DEBUGGER
);
7926 UFWORDX("DEBUGGER-RESUME", MT_RESUME_DEBUGEE
);
7927 UFWORDX("DEBUGGER-SINGLE-STEP", MT_SINGLE_STEP_DEBUGEE
);
7928 UFWORDX("ACTIVE-STATE", MT_ACTIVE_STATE
);
7929 UFWORDX("STATE-IP@", MT_STATE_IP_GET
);
7930 UFWORDX("STATE-IP!", MT_STATE_IP_SET
);
7931 UFWORDX("STATE-A>", MT_STATE_REGA_GET
);
7932 UFWORDX("STATE->A", MT_STATE_REGA_SET
);
7933 UFWORDX("STATE-USER@", MT_STATE_USER_GET
);
7934 UFWORDX("STATE-USER!", MT_STATE_USER_SET
);
7935 UFWORDX("STATE-RPOPCFA@", MT_STATE_RPOPCFA_GET
);
7936 UFWORDX("STATE-RPOPCFA!", MT_STATE_RPOPCFA_SET
);
7937 UFWORDX("YIELDED-FROM", MT_YIELDED_FROM
);
7938 UFWORDX("STATE-SP@", MT_DSTACK_DEPTH_GET
);
7939 UFWORDX("STATE-RP@", MT_RSTACK_DEPTH_GET
);
7940 UFWORDX("STATE-LP@", MT_LP_GET
);
7941 UFWORDX("STATE-LBP@", MT_LBP_GET
);
7942 UFWORDX("STATE-SP!", MT_DSTACK_DEPTH_SET
);
7943 UFWORDX("STATE-RP!", MT_RSTACK_DEPTH_SET
);
7944 UFWORDX("STATE-LP!", MT_LP_SET
);
7945 UFWORDX("STATE-LBP!", MT_LBP_SET
);
7946 UFWORDX("STATE-DS@", MT_DSTACK_LOAD
);
7947 UFWORDX("STATE-RS@", MT_RSTACK_LOAD
);
7948 UFWORDX("STATE-LS@", MT_LSTACK_LOAD
);
7949 UFWORDX("STATE-DS!", MT_DSTACK_STORE
);
7950 UFWORDX("STATE-RS!", MT_RSTACK_STORE
);
7951 UFWORDX("STATE-LS!", MT_LSTACK_STORE
);
7952 ufoVocSetOnlyDefs(ufoForthVocId
);
7956 //==========================================================================
7960 //==========================================================================
7961 UFO_DISABLE_INLINE
void ufoInitTTYWords (void) {
7962 // create "TTY" vocabulary
7963 const uint32_t ttyVocId
= ufoCreateVoc("TTY", 0, UFW_FLAG_PROTECTED
);
7964 ufoVocSetOnlyDefs(ttyVocId
);
7965 UFWORDX("TTY?", TTY_TTYQ
);
7966 UFWORDX("RAW?", TTY_RAWQ
);
7967 UFWORDX("SIZE", TTY_SIZE
);
7968 UFWORDX("SET-RAW", TTY_SET_RAW
);
7969 UFWORDX("SET-COOKED", TTY_SET_COOKED
);
7970 UFWORDX("RAW-EMIT", TTY_RAW_EMIT
);
7971 UFWORDX("RAW-TYPE", TTY_RAW_TYPE
);
7972 UFWORDX("RAW-FLUSH", TTY_RAW_FLUSH
);
7973 UFWORDX("RAW-READCH", TTY_RAW_READCH
);
7974 UFWORDX("RAW-READY?", TTY_RAW_READYQ
);
7975 ufoVocSetOnlyDefs(ufoForthVocId
);
7979 //==========================================================================
7981 // ufoInitVeryVeryHighWords
7983 //==========================================================================
7984 UFO_DISABLE_INLINE
void ufoInitVeryVeryHighWords (void) {
7986 //ufoDefineDefer("INTERPRET", idumbCFA);
7988 ufoDefineEmitType();
7990 // ( addr count FALSE -- addr count FALSE / TRUE )
7991 ufoDefineSColonForth("(INTERPRET-CHECK-WORD)");
7993 // ( addr count FALSE -- addr count FALSE / TRUE )
7994 ufoDefineSColonForth("(INTERPRET-WORD-NOT-FOUND)");
7996 // ( -- ) -- called in "EXIT", before compiling "FORTH:(EXIT)"
7997 ufoDefineSColonForth("(EXIT-EXTENDER)");
8001 ufoInterpretLine("!: EXIT ( -- ) COMPILER:?COMP (EXIT-EXTENDER) COMPILE FORTH:(EXIT) ;");
8003 ufoDefineInterpret();
8005 //ufoDumpVocab(ufoCompilerVocId);
8008 ": RUN-INTERPRET-LOOP "
8009 "$run-interp-loop-again: "
8010 " RP0! INTERPRET (UFO-INTERPRET-FINISHED-ACTION) "
8011 " FORTH:(BRANCH) $run-interp-loop-again "
8015 #define UFO_ADD_DO_CFA(cfx_) do { \
8016 ufoDo##cfx_##CFA = ufoCFAsUsed | UFO_ADDR_CFA_BIT; \
8017 ufoForthCFAs[ufoCFAsUsed] = &ufoDo##cfx_; \
8022 //==========================================================================
8026 //==========================================================================
8027 UFO_DISABLE_INLINE
void ufoInitCommon (void) {
8029 ufoForthVocId
= 0; ufoCompilerVocId
= 0;
8031 ufoForthCFAs
= calloc(UFO_MAX_NATIVE_CFAS
, sizeof(ufoForthCFAs
[0]));
8033 // allocate default TIB handle
8034 //UfoHandle *tibh = ufoAllocHandle(0x69a029a6); // arbitrary number
8035 //ufoDefTIB = tibh->ufoHandle;
8037 ufoForthCFAs
[0] = NULL
; ufoCFAsUsed
= 1u;
8038 UFO_ADD_DO_CFA(Forth
);
8039 UFO_ADD_DO_CFA(Variable
);
8040 UFO_ADD_DO_CFA(Value
);
8041 UFO_ADD_DO_CFA(Const
);
8042 UFO_ADD_DO_CFA(Defer
);
8043 UFO_ADD_DO_CFA(Voc
);
8044 UFO_ADD_DO_CFA(Create
);
8045 UFO_ADD_DO_CFA(UserVariable
);
8047 //fprintf(stderr, "DO-FORTH-CFA: 0x%08x\n", ufoDoForthCFA);
8051 // create "FORTH" vocabulary (it should be the first one)
8052 ufoForthVocId
= ufoCreateVoc("FORTH", 0, UFW_FLAG_PROTECTED
);
8053 ufoVocSetOnlyDefs(ufoForthVocId
);
8055 // base low-level interpreter words
8056 ufoInitBasicWords();
8061 // some COMPILER words
8062 ufoInitBasicCompilerWords();
8064 // STRING vocabulary
8065 ufoInitStringWords();
8068 ufoInitDebugWords();
8073 // HANDLE vocabulary
8074 ufoInitHandleWords();
8079 // some higher-level FORTH words (includes, etc.)
8080 ufoInitHigherWords();
8082 // very-very high-level FORTH words
8083 ufoInitVeryVeryHighWords();
8085 ufoFinalLabelCheck();
8088 ufoDecompileWord(ufoFindWordChecked("RUN-INTERPRET-LOOP"));
8097 // ////////////////////////////////////////////////////////////////////////// //
8098 // virtual machine executor
8102 //==========================================================================
8106 // address interpreter
8108 //==========================================================================
8109 static void ufoRunVMCFA (uint32_t cfa
) {
8110 const uint32_t oldRPTop
= ufoRPTop
;
8112 #ifdef UFO_TRACE_VM_RUN
8113 fprintf(stderr
, "**VM-INITIAL**: cfa=%u\n", cfa
);
8119 // VM execution loop
8121 if (ufoVMAbort
) ufoFatal("user abort");
8122 if (ufoVMStop
) { ufoRP
= oldRPTop
; break; }
8123 if (ufoCurrState
== NULL
) ufoFatal("execution state is lost");
8124 if (ufoVMRPopCFA
== 0) {
8126 if (ufoIP
== 0) ufoFatal("IP is NULL");
8127 if (ufoIP
& UFO_ADDR_HANDLE_BIT
) ufoFatal("IP is a handle");
8128 cfa
= ufoImgGetU32(ufoIP
); ufoIP
+= 4u;
8130 cfa
= ufoRPop(); ufoVMRPopCFA
= 0;
8133 if (cfa
== 0) ufoFatal("EXECUTE: NULL CFA");
8134 if (cfa
& UFO_ADDR_HANDLE_BIT
) ufoFatal("cannot execute handle");
8135 // get next word CFAIDX, and check it
8136 uint32_t cfaidx
= ufoImgGetU32(cfa
);
8137 if (cfaidx
& UFO_ADDR_HANDLE_BIT
) ufoFatal("cannot execute CFAIDX-handle");
8138 #ifdef UFO_TRACE_VM_RUN
8139 fprintf(stderr
, "**VM**: IP=%u; cfa=%u; cfaidx=0x%08x\n", ufoIP
- 4u, cfa
, cfaidx
);
8141 ufoDumpWordHeader(UFO_CFA_TO_LFA(cfa
));
8142 fprintf(stderr
, "######################################\n");
8144 if (cfaidx
& UFO_ADDR_CFA_BIT
) {
8145 cfaidx
&= UFO_ADDR_CFA_MASK
;
8146 if (cfaidx
>= ufoCFAsUsed
|| ufoForthCFAs
[cfaidx
] == NULL
) {
8147 ufoFatal("tried to execute an unknown word: %u (max is %u); IP=%u",
8148 cfaidx
, ufoCFAsUsed
, ufoIP
- 4u);
8150 #ifdef UFO_TRACE_VM_RUN
8151 fprintf(stderr
, "**VM-NATIVE**: cfaidx=%u (doForth=%u)\n", cfaidx
,
8152 (ufoDoForthCFA
& UFO_ADDR_CFA_MASK
));
8154 ufoForthCFAs
[cfaidx
](UFO_CFA_TO_PFA(cfa
));
8156 // if CFA points somewhere inside a dict, this is "DOES>" word
8157 // IP points to PFA we need to push
8158 // CFA points to Forth word we need to jump to
8159 #ifdef UFO_TRACE_VM_DOER
8160 fprintf(stderr
, "*** DOER! IP=%u; cfa=%u; cfaidx=%u ***\n", ufoIP
, cfa
, cfaidx
);
8161 UFCALL(UFO_BACKTRACE
);
8163 ufoPush(UFO_CFA_TO_PFA(cfa
)); // push PFA
8164 ufoRPush(ufoIP
); // push IP
8165 ufoIP
= cfaidx
; // fix IP
8167 // that's all we need to activate the debugger
8168 if (ufoSingleStep
) {
8170 if (ufoSingleStep
== 0 && ufoDebuggerState
!= NULL
) {
8171 if (ufoCurrState
== ufoDebuggerState
) ufoFatal("debugger cannot debug itself");
8172 UfoState
*ost
= ufoCurrState
;
8173 ufoSwitchToState(ufoDebuggerState
); // always use API call for this!
8178 } while (ufoRP
!= oldRPTop
);
8183 // ////////////////////////////////////////////////////////////////////////// //
8187 //==========================================================================
8191 // register new word
8193 //==========================================================================
8194 uint32_t ufoRegisterWord (const char *wname
, ufoNativeCFA cfa
, uint32_t flags
) {
8195 ufo_assert(cfa
!= NULL
);
8196 ufo_assert(wname
!= NULL
&& wname
[0] != 0);
8197 uint32_t cfaidx
= ufoCFAsUsed
;
8198 if (cfaidx
>= UFO_MAX_NATIVE_CFAS
) ufoFatal("too many native words");
8199 ufoForthCFAs
[cfaidx
] = cfa
;
8201 //ufoDefineNative(wname, xcfa, 0);
8202 cfaidx
|= UFO_ADDR_CFA_BIT
;
8203 flags
&= 0xffffff00u
;
8204 ufoCreateWordHeader(wname
, flags
);
8205 const uint32_t res
= UFO_GET_DP();
8206 ufoImgEmitU32(cfaidx
);
8211 //==========================================================================
8213 // ufoRegisterDataWord
8215 //==========================================================================
8216 static uint32_t ufoRegisterDataWord (const char *wname
, uint32_t cfaidx
, uint32_t value
,
8219 ufo_assert(wname
!= NULL
&& wname
[0] != 0);
8220 flags
&= 0xffffff00u
;
8221 ufoCreateWordHeader(wname
, flags
);
8222 ufoImgEmitU32(cfaidx
);
8223 const uint32_t res
= UFO_GET_DP();
8224 ufoImgEmitU32(value
);
8229 //==========================================================================
8231 // ufoRegisterConstant
8233 //==========================================================================
8234 void ufoRegisterConstant (const char *wname
, uint32_t value
, uint32_t flags
) {
8235 (void)ufoRegisterDataWord(wname
, ufoDoConstCFA
, value
, flags
);
8239 //==========================================================================
8241 // ufoRegisterVariable
8243 //==========================================================================
8244 uint32_t ufoRegisterVariable (const char *wname
, uint32_t value
, uint32_t flags
) {
8245 return ufoRegisterDataWord(wname
, ufoDoVariableCFA
, value
, flags
);
8249 //==========================================================================
8253 //==========================================================================
8254 uint32_t ufoRegisterValue (const char *wname
, uint32_t value
, uint32_t flags
) {
8255 return ufoRegisterDataWord(wname
, ufoDoValueCFA
, value
, flags
);
8259 //==========================================================================
8263 //==========================================================================
8264 uint32_t ufoRegisterDefer (const char *wname
, uint32_t value
, uint32_t flags
) {
8265 return ufoRegisterDataWord(wname
, ufoDoDeferCFA
, value
, flags
);
8269 //==========================================================================
8271 // ufoFindWordInVocabulary
8273 // check if we have the corresponding word.
8274 // return CFA suitable for executing, or 0.
8276 //==========================================================================
8277 uint32_t ufoFindWordInVocabulary (const char *wname
, uint32_t vocid
) {
8278 if (wname
== NULL
|| wname
[0] == 0) return 0;
8279 size_t wlen
= strlen(wname
);
8280 if (wlen
>= UFO_MAX_WORD_LENGTH
) return 0;
8281 return ufoFindWordInVocAndParents(wname
, (uint32_t)wlen
, 0, vocid
, 0);
8285 //==========================================================================
8289 //==========================================================================
8290 uint32_t ufoGetIP (void) {
8295 //==========================================================================
8299 //==========================================================================
8300 void ufoSetIP (uint32_t newip
) {
8305 //==========================================================================
8309 //==========================================================================
8310 int ufoIsExecuting (void) {
8311 return (ufoImgGetU32(ufoAddrSTATE
) == 0);
8315 //==========================================================================
8319 //==========================================================================
8320 int ufoIsCompiling (void) {
8321 return (ufoImgGetU32(ufoAddrSTATE
) != 0);
8325 //==========================================================================
8329 //==========================================================================
8330 void ufoSetExecuting (void) {
8331 ufoImgPutU32(ufoAddrSTATE
, 0);
8335 //==========================================================================
8339 //==========================================================================
8340 void ufoSetCompiling (void) {
8341 ufoImgPutU32(ufoAddrSTATE
, 1);
8345 //==========================================================================
8349 //==========================================================================
8350 uint32_t ufoGetHere () {
8351 return UFO_GET_DP();
8355 //==========================================================================
8359 //==========================================================================
8360 uint32_t ufoGetPad () {
8366 //==========================================================================
8370 //==========================================================================
8371 uint8_t ufoTIBPeekCh (uint32_t ofs
) {
8372 return ufoTibPeekChOfs(ofs
);
8376 //==========================================================================
8380 //==========================================================================
8381 uint8_t ufoTIBGetCh (void) {
8382 return ufoTibGetCh();
8386 //==========================================================================
8390 //==========================================================================
8391 void ufoTIBSkipCh (void) {
8396 //==========================================================================
8402 //==========================================================================
8403 int ufoTIBSRefill (int allowCrossIncludes
) {
8404 return ufoLoadNextLine(allowCrossIncludes
);
8408 //==========================================================================
8412 //==========================================================================
8413 uint32_t ufoPeekData (void) {
8418 //==========================================================================
8422 //==========================================================================
8423 uint32_t ufoPopData (void) {
8428 //==========================================================================
8432 //==========================================================================
8433 void ufoPushData (uint32_t value
) {
8434 return ufoPush(value
);
8438 //==========================================================================
8442 //==========================================================================
8443 void ufoPushBoolData (int val
) {
8448 //==========================================================================
8452 //==========================================================================
8453 uint32_t ufoPeekRet (void) {
8458 //==========================================================================
8462 //==========================================================================
8463 uint32_t ufoPopRet (void) {
8468 //==========================================================================
8472 //==========================================================================
8473 void ufoPushRet (uint32_t value
) {
8474 return ufoRPush(value
);
8478 //==========================================================================
8482 //==========================================================================
8483 void ufoPushBoolRet (int val
) {
8484 ufoRPush(val
? ufoTrueValue
: 0);
8488 //==========================================================================
8492 //==========================================================================
8493 uint8_t ufoPeekByte (uint32_t addr
) {
8494 return ufoImgGetU8Ext(addr
);
8498 //==========================================================================
8502 //==========================================================================
8503 uint16_t ufoPeekWord (uint32_t addr
) {
8510 //==========================================================================
8514 //==========================================================================
8515 uint32_t ufoPeekCell (uint32_t addr
) {
8522 //==========================================================================
8526 //==========================================================================
8527 void ufoPokeByte (uint32_t addr
, uint32_t value
) {
8528 ufoImgPutU8(addr
, value
);
8532 //==========================================================================
8536 //==========================================================================
8537 void ufoPokeWord (uint32_t addr
, uint32_t value
) {
8544 //==========================================================================
8548 //==========================================================================
8549 void ufoPokeCell (uint32_t addr
, uint32_t value
) {
8556 //==========================================================================
8560 //==========================================================================
8561 void ufoEmitByte (uint32_t value
) {
8562 ufoImgEmitU8(value
);
8566 //==========================================================================
8570 //==========================================================================
8571 void ufoEmitWord (uint32_t value
) {
8572 ufoImgEmitU8(value
& 0xff);
8573 ufoImgEmitU8((value
>> 8) & 0xff);
8577 //==========================================================================
8581 //==========================================================================
8582 void ufoEmitCell (uint32_t value
) {
8583 ufoImgEmitU32(value
);
8587 //==========================================================================
8591 //==========================================================================
8592 int ufoIsInited (void) {
8593 return (ufoMode
!= UFO_MODE_NONE
);
8597 static void (*ufoUserPostInitCB
) (void);
8600 //==========================================================================
8602 // ufoSetUserPostInit
8604 // called after main initialisation
8606 //==========================================================================
8607 void ufoSetUserPostInit (void (*cb
) (void)) {
8608 ufoUserPostInitCB
= cb
;
8612 //==========================================================================
8616 //==========================================================================
8617 void ufoInit (void) {
8618 if (ufoMode
!= UFO_MODE_NONE
) return;
8619 ufoMode
= UFO_MODE_NATIVE
;
8622 ufoInFileName
= NULL
; ufoInFileNameLen
= 0; ufoInFileNameHash
= 0;
8624 ufoLastIncPath
= NULL
; ufoLastSysIncPath
= NULL
;
8626 for (uint32_t f
= 0; f
< UFO_MAX_STATES
; f
+= 1u) ufoStateMap
[f
] = NULL
;
8627 memset(ufoStateUsedBitmap
, 0, sizeof(ufoStateUsedBitmap
));
8629 ufoCurrState
= ufoNewState();
8630 strcpy(ufoCurrState
->name
, "MAIN");
8631 ufoInitStateUserVars(ufoCurrState
, 0);
8632 ufoImgPutU32(ufoAddrDefTIB
, 0); // create TIB handle
8633 ufoImgPutU32(ufoAddrTIBx
, 0); // create TIB handle
8635 ufoYieldedState
= NULL
;
8636 ufoDebuggerState
= NULL
;
8639 #ifdef UFO_DEBUG_STARTUP_TIMES
8640 uint32_t stt
= ufo_get_msecs();
8641 ufoCondDefine("UFO-DEBUG-STARTUP-TIMES");
8644 #ifdef UFO_DEBUG_STARTUP_TIMES
8645 uint32_t ett
= ufo_get_msecs();
8646 fprintf(stderr
, "UrForth init time: %u msecs\n", (unsigned)(ett
- stt
));
8651 if (ufoUserPostInitCB
) {
8652 ufoUserPostInitCB();
8657 char *ufmname
= ufoCreateIncludeName("init", 1, NULL
);
8659 FILE *ufl
= fopen(ufmname
, "rb");
8661 FILE *ufl
= fopen(ufmname
, "r");
8665 ufoSetInFileNameReuse(ufmname
);
8667 ufoFileId
= ufoLastUsedFileId
;
8668 setLastIncPath(ufoInFileName
, 1);
8671 ufoFatal("cannot load init code");
8674 if (ufoInFile
!= NULL
) {
8675 ufoRunInterpretLoop();
8680 //==========================================================================
8684 //==========================================================================
8685 void ufoFinishVM (void) {
8690 //==========================================================================
8694 // check if VM was exited due to `ufoFinishVM()`
8696 //==========================================================================
8697 int ufoWasVMFinished (void) {
8698 return (ufoVMStop
!= 0);
8702 //==========================================================================
8706 // ( -- addr count TRUE / FALSE )
8707 // does base TIB parsing; never copies anything.
8708 // as our reader is line-based, returns FALSE on EOL.
8709 // EOL is detected after skipping leading delimiters.
8710 // passing -1 as delimiter skips the whole line, and always returns FALSE.
8711 // trailing delimiter is always skipped.
8712 // result is on the data stack.
8714 //==========================================================================
8715 void ufoCallParseIntr (uint32_t delim
, int skipLeading
) {
8716 ufoPush(delim
); ufoPushBool(skipLeading
);
8720 //==========================================================================
8724 // ( -- addr count )
8725 // parse with leading blanks skipping. doesn't copy anything.
8726 // return empty string on EOL.
8728 //==========================================================================
8729 void ufoCallParseName (void) {
8734 //==========================================================================
8738 // ( -- addr count TRUE / FALSE )
8739 // parse without skipping delimiters; never copies anything.
8740 // as our reader is line-based, returns FALSE on EOL.
8741 // passing 0 as delimiter skips the whole line, and always returns FALSE.
8742 // trailing delimiter is always skipped.
8744 //==========================================================================
8745 void ufoCallParse (uint32_t delim
) {
8751 //==========================================================================
8753 // ufoCallParseSkipBlanks
8755 //==========================================================================
8756 void ufoCallParseSkipBlanks (void) {
8757 UFCALL(PARSE_SKIP_BLANKS
);
8761 //==========================================================================
8763 // ufoCallParseSkipComments
8765 //==========================================================================
8766 void ufoCallParseSkipComments (void) {
8767 ufoPushBool(1); UFCALL(PAR_PARSE_SKIP_COMMENTS
);
8771 //==========================================================================
8773 // ufoCallParseSkipLineComments
8775 //==========================================================================
8776 void ufoCallParseSkipLineComments (void) {
8777 ufoPushBool(0); UFCALL(PAR_PARSE_SKIP_COMMENTS
);
8781 //==========================================================================
8783 // ufoCallParseSkipLine
8785 // to the end of line; doesn't refill
8787 //==========================================================================
8788 void ufoCallParseSkipLine (void) {
8789 UFCALL(PARSE_SKIP_LINE
);
8793 //==========================================================================
8795 // ufoCallBasedNumber
8797 // convert number from addrl+1
8798 // returns address of the first inconvertible char
8799 // (BASED-NUMBER) ( addr count allowsign? base -- num TRUE / FALSE )
8801 //==========================================================================
8802 void ufoCallBasedNumber (uint32_t addr
, uint32_t count
, int allowSign
, int base
) {
8803 ufoPush(addr
); ufoPush(count
); ufoPushBool(allowSign
);
8804 if (base
< 0) ufoPush(0); else ufoPush((uint32_t)base
);
8805 UFCALL(PAR_BASED_NUMBER
);
8809 //==========================================================================
8813 //==========================================================================
8814 void ufoRunWord (uint32_t cfa
) {
8816 if (ufoMode
== UFO_MODE_NONE
) ufoFatal("UrForth is not properly inited");
8817 if (ufoInRunWord
) ufoFatal("`ufoRunWord` cannot be called recursively");
8818 ufoMode
= UFO_MODE_NATIVE
;
8826 //==========================================================================
8830 //==========================================================================
8831 void ufoRunMacroWord (uint32_t cfa
) {
8833 if (ufoMode
== UFO_MODE_NONE
) ufoFatal("UrForth is not properly inited");
8834 if (ufoInRunWord
) ufoFatal("`ufoRunWord` cannot be called recursively");
8835 ufoMode
= UFO_MODE_MACRO
;
8836 const uint32_t oisp
= ufoFileStackPos
;
8839 (void)ufoLoadNextUserLine();
8844 ufo_assert(ufoFileStackPos
== oisp
); // sanity check
8849 //==========================================================================
8853 // check if we are currently in "MACRO" mode.
8854 // should be called from registered words.
8856 //==========================================================================
8857 int ufoIsInMacroMode (void) {
8858 return (ufoMode
== UFO_MODE_MACRO
);
8862 //==========================================================================
8864 // ufoRunInterpretLoop
8866 // run default interpret loop.
8868 //==========================================================================
8869 void ufoRunInterpretLoop (void) {
8870 if (ufoMode
== UFO_MODE_NONE
) {
8873 const uint32_t cfa
= ufoFindWord("RUN-INTERPRET-LOOP");
8874 if (cfa
== 0) ufoFatal("'RUN-INTERPRET-LOOP' word not found");
8876 ufoMode
= UFO_MODE_NATIVE
;
8880 while (ufoFileStackPos
!= 0) ufoPopInFile();
8884 //==========================================================================
8888 //==========================================================================
8889 void ufoRunFile (const char *fname
) {
8890 if (ufoMode
== UFO_MODE_NONE
) {
8893 if (ufoInRunWord
) ufoFatal("`ufoRunFile` cannot be called recursively");
8894 ufoMode
= UFO_MODE_NATIVE
;
8897 char *ufmname
= ufoCreateIncludeName(fname
, 0, ".");
8899 FILE *ufl
= fopen(ufmname
, "rb");
8901 FILE *ufl
= fopen(ufmname
, "r");
8905 ufoSetInFileNameReuse(ufmname
);
8907 ufoFileId
= ufoLastUsedFileId
;
8908 setLastIncPath(ufoInFileName
, 0);
8911 ufoFatal("cannot load source file '%s'", fname
);
8913 ufoRunInterpretLoop();