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

Make >body smarter to eliminate >:body

Browse Source
This commit is contained in:
Brad Nelson
2021-01-13 10:13:27 -08:00
parent 0a7109e108
commit ea2fec02e9
2 changed files with 3 additions and 4 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
ueforth/common/boot.fs
View File

@ -80,8 +80,7 @@
: >name ( xt -- a n ) 3 cells - dup @ swap over aligned - swap ; : >name ( xt -- a n ) 3 cells - dup @ swap over aligned - swap ;
: >link ( xt -- a ) 2 cells - @ ; : >link ( xt -- a ) 2 cells - @ ;
: >flags ( xt -- flags ) cell - ; : >flags ( xt -- flags ) cell - ;
: >body ( xt -- a ) 2 cells + ; : >body ( xt -- a ) dup @ [ ' >flags @ ] literal = 2 + cells + ;
: >:body ( xt -- a ) cell+ ;
( Postpone - done here so we have ['] and IF ) ( Postpone - done here so we have ['] and IF )
: immediate? ( xt -- f ) >flags @ 1 and 0= 0= ; : immediate? ( xt -- f ) >flags @ 1 and 0= 0= ;
@ -189,7 +188,7 @@ variable hld
: see-one ( xt -- xt+1 ) : see-one ( xt -- xt+1 )
dup @ dup ['] DOLIT = if drop cell+ dup @ . else see. then cell+ ; dup @ dup ['] DOLIT = if drop cell+ dup @ . else see. then cell+ ;
: exit= ( xt -- ) ['] exit = ; : exit= ( xt -- ) ['] exit = ;
: see-loop >:body begin see-one dup @ exit= until ; : see-loop >body begin see-one dup @ exit= until ;
: see cr ['] : see. ' dup see. space see-loop drop ['] ; see. cr ; : see cr ['] : see. ' dup see. space see-loop drop ['] ; see. cr ;
75 value line-width 75 value line-width
: onlines ( n xt -- n xt ) : onlines ( n xt -- n xt )

2
ueforth/common/tasks.fs
View File

@ -4,7 +4,7 @@
create here >r 0 , 0 , 0 , create here >r 0 , 0 , 0 ,
here cell+ r@ cell+ ! cells allot here cell+ r@ cell+ ! cells allot
here r@ 2 cells + ! cells allot here r@ 2 cells + ! cells allot
dup 0= if drop else >:body r@ 2 cells + @ ! then rdrop ; dup 0= if drop else >body r@ 2 cells + @ ! then rdrop ;
variable task-list variable task-list