diff --git a/common/boot.fs b/common/boot.fs index cb0abec..4a6f313 100644 --- a/common/boot.fs +++ b/common/boot.fs @@ -61,20 +61,20 @@ variable leaving : leaving( leaving @ 0 leaving ! 2 nest-depth +! ; : )leaving leaving @ swap leaving ! -2 nest-depth +! 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 .. ) +: 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 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 +: ?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 - @ ; diff --git a/common/forth_namespace_tests.fs b/common/forth_namespace_tests.fs index acfa2fb..ed9cf8d 100644 --- a/common/forth_namespace_tests.fs +++ b/common/forth_namespace_tests.fs @@ -103,7 +103,7 @@ e: check-boot out: loop out: +loop out: leave - out: unloop + out: UNLOOP out: ?do out: do out: next diff --git a/common/utils.fs b/common/utils.fs index fff0105..a9805e3 100644 --- a/common/utils.fs +++ b/common/utils.fs @@ -34,6 +34,7 @@ internals definitions 16 constant NONAMED 32 constant +TAB 64 constant -TAB +128 constant ARGS_MARK : mem= ( a a n -- f) for aft 2dup c@ swap c@ <> if 2drop rdrop 0 exit then 1+ swap 1+ then next 2drop -1 ; forth definitions also internals @@ -60,6 +61,11 @@ internals internalized definitions +TAB flags'or! AFT +TAB flags'or! FOR -TAB flags'or! NEXT ++TAB flags'or! DO +ARGS_MARK +TAB or flags'or! ?DO +ARGS_MARK -TAB or flags'or! +LOOP +ARGS_MARK -TAB or flags'or! LOOP +ARGS_MARK flags'or! LEAVE forth definitions @@ -90,10 +96,7 @@ variable indent dup @ ['] BRANCH @ = over @ ['] 0BRANCH @ = or over @ ['] DONEXT @ = or - over ['] (?do) = or - over ['] (+loop) = or - over ['] (loop) = or - over ['] (leave) = or + over >flags ARGS_MARK and or if swap cell+ swap then drop ; diff --git a/common/vocabulary.fs b/common/vocabulary.fs index 1d79caa..a6e369e 100644 --- a/common/vocabulary.fs +++ b/common/vocabulary.fs @@ -57,7 +57,6 @@ transfer{ immediate? input-buffer ?echo ?arrow. arrow evaluate-buffer aliteral value-bind leaving( )leaving leaving leaving, - (do) (?do) (+loop) (loop) (leave) parse-quote digit $@ raw.s tib-setup input-limit [SKIP] [SKIP]' raw-ok boot-prompt free. @@ -71,6 +70,8 @@ cleave begin cleave again cleave until cleave ahead cleave then cleave if cleave else cleave while cleave repeat cleave aft cleave for cleave next +cleave do cleave ?do cleave +loop +cleave loop cleave leave forth definitions