1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
|
\ @(#) ansilocs.fth 98/01/26 1.3
\ local variable support words
\ These support the ANSI standard (LOCAL) and TO words.
\
\ They are built from the following low level primitives written in 'C':
\ (local@) ( i+1 -- n , fetch from ith local variable )
\ (local!) ( n i+1 -- , store to ith local variable )
\ (local.entry) ( num -- , allocate stack frame for num local variables )
\ (local.exit) ( -- , free local variable stack frame )
\ local-compiler ( -- addr , variable containing CFA of locals compiler )
\
\ Author: Phil Burk
\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
\
\ The pForth software code is dedicated to the public domain,
\ and any third party may reproduce, distribute and modify
\ the pForth software code or any derivative works thereof
\ without any compensation or license. The pForth software
\ code is provided on an "as is" basis without any warranty
\ of any kind, including, without limitation, the implied
\ warranties of merchantability and fitness for a particular
\ purpose and their equivalents under the laws of any jurisdiction.
anew task-ansilocs.fth
private{
decimal
16 constant LV_MAX_VARS \ maximum number of local variables
31 constant LV_MAX_CHARS \ maximum number of letters in name
lv_max_vars lv_max_chars $array LV-NAMES
variable LV-#NAMES \ number of names currently defined
\ Search name table for match
: LV.MATCH ( $string -- index true | $string false )
0 swap
lv-#names @ 0
?DO i lv-names
over $=
IF 2drop true i LEAVE
THEN
LOOP swap
;
: LV.COMPILE.FETCH ( index -- )
1+ \ adjust for optimised (local@), LocalsPtr points above vars
CASE
1 OF compile (1_local@) ENDOF
2 OF compile (2_local@) ENDOF
3 OF compile (3_local@) ENDOF
4 OF compile (4_local@) ENDOF
5 OF compile (5_local@) ENDOF
6 OF compile (6_local@) ENDOF
7 OF compile (7_local@) ENDOF
8 OF compile (8_local@) ENDOF
dup [compile] literal compile (local@)
ENDCASE
;
: LV.COMPILE.STORE ( index -- )
1+ \ adjust for optimised (local!), LocalsPtr points above vars
CASE
1 OF compile (1_local!) ENDOF
2 OF compile (2_local!) ENDOF
3 OF compile (3_local!) ENDOF
4 OF compile (4_local!) ENDOF
5 OF compile (5_local!) ENDOF
6 OF compile (6_local!) ENDOF
7 OF compile (7_local!) ENDOF
8 OF compile (8_local!) ENDOF
dup [compile] literal compile (local!)
ENDCASE
;
: LV.COMPILE.LOCAL ( $name -- handled? , check for matching locals name )
\ ." LV.COMPILER.LOCAL name = " dup count type cr
lv.match
IF ( index )
lv.compile.fetch
true
ELSE
drop false
THEN
;
: LV.CLEANUP ( -- , restore stack frame on exit from colon def )
lv-#names @
IF
compile (local.exit)
THEN
;
: LV.FINISH ( -- , restore stack frame on exit from colon def )
lv.cleanup
lv-#names off
local-compiler off
;
: LV.SETUP ( -- )
0 lv-#names !
;
: LV.TERM
." Locals turned off" cr
lv-#names off
local-compiler off
;
if.forgotten lv.term
}private
: (LOCAL) ( adr len -- , ANSI local primitive )
dup
IF
lv-#names @ lv_max_vars >= abort" Too many local variables!"
lv-#names @ lv-names place
\ Warn programmer if local variable matches an existing dictionary name.
lv-#names @ lv-names find nip
IF
." (LOCAL) - Note: "
lv-#names @ lv-names count type
." redefined as a local variable in "
latest id. cr
THEN
1 lv-#names +!
ELSE
\ Last local. Finish building local stack frame.
2drop
lv-#names @ [compile] literal compile (local.entry)
['] lv.compile.local local-compiler !
THEN
;
: VALUE
CREATE ( n <name> )
,
immediate
DOES>
state @
IF
[compile] aliteral
compile @
ELSE
@
THEN
;
: TO ( val <name> -- )
bl word
lv.match
IF ( -- index )
lv.compile.store
ELSE
find
1 = 0= abort" TO or -> before non-local or non-value"
>body \ point to data
state @
IF \ compiling ( -- pfa )
[compile] aliteral
compile !
ELSE \ executing ( -- val pfa )
!
THEN
THEN
; immediate
: -> ( -- ) [compile] to ; immediate
: +-> ( val <name> -- )
bl word
lv.match
IF ( -- index )
1+ \ adjust for optimised (local!), LocalsPtr points above vars
[compile] literal compile (local+!)
ELSE
find
1 = 0= abort" +-> before non-local or non-value"
>body \ point to data
state @
IF \ compiling ( -- pfa )
[compile] aliteral
compile +!
ELSE \ executing ( -- val pfa )
+!
THEN
THEN
; immediate
: : lv.setup : ;
: ; lv.finish [compile] ; ; immediate
: exit lv.cleanup compile exit ; immediate
: does> lv.finish [compile] does> ; immediate
privatize
|
