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

Condense DO LOOP.

Browse Source
This commit is contained in:
Brad Nelson
2022-07-30 16:49:11 -07:00
parent 1e6aeacbe3
commit f0a1d54b35
3 changed files with 17 additions and 10 deletions
Download Patch File Download Diff File Expand all files Collapse all files

21
common/boot.fs
View File

@ -63,15 +63,18 @@ variable leaving
begin dup while dup @ swap here swap ! repeat drop ;
: (do) ( n n -- .. ) swap r> -rot >r >r >r ;
: do ( lim s -- ) leaving( postpone (do) here ; immediate
: (?do) ( n n -- n n f .. ) 2dup = if 2drop 0 else -1 then ;
: ?do ( lim s -- ) leaving( postpone (?do) postpone 0branch leaving,
postpone (do) here ; immediate
: unloop postpone rdrop postpone rdrop ; immediate
: leave postpone unloop postpone branch leaving, ; immediate
: (+loop) ( n -- f .. ) dup 0< swap r> r> rot + dup r@ < -rot >r >r xor 0= ;
: +loop ( n -- ) postpone (+loop) postpone until
postpone unloop )leaving ; immediate
: loop 1 aliteral postpone +loop ; immediate
: (?do) ( n n -- n n f .. )
2dup = if 2drop r> @ >r else swap r> cell+ -rot >r >r >r then ;
: ?do ( lim s -- ) leaving( postpone (?do) leaving, here ; immediate
: unloop r> rdrop rdrop >r ;
: (leave) r> rdrop rdrop @ >r ;
: leave postpone (leave) leaving, ; immediate
: (+loop) ( n -- ) dup 0< swap r> r> rot + dup r@ < -rot >r >r xor 0=
if r> cell+ rdrop rdrop >r else r> @ >r then ;
: +loop ( n -- ) postpone (+loop) , )leaving ; immediate
: (loop) r> r> 1+ dup r@ < -rot >r >r 0=
if r> cell+ rdrop rdrop >r else r> @ >r then ;
: loop postpone (loop) , )leaving ; immediate
create I ' r@ @ ' i ! ( i is same as r@ )
: J ( -- n ) rp@ 3 cells - @ ;
: K ( -- n ) rp@ 5 cells - @ ;