Made locals ans compatible and nestable.
This commit is contained in:
@ -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
|
||||||
|
|||||||
@ -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
|
||||||
|
|||||||
Reference in New Issue
Block a user