198 lines
4.2 KiB
Forth
198 lines
4.2 KiB
Forth
\ tag: local variables
|
|
\
|
|
\ Copyright (C) 2012 Mark Cave-Ayland
|
|
\
|
|
\ See the file "COPYING" for further information about
|
|
\ the copyright and warranty status of this work.
|
|
\
|
|
|
|
[IFDEF] CONFIG_LOCALS
|
|
|
|
\ Init local variable stack
|
|
variable locals-var-stack
|
|
here 200 cells allot locals-var-stack !
|
|
|
|
\ Set initial stack pointer
|
|
\
|
|
\ Stack looks like this:
|
|
\ ... (sp n-2) local1 ... localm-1 localm (sp n-1) <-- sp
|
|
|
|
locals-var-stack @ value locals-var-sp
|
|
locals-var-sp locals-var-stack @ !
|
|
|
|
0 value locals-var-count
|
|
0 value locals-flags
|
|
|
|
here 200 cells allot locals-dict-buf !
|
|
|
|
8 constant #locals
|
|
|
|
: (local1) locals-var-sp @ /n + ;
|
|
: (local2) locals-var-sp @ 2 cells + ;
|
|
: (local3) locals-var-sp @ 3 cells + ;
|
|
: (local4) locals-var-sp @ 4 cells + ;
|
|
: (local5) locals-var-sp @ 5 cells + ;
|
|
: (local6) locals-var-sp @ 6 cells + ;
|
|
: (local7) locals-var-sp @ 7 cells + ;
|
|
: (local8) locals-var-sp @ 8 cells + ;
|
|
|
|
: local1@ (local1) @ ;
|
|
: local2@ (local2) @ ;
|
|
: local3@ (local3) @ ;
|
|
: local4@ (local4) @ ;
|
|
: local5@ (local5) @ ;
|
|
: local6@ (local6) @ ;
|
|
: local7@ (local7) @ ;
|
|
: local8@ (local8) @ ;
|
|
|
|
: local1! (local1) ! ;
|
|
: local2! (local2) ! ;
|
|
: local3! (local3) ! ;
|
|
: local4! (local4) ! ;
|
|
: local5! (local5) ! ;
|
|
: local6! (local6) ! ;
|
|
: local7! (local7) ! ;
|
|
: local8! (local8) ! ;
|
|
|
|
create locals-read-table
|
|
['] local1@ ,
|
|
['] local2@ ,
|
|
['] local3@ ,
|
|
['] local4@ ,
|
|
['] local5@ ,
|
|
['] local6@ ,
|
|
['] local7@ ,
|
|
['] local8@ ,
|
|
|
|
create locals-write-table
|
|
['] local1! ,
|
|
['] local2! ,
|
|
['] local3! ,
|
|
['] local4! ,
|
|
['] local5! ,
|
|
['] local6! ,
|
|
['] local7! ,
|
|
['] local8! ,
|
|
|
|
|
|
: locals-push ( n -- )
|
|
locals-var-sp /n + to locals-var-sp
|
|
locals-var-sp !
|
|
;
|
|
|
|
: locals-0-push ( -- )
|
|
0 locals-push
|
|
;
|
|
|
|
: (apply-local-flags) ( lfa -- )
|
|
1 - dup c@ locals-flags or swap c!
|
|
;
|
|
|
|
: locals-no-pop? ( lfa -- ? )
|
|
1 - c@ 8 and 0<>
|
|
;
|
|
|
|
: locals-drop \ Destroy current stack frame
|
|
locals-var-sp @ to locals-var-sp
|
|
;
|
|
|
|
['] locals-drop to locals-end
|
|
|
|
: (local-init) ( str len -- )
|
|
header 1 , \ DOCOL
|
|
['] (lit) , ['] noop , \ read-xt
|
|
['] (lit) , ['] noop , \ write-xt
|
|
['] 2drop , \ do nothing
|
|
['] (lit) ,
|
|
here 5 cells - ,
|
|
['] @ , ['] , , \ store read-xt
|
|
['] (semis) ,
|
|
reveal
|
|
immediate
|
|
last @ (apply-local-flags)
|
|
;
|
|
|
|
: (local-noop) ( str len -- )
|
|
2drop
|
|
;
|
|
|
|
\ Word called when consuming a local variable
|
|
defer (local)
|
|
|
|
: } ( C: current latest here -- )
|
|
here! latest ! current ! \ Switch back to normal dict
|
|
locals-dict-buf @ to locals-dict \ Make locals-dict visible to $find
|
|
0 to locals-var-count
|
|
['] locals-var-sp , \ save previous sp on rstack
|
|
['] >r ,
|
|
locals-dict @ \ ( last -- )
|
|
begin
|
|
?dup 0<>
|
|
while
|
|
>r
|
|
locals-var-count /n *
|
|
locals-read-table + @ r@ 3 cells + ! \ set read-xt
|
|
locals-var-count /n *
|
|
locals-write-table + @ r@ 5 cells + ! \ set write-xt
|
|
locals-var-count 1+ to locals-var-count
|
|
r@ locals-no-pop? if
|
|
['] locals-0-push , \ initialise with 0
|
|
else
|
|
['] locals-push , \ initialise from stack
|
|
then
|
|
r> @ \ next lfa
|
|
repeat
|
|
['] r> ,
|
|
['] locals-push , \ write previous sp
|
|
; immediate
|
|
|
|
: { ( C: -- current latest here )
|
|
current @ latest @ here
|
|
['] (local-init) to (local)
|
|
0 to locals-flags
|
|
0 to locals-var-count
|
|
locals-dict-buf @ 200 cells 0 fill \ Zero out temporary dictionary
|
|
locals-dict-buf @ current ! \ Switch to locals dictionary
|
|
locals-dict-buf @ /n + here!
|
|
|
|
begin
|
|
parse-word
|
|
2dup s" }" strcmp 0= if
|
|
2drop
|
|
['] } execute -1
|
|
else
|
|
2dup s" ;" strcmp 0= if
|
|
2drop
|
|
8 to locals-flags 0 \ Don't init from stack
|
|
else
|
|
2dup s" |" strcmp 0= if
|
|
2drop
|
|
8 to locals-flags 0 \ Don't init from stack
|
|
else
|
|
2dup s" --" strcmp 0= if
|
|
2drop
|
|
['] (local-noop) to (local) 0
|
|
else
|
|
locals-var-count #locals < if
|
|
(local) 0 \ accept local
|
|
else
|
|
s" maximum locals used ignoring " type type cr 0
|
|
then
|
|
locals-var-count 1+ to locals-var-count
|
|
then
|
|
then
|
|
then
|
|
then
|
|
until
|
|
; immediate
|
|
|
|
: -> ( n -- )
|
|
parse-word $find if
|
|
4 cells + @ ,
|
|
else
|
|
s" unable to find word " type type
|
|
then
|
|
; immediate
|
|
|
|
[THEN]
|