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

Fixed TO for locals.

Browse Source
This commit is contained in:
Brad Nelson
2021-07-10 18:11:08 -07:00
parent 4d598c7e5f
commit f0642252d3
3 changed files with 33 additions and 10 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
ueforth/common/boot.fs
View File

@ -158,10 +158,10 @@ variable handler
( Values ) ( Values )
: value ( n -- ) create , does> @ ; : value ( n -- ) create , does> @ ;
: to ( n -- ) : value-bind ( xt-val xt )
' >body state @ if aliteral postpone ! else ! then ; immediate >r >body state @ if aliteral r> , else r> execute then ;
: +to ( n -- ) : to ( n -- ) ' ['] ! value-bind ; immediate
' >body state @ if aliteral postpone +! else +! then ; immediate : +to ( n -- ) ' ['] +! value-bind ; immediate
( Deferred Words ) ( Deferred Words )
: defer ( "name" -- ) create 0 , does> @ dup 0= throw execute ; : defer ( "name" -- ) create 0 , does> @ dup 0= throw execute ;

23
ueforth/common/locals.fs
View File

@ -24,18 +24,23 @@ create locals-area locals-capacity allot
variable locals-here locals-area locals-here ! variable locals-here locals-area locals-here !
: <>locals locals-here @ here locals-here ! here - allot ; : <>locals locals-here @ here locals-here ! here - allot ;
variable scope-depth
: scope-clear
begin scope-depth @ while postpone rdrop cell scope-depth +! repeat
0 scope ! locals-area locals-here ! ;
: local@ ( n -- ) rp@ + @ ; : local@ ( n -- ) rp@ + @ ;
: do-local ( n -- ) nest-depth @ 1+ cells - aliteral ['] local@ , ; : local! ( n -- ) rp@ + ! ;
: local+! ( n -- ) rp@ + +! ;
variable scope-depth
variable local-op ' local@ local-op !
: scope-clear
scope-depth @ for aft postpone rdrop then next
0 scope-depth ! 0 scope ! locals-area locals-here ! ;
: do-local ( n -- ) nest-depth @ + 1+ cells negate aliteral
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 , scope-depth @ aliteral postpone do-local ['] exit ,
cell negate scope-depth +! 1 scope-depth +!
; ;
: ?room locals-here @ locals-area - locals-capacity locals-gap - > : ?room locals-here @ locals-area - locals-capacity locals-gap - >
@ -46,6 +51,9 @@ variable scope-depth
: }? ( 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 ;
also forth definitions also forth definitions
: { begin bl parse : { begin bl parse
@ -53,6 +61,9 @@ also forth definitions
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 (local) again ; immediate
( 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
only forth definitions only forth definitions

12
ueforth/common/locals_tests.fs
View File

@ -59,3 +59,15 @@ e: test-do-+loop
99 999 test 99 999 test
out: 0 99 999 2 99 999 4 99 999 6 99 999 8 99 999 out: 0 99 999 2 99 999 4 99 999 6 99 999 8 99 999
;e ;e
e: test-to
: test 0 { a b } 123 to b a . b . cr ;
3 test
out: 3 123
;e
e: test-to-loop
: test 0 { x } 5 0 do i i * to x x . loop cr ;
test
out: 0 1 4 9 16
;e