1
2 /******************************************************************************
3 * MODULE : evaluate_main.cpp
4 * DESCRIPTION: evaluation of macro constructs
5 * COPYRIGHT : (C) 2006 Joris van der Hoeven
6 *******************************************************************************
7 * This software falls under the GNU general public license version 3 or later.
8 * It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
9 * in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
10 ******************************************************************************/
11
12 #include "evaluate_main.hpp"
13 #include "std_environment.hpp"
14 #include "drd_mode.hpp"
15 #include "drd_std.hpp"
16
17 /******************************************************************************
18 * Environment changes
19 ******************************************************************************/
20
21 tree
evaluate_assign(tree t)22 evaluate_assign (tree t) {
23 int i, n=N(t), k=n>>1;
24 assoc_environment local (k);
25 for (i=0; i<k; i++) {
26 string var= as_string (evaluate (t[i<<1]));
27 tree val= evaluate (t[(i<<1)+1]);
28 local->raw_write (i, var, val);
29 }
30 assign (std_env, local);
31 return "";
32 }
33
34 tree
evaluate_with(tree t)35 evaluate_with (tree t) {
36 int i, n=N(t), k=(n-1)>>1;
37 assoc_environment local (k);
38 tree w (WITH);
39 for (i=0; i<k; i++) {
40 string var= as_string (evaluate (t[i<<1]));
41 tree val= evaluate (t[(i<<1)+1]);
42 local->raw_write (i, var, val);
43 w << var << val; // FIXME: don't add non-typesetter variables (?)
44 }
45 begin_with (std_env, local);
46 tree r= evaluate (t[n-1]);
47 end_with (std_env);
48 w << r;
49 return w;
50 }
51
52 tree
evaluate_provides(tree t)53 evaluate_provides (tree t) {
54 tree r= evaluate (t[0]);
55 if (is_compound (r)) return evaluate_error ("bad provides");
56 if (std_env->contains (r->label)) return "true"; else return "false";
57 }
58
59 tree
evaluate_value(tree t)60 evaluate_value (tree t) {
61 tree r= evaluate (t[0]);
62 if (is_compound (r)) return evaluate_error ("bad value");
63 int key= make_tree_label (r->label);
64 if (!std_env->contains (key)) return evaluate_error ("undefined", r);
65 return evaluate (std_env[key]);
66 }
67
68 tree
evaluate_quote_value(tree t)69 evaluate_quote_value (tree t) {
70 tree r= evaluate (t[0]);
71 if (is_compound (r)) return evaluate_error ("bad quoted value");
72 int key= make_tree_label (r->label);
73 if (!std_env->contains (key)) return evaluate_error ("undefined", r);
74 return std_env[key];
75 }
76
77 /******************************************************************************
78 * DRD properties
79 ******************************************************************************/
80
81 tree
evaluate_drd_props(tree t)82 evaluate_drd_props (tree t) {
83 (void) t; return "";
84 // FIXME: not yet implemented
85 }
86
87 /******************************************************************************
88 * Syntactic decomposition
89 ******************************************************************************/
90
91 tree
evaluate_get_label(tree t)92 evaluate_get_label (tree t) {
93 tree r= evaluate (t[0]);
94 return copy (as_string (L(r)));
95 }
96
97 tree
evaluate_get_arity(tree t)98 evaluate_get_arity (tree t) {
99 tree r= evaluate (t[0]);
100 return as_string (arity (r));
101 }
102
103 /******************************************************************************
104 * Classical macro expansion
105 ******************************************************************************/
106
107 #ifdef CLASSICAL_MACRO_EXPANSION
108 tree
evaluate_compound(tree t)109 evaluate_compound (tree t) {
110 int d; tree f;
111 if (L(t) == COMPOUND) {
112 d= 1;
113 f= t[0];
114 if (is_compound (f)) f= evaluate (f);
115 if (is_atomic (f)) {
116 string var= f->label;
117 if (!std_env->contains (var)) return evaluate_error ("undefined", var);
118 f= std_env [var];
119 }
120 }
121 else {
122 string var= as_string (L(t));
123 if (!std_env->contains (var)) return evaluate_error ("undefined", var);
124 d= 0;
125 f= std_env [var];
126 }
127
128 if (is_applicable (f)) {
129 int i, n=N(f)-1, m=N(t)-d;
130 assoc_environment local (L(f)==XMACRO? 1: n);
131 if (L(f) == XMACRO)
132 local->raw_write (0, as_string (f[0]), t);
133 else {
134 static tree uninit (UNINIT);
135 for (i=0; i<n; i++)
136 local->raw_write (i, as_string (f[i]), i<m? t[i+d]: uninit);
137 //local->print ("");
138 }
139 macro_down (std_env, local);
140 tree r= evaluate (f[n]);
141 macro_up (std_env);
142 return r;
143 }
144 else return evaluate (f);
145 }
146
147 tree
evaluate_arg(tree t)148 evaluate_arg (tree t) {
149 tree r= t[0];
150 if (is_compound (r)) return evaluate_error ("bad arg");
151 int key= make_tree_label (r->label);
152 if (macro_top_level (std_env)) return evaluate_error ("undefined", r);
153 basic_environment local= macro_arguments (std_env);
154 //local->print ("");
155 if (!local->contains (key)) return evaluate_error ("undefined", r);
156 macro_up (std_env);
157 r= local[key];
158 if (N(t) > 1) {
159 int i, n= N(t);
160 for (i=1; i<n; i++) {
161 tree u= evaluate (t[i]);
162 if (!is_int (u)) break;
163 int nr= as_int (u);
164 if ((!is_compound (r)) || (nr<0) || (nr>=N(r))) break;
165 r= r[nr];
166 }
167 }
168 r= evaluate (r);
169 macro_redown (std_env, local);
170 return r;
171 }
172
173 tree
evaluate_quote_arg(tree t)174 evaluate_quote_arg (tree t) {
175 tree r= t[0];
176 if (is_compound (r)) return evaluate_error ("bad quoted arg");
177 int key= make_tree_label (r->label);
178 if (macro_top_level (std_env)) return evaluate_error ("undefined", r);
179 basic_environment local= macro_arguments (std_env);
180 if (!local->contains (key)) return evaluate_error ("undefined", r);
181 r= local[key];
182 if (N(t) > 1) {
183 int i, n= N(t);
184 for (i=1; i<n; i++) {
185 tree u= evaluate (t[i]);
186 if (!is_int (u)) break;
187 int nr= as_int (u);
188 if ((!is_compound (r)) || (nr<0) || (nr>=N(r))) break;
189 r= r[nr];
190 }
191 }
192 return r;
193 }
194 #endif // CLASSICAL_MACRO_EXPANSION
195
196 /******************************************************************************
197 * Alternative macro expansion
198 ******************************************************************************/
199
200 #ifdef ALTERNATIVE_MACRO_EXPANSION
201
202 tree
expand(tree t,assoc_environment env)203 expand (tree t, assoc_environment env) {
204 if (is_atomic (t)) return t;
205 else {
206 int i, n= N(t);
207 switch (L(t)) {
208 case MACRO:
209 {
210 assoc_environment local= copy (env);
211 for (i=0; i+1<n; i+=2)
212 if (is_atomic (t[i])) {
213 int key= make_tree_label (t[i]->label);
214 local->remove (key);
215 }
216 bool flag= true;
217 tree r (t, n);
218 for (i=0; i<n; i++) {
219 r[i]= expand (t[i], i==n-1? local: env);
220 flag= flag && weak_equal (r[i], t[i]);
221 }
222 if (flag) return t;
223 return r;
224 }
225 case XMACRO:
226 {
227 assoc_environment local= copy (env);
228 if (is_atomic (t[i])) {
229 int key= make_tree_label (t[0]->label);
230 local->remove (key);
231 }
232 tree body= expand (t[1], local);
233 if (weak_equal (body, t[1])) return t;
234 return tree (XMACRO, t[0], body);
235 }
236 case ARG:
237 {
238 tree r= t[0];
239 if (is_compound (r)) return evaluate_error ("bad arg");
240 int key= make_tree_label (r->label);
241 if (!env->contains (key)) return t;
242 r= env[key];
243 if (N(t) > 1) {
244 int i, n= N(t);
245 for (i=1; i<n; i++) {
246 tree u= evaluate (expand (t[i], env));
247 if (!is_int (u)) break;
248 int nr= as_int (u);
249 if ((!is_compound (r)) || (nr<0) || (nr>=N(r))) break;
250 r= r[nr];
251 }
252 }
253 return r;
254 }
255 case QUOTE_ARG:
256 return tree (QUOTE, expand (tree (ARG, A(t)), env));
257 case MAP_ARGS:
258 {
259 if (!(is_atomic (t[0]) && is_atomic (t[1]) && is_atomic (t[2])))
260 return evaluate_error ("invalid map-args");
261 int key= make_tree_label (t[2]->label);
262 if (!env->contains (key))
263 return evaluate_error ("undefined", t[2]);
264 tree val= env [key];
265 if (is_atomic (val))
266 return evaluate_error ("invalid-map-args");
267
268 int start= 0, end= N(val);
269 if (N(t)>=4) start= as_int (evaluate (expand (t[3], env)));
270 if (N(t)>=5) end = as_int (evaluate (expand (t[4], env)));
271 int i, n= max (0, end-start);
272 tree r (make_tree_label (t[1]->label), n);
273 for (i=0; i<n; i++)
274 r[i]= tree (make_tree_label (t[0]->label),
275 val[start+i],
276 as_string (start+i));
277 return r;
278 }
279 case EVAL_ARGS:
280 return tree (EVAL_ARGS, expand (tree (ARG, t[0]), env));
281 default:
282 {
283 bool flag= true;
284 tree r (t, n);
285 for (i=0; i<n; i++) {
286 r[i]= expand (t[i], env);
287 flag= flag && weak_equal (r[i], t[i]);
288 }
289 if (flag) return t;
290 return r;
291 }
292 }
293 }
294 }
295
296 tree
evaluate_compound(tree t)297 evaluate_compound (tree t) {
298 int d; tree f;
299 if (L(t) == COMPOUND) {
300 d= 1;
301 f= t[0];
302 if (is_compound (f)) f= evaluate (f);
303 if (is_atomic (f)) {
304 string var= f->label;
305 if (!std_env->contains (var)) return evaluate_error ("undefined", var);
306 f= std_env [var];
307 }
308 }
309 else {
310 string var= as_string (L(t));
311 if (!std_env->contains (var)) return evaluate_error ("undefined", var);
312 d= 0;
313 f= std_env [var];
314 }
315
316 if (is_applicable (f)) {
317 int i, n=N(f)-1, m=N(t)-d;
318 assoc_environment local (L(f)==XMACRO? 1: n);
319 if (L(f) == XMACRO)
320 local->raw_write (0, as_string (f[0]), t);
321 else {
322 static tree uninit (UNINIT);
323 for (i=0; i<n; i++)
324 local->raw_write (i, as_string (f[i]), i<m? t[i+d]: uninit);
325 //local->print ("");
326 }
327 tree e= expand (f[n], local);
328 decorate_ip (t, e);
329 return evaluate (e);
330 // FIXME: should we remember partial expansions?
331 }
332 else return evaluate (f);
333 }
334
335 #endif // ALTERNATIVE_MACRO_EXPANSION
336
337 /******************************************************************************
338 * Argument expansion
339 ******************************************************************************/
340
341 #define is_accessible(p) ((is_nil (p)) || ((p)->item >= 0))
342
343 tree
expand(tree t,bool search_accessible)344 expand (tree t, bool search_accessible) {
345 if (is_atomic (t)) return t;
346 #ifdef CLASSICAL_MACRO_EXPANSION
347 else if (macro_top_level (std_env)) return t;
348 else if (is_func (t, ARG) || is_func (t, QUOTE_ARG)) {
349 tree r= t[0];
350 if (is_compound (r)) return evaluate_error ("bad arg");
351 int key= make_tree_label (r->label);
352 basic_environment local= macro_arguments (std_env);
353 if (!local->contains (key)) return evaluate_error ("undefined", r);
354 macro_up (std_env);
355 r= local[key];
356 if (N(t) > 1) {
357 int i, n= N(t);
358 for (i=1; i<n; i++) {
359 tree u= evaluate (t[i]);
360 if (!is_int (u)) break;
361 int nr= as_int (u);
362 if ((!is_compound (r)) || (nr<0) || (nr>=N(r))) break;
363 r= r[nr];
364 }
365 }
366 if (is_func (t, ARG))
367 r= expand (r, search_accessible);
368 macro_redown (std_env, local);
369 return r;
370 }
371 #endif // CLASSICAL_MACRO_EXPANSION
372 else if (is_func (t, EXPAND_AS, 2))
373 return expand (t[0], search_accessible);
374 else if (search_accessible && is_accessible (obtain_ip (t)))
375 return t;
376 else {
377 int i, n= N(t);
378 tree r (t, n);
379 for (i=0; i<n; i++) {
380 r[i]= expand (t[i], search_accessible);
381 if (search_accessible &&
382 is_accessible (obtain_ip (r[i])) &&
383 the_drd->is_accessible_child (t, i)
384 // FIXME: should be drd->is_accessible_child (t, i)
385 )
386 return r[i];
387 }
388 if (search_accessible) return t;
389 return r;
390 }
391 }
392