From 4abd02ba9431f404f91830ea202b855b54db7ad1 Mon Sep 17 00:00:00 2001 From: Brad Nelson Date: Sun, 6 Feb 2022 18:19:01 -0800 Subject: [PATCH] New builtins work now. --- ueforth/Makefile | 2 +- ueforth/common/calls.h | 23 +- ueforth/common/floats.fs | 1 - ueforth/common/floats.h | 4 +- ueforth/common/forth_namespace_tests.fs | 327 +++++++++++++----------- ueforth/common/hide_calls.fs | 19 -- ueforth/common/opcodes.h | 23 +- ueforth/common/utils.fs | 6 +- ueforth/common/vocabulary.fs | 3 +- ueforth/esp32/platform.fs | 1 - ueforth/windows/interp.h | 1 + 11 files changed, 214 insertions(+), 196 deletions(-) delete mode 100644 ueforth/common/hide_calls.fs diff --git a/ueforth/Makefile b/ueforth/Makefile index 207957f..6bc62a7 100644 --- a/ueforth/Makefile +++ b/ueforth/Makefile @@ -179,7 +179,7 @@ $(GEN): COMMON_PHASE1 = common/boot.fs common/conditionals.fs common/vocabulary.fs \ common/floats.fs -COMMON_DESKTOP = common/hide_calls.fs common/ansi.fs common/desktop.fs +COMMON_DESKTOP = common/ansi.fs common/desktop.fs COMMON_PHASE2 = common/tasks.fs common/utils.fs common/locals.fs \ common/filetools.fs common/including.fs \ diff --git a/ueforth/common/calls.h b/ueforth/common/calls.h index 82fd682..ea9b029 100644 --- a/ueforth/common/calls.h +++ b/ueforth/common/calls.h @@ -25,15 +25,14 @@ typedef cell_t (CALLTYPE *call_t)(); #define ct0 ((call_t) n0) #define CALLING_OPCODE_LIST \ - Y(CALL0, n0 = ct0()) \ - Y(CALL1, n0 = ct0(n1); --sp) \ - Y(CALL2, n0 = ct0(n2, n1); sp -= 2) \ - Y(CALL3, n0 = ct0(n3, n2, n1); sp -= 3) \ - Y(CALL4, n0 = ct0(n4, n3, n2, n1); sp -= 4) \ - Y(CALL5, n0 = ct0(n5, n4, n3, n2, n1); sp -= 5) \ - Y(CALL6, n0 = ct0(n6, n5, n4, n3, n2, n1); sp -= 6) \ - Y(CALL7, n0 = ct0(n7, n6, n5, n4, n3, n2, n1); sp -= 7) \ - Y(CALL8, n0 = ct0(n8, n7, n6, n5, n4, n3, n2, n1); sp -= 8) \ - Y(CALL9, n0 = ct0(n9, n8, n7, n6, n5, n4, n3, n2, n1); sp -= 9) \ - Y(CALL10, n0 = ct0(n10, n9, n8, n7, n6, n5, n4, n3, n2, n1); sp -= 10) \ - + YV(internals, CALL0, n0 = ct0()) \ + YV(internals, CALL1, n0 = ct0(n1); --sp) \ + YV(internals, CALL2, n0 = ct0(n2, n1); sp -= 2) \ + YV(internals, CALL3, n0 = ct0(n3, n2, n1); sp -= 3) \ + YV(internals, CALL4, n0 = ct0(n4, n3, n2, n1); sp -= 4) \ + YV(internals, CALL5, n0 = ct0(n5, n4, n3, n2, n1); sp -= 5) \ + YV(internals, CALL6, n0 = ct0(n6, n5, n4, n3, n2, n1); sp -= 6) \ + YV(internals, CALL7, n0 = ct0(n7, n6, n5, n4, n3, n2, n1); sp -= 7) \ + YV(internals, CALL8, n0 = ct0(n8, n7, n6, n5, n4, n3, n2, n1); sp -= 8) \ + YV(internals, CALL9, n0 = ct0(n9, n8, n7, n6, n5, n4, n3, n2, n1); sp -= 9) \ + YV(internals, CALL10, n0 = ct0(n10, n9, n8, n7, n6, n5, n4, n3, n2, n1); sp -= 10) diff --git a/ueforth/common/floats.fs b/ueforth/common/floats.fs index 6e7c24f..fbaa733 100644 --- a/ueforth/common/floats.fs +++ b/ueforth/common/floats.fs @@ -27,7 +27,6 @@ internals definitions : #f+s ( r -- ) fdup precision 0 ?do 10e f* loop precision 0 ?do fdup f>s 10 mod [char] 0 + hold 0.1e f* loop [char] . hold fdrop f>s #s ; -transfer doflit forth definitions internals : #fs ( r -- ) fdup f0< if fnegate #f+s [char] - hold else #f+s then ; diff --git a/ueforth/common/floats.h b/ueforth/common/floats.h index 4c20050..5165adb 100644 --- a/ueforth/common/floats.h +++ b/ueforth/common/floats.h @@ -13,7 +13,7 @@ // limitations under the License. #define FLOATING_POINT_LIST \ - Y(DOFLIT, *++fp = *(float *) ip++) \ + YV(internals, DOFLIT, *++fp = *(float *) ip++) \ X("FP@", FPAT, DUP; tos = (cell_t) fp) \ X("FP!", FPSTORE, fp = (float *) tos; DROP) \ X("SF@", FAT, *++fp = *(float *) tos; DROP) \ @@ -39,7 +39,7 @@ X("1/F", FINVERSE, *fp = 1.0 / *fp) \ X("S>F", STOF, *++fp = (float) tos; DROP) \ X("F>S", FTOS, DUP; tos = (cell_t) *fp--) \ - X("F>NUMBER?", FCONVERT, tos = fconvert((const char *) *sp, tos, fp); --sp) \ + XV(internals, "F>NUMBER?", FCONVERT, tos = fconvert((const char *) *sp, tos, fp); --sp) \ Y(SFLOAT, DUP; tos = sizeof(float)) \ Y(SFLOATS, tos *= sizeof(float)) \ X("SFLOAT+", SFLOATPLUS, DUP; tos += sizeof(float)) \ diff --git a/ueforth/common/forth_namespace_tests.fs b/ueforth/common/forth_namespace_tests.fs index 680d1c7..a53bd7e 100644 --- a/ueforth/common/forth_namespace_tests.fs +++ b/ueforth/common/forth_namespace_tests.fs @@ -13,7 +13,18 @@ \ limitations under the License. also internals -: list-from ( xt ) begin dup nonvoc? while dup see. cr >link repeat drop ; +: list-builtins ( voc ) + >r 'builtins begin dup >link while + dup >params r@ = if dup see. cr then + 3 cells + + repeat drop rdrop ; +: list-from ( xt ) begin dup nonvoc? while + dup >flags BUILTIN_FORK and if + dup cell+ @ list-builtins + then + dup see. cr + >link + repeat drop ; e: check-locals out: +to @@ -137,143 +148,141 @@ e: check-boot ;e e: check-extra-opcodes - out: >body - out: >name - out: >link - out: >link& - out: >size - out: >params - out: >flags - - out: c, - out: , - out: align - out: aligned - out: allot - out: here - - out: abs - out: max - out: min - - out: blank - out: erase - out: fill - out: cmove> - out: cmove - - out: 2! - out: 2@ - out: 2dup - out: 2drop - out: cell/ - out: cells - out: cell+ - out: +! - out: 4/ - out: 4* - out: 2/ - out: 2* - out: 1- - out: 1+ - out: nl - out: bl - out: 0<> - out: <> - out: = - out: >= - out: <= - out: > - out: < - out: -rot - out: rot - out: - - out: negate - out: invert - out: mod - out: / - out: /mod - out: * - out: */ - out: rdrop out: nip + out: rdrop + out: */ + out: * + out: /mod + out: / + out: mod + out: invert + out: negate + out: - + out: rot + out: -rot + out: < + out: > + out: <= + out: >= + out: = + out: <> + out: 0<> + out: bl + out: nl + out: 1+ + out: 1- + out: 2* + out: 2/ + out: 4* + out: 4/ + out: +! + out: cell+ + out: cells + out: cell/ + out: 2drop + out: 2dup + out: 2@ + out: 2! + + out: cmove + out: cmove> + out: fill + out: erase + out: blank + + out: min + out: max + out: abs + + out: here + out: allot + out: aligned + out: align + out: , + out: c, + + out: >flags + out: >params + out: >size + out: >link& + out: >link + out: >name + out: >body ;e e: check-core-opcodes - out: ; - out: EXIT - out: : - out: IMMEDIATE - out: DOES> - out: CREATE - out: S>NUMBER? - out: PARSE - out: FIND - out: CELL - out: EXECUTE - out: R@ - out: R> - out: >R - out: RP! - out: RP@ - out: SP! - out: SP@ - out: C! - out: W! - out: L! - out: ! - out: C@ - out: SW@ - out: SL@ - out: @ - out: DROP - out: OVER - out: SWAP - out: DUP - out: XOR - out: OR - out: AND - out: RSHIFT - out: LSHIFT - out: */MOD - out: U/MOD - out: + - out: 0< out: 0= + out: 0< + out: + + out: U/MOD + out: */MOD + out: LSHIFT + out: RSHIFT + out: AND + out: OR + out: XOR + out: DUP + out: SWAP + out: OVER + out: DROP + out: @ + out: SL@ + out: SW@ + out: C@ + out: ! + out: L! + out: W! + out: C! + out: SP@ + out: SP! + out: RP@ + out: RP! + out: >R + out: R> + out: R@ + out: EXECUTE + out: CELL + out: FIND + out: PARSE + out: CREATE + out: DOES> + out: IMMEDIATE + out: : + out: EXIT + out: ; ;e e: check-float-opcodes - out: FSQRT - out: PI - out: SFLOAT+ - out: SFLOATS - out: SFLOAT - out: F>NUMBER? - out: F>S - out: S>F - out: 1/F - out: F/ - out: F* - out: F- - out: F+ - out: F>= - out: F<= - out: F<> - out: F> - out: F< - out: F= - out: F0= - out: F0< - out: FNEGATE - out: FSWAP - out: FOVER - out: FDROP - out: FNIP - out: FDUP - out: SF! - out: SF@ - out: FP! out: FP@ + out: FP! + out: SF@ + out: SF! + out: FDUP + out: FNIP + out: FDROP + out: FOVER + out: FSWAP + out: FNEGATE + out: F0< + out: F0= + out: F= + out: F< + out: F> + out: F<> + out: F<= + out: F>= + out: F+ + out: F- + out: F* + out: F/ + out: 1/F + out: S>F + out: F>S + out: SFLOAT + out: SFLOATS + out: SFLOAT+ + out: PI + out: FSQRT ;e e: check-files @@ -296,6 +305,26 @@ e: check-files out: R/O ;e +e: check-files-reverse + out: R/O + out: W/O + out: R/W + out: BIN + out: CLOSE-FILE + out: FLUSH-FILE + out: OPEN-FILE + out: CREATE-FILE + out: DELETE-FILE + out: RENAME-FILE + out: WRITE-FILE + out: READ-FILE + out: FILE-POSITION + out: REPOSITION-FILE + out: RESIZE-FILE + out: FILE-SIZE + out: NON-BLOCK +;e + e: check-blocks out: editor out: list @@ -397,9 +426,12 @@ e: check-phase1 check-vocabulary check-[]conds check-boot -\ check-core-opcodes -\ check-extra-opcodes -\ check-float-opcodes +;e + +e: check-opcodes + check-float-opcodes + check-extra-opcodes + check-core-opcodes ;e e: check-desktop @@ -446,8 +478,9 @@ e: test-windows-forth-namespace out: default-type out: windows check-phase1 - \ out: LOADLIBRARYA - \ out: GETPROCADDRESS + out: GETPROCADDRESS + out: LOADLIBRARYA + check-opcodes out: forth-builtins ;e @@ -488,7 +521,8 @@ e: test-posix-forth-namespace out: default-type out: posix check-phase1 -\ out: DLSYM + out: DLSYM + check-opcodes out: forth-builtins ;e @@ -533,17 +567,17 @@ e: check-esp32-basics out: pin ;e -e: check-esp32-basics2 - out: MDNS.begin - out: dacWrite - check-files - out: TERMINATE - out: MS-TICKS - out: pulseIn - out: analogRead - out: digitalRead - out: digitalWrite +e: check-esp32-builtins out: pinMode + out: digitalWrite + out: digitalRead + out: analogRead + out: pulseIn + out: MS-TICKS + out: TERMINATE + check-files-reverse + out: dacWrite + out: MDNS.begin ;e e: test-esp32-forth-namespace @@ -583,7 +617,8 @@ e: test-esp32-forth-namespace check-phase2 check-allocation check-phase1 -\ check-esp32-basics2 + check-esp32-builtins + check-opcodes out: forth-builtins ;e diff --git a/ueforth/common/hide_calls.fs b/ueforth/common/hide_calls.fs deleted file mode 100644 index f397abe..0000000 --- a/ueforth/common/hide_calls.fs +++ /dev/null @@ -1,19 +0,0 @@ -\ Copyright 2021 Bradley D. Nelson -\ -\ Licensed under the Apache License, Version 2.0 (the "License"); -\ you may not use this file except in compliance with the License. -\ You may obtain a copy of the License at -\ -\ http://www.apache.org/licenses/LICENSE-2.0 -\ -\ Unless required by applicable law or agreed to in writing, software -\ distributed under the License is distributed on an "AS IS" BASIS, -\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -\ See the License for the specific language governing permissions and -\ limitations under the License. - -internals definitions -transfer{ - call0 call1 call2 call3 call4 call5 call6 call7 call8 call9 call10 -}transfer -forth definitions diff --git a/ueforth/common/opcodes.h b/ueforth/common/opcodes.h index 8ebb2ff..512c364 100644 --- a/ueforth/common/opcodes.h +++ b/ueforth/common/opcodes.h @@ -63,8 +63,13 @@ typedef int64_t dcell_t; typedef struct { const char *name; - uint8_t flags, name_length; - uint16_t vocabulary; + union { + struct { + uint8_t flags, name_length; + uint16_t vocabulary; + }; + cell_t multi; + }; const void *code; } BUILTIN_WORD; @@ -100,11 +105,11 @@ typedef struct { X("R>", FROMR, DUP; tos = *rp; --rp) \ X("R@", RAT, DUP; tos = *rp) \ Y(EXECUTE, w = tos; DROP; JMPW) \ - Y(BRANCH, ip = (cell_t *) *ip) \ - Y(0BRANCH, if (!tos) ip = (cell_t *) *ip; else ++ip; DROP) \ - Y(DONEXT, *rp = *rp - 1; if (~*rp) ip = (cell_t *) *ip; else (--rp, ++ip)) \ - Y(DOLIT, DUP; tos = *ip++) \ - Y(ALITERAL, COMMA(g_sys.DOLIT_XT); COMMA(tos); DROP) \ + YV(internals, BRANCH, ip = (cell_t *) *ip) \ + YV(internals, 0BRANCH, if (!tos) ip = (cell_t *) *ip; else ++ip; DROP) \ + YV(internals, DONEXT, *rp = *rp - 1; if (~*rp) ip = (cell_t *) *ip; else (--rp, ++ip)) \ + YV(internals, DOLIT, DUP; tos = *ip++) \ + YV(internals, ALITERAL, COMMA(g_sys.DOLIT_XT); COMMA(tos); DROP) \ Y(CELL, DUP; tos = sizeof(cell_t)) \ Y(FIND, tos = find((const char *) *sp, tos); --sp) \ Y(PARSE, DUP; tos = parse(tos, sp)) \ @@ -117,7 +122,7 @@ typedef struct { X("DOES>", DOES, DOES(ip); ip = (cell_t *) *rp; --rp) \ Y(IMMEDIATE, DOIMMEDIATE()) \ XV(internals, "'SYS", SYS, DUP; tos = (cell_t) &g_sys) \ - Y(YIELD, PARK; return rp) \ + YV(internals, YIELD, PARK; return rp) \ X(":", COLON, DUP; DUP; tos = parse(32, sp); \ create((const char *) *sp, tos, SMUDGE, ADDR_DOCOLON); \ g_sys.state = -1; --sp; DROP) \ @@ -125,5 +130,5 @@ typedef struct { sp = evaluate1(sp, &tfp); \ fp = tfp; w = *sp--; DROP; if (w) JMPW) \ Y(EXIT, ip = (cell_t *) *rp--) \ - XV(internals, "'builtins", TBUILTINS, DUP; tos = (cell_t) g_sys.builtins) \ + XV(internals, "'builtins", TBUILTINS, DUP; tos = (cell_t) &g_sys.builtins->code) \ XV(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 8aaeb7f..6daece4 100644 --- a/ueforth/common/utils.fs +++ b/ueforth/common/utils.fs @@ -108,7 +108,7 @@ internals definitions line-pos line-width > if cr 0 to line-pos then dup >name nip 1+ line-pos + to line-pos ; : vins. ( voc -- ) - >r 'builtins 2 cells + begin dup 2 cells - @ while + >r 'builtins begin dup >link while dup >params r@ = if dup onlines see. then 3 cells + repeat drop rdrop ; @@ -116,9 +116,9 @@ internals definitions : ?ins. ( xt -- xt ) dup >flags BUILTIN_FORK and if dup ins. then ; forth definitions also internals : vlist 0 to line-pos context @ @ - begin dup nonvoc? while onlines dup ?ins. see. >link repeat drop cr ; + begin dup nonvoc? while ?ins. dup onlines see. >link repeat drop cr ; : words 0 to line-pos context @ @ - begin dup while onlines dup see. >link repeat drop cr ; + begin dup while ?ins. dup onlines see. >link repeat drop cr ; only forth definitions ( Extra Task Utils ) diff --git a/ueforth/common/vocabulary.fs b/ueforth/common/vocabulary.fs index 94238cf..6f27bff 100644 --- a/ueforth/common/vocabulary.fs +++ b/ueforth/common/vocabulary.fs @@ -50,10 +50,9 @@ variable scope scope context cell - ! transfer{ xt-find& xt-hide xt-transfer voc-stack-end last-vocabulary - yield branch 0branch donext dolit 'context 'notfound notfound immediate? input-buffer ?echo ?arrow. arrow - evaluate1 evaluate-buffer + evaluate-buffer 'sys 'heap aliteral 'heap-start 'heap-size 'stack-cells 'boot 'boot-size 'latestxt 'argc 'argv 'runner 'tib diff --git a/ueforth/esp32/platform.fs b/ueforth/esp32/platform.fs index fef25d8..0012d09 100644 --- a/ueforth/esp32/platform.fs +++ b/ueforth/esp32/platform.fs @@ -14,7 +14,6 @@ ( Add a yielding task so pause yields ) internals definitions -transfer{ raw-yield }transfer : yield-step raw-yield yield ; ' yield-step 100 100 task yield-task yield-task start-task diff --git a/ueforth/windows/interp.h b/ueforth/windows/interp.h index b830b0a..94149da 100644 --- a/ueforth/windows/interp.h +++ b/ueforth/windows/interp.h @@ -38,6 +38,7 @@ static cell_t *forth_run(cell_t *init_rp) { EXTRA_OPCODE_LIST OPCODE_LIST #undef XV + 0, 0, 0, }; if (!init_rp) {