From ba1db93e62179b4d323148879dc568b4ddccbf4a Mon Sep 17 00:00:00 2001 From: Brad Nelson Date: Sun, 6 Feb 2022 15:04:28 -0800 Subject: [PATCH] Builtins now internals, but vlist skips them. --- ueforth/common/core.h | 4 +++- ueforth/common/forth_namespace_tests.fs | 17 ++++++++++------- ueforth/common/interp.h | 8 ++------ ueforth/common/opcodes.h | 6 ++++-- ueforth/common/utils.fs | 5 +++-- ueforth/common/vocabulary.fs | 8 +++++--- ueforth/windows/interp.h | 9 ++------- 7 files changed, 29 insertions(+), 28 deletions(-) diff --git a/ueforth/common/core.h b/ueforth/common/core.h index 7c8589a..9212452 100644 --- a/ueforth/common/core.h +++ b/ueforth/common/core.h @@ -22,6 +22,7 @@ #define IMMEDIATE 1 #define SMUDGE 2 #define BUILTIN_FORK 4 +#define BUILTIN_MARK 8 // Maximum ALSO layers. #define VOCABULARY_DEPTH 16 @@ -242,7 +243,8 @@ static void forth_init(int argc, char *argv[], void *heap, for (int i = 0; i < VOCABULARY_DEPTH; ++i) { *g_sys.heap++ = 0; } forth_run(0); - g_sys.latestxt = 0; // So ; doesn't get wrong size. + create("end", 3, BUILTIN_FORK, 0); + g_sys.latestxt = 0; // So last builtin doesn't get wrong size. g_sys.DOLIT_XT = FIND("DOLIT"); g_sys.DOFLIT_XT = FIND("DOFLIT"); g_sys.DOEXIT_XT = FIND("EXIT"); diff --git a/ueforth/common/forth_namespace_tests.fs b/ueforth/common/forth_namespace_tests.fs index 1035539..5b9143b 100644 --- a/ueforth/common/forth_namespace_tests.fs +++ b/ueforth/common/forth_namespace_tests.fs @@ -397,9 +397,9 @@ e: check-phase1 check-vocabulary check-[]conds check-boot - check-core-opcodes - check-extra-opcodes - check-float-opcodes +\ check-core-opcodes +\ check-extra-opcodes +\ check-float-opcodes ;e e: check-desktop @@ -446,8 +446,9 @@ e: test-windows-forth-namespace out: default-type out: windows check-phase1 - out: LOADLIBRARYA - out: GETPROCADDRESS + \ out: LOADLIBRARYA + \ out: GETPROCADDRESS + out: end ;e [ELSE] DEFINED? posix [IF] @@ -487,7 +488,8 @@ e: test-posix-forth-namespace out: default-type out: posix check-phase1 - out: DLSYM +\ out: DLSYM + out: end ;e [ELSE] @@ -581,7 +583,8 @@ e: test-esp32-forth-namespace check-phase2 check-allocation check-phase1 - check-esp32-basics2 +\ check-esp32-basics2 + out: end ;e [THEN] [THEN] diff --git a/ueforth/common/interp.h b/ueforth/common/interp.h index 2e8d74f..ba83c76 100644 --- a/ueforth/common/interp.h +++ b/ueforth/common/interp.h @@ -21,7 +21,8 @@ static cell_t *forth_run(cell_t *init_rp) { static const BUILTIN_WORD builtins[] = { #define XV(flags, name, op, code) \ - name, 0, sizeof(name) - 1, (flags & 0xff), && OP_ ## op, + name, ((flags >> 8) & 0xff) | BUILTIN_MARK, \ + sizeof(name) - 1, (flags & 0xff), && OP_ ## op, PLATFORM_OPCODE_LIST EXTRA_OPCODE_LIST OPCODE_LIST @@ -31,11 +32,6 @@ static cell_t *forth_run(cell_t *init_rp) { if (!init_rp) { g_sys.builtins = builtins; -#define XV(flags, name, op, code) create(name, sizeof(name) - 1, name[0] == ';', && OP_ ## op); - PLATFORM_OPCODE_LIST - EXTRA_OPCODE_LIST - OPCODE_LIST -#undef XV return 0; } register cell_t *ip, *rp, *sp, tos, w; diff --git a/ueforth/common/opcodes.h b/ueforth/common/opcodes.h index 2964852..00c236c 100644 --- a/ueforth/common/opcodes.h +++ b/ueforth/common/opcodes.h @@ -23,6 +23,7 @@ typedef uintptr_t ucell_t; #define YV(flags, op, code) XV(flags, #op, ID_ ## op, code) #define X(name, op, code) XV(FORTH, name, op, code) #define Y(op, code) XV(FORTH, #op, ID_ ## op, code) +#define FL(vocab, flags) ((vocab) | ((flags) << 8)) #define NIP (--sp) #define NIPn(n) (sp -= (n)) @@ -41,7 +42,8 @@ typedef uintptr_t ucell_t; #define TOPARAMS(xt) ((uint16_t *) (TOFLAGS(xt) + 2)) #define TOSIZE(xt) (CELL_ALIGNED(*TONAMELEN(xt)) + sizeof(cell_t) * (3 + *TOPARAMS(xt))) #define TOLINK(xt) (((cell_t *) (xt)) - 2) -#define TONAME(xt) (((char *) TOLINK(xt)) - CELL_ALIGNED(*TONAMELEN(xt))) +#define TONAME(xt) ((*TOFLAGS(xt) & BUILTIN_MARK) ? (*(char **) TOLINK(xt)) \ + : (((char *) TOLINK(xt)) - CELL_ALIGNED(*TONAMELEN(xt)))) #define TOBODY(xt) (((cell_t *) xt) + ((void *) *((cell_t *) xt) == ADDR_DOCOLON ? 1 : 2)) #define DOIMMEDIATE() *TOFLAGS(*g_sys.current) |= IMMEDIATE @@ -124,4 +126,4 @@ typedef struct { sp = evaluate1(sp, &tfp); \ fp = tfp; w = *sp--; DROP; if (w) JMPW) \ Y(EXIT, ip = (cell_t *) *rp--) \ - X(";", SEMICOLON, COMMA(g_sys.DOEXIT_XT); UNSMUDGE(); g_sys.state = 0) + XV(FL(FORTH, IMMEDIATE), ";", SEMICOLON, COMMA(g_sys.DOEXIT_XT); UNSMUDGE(); g_sys.state = 0) diff --git a/ueforth/common/utils.fs b/ueforth/common/utils.fs index 720b202..0a3508d 100644 --- a/ueforth/common/utils.fs +++ b/ueforth/common/utils.fs @@ -26,7 +26,8 @@ internals definitions 2 constant SMUDGE -8 constant NONAMED +4 constant BUILTIN_FORK +16 constant NONAMED : mem= ( a a n -- f) for aft 2dup c@ swap c@ <> if 2drop rdrop 0 exit then 1+ swap 1+ then next 2drop -1 ; forth definitions also internals @@ -64,7 +65,7 @@ internals definitions ." Unsupported: " see. cr ; : nonvoc? ( xt -- f ) - dup 0= if exit then dup >name nip swap >flags NONAMED and or ; + dup 0= if exit then dup >name nip swap >flags NONAMED BUILTIN_FORK or and or ; : see-vocabulary ( voc ) @ begin dup nonvoc? while dup see-xt >link repeat drop cr ; : >vocnext ( xt -- xt ) >body 2 cells + @ ; diff --git a/ueforth/common/vocabulary.fs b/ueforth/common/vocabulary.fs index 8fa56cd..94238cf 100644 --- a/ueforth/common/vocabulary.fs +++ b/ueforth/common/vocabulary.fs @@ -28,7 +28,9 @@ forth definitions ( Make it easy to transfer words between vocabularies ) : xt-find& ( xt -- xt& ) context @ begin 2dup @ <> while @ >link& repeat nip ; : xt-hide ( xt -- ) xt-find& dup @ >link swap ! ; -: xt-transfer ( xt -- ) dup xt-hide current @ @ over >link& ! current @ ! ; +8 constant BUILTIN_MARK +: xt-transfer ( xt -- ) dup >flags BUILTIN_MARK and if drop exit then + dup xt-hide current @ @ over >link& ! current @ ! ; : transfer ( "name" ) ' xt-transfer ; : }transfer ; : transfer{ begin ' dup ['] }transfer = if drop exit then xt-transfer again ; @@ -56,11 +58,11 @@ transfer{ 'stack-cells 'boot 'boot-size 'latestxt 'argc 'argv 'runner 'tib leaving( )leaving leaving leaving, - (do) (?do) (+loop) + (do) (?do) (+loop) parse-quote digit $@ raw.s tib-setup input-limit [SKIP] [SKIP]' raw-ok - $place zplace sys: + $place zplace sys: BUILTIN_MARK }transfer forth definitions diff --git a/ueforth/windows/interp.h b/ueforth/windows/interp.h index 6d25c24..9deeb5d 100644 --- a/ueforth/windows/interp.h +++ b/ueforth/windows/interp.h @@ -32,7 +32,8 @@ enum { static cell_t *forth_run(cell_t *init_rp) { static const BUILTIN_WORD builtins[] = { #define XV(flags, name, op, code) \ - name, 0, sizeof(name) - 1, (flags & 0xff), (void *) OP_ ## op, + name, ((flags >> 8) & 0xff) | BUILTIN_MARK, sizeof(name) - 1, \ + (flags & 0xff), (void *) OP_ ## op, PLATFORM_OPCODE_LIST EXTRA_OPCODE_LIST OPCODE_LIST @@ -41,12 +42,6 @@ static cell_t *forth_run(cell_t *init_rp) { if (!init_rp) { g_sys.builtins = builtins; -#define XV(flags, name, op, code) \ - create(name, sizeof(name) - 1, name[0] == ';', (void *) OP_ ## op); - PLATFORM_OPCODE_LIST - EXTRA_OPCODE_LIST - OPCODE_LIST -#undef XV return 0; } register cell_t *ip, *rp, *sp, tos, w;