3 \ Copyright (C) 2012 Mark Cave-Ayland
5 \ See the file "COPYING" for further information about
6 \ the copyright and warranty status of this work.
11 \ Init local variable stack
12 variable locals-var-stack
13 here 200 cells allot locals-var-stack !
15 \ Set initial stack pointer
17 \ Stack looks like this:
18 \ ... (sp n-2) local1 ... localm-1 localm (sp n-1) <-- sp
20 locals-var-stack @ value locals-var-sp
21 locals-var-sp locals-var-stack @ !
23 0 value locals-var-count
26 here 200 cells allot locals-dict-buf !
30 : (local1) locals-var-sp @ /n + ;
31 : (local2) locals-var-sp @ 2 cells + ;
32 : (local3) locals-var-sp @ 3 cells + ;
33 : (local4) locals-var-sp @ 4 cells + ;
34 : (local5) locals-var-sp @ 5 cells + ;
35 : (local6) locals-var-sp @ 6 cells + ;
36 : (local7) locals-var-sp @ 7 cells + ;
37 : (local8) locals-var-sp @ 8 cells + ;
39 : local1@ (local1) @ ;
40 : local2@ (local2) @ ;
41 : local3@ (local3) @ ;
42 : local4@ (local4) @ ;
43 : local5@ (local5) @ ;
44 : local6@ (local6) @ ;
45 : local7@ (local7) @ ;
46 : local8@ (local8) @ ;
48 : local1! (local1) ! ;
49 : local2! (local2) ! ;
50 : local3! (local3) ! ;
51 : local4! (local4) ! ;
52 : local5! (local5) ! ;
53 : local6! (local6) ! ;
54 : local7! (local7) ! ;
55 : local8! (local8) ! ;
57 create locals-read-table
67 create locals-write-table
78 : locals-push ( n -- )
79 locals-var-sp /n + to locals-var-sp
83 : locals-0-push ( -- )
87 : (apply-local-flags) ( lfa -- )
88 1 - dup c@ locals-flags or swap c!
91 : locals-no-pop? ( lfa -- ? )
95 : locals-drop \ Destroy current stack frame
96 locals-var-sp @ to locals-var-sp
99 ['] locals-drop to locals-end
101 : (local-init) ( str len -- )
103 ['] (lit) , ['] noop , \ read-xt
104 ['] (lit) , ['] noop , \ write-xt
105 ['] 2drop , \ do nothing
108 ['] @ , ['] , , \ store read-xt
112 last @ (apply-local-flags)
115 : (local-noop) ( str len -- )
119 \ Word called when consuming a local variable
122 : } ( C: current latest here -- )
123 here! latest ! current ! \ Switch back to normal dict
124 locals-dict-buf @ to locals-dict \ Make locals-dict visible to $find
125 0 to locals-var-count
126 ['] locals-var-sp , \ save previous sp on rstack
128 locals-dict @ \ ( last -- )
133 locals-var-count /n *
134 locals-read-table + @ r@ 3 cells + ! \ set read-xt
135 locals-var-count /n *
136 locals-write-table + @ r@ 5 cells + ! \ set write-xt
137 locals-var-count 1+ to locals-var-count
139 ['] locals-0-push , \ initialise with 0
141 ['] locals-push , \ initialise from stack
146 ['] locals-push , \ write previous sp
149 : { ( C: -- current latest here )
150 current @ latest @ here
151 ['] (local-init) to (local)
153 0 to locals-var-count
154 locals-dict-buf @ 200 cells 0 fill \ Zero out temporary dictionary
155 locals-dict-buf @ current ! \ Switch to locals dictionary
156 locals-dict-buf @ /n + here!
160 2dup s" }" strcmp 0= if
164 2dup s" ;" strcmp 0= if
166 8 to locals-flags 0 \ Don't init from stack
168 2dup s" |" strcmp 0= if
170 8 to locals-flags 0 \ Don't init from stack
172 2dup s" --" strcmp 0= if
174 ['] (local-noop) to (local) 0
176 locals-var-count #locals < if
177 (local) 0 \ accept local
179 s" maximum locals used ignoring " type type cr 0
181 locals-var-count 1+ to locals-var-count
193 s" unable to find word " type type