Made locals ans compatible and nestable.

This commit is contained in:
Brad Nelson
2021-07-11 22:22:35 -07:00
parent f0642252d3
commit 168f689631
2 changed files with 24 additions and 11 deletions

View File

@ -31,36 +31,37 @@ variable locals-here locals-area locals-here !
variable scope-depth variable scope-depth
variable local-op ' local@ local-op ! variable local-op ' local@ local-op !
: scope-clear : scope-clear
scope-depth @ negate nest-depth +!
scope-depth @ for aft postpone rdrop then next scope-depth @ for aft postpone rdrop then next
0 scope-depth ! 0 scope ! locals-area locals-here ! ; 0 scope-depth ! 0 scope ! locals-area locals-here ! ;
: do-local ( n -- ) nest-depth @ + 1+ cells negate aliteral : do-local ( n -- ) nest-depth @ + cells negate aliteral
local-op @ , ['] local@ local-op ! ; local-op @ , ['] local@ local-op ! ;
: scope-create ( a n -- ) : scope-create ( a n -- )
dup >r $place align r> , ( name ) dup >r $place align r> , ( name )
scope @ , 1 , ( IMMEDIATE ) here scope ! ( link, flags ) scope @ , 1 , ( IMMEDIATE ) here scope ! ( link, flags )
['] scope-clear @ ( docol) , ['] scope-clear @ ( docol) ,
scope-depth @ aliteral postpone do-local ['] exit , nest-depth @ negate aliteral postpone do-local ['] exit ,
1 scope-depth +! 1 scope-depth +! 1 nest-depth +!
; ;
: ?room locals-here @ locals-area - locals-capacity locals-gap - > : ?room locals-here @ locals-area - locals-capacity locals-gap - >
if scope-clear -1 throw then ; if scope-clear -1 throw then ;
( NOTE: This is not ANSForth compatible )
: (local) ( a n -- ) ?room <>locals scope-create <>locals postpone >r ;
: }? ( a n -- ) 1 <> if drop 0 exit then c@ [char] } = ; : }? ( a n -- ) 1 <> if drop 0 exit then c@ [char] } = ;
: --? ( a n -- ) s" --" str= ; : --? ( a n -- ) s" --" str= ;
: (to) ( xt -- ) ['] local! local-op ! execute ; : (to) ( xt -- ) ['] local! local-op ! execute ;
: (+to) ( xt -- ) ['] local+! local-op ! execute ; : (+to) ( xt -- ) ['] local+! local-op ! execute ;
also forth definitions also forth definitions
: { begin bl parse : (local) ( a n -- )
dup 0= if 2drop exit then
?room <>locals scope-create <>locals postpone >r ;
: { bl parse
dup 0= if scope-clear -1 throw then dup 0= if scope-clear -1 throw then
2dup --? if 2drop [char] } parse 2drop exit then 2dup --? if 2drop [char] } parse 2drop exit then
2dup }? if 2drop exit then 2dup }? if 2drop exit then
(local) again ; immediate recurse (local) ; immediate
( TODO: Hide the words overriden here. ) ( TODO: Hide the words overriden here. )
: ; scope-clear postpone ; ; immediate : ; scope-clear postpone ; ; immediate
: to ( n -- ) ' dup >flags @ if (to) else ['] ! value-bind then ; immediate : to ( n -- ) ' dup >flags @ if (to) else ['] ! value-bind then ; immediate

View File

@ -71,3 +71,15 @@ e: test-to-loop
test test
out: 0 1 4 9 16 out: 0 1 4 9 16
;e ;e
e: test-multi
: test { a b } 9 99 { c d } a . b . c . d . ;
1 2 test cr
out: 1 2 9 99
;e
e: test-multi-to
: test { a b } 9 99 { c d } 5 to c a . b . c . d . ;
1 2 test cr
out: 1 2 5 99
;e