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