Moved see into utils.

This commit is contained in:
Brad Nelson
2021-02-12 21:16:06 -08:00
parent f5787bcc7c
commit 979e01b917
5 changed files with 32 additions and 31 deletions

View File

@ -106,11 +106,14 @@ clean:
# ---- TESTS ----
tests: unit_tests
tests: unit_tests see_all_test
unit_tests: $(POSIX)/ueforth common/all_tests.fs
$^
see_all_test: $(POSIX)/ueforth
echo "internals see-all bye" | $< >/dev/null
# ---- GENERATED ----
$(GEN):

View File

@ -186,27 +186,6 @@ variable hld
if cr ." ERROR: " type ." NOT FOUND!" cr -1 throw then ;
' notfound 'notfound !
( Examine Dictionary )
: see. ( xt -- ) >name type space ;
: see-one ( xt -- xt+1 )
dup cell+ swap @
dup ['] DOLIT = if drop dup @ . cell+ exit then
dup ['] $@ = if drop ['] s" see.
dup @ dup >r >r dup cell+ r> type cell+ r> aligned +
[char] " emit space exit then
dup ['] BRANCH =
over ['] 0BRANCH = or
over ['] DONEXT = or
if see. cell+ exit then
see. ;
: exit= ( xt -- ) ['] exit = ;
: see-loop >body begin dup @ exit= 0= while see-one repeat drop ;
: see-xt ( xt -- )
cr dup @ ['] see-loop @ <>
if ." Unsupported word type: " see. cr exit then
['] : see. dup see. space see-loop ['] ; see. cr ;
: see ' see-xt ;
( Input )
: raw.s depth 0 max for aft sp@ r@ cells - @ . then next ;
variable echo -1 echo !

View File

@ -19,6 +19,33 @@ forth definitions also internals
: .s ." <" depth n. ." > " raw.s cr ;
only forth definitions
( Definitions building to SEE and ORDER )
internals definitions
: see. ( xt -- ) >name type space ;
: see-one ( xt -- xt+1 )
dup cell+ swap @
dup ['] DOLIT = if drop dup @ . cell+ exit then
dup ['] $@ = if drop ['] s" see.
dup @ dup >r >r dup cell+ r> type cell+ r> aligned +
[char] " emit space exit then
dup ['] BRANCH =
over ['] 0BRANCH = or
over ['] DONEXT = or
if see. cell+ exit then
see. ;
: exit= ( xt -- ) ['] exit = ;
: see-loop >body begin dup @ exit= 0= while see-one repeat drop ;
: see-xt ( xt -- )
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. ;
forth definitions also internals
: see ' see-xt ;
: order context begin dup @ while dup @ voc. cell+ repeat drop cr ;
only forth definitions
( List words in Dictionary / Vocabulary )
internals definitions
75 value line-width
@ -28,5 +55,4 @@ internals definitions
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 ;
: see-all 0 context @ @ begin dup while onlines dup see-xt >link repeat 2drop cr ;
only forth definitions

View File

@ -30,34 +30,29 @@ e: test-forget
e: test-see-number
: test 123 456 ;
see test
out:cr
out: : test 123 456 ;
;e
e: test-see-string
: test s" hello there" ;
see test
out:cr
out: : test s" hello there" ;
;e
e: test-see-branch
: test begin again ;
see test
out:cr
out: : test BRANCH ;
;e
e: test-see-0branch
: test begin until ;
see test
out:cr
out: : test 0BRANCH ;
;e
e: test-see-fornext
: test for next ;
see test
out:cr
out: : test >R DONEXT ;
;e

View File

@ -19,13 +19,11 @@ current @ constant forth-wordlist
: 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+ ! ;
: voc. ( voc -- ) dup forth-wordlist = if ." FORTH " drop exit then 3 cells - see. ;
: order context begin dup @ while dup @ voc. cell+ repeat drop cr ;
( Hide some words in an internals vocabulary )
vocabulary internals internals definitions
transfer{
transfer-xt voc-stack-end forth-wordlist voc.
transfer-xt voc-stack-end forth-wordlist
last-vocabulary
branch 0branch donext dolit
'context 'notfound notfound