alx/ueforth
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Improved SEE

Browse Source
This commit is contained in:
Brad Nelson
2021-02-12 20:57:10 -08:00
parent 03f82385f6
commit 364505ed73
4 changed files with 55 additions and 3 deletions
Download Patch File Download Diff File Expand all files Collapse all files

19
ueforth/common/boot.fs
View File

@ -189,10 +189,23 @@ variable hld
( Examine Dictionary ) ( Examine Dictionary )
: see. ( xt -- ) >name type space ; : see. ( xt -- ) >name type space ;
: see-one ( xt -- xt+1 ) : see-one ( xt -- xt+1 )
dup @ dup ['] DOLIT = if drop cell+ dup @ . else see. then cell+ ; 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 = ; : exit= ( xt -- ) ['] exit = ;
: see-loop >body begin see-one dup @ exit= until ; : see-loop >body begin dup @ exit= 0= while see-one repeat drop ;
: see cr ['] : see. ' dup see. space see-loop drop ['] ; see. cr ; : 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 ;
75 value line-width 75 value line-width
: onlines ( n xt -- n xt ) : onlines ( n xt -- n xt )
swap dup line-width > if drop 0 cr then over >name nip + 1+ swap ; swap dup line-width > if drop 0 cr then over >name nip + 1+ swap ;

1
ueforth/common/testing.fs
View File

@ -20,6 +20,7 @@ variable expect-used variable result-used
: result-type ( a n -- ) for aft dup c@ result-emit 1+ then next drop ; : result-type ( a n -- ) for aft dup c@ result-emit 1+ then next drop ;
: expected ( -- a n ) expect-buffer expect-used @ ; : expected ( -- a n ) expect-buffer expect-used @ ;
: resulted ( -- a n ) result-buffer result-used @ ; : resulted ( -- a n ) result-buffer result-used @ ;
: out:cr nl expect-emit ;
: out: ( "line" -- ) nl parse expect-type nl expect-emit ; : out: ( "line" -- ) nl parse expect-type nl expect-emit ;
: out:\ ( "line" -- ) nl parse expect-type ; : out:\ ( "line" -- ) nl parse expect-type ;
variable confirm-old-type variable confirm-old-type

3
ueforth/common/utils.fs
View File

@ -1,4 +1,6 @@
( Words built after boot ) ( Words built after boot )
( For tests and asserts )
: assert ( f -- ) 0= throw ; : assert ( f -- ) 0= throw ;
internals definitions internals definitions
@ -8,6 +10,7 @@ forth definitions also internals
: str= ( a n a n -- f) >r swap r@ <> if rdrop 2drop 0 exit then r> mem= ; : str= ( a n a n -- f) >r swap r@ <> if rdrop 2drop 0 exit then r> mem= ;
: startswith? ( a n a n -- f ) >r swap r@ < if rdrop 2drop 0 exit then r> mem= ; : startswith? ( a n a n -- f ) >r swap r@ < if rdrop 2drop 0 exit then r> mem= ;
: .s ." <" depth n. ." > " raw.s cr ; : .s ." <" depth n. ." > " raw.s cr ;
: see-all 0 context @ @ begin dup while onlines dup see-xt >link repeat 2drop cr ;
only forth definitions only forth definitions
: forget ( "name" ) ' dup >link current @ ! >name drop here - allot ; : forget ( "name" ) ' dup >link current @ ! >name drop here - allot ;

35
ueforth/common/utils_tests.fs
View File

@ -26,3 +26,38 @@ e: test-forget
current @ = assert current @ = assert
context @ @ = assert context @ @ = assert
;e ;e
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