diff --git a/ueforth/common/boot.fs b/ueforth/common/boot.fs index 27797cc..822c572 100644 --- a/ueforth/common/boot.fs +++ b/ueforth/common/boot.fs @@ -121,15 +121,18 @@ sp@ constant sp0 rp@ constant rp0 : depth ( -- n ) sp@ sp0 - cell/ ; +( Rstack nest depth ) +variable nest-depth + ( FOR..NEXT ) -: for postpone >r postpone begin ; immediate -: next postpone donext , ; immediate +: for 1 nest-depth +! postpone >r postpone begin ; immediate +: next -1 nest-depth +! postpone donext , ; immediate ( DO..LOOP ) variable leaving : leaving, here leaving @ , leaving ! ; -: leaving( leaving @ 0 leaving ! ; -: )leaving leaving @ swap 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 diff --git a/ueforth/common/locals.fs b/ueforth/common/locals.fs index 45d2d40..c8a4065 100644 --- a/ueforth/common/locals.fs +++ b/ueforth/common/locals.fs @@ -18,29 +18,39 @@ internals definitions +( Leave a region for locals definitions ) +1024 constant locals-capacity 128 constant locals-gap +create locals-area locals-capacity allot +variable locals-here locals-area locals-here ! +: <>locals locals-here @ here locals-here ! here - allot ; + variable scope-depth -: scope-doer create does> @ rp@ + @ ; -scope-doer scope-template : scope-clear begin scope-depth @ while postpone rdrop cell scope-depth +! repeat - 0 scope ! ; + 0 scope ! locals-area locals-here ! ; +: local@ ( n -- ) rp@ + @ ; +: do-local ( n -- ) nest-depth @ 1+ cells - aliteral ['] local@ , ; : scope-create ( a n -- ) dup >r $place align r> , ( name ) - scope @ , 0 , here scope ! ( link, flags ) - ['] scope-template dup @ , cell+ @ , - cell negate scope-depth +! scope-depth @ , ; + scope @ , 1 , ( IMMEDIATE ) here scope ! ( link, flags ) + ['] scope-clear @ ( docol) , + scope-depth @ aliteral postpone do-local ['] exit , + cell negate scope-depth +! +; + +: ?room locals-here @ locals-area - locals-capacity locals-gap - > + if scope-clear -1 throw then ; ( NOTE: This is not ANSForth compatible ) -: (local) ( a n -- ) - >r >r postpone >r postpone ahead r> r> scope-create postpone then ; +: (local) ( a n -- ) ?room <>locals scope-create <>locals postpone >r ; : }? ( a n -- ) 1 <> if drop 0 exit then c@ [char] } = ; : --? ( a n -- ) s" --" str= ; -: eat} begin bl parse }? until ; also forth definitions : { begin bl parse - 2dup --? if 2drop eat} exit then + dup 0= if scope-clear -1 throw then + 2dup --? if 2drop [char] } parse 2drop exit then 2dup }? if 2drop exit then (local) again ; immediate : ; scope-clear postpone ; ; immediate diff --git a/ueforth/common/locals_tests.fs b/ueforth/common/locals_tests.fs index 7fbf9e2..4b5dfc7 100644 --- a/ueforth/common/locals_tests.fs +++ b/ueforth/common/locals_tests.fs @@ -41,3 +41,21 @@ e: test-dash : test { a b c -- a a b b c c } a a b b c c ; 1 2 3 test * + * + * 23 = assert ;e + +e: test-for-loop + : test { a b } 5 for a . b . next cr ; + 1 2 test + out: 1 2 1 2 1 2 1 2 1 2 1 2 +;e + +e: test-do-loop + : test { a b } 5 0 do a . b . loop cr ; + 1 2 test + out: 1 2 1 2 1 2 1 2 1 2 +;e + +e: test-do-+loop + : test { a b } 10 0 do i . a . b . 2 +loop cr ; + 99 999 test + out: 0 99 999 2 99 999 4 99 999 6 99 999 8 99 999 +;e