abort-to-prompt* instead of @abort
[bpt/guile.git] / libguile / expand.c
CommitLineData
2aed2667 1/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012
dc3e203e
AW
2 * Free Software Foundation, Inc.
3 *
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
8 *
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
13 *
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
17 * 02110-1301 USA
18 */
19
20\f
21
22#ifdef HAVE_CONFIG_H
23# include <config.h>
24#endif
25
26#include "libguile/__scm.h"
27#include "libguile/_scm.h"
28#include "libguile/continuations.h"
29#include "libguile/eq.h"
30#include "libguile/list.h"
31#include "libguile/macros.h"
32#include "libguile/expand.h"
33#include "libguile/modules.h"
34#include "libguile/srcprop.h"
35#include "libguile/ports.h"
36#include "libguile/print.h"
37#include "libguile/strings.h"
38#include "libguile/throw.h"
39#include "libguile/validate.h"
40
41
42\f
43
44
45SCM scm_exp_vtable_vtable;
46static SCM exp_vtables[SCM_NUM_EXPANDED_TYPES];
47static size_t exp_nfields[SCM_NUM_EXPANDED_TYPES];
48static const char* exp_names[SCM_NUM_EXPANDED_TYPES];
49static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
50
51
baeb727b
AW
52/* The trailing underscores on these first to are to avoid spurious
53 conflicts with macros defined on MinGW. */
54
55#define VOID_(src) \
dc3e203e 56 SCM_MAKE_EXPANDED_VOID(src)
baeb727b 57#define CONST_(src, exp) \
dc3e203e
AW
58 SCM_MAKE_EXPANDED_CONST(src, exp)
59#define PRIMITIVE_REF_TYPE(src, name) \
60 SCM_MAKE_EXPANDED_PRIMITIVE_REF_TYPE(src, name)
61#define LEXICAL_REF(src, name, gensym) \
62 SCM_MAKE_EXPANDED_LEXICAL_REF(src, name, gensym)
63#define LEXICAL_SET(src, name, gensym, exp) \
64 SCM_MAKE_EXPANDED_LEXICAL_SET(src, name, gensym, exp)
65#define MODULE_REF(src, mod, name, public) \
66 SCM_MAKE_EXPANDED_MODULE_REF(src, mod, name, public)
67#define MODULE_SET(src, mod, name, public, exp) \
68 SCM_MAKE_EXPANDED_MODULE_SET(src, mod, name, public, exp)
69#define TOPLEVEL_REF(src, name) \
70 SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, name)
71#define TOPLEVEL_SET(src, name, exp) \
72 SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, name, exp)
73#define TOPLEVEL_DEFINE(src, name, exp) \
74 SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, name, exp)
75#define CONDITIONAL(src, test, consequent, alternate) \
76 SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate)
7081d4f9
AW
77#define CALL(src, proc, exps) \
78 SCM_MAKE_EXPANDED_CALL(src, proc, exps)
6fc3eae4
AW
79#define SEQ(src, head, tail) \
80 SCM_MAKE_EXPANDED_SEQ(src, head, tail)
dc3e203e
AW
81#define LAMBDA(src, meta, body) \
82 SCM_MAKE_EXPANDED_LAMBDA(src, meta, body)
83#define LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate) \
84 SCM_MAKE_EXPANDED_LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate)
85#define LET(src, names, gensyms, vals, body) \
86 SCM_MAKE_EXPANDED_LET(src, names, gensyms, vals, body)
fb6e61ca
AW
87#define LETREC(src, in_order_p, names, gensyms, vals, body) \
88 SCM_MAKE_EXPANDED_LETREC(src, in_order_p, names, gensyms, vals, body)
dc3e203e
AW
89#define DYNLET(src, fluids, vals, body) \
90 SCM_MAKE_EXPANDED_DYNLET(src, fluids, vals, body)
91
92#define CAR(x) SCM_CAR(x)
93#define CDR(x) SCM_CDR(x)
94#define CAAR(x) SCM_CAAR(x)
95#define CADR(x) SCM_CADR(x)
96#define CDAR(x) SCM_CDAR(x)
97#define CDDR(x) SCM_CDDR(x)
98#define CADDR(x) SCM_CADDR(x)
99#define CDDDR(x) SCM_CDDDR(x)
100#define CADDDR(x) SCM_CADDDR(x)
101
102
103static const char s_bad_expression[] = "Bad expression";
104static const char s_expression[] = "Missing or extra expression in";
105static const char s_missing_expression[] = "Missing expression in";
106static const char s_extra_expression[] = "Extra expression in";
107static const char s_empty_combination[] = "Illegal empty combination";
108static const char s_missing_body_expression[] = "Missing body expression in";
109static const char s_mixed_body_forms[] = "Mixed definitions and expressions in";
110static const char s_bad_define[] = "Bad define placement";
111static const char s_missing_clauses[] = "Missing clauses";
112static const char s_misplaced_else_clause[] = "Misplaced else clause";
113static const char s_bad_case_clause[] = "Bad case clause";
114static const char s_bad_case_labels[] = "Bad case labels";
115static const char s_duplicate_case_label[] = "Duplicate case label";
116static const char s_bad_cond_clause[] = "Bad cond clause";
117static const char s_missing_recipient[] = "Missing recipient in";
118static const char s_bad_variable[] = "Bad variable";
119static const char s_bad_bindings[] = "Bad bindings";
120static const char s_bad_binding[] = "Bad binding";
121static const char s_duplicate_binding[] = "Duplicate binding";
122static const char s_bad_exit_clause[] = "Bad exit clause";
123static const char s_bad_formals[] = "Bad formals";
124static const char s_bad_formal[] = "Bad formal";
125static const char s_duplicate_formal[] = "Duplicate formal";
126static const char s_splicing[] = "Non-list result for unquote-splicing";
127static const char s_bad_slot_number[] = "Bad slot number";
128
129static void syntax_error (const char* const, const SCM, const SCM) SCM_NORETURN;
130
131SCM_SYMBOL (syntax_error_key, "syntax-error");
132
133/* Shortcut macros to simplify syntax error handling. */
134#define ASSERT_SYNTAX(cond, message, form) \
135 { if (SCM_UNLIKELY (!(cond))) \
136 syntax_error (message, form, SCM_UNDEFINED); }
137#define ASSERT_SYNTAX_2(cond, message, form, expr) \
138 { if (SCM_UNLIKELY (!(cond))) \
139 syntax_error (message, form, expr); }
140
141
142\f
143
144/* Primitive syntax. */
145
146#define SCM_SYNTAX(STR, CFN) \
147SCM_SNARF_HERE(static SCM CFN (SCM xorig, SCM env)) \
148SCM_SNARF_INIT(scm_c_define (STR, scm_i_make_primitive_macro (STR, CFN)))
149
150
151/* True primitive syntax */
152SCM_SYNTAX ("@", expand_at);
153SCM_SYNTAX ("@@", expand_atat);
154SCM_SYNTAX ("begin", expand_begin);
155SCM_SYNTAX ("define", expand_define);
156SCM_SYNTAX ("with-fluids", expand_with_fluids);
157SCM_SYNTAX ("eval-when", expand_eval_when);
158SCM_SYNTAX ("if", expand_if);
159SCM_SYNTAX ("lambda", expand_lambda);
160SCM_SYNTAX ("let", expand_let);
161SCM_SYNTAX ("quote", expand_quote);
162SCM_SYNTAX ("set!", expand_set_x);
163
164/* Convenient syntax during boot, expands to primitive syntax. Replaced after
165 psyntax boots. */
166SCM_SYNTAX ("and", expand_and);
167SCM_SYNTAX ("cond", expand_cond);
168SCM_SYNTAX ("letrec", expand_letrec);
826373a2 169SCM_SYNTAX ("letrec*", expand_letrec_star);
dc3e203e
AW
170SCM_SYNTAX ("let*", expand_letstar);
171SCM_SYNTAX ("or", expand_or);
172SCM_SYNTAX ("lambda*", expand_lambda_star);
173SCM_SYNTAX ("case-lambda", expand_case_lambda);
174SCM_SYNTAX ("case-lambda*", expand_case_lambda_star);
175
176
177SCM_GLOBAL_SYMBOL (scm_sym_apply, "apply");
178SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
179SCM_GLOBAL_SYMBOL (scm_sym_at, "@");
180SCM_GLOBAL_SYMBOL (scm_sym_atat, "@@");
181SCM_GLOBAL_SYMBOL (scm_sym_at_call_with_values, "@call-with-values");
182SCM_GLOBAL_SYMBOL (scm_sym_atapply, "@apply");
183SCM_GLOBAL_SYMBOL (scm_sym_atcall_cc, "@call-with-current-continuation");
184SCM_GLOBAL_SYMBOL (scm_sym_begin, "begin");
185SCM_GLOBAL_SYMBOL (scm_sym_case, "case");
186SCM_GLOBAL_SYMBOL (scm_sym_cond, "cond");
187SCM_GLOBAL_SYMBOL (scm_sym_define, "define");
188SCM_GLOBAL_SYMBOL (scm_sym_at_dynamic_wind, "@dynamic-wind");
189SCM_GLOBAL_SYMBOL (scm_sym_with_fluids, "with-fluids");
190SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
191SCM_GLOBAL_SYMBOL (scm_sym_eval_when, "eval-when");
192SCM_GLOBAL_SYMBOL (scm_sym_if, "if");
193SCM_GLOBAL_SYMBOL (scm_sym_lambda, "lambda");
194SCM_GLOBAL_SYMBOL (scm_sym_let, "let");
195SCM_GLOBAL_SYMBOL (scm_sym_letrec, "letrec");
196SCM_GLOBAL_SYMBOL (scm_sym_letstar, "let*");
197SCM_GLOBAL_SYMBOL (scm_sym_or, "or");
198SCM_GLOBAL_SYMBOL (scm_sym_at_prompt, "@prompt");
199SCM_GLOBAL_SYMBOL (scm_sym_quote, "quote");
200SCM_GLOBAL_SYMBOL (scm_sym_set_x, "set!");
201SCM_SYMBOL (sym_lambda_star, "lambda*");
202SCM_SYMBOL (sym_eval, "eval");
203SCM_SYMBOL (sym_load, "load");
204
205SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
206SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, "quasiquote");
207SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
208
209SCM_KEYWORD (kw_allow_other_keys, "allow-other-keys");
210SCM_KEYWORD (kw_optional, "optional");
211SCM_KEYWORD (kw_key, "key");
212SCM_KEYWORD (kw_rest, "rest");
213
214
215\f
216
217
218/* Signal a syntax error. We distinguish between the form that caused the
219 * error and the enclosing expression. The error message will print out as
220 * shown in the following pattern. The file name and line number are only
221 * given when they can be determined from the erroneous form or from the
222 * enclosing expression.
223 *
224 * <filename>: In procedure memoization:
225 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
226
227static void
228syntax_error (const char* const msg, const SCM form, const SCM expr)
229{
230 SCM msg_string = scm_from_locale_string (msg);
231 SCM filename = SCM_BOOL_F;
232 SCM linenr = SCM_BOOL_F;
233 const char *format;
234 SCM args;
235
236 if (scm_is_pair (form))
237 {
238 filename = scm_source_property (form, scm_sym_filename);
239 linenr = scm_source_property (form, scm_sym_line);
240 }
241
242 if (scm_is_false (filename) && scm_is_false (linenr) && scm_is_pair (expr))
243 {
244 filename = scm_source_property (expr, scm_sym_filename);
245 linenr = scm_source_property (expr, scm_sym_line);
246 }
247
248 if (!SCM_UNBNDP (expr))
249 {
250 if (scm_is_true (filename))
251 {
252 format = "In file ~S, line ~S: ~A ~S in expression ~S.";
253 args = scm_list_5 (filename, linenr, msg_string, form, expr);
254 }
255 else if (scm_is_true (linenr))
256 {
257 format = "In line ~S: ~A ~S in expression ~S.";
258 args = scm_list_4 (linenr, msg_string, form, expr);
259 }
260 else
261 {
262 format = "~A ~S in expression ~S.";
263 args = scm_list_3 (msg_string, form, expr);
264 }
265 }
266 else
267 {
268 if (scm_is_true (filename))
269 {
270 format = "In file ~S, line ~S: ~A ~S.";
271 args = scm_list_4 (filename, linenr, msg_string, form);
272 }
273 else if (scm_is_true (linenr))
274 {
275 format = "In line ~S: ~A ~S.";
276 args = scm_list_3 (linenr, msg_string, form);
277 }
278 else
279 {
280 format = "~A ~S.";
281 args = scm_list_2 (msg_string, form);
282 }
283 }
284
285 scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F);
286}
287
288
289\f
290
291
292static int
293expand_env_var_is_free (SCM env, SCM x)
294{
295 for (; scm_is_pair (env); env = CDR (env))
296 if (scm_is_eq (x, CAAR (env)))
297 return 0; /* bound */
298 return 1; /* free */
299}
300
301static SCM
302expand_env_ref_macro (SCM env, SCM x)
303{
304 SCM var;
305 if (!expand_env_var_is_free (env, x))
306 return SCM_BOOL_F; /* lexical */
307
308 var = scm_module_variable (scm_current_module (), x);
309 if (scm_is_true (var) && scm_is_true (scm_variable_bound_p (var))
310 && scm_is_true (scm_macro_p (scm_variable_ref (var))))
311 return scm_variable_ref (var);
312 else
313 return SCM_BOOL_F; /* anything else */
314}
315
316static SCM
317expand_env_lexical_gensym (SCM env, SCM name)
318{
319 for (; scm_is_pair (env); env = CDR (env))
320 if (scm_is_eq (name, CAAR (env)))
321 return CDAR (env); /* bound */
322 return SCM_BOOL_F; /* free */
323}
324
325static SCM
326expand_env_extend (SCM env, SCM names, SCM vars)
327{
328 while (scm_is_pair (names))
329 {
330 env = scm_acons (CAR (names), CAR (vars), env);
331 names = CDR (names);
332 vars = CDR (vars);
333 }
334 return env;
335}
336
337static SCM
338expand (SCM exp, SCM env)
339{
340 if (scm_is_pair (exp))
341 {
342 SCM car;
343 scm_t_macro_primitive trans = NULL;
344 SCM macro = SCM_BOOL_F;
345
346 car = CAR (exp);
347 if (scm_is_symbol (car))
348 macro = expand_env_ref_macro (env, car);
349
350 if (scm_is_true (macro))
351 trans = scm_i_macro_primitive (macro);
352
353 if (trans)
354 return trans (exp, env);
355 else
356 {
357 SCM arg_exps = SCM_EOL;
358 SCM args = SCM_EOL;
359 SCM proc = CAR (exp);
360
361 for (arg_exps = CDR (exp); scm_is_pair (arg_exps);
362 arg_exps = CDR (arg_exps))
363 args = scm_cons (expand (CAR (arg_exps), env), args);
364 if (scm_is_null (arg_exps))
7081d4f9
AW
365 return CALL (scm_source_properties (exp),
366 expand (proc, env),
367 scm_reverse_x (args, SCM_UNDEFINED));
dc3e203e
AW
368 else
369 syntax_error ("expected a proper list", exp, SCM_UNDEFINED);
370 }
371 }
372 else if (scm_is_symbol (exp))
373 {
374 SCM gensym = expand_env_lexical_gensym (env, exp);
375 if (scm_is_true (gensym))
376 return LEXICAL_REF (SCM_BOOL_F, exp, gensym);
377 else
378 return TOPLEVEL_REF (SCM_BOOL_F, exp);
379 }
380 else
baeb727b 381 return CONST_ (SCM_BOOL_F, exp);
dc3e203e
AW
382}
383
384static SCM
385expand_exprs (SCM forms, const SCM env)
386{
387 SCM ret = SCM_EOL;
388
389 for (; !scm_is_null (forms); forms = CDR (forms))
390 ret = scm_cons (expand (CAR (forms), env), ret);
391 return scm_reverse_x (ret, SCM_UNDEFINED);
392}
393
394static SCM
395expand_sequence (const SCM forms, const SCM env)
396{
397 ASSERT_SYNTAX (scm_ilength (forms) >= 1, s_bad_expression,
398 scm_cons (scm_sym_begin, forms));
399 if (scm_is_null (CDR (forms)))
400 return expand (CAR (forms), env);
401 else
6fc3eae4
AW
402 return SEQ (scm_source_properties (forms),
403 expand (CAR (forms), env),
404 expand_sequence (CDR (forms), env));
dc3e203e
AW
405}
406
407
408\f
409
410
411static SCM
412expand_at (SCM expr, SCM env SCM_UNUSED)
413{
414 ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
415 ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
416 ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);
417
418 return MODULE_REF (scm_source_properties (expr),
419 CADR (expr), CADDR (expr), SCM_BOOL_T);
420}
421
422static SCM
423expand_atat (SCM expr, SCM env SCM_UNUSED)
424{
425 ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
426 ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
427 ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);
428
429 return MODULE_REF (scm_source_properties (expr),
430 CADR (expr), CADDR (expr), SCM_BOOL_F);
431}
432
433static SCM
434expand_and (SCM expr, SCM env)
435{
436 const SCM cdr_expr = CDR (expr);
437
438 if (scm_is_null (cdr_expr))
baeb727b 439 return CONST_ (SCM_BOOL_F, SCM_BOOL_T);
dc3e203e
AW
440
441 ASSERT_SYNTAX (scm_is_pair (cdr_expr), s_bad_expression, expr);
442
443 if (scm_is_null (CDR (cdr_expr)))
444 return expand (CAR (cdr_expr), env);
445 else
446 return CONDITIONAL (scm_source_properties (expr),
447 expand (CAR (cdr_expr), env),
448 expand_and (cdr_expr, env),
baeb727b 449 CONST_ (SCM_BOOL_F, SCM_BOOL_F));
dc3e203e
AW
450}
451
452static SCM
453expand_begin (SCM expr, SCM env)
454{
455 const SCM cdr_expr = CDR (expr);
456 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 1, s_bad_expression, expr);
457 return expand_sequence (cdr_expr, env);
458}
459
460static SCM
461expand_cond_clauses (SCM clause, SCM rest, int elp, int alp, SCM env)
462{
463 SCM test;
464 const long length = scm_ilength (clause);
465 ASSERT_SYNTAX (length >= 1, s_bad_cond_clause, clause);
466
467 test = CAR (clause);
468 if (scm_is_eq (test, scm_sym_else) && elp)
469 {
470 const int last_clause_p = scm_is_null (rest);
471 ASSERT_SYNTAX (length >= 2, s_bad_cond_clause, clause);
472 ASSERT_SYNTAX (last_clause_p, s_misplaced_else_clause, clause);
473 return expand_sequence (CDR (clause), env);
474 }
475
476 if (scm_is_null (rest))
baeb727b 477 rest = VOID_ (SCM_BOOL_F);
dc3e203e
AW
478 else
479 rest = expand_cond_clauses (CAR (rest), CDR (rest), elp, alp, env);
480
481 if (length >= 2
482 && scm_is_eq (CADR (clause), scm_sym_arrow)
483 && alp)
484 {
485 SCM tmp = scm_gensym (scm_from_locale_string ("cond "));
486 SCM new_env = scm_acons (tmp, tmp, env);
487 ASSERT_SYNTAX (length > 2, s_missing_recipient, clause);
488 ASSERT_SYNTAX (length == 3, s_extra_expression, clause);
489 return LET (SCM_BOOL_F,
490 scm_list_1 (tmp),
491 scm_list_1 (tmp),
492 scm_list_1 (expand (test, env)),
493 CONDITIONAL (SCM_BOOL_F,
494 LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
7081d4f9
AW
495 CALL (SCM_BOOL_F,
496 expand (CADDR (clause), new_env),
497 scm_list_1 (LEXICAL_REF (SCM_BOOL_F,
498 tmp, tmp))),
dc3e203e
AW
499 rest));
500 }
501 /* FIXME length == 1 case */
502 else
503 return CONDITIONAL (SCM_BOOL_F,
504 expand (test, env),
505 expand_sequence (CDR (clause), env),
506 rest);
507}
508
509static SCM
510expand_cond (SCM expr, SCM env)
511{
512 const int else_literal_p = expand_env_var_is_free (env, scm_sym_else);
513 const int arrow_literal_p = expand_env_var_is_free (env, scm_sym_arrow);
514 const SCM clauses = CDR (expr);
515
516 ASSERT_SYNTAX (scm_ilength (clauses) >= 0, s_bad_expression, expr);
517 ASSERT_SYNTAX (scm_ilength (clauses) >= 1, s_missing_clauses, expr);
518
519 return expand_cond_clauses (CAR (clauses), CDR (clauses),
520 else_literal_p, arrow_literal_p, env);
521}
522
523/* lone forward decl */
524static SCM expand_lambda (SCM expr, SCM env);
525
526/* According to Section 5.2.1 of R5RS we first have to make sure that the
527 variable is bound, and then perform the `(set! variable expression)'
528 operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
529 bound. This means that EXPRESSION won't necessarily be able to assign
530 values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
531static SCM
532expand_define (SCM expr, SCM env)
533{
534 const SCM cdr_expr = CDR (expr);
535 SCM body;
536 SCM variable;
537
538 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
539 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
540 ASSERT_SYNTAX (!scm_is_pair (env), s_bad_define, expr);
541
542 body = CDR (cdr_expr);
543 variable = CAR (cdr_expr);
544
545 if (scm_is_pair (variable))
546 {
547 ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable)), s_bad_variable, variable, expr);
548 return TOPLEVEL_DEFINE
549 (scm_source_properties (expr),
550 CAR (variable),
551 expand_lambda (scm_cons (scm_sym_lambda, scm_cons (CDR (variable), body)),
552 env));
553 }
554 ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
555 ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr);
556 return TOPLEVEL_DEFINE (scm_source_properties (expr), variable,
557 expand (CAR (body), env));
558}
559
560static SCM
561expand_with_fluids (SCM expr, SCM env)
562{
563 SCM binds, fluids, vals;
564 ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
565 binds = CADR (expr);
566 ASSERT_SYNTAX_2 (scm_ilength (binds) >= 0, s_bad_bindings, binds, expr);
567 for (fluids = SCM_EOL, vals = SCM_EOL;
568 scm_is_pair (binds);
569 binds = CDR (binds))
570 {
571 SCM binding = CAR (binds);
572 ASSERT_SYNTAX_2 (scm_ilength (CAR (binds)) == 2, s_bad_binding,
573 binding, expr);
574 fluids = scm_cons (expand (CAR (binding), env), fluids);
575 vals = scm_cons (expand (CADR (binding), env), vals);
576 }
577
578 return DYNLET (scm_source_properties (expr),
579 scm_reverse_x (fluids, SCM_UNDEFINED),
580 scm_reverse_x (vals, SCM_UNDEFINED),
581 expand_sequence (CDDR (expr), env));
582}
583
584static SCM
585expand_eval_when (SCM expr, SCM env)
586{
587 ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
588 ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
589
590 if (scm_is_true (scm_memq (sym_eval, CADR (expr)))
591 || scm_is_true (scm_memq (sym_load, CADR (expr))))
592 return expand_sequence (CDDR (expr), env);
593 else
baeb727b 594 return VOID_ (scm_source_properties (expr));
dc3e203e
AW
595}
596
597static SCM
598expand_if (SCM expr, SCM env SCM_UNUSED)
599{
600 const SCM cdr_expr = CDR (expr);
601 const long length = scm_ilength (cdr_expr);
602 ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr);
603 return CONDITIONAL (scm_source_properties (expr),
604 expand (CADR (expr), env),
605 expand (CADDR (expr), env),
606 ((length == 3)
607 ? expand (CADDDR (expr), env)
baeb727b 608 : VOID_ (SCM_BOOL_F)));
dc3e203e
AW
609}
610
611/* A helper function for expand_lambda to support checking for duplicate
612 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
613 * LIST or to the CDR of the last cons. Therefore, LIST may have any of the
614 * forms that a formal argument can have:
615 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
616static int
617c_improper_memq (SCM obj, SCM list)
618{
619 for (; scm_is_pair (list); list = CDR (list))
620 {
621 if (scm_is_eq (CAR (list), obj))
622 return 1;
623 }
624 return scm_is_eq (list, obj);
625}
626
627static SCM
628expand_lambda_case (SCM clause, SCM alternate, SCM env)
629{
630 SCM formals;
631 SCM rest;
632 SCM req = SCM_EOL;
633 SCM vars = SCM_EOL;
634 SCM body;
635 int nreq = 0;
636
637 ASSERT_SYNTAX (scm_is_pair (clause) && scm_is_pair (CDR (clause)),
638 s_bad_expression, scm_cons (scm_sym_lambda, clause));
639
640 /* Before iterating the list of formal arguments, make sure the formals
641 * actually are given as either a symbol or a non-cyclic list. */
642 formals = CAR (clause);
643 if (scm_is_pair (formals))
644 {
645 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
646 * detected, report a 'Bad formals' error. */
647 }
648 else
649 ASSERT_SYNTAX_2 (scm_is_symbol (formals) || scm_is_null (formals),
650 s_bad_formals, formals, scm_cons (scm_sym_lambda, clause));
651
652 /* Now iterate the list of formal arguments to check if all formals are
653 * symbols, and that there are no duplicates. */
654 while (scm_is_pair (formals))
655 {
656 const SCM formal = CAR (formals);
657 formals = CDR (formals);
658 ASSERT_SYNTAX_2 (scm_is_symbol (formal), s_bad_formal, formal,
659 scm_cons (scm_sym_lambda, clause));
660 ASSERT_SYNTAX_2 (!c_improper_memq (formal, formals), s_duplicate_formal,
661 formal, scm_cons (scm_sym_lambda, clause));
662 nreq++;
663 req = scm_cons (formal, req);
664 vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
665 env = scm_acons (formal, CAR (vars), env);
666 }
667
668 ASSERT_SYNTAX_2 (scm_is_null (formals) || scm_is_symbol (formals),
669 s_bad_formal, formals, scm_cons (scm_sym_lambda, clause));
670 if (scm_is_symbol (formals))
671 {
672 rest = formals;
673 vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
674 env = scm_acons (rest, CAR (vars), env);
675 }
676 else
677 rest = SCM_BOOL_F;
678
679 body = expand_sequence (CDR (clause), env);
680 req = scm_reverse_x (req, SCM_UNDEFINED);
681 vars = scm_reverse_x (vars, SCM_UNDEFINED);
682
683 if (scm_is_true (alternate) && !(SCM_EXPANDED_P (alternate) && SCM_EXPANDED_TYPE (alternate) == SCM_EXPANDED_LAMBDA_CASE))
684 abort ();
685
686 return LAMBDA_CASE (SCM_BOOL_F, req, SCM_BOOL_F, rest, SCM_BOOL_F,
687 SCM_EOL, vars, body, alternate);
688}
689
690static SCM
691expand_lambda (SCM expr, SCM env)
692{
693 return LAMBDA (scm_source_properties (expr),
694 SCM_EOL,
695 expand_lambda_case (CDR (expr), SCM_BOOL_F, env));
696}
697
698static SCM
699expand_lambda_star_case (SCM clause, SCM alternate, SCM env)
700{
701 SCM req, opt, kw, allow_other_keys, rest, formals, vars, body, tmp;
632ddbf0 702 SCM inits;
dc3e203e
AW
703 int nreq, nopt;
704
705 const long length = scm_ilength (clause);
706 ASSERT_SYNTAX (length >= 1, s_bad_expression,
707 scm_cons (sym_lambda_star, clause));
708 ASSERT_SYNTAX (length >= 2, s_missing_expression,
709 scm_cons (sym_lambda_star, clause));
710
711 formals = CAR (clause);
712 body = CDR (clause);
713
714 nreq = nopt = 0;
715 req = opt = kw = SCM_EOL;
716 rest = allow_other_keys = SCM_BOOL_F;
717
718 while (scm_is_pair (formals) && scm_is_symbol (CAR (formals)))
719 {
720 nreq++;
721 req = scm_cons (CAR (formals), req);
722 formals = scm_cdr (formals);
723 }
724
725 if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_optional))
726 {
727 formals = CDR (formals);
728 while (scm_is_pair (formals)
729 && (scm_is_symbol (CAR (formals)) || scm_is_pair (CAR (formals))))
730 {
731 nopt++;
732 opt = scm_cons (CAR (formals), opt);
733 formals = scm_cdr (formals);
734 }
735 }
736
737 if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_key))
738 {
739 formals = CDR (formals);
740 while (scm_is_pair (formals)
741 && (scm_is_symbol (CAR (formals)) || scm_is_pair (CAR (formals))))
742 {
743 kw = scm_cons (CAR (formals), kw);
744 formals = scm_cdr (formals);
745 }
746 }
747
748 if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_allow_other_keys))
749 {
750 formals = CDR (formals);
751 allow_other_keys = SCM_BOOL_T;
752 }
753
754 if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_rest))
755 {
756 ASSERT_SYNTAX (scm_ilength (formals) == 2, s_bad_formals,
757 CAR (clause));
758 rest = CADR (formals);
759 }
760 else if (scm_is_symbol (formals))
761 rest = formals;
762 else
763 {
764 ASSERT_SYNTAX (scm_is_null (formals), s_bad_formals, CAR (clause));
765 rest = SCM_BOOL_F;
766 }
767
768 /* Now, iterate through them a second time, building up an expansion-time
769 environment, checking, expanding and canonicalizing the opt/kw init forms,
770 and eventually memoizing the body as well. Note that the rest argument, if
771 any, is expanded before keyword args, thus necessitating the second
772 pass.
773
774 Also note that the specific environment during expansion of init
775 expressions here needs to coincide with the environment when psyntax
776 expands. A lot of effort for something that is only used in the bootstrap
777 expandr, you say? Yes. Yes it is.
778 */
779
780 vars = SCM_EOL;
781 req = scm_reverse_x (req, SCM_EOL);
782 for (tmp = req; scm_is_pair (tmp); tmp = scm_cdr (tmp))
783 {
784 vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
785 env = scm_acons (CAR (tmp), CAR (vars), env);
786 }
787
788 /* Build up opt inits and env */
789 inits = SCM_EOL;
790 opt = scm_reverse_x (opt, SCM_EOL);
791 for (tmp = opt; scm_is_pair (tmp); tmp = scm_cdr (tmp))
792 {
793 SCM x = CAR (tmp);
794 vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
795 env = scm_acons (x, CAR (vars), env);
796 if (scm_is_symbol (x))
baeb727b 797 inits = scm_cons (CONST_ (SCM_BOOL_F, SCM_BOOL_F), inits);
dc3e203e
AW
798 else
799 {
800 ASSERT_SYNTAX (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)),
801 s_bad_formals, CAR (clause));
802 inits = scm_cons (expand (CADR (x), env), inits);
803 }
804 env = scm_acons (scm_is_symbol (x) ? x : CAR (x), CAR (vars), env);
805 }
806 if (scm_is_null (opt))
807 opt = SCM_BOOL_F;
808
809 /* Process rest before keyword args */
810 if (scm_is_true (rest))
811 {
812 vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
813 env = scm_acons (rest, CAR (vars), env);
814 }
815
632ddbf0 816 /* Build up kw inits, env, and kw-canon list */
dc3e203e
AW
817 if (scm_is_null (kw))
818 kw = SCM_BOOL_F;
819 else
820 {
632ddbf0 821 SCM kw_canon = SCM_EOL;
dc3e203e
AW
822 kw = scm_reverse_x (kw, SCM_UNDEFINED);
823 for (tmp = kw; scm_is_pair (tmp); tmp = scm_cdr (tmp))
824 {
825 SCM x, sym, k, init;
826 x = CAR (tmp);
827 if (scm_is_symbol (x))
828 {
829 sym = x;
830 init = SCM_BOOL_F;
831 k = scm_symbol_to_keyword (sym);
832 }
833 else if (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)))
834 {
835 sym = CAR (x);
836 init = CADR (x);
837 k = scm_symbol_to_keyword (sym);
838 }
839 else if (scm_ilength (x) == 3 && scm_is_symbol (CAR (x))
840 && scm_is_keyword (CADDR (x)))
841 {
842 sym = CAR (x);
843 init = CADR (x);
844 k = CADDR (x);
845 }
846 else
847 syntax_error (s_bad_formals, CAR (clause), SCM_UNDEFINED);
848
dc3e203e
AW
849 inits = scm_cons (expand (init, env), inits);
850 vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
632ddbf0 851 kw_canon = scm_cons (scm_list_3 (k, sym, CAR (vars)), kw_canon);
dc3e203e
AW
852 env = scm_acons (sym, CAR (vars), env);
853 }
632ddbf0
AW
854 kw_canon = scm_reverse_x (kw_canon, SCM_UNDEFINED);
855 kw = scm_cons (allow_other_keys, kw_canon);
dc3e203e
AW
856 }
857
858 /* We should check for no duplicates, but given that psyntax does this
859 already, we can punt on it here... */
860
861 vars = scm_reverse_x (vars, SCM_UNDEFINED);
862 inits = scm_reverse_x (inits, SCM_UNDEFINED);
863 body = expand_sequence (body, env);
864
865 return LAMBDA_CASE (SCM_BOOL_F, req, opt, rest, kw, inits, vars, body,
866 alternate);
867}
868
869static SCM
870expand_lambda_star (SCM expr, SCM env)
871{
872 return LAMBDA (scm_source_properties (expr),
873 SCM_EOL,
874 expand_lambda_star_case (CDR (expr), SCM_BOOL_F, env));
875}
876
877static SCM
878expand_case_lambda_clauses (SCM expr, SCM rest, SCM env)
879{
880 SCM alt;
881
882 if (scm_is_pair (rest))
883 alt = expand_case_lambda_clauses (CAR (rest), CDR (rest), env);
884 else
885 alt = SCM_BOOL_F;
886
887 return expand_lambda_case (expr, alt, env);
888}
889
890static SCM
891expand_case_lambda (SCM expr, SCM env)
892{
893 ASSERT_SYNTAX (scm_is_pair (CDR (expr)), s_missing_expression, expr);
894
895 return LAMBDA (scm_source_properties (expr),
896 SCM_EOL,
897 expand_case_lambda_clauses (CADR (expr), CDDR (expr), env));
898}
899
900static SCM
901expand_case_lambda_star_clauses (SCM expr, SCM rest, SCM env)
902{
903 SCM alt;
904
905 if (scm_is_pair (rest))
906 alt = expand_case_lambda_star_clauses (CAR (rest), CDR (rest), env);
907 else
908 alt = SCM_BOOL_F;
909
910 return expand_lambda_star_case (expr, alt, env);
911}
912
913static SCM
914expand_case_lambda_star (SCM expr, SCM env)
915{
916 ASSERT_SYNTAX (scm_is_pair (CDR (expr)), s_missing_expression, expr);
917
918 return LAMBDA (scm_source_properties (expr),
919 SCM_EOL,
920 expand_case_lambda_star_clauses (CADR (expr), CDDR (expr), env));
921}
922
923/* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
924static void
925check_bindings (const SCM bindings, const SCM expr)
926{
927 SCM binding_idx;
928
929 ASSERT_SYNTAX_2 (scm_ilength (bindings) >= 0,
930 s_bad_bindings, bindings, expr);
931
932 binding_idx = bindings;
933 for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
934 {
935 SCM name; /* const */
936
937 const SCM binding = CAR (binding_idx);
938 ASSERT_SYNTAX_2 (scm_ilength (binding) == 2,
939 s_bad_binding, binding, expr);
940
941 name = CAR (binding);
942 ASSERT_SYNTAX_2 (scm_is_symbol (name), s_bad_variable, name, expr);
943 }
944}
945
946/* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
947 * transformed to the lists (vn .. v2 v1) and (i1 i2 ... in). If a duplicate
948 * variable name is detected, an error is signalled. */
949static void
950transform_bindings (const SCM bindings, const SCM expr,
951 SCM *const names, SCM *const vars, SCM *const initptr)
952{
953 SCM rnames = SCM_EOL;
954 SCM rvars = SCM_EOL;
955 SCM rinits = SCM_EOL;
956 SCM binding_idx = bindings;
957 for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
958 {
959 const SCM binding = CAR (binding_idx);
960 const SCM CDR_binding = CDR (binding);
961 const SCM name = CAR (binding);
962 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name, rnames)),
963 s_duplicate_binding, name, expr);
964 rnames = scm_cons (name, rnames);
965 rvars = scm_cons (scm_gensym (SCM_UNDEFINED), rvars);
966 rinits = scm_cons (CAR (CDR_binding), rinits);
967 }
968 *names = scm_reverse_x (rnames, SCM_UNDEFINED);
969 *vars = scm_reverse_x (rvars, SCM_UNDEFINED);
970 *initptr = scm_reverse_x (rinits, SCM_UNDEFINED);
971}
972
973/* FIXME: Remove named let in this boot expander. */
974static SCM
975expand_named_let (const SCM expr, SCM env)
976{
977 SCM var_names, var_syms, inits;
978 SCM inner_env;
979 SCM name_sym;
980
981 const SCM cdr_expr = CDR (expr);
982 const SCM name = CAR (cdr_expr);
983 const SCM cddr_expr = CDR (cdr_expr);
984 const SCM bindings = CAR (cddr_expr);
985 check_bindings (bindings, expr);
986
987 transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
988 name_sym = scm_gensym (SCM_UNDEFINED);
989 inner_env = scm_acons (name, name_sym, env);
990 inner_env = expand_env_extend (inner_env, var_names, var_syms);
991
992 return LETREC
fb6e61ca 993 (scm_source_properties (expr), SCM_BOOL_F,
dc3e203e
AW
994 scm_list_1 (name), scm_list_1 (name_sym),
995 scm_list_1 (LAMBDA (SCM_BOOL_F,
996 SCM_EOL,
997 LAMBDA_CASE (SCM_BOOL_F, var_names, SCM_BOOL_F, SCM_BOOL_F,
998 SCM_BOOL_F, SCM_BOOL_F, var_syms,
999 expand_sequence (CDDDR (expr), inner_env),
1000 SCM_BOOL_F))),
7081d4f9
AW
1001 CALL (SCM_BOOL_F,
1002 LEXICAL_REF (SCM_BOOL_F, name, name_sym),
1003 expand_exprs (inits, env)));
dc3e203e
AW
1004}
1005
1006static SCM
1007expand_let (SCM expr, SCM env)
1008{
1009 SCM bindings;
1010
1011 const SCM cdr_expr = CDR (expr);
1012 const long length = scm_ilength (cdr_expr);
1013 ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
1014 ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
1015
1016 bindings = CAR (cdr_expr);
1017 if (scm_is_symbol (bindings))
1018 {
1019 ASSERT_SYNTAX (length >= 3, s_missing_expression, expr);
1020 return expand_named_let (expr, env);
1021 }
1022
1023 check_bindings (bindings, expr);
1024 if (scm_is_null (bindings))
1025 return expand_sequence (CDDR (expr), env);
1026 else
1027 {
1028 SCM var_names, var_syms, inits;
1029 transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
1030 return LET (SCM_BOOL_F,
1031 var_names, var_syms, expand_exprs (inits, env),
1032 expand_sequence (CDDR (expr),
1033 expand_env_extend (env, var_names,
1034 var_syms)));
1035 }
1036}
1037
1038static SCM
826373a2 1039expand_letrec_helper (SCM expr, SCM env, SCM in_order_p)
dc3e203e
AW
1040{
1041 SCM bindings;
1042
1043 const SCM cdr_expr = CDR (expr);
1044 const long length = scm_ilength (cdr_expr);
1045 ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
1046 ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
1047
1048 bindings = CAR (cdr_expr);
1049 check_bindings (bindings, expr);
1050 if (scm_is_null (bindings))
1051 return expand_sequence (CDDR (expr), env);
1052 else
1053 {
1054 SCM var_names, var_syms, inits;
1055 transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
1056 env = expand_env_extend (env, var_names, var_syms);
826373a2 1057 return LETREC (SCM_BOOL_F, in_order_p,
dc3e203e
AW
1058 var_names, var_syms, expand_exprs (inits, env),
1059 expand_sequence (CDDR (expr), env));
1060 }
1061}
1062
826373a2
AW
1063static SCM
1064expand_letrec (SCM expr, SCM env)
1065{
1066 return expand_letrec_helper (expr, env, SCM_BOOL_F);
1067}
1068
1069static SCM
1070expand_letrec_star (SCM expr, SCM env)
1071{
1072 return expand_letrec_helper (expr, env, SCM_BOOL_T);
1073}
1074
dc3e203e
AW
1075static SCM
1076expand_letstar_clause (SCM bindings, SCM body, SCM env SCM_UNUSED)
1077{
1078 if (scm_is_null (bindings))
1079 return expand_sequence (body, env);
1080 else
1081 {
1082 SCM bind, name, sym, init;
1083
1084 ASSERT_SYNTAX (scm_is_pair (bindings), s_bad_expression, bindings);
1085 bind = CAR (bindings);
1086 ASSERT_SYNTAX (scm_ilength (bind) == 2, s_bad_binding, bind);
1087 name = CAR (bind);
1088 sym = scm_gensym (SCM_UNDEFINED);
1089 init = CADR (bind);
1090
1091 return LET (SCM_BOOL_F, scm_list_1 (name), scm_list_1 (sym),
1092 scm_list_1 (expand (init, env)),
1093 expand_letstar_clause (CDR (bindings), body,
1094 scm_acons (name, sym, env)));
1095 }
1096}
1097
1098static SCM
1099expand_letstar (SCM expr, SCM env SCM_UNUSED)
1100{
1101 const SCM cdr_expr = CDR (expr);
1102 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1103 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
1104
1105 return expand_letstar_clause (CADR (expr), CDDR (expr), env);
1106}
1107
1108static SCM
1109expand_or (SCM expr, SCM env SCM_UNUSED)
1110{
1111 SCM tail = CDR (expr);
1112 const long length = scm_ilength (tail);
1113
1114 ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
1115
1116 if (scm_is_null (CDR (expr)))
baeb727b 1117 return CONST_ (SCM_BOOL_F, SCM_BOOL_F);
dc3e203e
AW
1118 else
1119 {
1120 SCM tmp = scm_gensym (SCM_UNDEFINED);
1121 return LET (SCM_BOOL_F,
1122 scm_list_1 (tmp), scm_list_1 (tmp),
1123 scm_list_1 (expand (CADR (expr), env)),
1124 CONDITIONAL (SCM_BOOL_F,
1125 LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
1126 LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
1127 expand_or (CDR (expr),
1128 scm_acons (tmp, tmp, env))));
1129 }
1130}
1131
1132static SCM
1133expand_quote (SCM expr, SCM env SCM_UNUSED)
1134{
1135 SCM quotee;
1136
1137 const SCM cdr_expr = CDR (expr);
1138 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1139 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
1140 quotee = CAR (cdr_expr);
baeb727b 1141 return CONST_ (scm_source_properties (expr), quotee);
dc3e203e
AW
1142}
1143
1144static SCM
1145expand_set_x (SCM expr, SCM env)
1146{
1147 SCM variable;
1148 SCM vmem;
1149
1150 const SCM cdr_expr = CDR (expr);
1151 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1152 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
1153 variable = CAR (cdr_expr);
1154 vmem = expand (variable, env);
1155
1156 switch (SCM_EXPANDED_TYPE (vmem))
1157 {
1158 case SCM_EXPANDED_LEXICAL_REF:
1159 return LEXICAL_SET (scm_source_properties (expr),
1160 SCM_EXPANDED_REF (vmem, LEXICAL_REF, NAME),
1161 SCM_EXPANDED_REF (vmem, LEXICAL_REF, GENSYM),
1162 expand (CADDR (expr), env));
1163 case SCM_EXPANDED_TOPLEVEL_REF:
1164 return TOPLEVEL_SET (scm_source_properties (expr),
1165 SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, NAME),
1166 expand (CADDR (expr), env));
1167 case SCM_EXPANDED_MODULE_REF:
1168 return MODULE_SET (scm_source_properties (expr),
1169 SCM_EXPANDED_REF (vmem, MODULE_REF, MOD),
1170 SCM_EXPANDED_REF (vmem, MODULE_REF, NAME),
1171 SCM_EXPANDED_REF (vmem, MODULE_REF, PUBLIC),
1172 expand (CADDR (expr), env));
1173 default:
1174 syntax_error (s_bad_variable, variable, expr);
1175 }
1176}
1177
1178
1179\f
1180
a310a1d1
AW
1181/* This is the boot expander. It is later replaced with psyntax's sc-expand. */
1182SCM_DEFINE (scm_macroexpand, "macroexpand", 1, 0, 0,
dc3e203e
AW
1183 (SCM exp),
1184 "Expand the expression @var{exp}.")
1185#define FUNC_NAME s_scm_macroexpand
1186{
1187 return expand (exp, scm_current_module ());
1188}
1189#undef FUNC_NAME
1190
a310a1d1
AW
1191SCM_DEFINE (scm_macroexpanded_p, "macroexpanded?", 1, 0, 0,
1192 (SCM exp),
1193 "Return @code{#t} if @var{exp} is an expanded expression.")
1194#define FUNC_NAME s_scm_macroexpanded_p
1195{
1196 return scm_from_bool (SCM_EXPANDED_P (exp));
1197}
1198#undef FUNC_NAME
1199
dc3e203e
AW
1200
1201 \f
1202
1203#define DEFINE_NAMES(type) \
1204 { \
1205 static const char *fields[] = SCM_EXPANDED_##type##_FIELD_NAMES; \
1206 exp_field_names[SCM_EXPANDED_##type] = fields; \
1207 exp_names[SCM_EXPANDED_##type] = SCM_EXPANDED_##type##_TYPE_NAME; \
1208 exp_nfields[SCM_EXPANDED_##type] = SCM_NUM_EXPANDED_##type##_FIELDS; \
1209 }
1210
1211static SCM
1212make_exp_vtable (size_t n)
1213{
1214 SCM layout, printer, name, code, fields;
1215
1216 layout = scm_string_to_symbol
1217 (scm_string_append (scm_make_list (scm_from_size_t (exp_nfields[n]),
1218 scm_from_locale_string ("pw"))));
1219 printer = SCM_BOOL_F;
25d50a05 1220 name = scm_from_utf8_symbol (exp_names[n]);
dc3e203e
AW
1221 code = scm_from_size_t (n);
1222 fields = SCM_EOL;
1223 {
1224 size_t m = exp_nfields[n];
1225 while (m--)
25d50a05 1226 fields = scm_cons (scm_from_utf8_symbol (exp_field_names[n][m]), fields);
dc3e203e
AW
1227 }
1228
1229 return scm_c_make_struct (scm_exp_vtable_vtable, 0, 5,
1230 SCM_UNPACK (layout), SCM_UNPACK (printer), SCM_UNPACK (name),
1231 SCM_UNPACK (code), SCM_UNPACK (fields));
1232}
1233
1234void
1235scm_init_expand ()
1236{
1237 size_t n;
1238 SCM exp_vtable_list = SCM_EOL;
1239
1240 DEFINE_NAMES (VOID);
1241 DEFINE_NAMES (CONST);
1242 DEFINE_NAMES (PRIMITIVE_REF);
1243 DEFINE_NAMES (LEXICAL_REF);
1244 DEFINE_NAMES (LEXICAL_SET);
1245 DEFINE_NAMES (MODULE_REF);
1246 DEFINE_NAMES (MODULE_SET);
1247 DEFINE_NAMES (TOPLEVEL_REF);
1248 DEFINE_NAMES (TOPLEVEL_SET);
1249 DEFINE_NAMES (TOPLEVEL_DEFINE);
1250 DEFINE_NAMES (CONDITIONAL);
7081d4f9 1251 DEFINE_NAMES (CALL);
a881a4ae 1252 DEFINE_NAMES (PRIMCALL);
6fc3eae4 1253 DEFINE_NAMES (SEQ);
dc3e203e
AW
1254 DEFINE_NAMES (LAMBDA);
1255 DEFINE_NAMES (LAMBDA_CASE);
1256 DEFINE_NAMES (LET);
1257 DEFINE_NAMES (LETREC);
1258 DEFINE_NAMES (DYNLET);
1259
1260 scm_exp_vtable_vtable =
1261 scm_make_vtable (scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT "pwuwpw"),
1262 SCM_BOOL_F);
1263
1264 for (n = 0; n < SCM_NUM_EXPANDED_TYPES; n++)
1265 exp_vtables[n] = make_exp_vtable (n);
1266
1267 /* Now walk back down, consing in reverse. */
1268 while (n--)
1269 exp_vtable_list = scm_cons (exp_vtables[n], exp_vtable_list);
1270
ccbc25f3 1271 scm_c_define ("%expanded-vtables", scm_vector (exp_vtable_list));
dc3e203e
AW
1272
1273#include "libguile/expand.x"
1274}
1275
1276/*
1277 Local Variables:
1278 c-file-style: "gnu"
1279 End:
1280*/