From 61749a4796724c4e16fadacb8ce73835fabc3dac Mon Sep 17 00:00:00 2001 From: Brad Nelson Date: Sat, 29 Jan 2022 22:22:36 -0800 Subject: [PATCH] Cleanup vocabularys + see-all test. --- ueforth/Makefile | 14 +------------- ueforth/common/core.h | 12 +++++++----- ueforth/common/filetools.fs | 4 ++-- ueforth/common/testing.fs | 3 +++ ueforth/common/utils.fs | 20 ++++++++++++++++---- ueforth/common/vocabulary.fs | 18 +++++++++++------- ueforth/common/vocabulary_tests.fs | 30 +++++++++++++++++++++++++++++- ueforth/windows/windows.fs | 13 ++++++++++--- 8 files changed, 79 insertions(+), 35 deletions(-) diff --git a/ueforth/Makefile b/ueforth/Makefile index 49a18bd..c586460 100644 --- a/ueforth/Makefile +++ b/ueforth/Makefile @@ -145,19 +145,7 @@ unit_tests_win64: $(WINDOWS)/uEf64.exe common/all_tests.fs wine $^ see_all_test: $(POSIX)/ueforth - echo \ - also internals \ - also posix \ - also tasks \ - also streams \ - also ansi \ - also termios \ - also sockets \ - also telnetd \ - also httpd \ - also web-interface \ - also editor \ - see-all bye | $< >/dev/null + echo internals see-all bye | $< >/dev/null # ---- GENERATED ---- diff --git a/ueforth/common/core.h b/ueforth/common/core.h index 2cd585d..2af39d0 100644 --- a/ueforth/common/core.h +++ b/ueforth/common/core.h @@ -21,6 +21,8 @@ #define CELL_ALIGNED(a) (((cell_t) (a) + CELL_MASK) & ~CELL_MASK) #define IMMEDIATE 1 #define SMUDGE 2 + +// Maximum ALSO layers. #define VOCABULARY_DEPTH 16 #if PRINT_ERRORS @@ -210,13 +212,13 @@ static void forth_init(int argc, char *argv[], void *heap, cell_t *rp = g_sys.heap + 1; g_sys.heap += STACK_CELLS; cell_t *sp = g_sys.heap + 1; g_sys.heap += STACK_CELLS; - // FORTH vocabulary - *g_sys.heap++ = 0; cell_t *forth = g_sys.heap; - *g_sys.heap++ = 0; *g_sys.heap++ = 0; *g_sys.heap++ = 0; + // FORTH worldlist (relocated when vocabularies added). + cell_t *forth_wordlist = g_sys.heap; + *g_sys.heap++ = 0; // Vocabulary stack - g_sys.current = (cell_t **) forth; + g_sys.current = (cell_t **) forth_wordlist; g_sys.context = (cell_t ***) g_sys.heap; - *g_sys.heap++ = (cell_t) forth; + *g_sys.heap++ = (cell_t) forth_wordlist; for (int i = 0; i < VOCABULARY_DEPTH; ++i) { *g_sys.heap++ = 0; } forth_run(0); diff --git a/ueforth/common/filetools.fs b/ueforth/common/filetools.fs index 53e3b11..7e4d407 100644 --- a/ueforth/common/filetools.fs +++ b/ueforth/common/filetools.fs @@ -29,7 +29,7 @@ internals definitions : save-name 'heap @ park-heap ! - forth-wordlist @ park-forth ! + ' forth >body @ park-forth ! w/o create-file throw >r saving-base here over - r@ write-file throw r> close-file throw ; @@ -39,7 +39,7 @@ internals definitions saving-base r@ file-size throw r@ read-file throw drop r> close-file throw park-heap @ 'heap ! - park-forth @ forth-wordlist ! + park-forth @ ' forth >body ! 'cold @ dup if execute else drop then ; defer remember-filename diff --git a/ueforth/common/testing.fs b/ueforth/common/testing.fs index 8a65511..040a365 100644 --- a/ueforth/common/testing.fs +++ b/ueforth/common/testing.fs @@ -58,6 +58,9 @@ variable confirm-old-type : = if }confirm ." MUST BE LESS THAN: " . ." ACTUAL: " . space 0 assert then 2drop ; +: >assert ( actual expected -- ) + 2dup <= if }confirm ." MUST BE GREATER THAN: " . + ." ACTUAL: " . space 0 assert then 2drop ; ( Input testing ) create in-buffer 1000 allot diff --git a/ueforth/common/utils.fs b/ueforth/common/utils.fs index 423a8ca..4a6b212 100644 --- a/ueforth/common/utils.fs +++ b/ueforth/common/utils.fs @@ -56,11 +56,24 @@ internals definitions dup @ ['] see-loop @ <> if ." Unsupported word type: " see. cr exit then ['] : see. dup see. space see-loop ['] ; see. cr ; -: see-all 0 context @ @ begin dup while dup see-xt >link repeat 2drop cr ; -: voc. ( voc -- ) dup forth-wordlist = if ." FORTH " drop exit then 3 cells - see. ; +: >name-length ( xt -- n ) dup 0= if exit then >name nip ; +: see-vocabulary ( voc ) @ begin dup >name-length while dup see-xt >link repeat drop cr ; +: >vocnext ( xt -- xt ) >body 2 cells + @ ; +: see-all + last-vocabulary @ begin dup while + ." VOCABULARY " dup see. cr ." ------------------------" cr + dup >body see-vocabulary + >vocnext + repeat drop cr ; +: voclist last-vocabulary @ begin dup while dup see. >vocnext repeat drop cr ; +: voc. ( voc -- ) 2 cells - see. ; +: vocs. ( voc -- ) dup voc. @ begin dup while + dup >name-length 0= if ." >> " dup 2 cells - voc. then + >link + repeat drop cr ; forth definitions also internals : see ' see-xt ; -: order context begin dup @ while dup @ voc. cell+ repeat drop cr ; +: order context begin dup @ while dup @ vocs. cell+ repeat drop ; only forth definitions ( List words in Dictionary / Vocabulary ) @@ -68,7 +81,6 @@ internals definitions 75 value line-width : onlines ( n xt -- n xt ) swap dup line-width > if drop 0 cr then over >name nip + 1+ swap ; -: >name-length ( xt -- n ) dup 0= if exit then >name nip ; forth definitions also internals : vlist 0 context @ @ begin dup >name-length while onlines dup see. >link repeat 2drop cr ; : words 0 context @ @ begin dup while onlines dup see. >link repeat 2drop cr ; diff --git a/ueforth/common/vocabulary.fs b/ueforth/common/vocabulary.fs index ec0c209..5fdfe1e 100644 --- a/ueforth/common/vocabulary.fs +++ b/ueforth/common/vocabulary.fs @@ -13,12 +13,17 @@ \ limitations under the License. ( Implement Vocabularies ) +( normal: link, flags&len, code ) +( vocab: link, flags&len, code | link , len=0, voclink ) variable last-vocabulary -current @ constant forth-wordlist -: forth forth-wordlist context ! ; -: vocabulary ( "name" ) create 0 , current @ 2 cells + , current @ @ last-vocabulary ! - does> cell+ context ! ; +: vocabulary ( "name" ) + create current @ 2 cells + , 0 , last-vocabulary @ , + current @ @ last-vocabulary ! + does> context ! ; : definitions context @ current ! ; +vocabulary FORTH +' forth >body @ >link ' forth >body ! +forth definitions ( Make it easy to transfer words between vocabularies ) : xt-find& ( xt -- xt& ) context @ begin 2dup @ <> while @ >link& repeat nip ; @@ -32,7 +37,7 @@ current @ constant forth-wordlist : only forth 0 context cell+ ! ; : voc-stack-end ( -- a ) context begin dup @ while cell+ repeat ; : also context context cell+ voc-stack-end over - 2 cells + cmove> ; -: sealed 0 last-vocabulary @ >body cell+ ! ; +: sealed 0 last-vocabulary @ >body ! ; ( Hide some words in an internals vocabulary ) vocabulary internals internals definitions @@ -42,8 +47,7 @@ variable scope scope context cell - ! transfer{ xt-find& xt-hide xt-transfer - voc-stack-end forth-wordlist - last-vocabulary + voc-stack-end last-vocabulary branch 0branch donext dolit 'context 'notfound notfound immediate? input-buffer ?echo ?arrow. arrow diff --git a/ueforth/common/vocabulary_tests.fs b/ueforth/common/vocabulary_tests.fs index 9f24b59..400e379 100644 --- a/ueforth/common/vocabulary_tests.fs +++ b/ueforth/common/vocabulary_tests.fs @@ -50,7 +50,10 @@ e: test-order vocabulary baz also foo also bar also baz order - out: baz bar foo FORTH + out: baz >> FORTH + out: bar >> FORTH + out: foo >> FORTH + out: FORTH only forth definitions ;e @@ -102,6 +105,20 @@ e: test-sealed only forth definitions ;e +e: test-nested + vocabulary foo + foo definitions + : hi ; + : there ; + vocabulary bar + bar definitions + : a ; + : b ; + vlist + out: b a + only forth definitions +;e + e: test-fixed-does>-normal : adder create , does> @ + ; 3 adder foo @@ -109,6 +126,17 @@ e: test-fixed-does>-normal 4 ' foo execute 7 =assert ;e +also internals +variable see-tally +: tally-type ( a n -- ) nip see-tally +! ; +: test-see-all + 0 see-tally ! + ['] tally-type is type + see-all + ['] default-type is type + see-tally @ 36000 >assert +; + ( e: test-fixed-does>-interp create hi 123 , does> @ + ; diff --git a/ueforth/windows/windows.fs b/ueforth/windows/windows.fs index 5e5fe67..0f31376 100644 --- a/ueforth/windows/windows.fs +++ b/ueforth/windows/windows.fs @@ -111,14 +111,21 @@ stdout console-mode GetConsoleMode drop stdout console-mode @ ENABLE_VIRTUAL_TERMINAL_PROCESSING or SetConsoleMode drop : win-type ( a n -- ) stdout -rot NULL NULL WriteFile drop ; -' win-type is type : raw-key ( -- n ) 0 >r stdin rp@ 1 NULL NULL ReadFile drop r> ; : win-key? ( -- f ) stdin 0 WaitForSingleObject 0= ; -' win-key? is key? : win-key ( -- n ) raw-key dup 13 = if drop nl then ; -' win-key is key : win-bye ( -- ) 0 ExitProcess drop ; + +also forth definitions +: default-type win-type ; +: default-key win-key ; +: default-key? win-key? ; +only windows definitions +' default-type is type +' default-key is key +' default-key? is key? ' win-bye is bye + -1 echo ! ansi