Cleanup vocabularys + see-all test.

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 ----
 

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);

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

ueforth/common/testing.fs

@@ -58,6 +58,9 @@ variable confirm-old-type
 : <assert ( actual expected -- )
   2dup >= 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

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 ;

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

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> @ + ;

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