X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=forth.jl.git;a=blobdiff_plain;f=src%2Flib_8_vocab.4th;fp=src%2Flib_8_vocab.4th;h=22d98b573e3daa4d6ca74f62a1e2f7e7b379fb23;hp=0000000000000000000000000000000000000000;hb=30a093845e2d1097242e948bb577fb71f73bc860;hpb=c52194127d604bd365f7222936b46f34f62a4814

diff --git a/src/lib_8_vocab.4th b/src/lib_8_vocab.4th
new file mode 100644
index 0000000..22d98b5
--- /dev/null
+++ b/src/lib_8_vocab.4th
@@ -0,0 +1,119 @@
+\ Vocabulary management
+
+\ Forget word and everything defined after it in compilation dict
+: FORGET
+        BL WORD CURRENT @ FINDVOCAB ( find the word, gets the dictionary entry address )
+
+        0= if
+                drop exit
+        then
+
+        >link
+
+        dup @ current @ 1+ !      ( set LATEST to point to the previous word )
+;
+
+\ Mark word as hidden
+: HIDE ( -- )
+        BL WORD FIND DROP >NAME
+        DUP @ F_HIDDEN OR SWAP !
+;
+
+: ?HIDDEN
+        1+              ( skip over the link pointer )
+        @               ( get the flags/length byte )
+        F_HIDDEN AND    ( mask the F_HIDDEN flag and return it (as a truth value) )
+;
+
+\ Display name of word
+: .NAME ( cfa -- )
+        DUP @           ( get the flags/length byte )
+        F_LENMASK AND   ( mask out the flags - just want the length )
+
+        BEGIN
+                DUP 0>          ( length > 0? )
+        WHILE
+                SWAP 1+         ( addr len -- len addr+1 )
+                DUP @           ( len addr -- len addr char | get the next character)
+                DUP 32 >= IF
+                        EMIT    ( len addr char -- len addr | and print it)
+                ELSE
+                        BASE @ SWAP HEX
+                        ." \x" 0 .R
+                        BASE !
+                THEN
+                SWAP 1-         ( len addr -- addr len-1    | subtract one from length )
+        REPEAT
+        2DROP           ( len addr -- )
+;
+
+
+\ Create new vocabulary
+: VOCABULARY
+        create 0 ,
+does>
+        body> context #context @ 1- + !
+;
+
+: DEFINITIONS
+        context #context @ 1- + @ current !
+;
+
+\ Define root vocabulary (always available)
+vocabulary ROOT
+
+: ONLY
+        1 #context !
+        root 
+        2 #context !
+        root 
+;
+
+: PREVIOUS
+        #context @
+        1 <= abort" Cannot empty search order stack!"
+
+        1 #context -!
+;
+
+: ALSO
+        context #context @ + dup 1- @ swap !
+        1 #context +!
+;
+
+also root definitions
+
+    : FORTH forth ;
+
+    \ Display search order and compilation dictionary
+    : ORDER
+
+            \ Search order
+            context #context @ 1- + context swap
+            do
+                i @ >name .name space
+            -1 +loop
+
+            \ Current (definitions)
+            5 spaces
+            current @ >name .name
+    ;
+
+    \ Display transient vocabulary contents
+    : WORDS
+            cr
+            context #context @ 1- + @
+            1+ @
+            BEGIN
+                    ?DUP            ( while link pointer is not 0 )
+            WHILE
+                    DUP ?HIDDEN NOT IF      ( ignore hidden words )
+                            DUP 1+ .NAME         ( but if not hidden, print the word )
+                            SPACE
+                    THEN
+                    @               ( dereference the link pointer - go to previous word )
+            REPEAT
+            CR
+    ;
+
+only forth also definitions