1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012,2013
2 * Free Software Foundation, Inc.
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.
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.
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
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"
45 SCM scm_exp_vtable_vtable
;
46 static SCM exp_vtables
[SCM_NUM_EXPANDED_TYPES
];
47 static size_t exp_nfields
[SCM_NUM_EXPANDED_TYPES
];
48 static const char* exp_names
[SCM_NUM_EXPANDED_TYPES
];
49 static const char** exp_field_names
[SCM_NUM_EXPANDED_TYPES
];
52 /* The trailing underscores on these first to are to avoid spurious
53 conflicts with macros defined on MinGW. */
56 SCM_MAKE_EXPANDED_VOID(src)
57 #define CONST_(src, exp) \
58 SCM_MAKE_EXPANDED_CONST(src, exp)
59 #define PRIMITIVE_REF(src, name) \
60 SCM_MAKE_EXPANDED_PRIMITIVE_REF(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)
77 #define PRIMCALL(src, name, exps) \
78 SCM_MAKE_EXPANDED_PRIMCALL(src, name, exps)
79 #define CALL(src, proc, exps) \
80 SCM_MAKE_EXPANDED_CALL(src, proc, exps)
81 #define SEQ(src, head, tail) \
82 SCM_MAKE_EXPANDED_SEQ(src, head, tail)
83 #define LAMBDA(src, meta, body) \
84 SCM_MAKE_EXPANDED_LAMBDA(src, meta, body)
85 #define LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate) \
86 SCM_MAKE_EXPANDED_LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate)
87 #define LET(src, names, gensyms, vals, body) \
88 SCM_MAKE_EXPANDED_LET(src, names, gensyms, vals, body)
89 #define LETREC(src, in_order_p, names, gensyms, vals, body) \
90 SCM_MAKE_EXPANDED_LETREC(src, in_order_p, names, gensyms, vals, body)
91 #define DYNLET(src, fluids, vals, body) \
92 SCM_MAKE_EXPANDED_DYNLET(src, fluids, vals, body)
94 #define CAR(x) SCM_CAR(x)
95 #define CDR(x) SCM_CDR(x)
96 #define CAAR(x) SCM_CAAR(x)
97 #define CADR(x) SCM_CADR(x)
98 #define CDAR(x) SCM_CDAR(x)
99 #define CDDR(x) SCM_CDDR(x)
100 #define CADDR(x) SCM_CADDR(x)
101 #define CDDDR(x) SCM_CDDDR(x)
102 #define CADDDR(x) SCM_CADDDR(x)
105 static const char s_bad_expression
[] = "Bad expression";
106 static const char s_expression
[] = "Missing or extra expression in";
107 static const char s_missing_expression
[] = "Missing expression in";
108 static const char s_extra_expression
[] = "Extra expression in";
109 static const char s_empty_combination
[] = "Illegal empty combination";
110 static const char s_missing_body_expression
[] = "Missing body expression in";
111 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
112 static const char s_bad_define
[] = "Bad define placement";
113 static const char s_missing_clauses
[] = "Missing clauses";
114 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
115 static const char s_bad_case_clause
[] = "Bad case clause";
116 static const char s_bad_case_labels
[] = "Bad case labels";
117 static const char s_duplicate_case_label
[] = "Duplicate case label";
118 static const char s_bad_cond_clause
[] = "Bad cond clause";
119 static const char s_missing_recipient
[] = "Missing recipient in";
120 static const char s_bad_variable
[] = "Bad variable";
121 static const char s_bad_bindings
[] = "Bad bindings";
122 static const char s_bad_binding
[] = "Bad binding";
123 static const char s_duplicate_binding
[] = "Duplicate binding";
124 static const char s_bad_exit_clause
[] = "Bad exit clause";
125 static const char s_bad_formals
[] = "Bad formals";
126 static const char s_bad_formal
[] = "Bad formal";
127 static const char s_duplicate_formal
[] = "Duplicate formal";
128 static const char s_splicing
[] = "Non-list result for unquote-splicing";
129 static const char s_bad_slot_number
[] = "Bad slot number";
131 static void syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
133 SCM_SYMBOL (syntax_error_key
, "syntax-error");
135 /* Shortcut macros to simplify syntax error handling. */
136 #define ASSERT_SYNTAX(cond, message, form) \
137 { if (SCM_UNLIKELY (!(cond))) \
138 syntax_error (message, form, SCM_UNDEFINED); }
139 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
140 { if (SCM_UNLIKELY (!(cond))) \
141 syntax_error (message, form, expr); }
146 /* Primitive syntax. */
148 #define SCM_SYNTAX(STR, CFN) \
149 SCM_SNARF_HERE(static SCM CFN (SCM xorig, SCM env)) \
150 SCM_SNARF_INIT(scm_c_define (STR, scm_i_make_primitive_macro (STR, CFN)))
153 /* True primitive syntax */
154 SCM_SYNTAX ("@", expand_at
);
155 SCM_SYNTAX ("@@", expand_atat
);
156 SCM_SYNTAX ("begin", expand_begin
);
157 SCM_SYNTAX ("define", expand_define
);
158 SCM_SYNTAX ("with-fluids", expand_with_fluids
);
159 SCM_SYNTAX ("eval-when", expand_eval_when
);
160 SCM_SYNTAX ("if", expand_if
);
161 SCM_SYNTAX ("lambda", expand_lambda
);
162 SCM_SYNTAX ("let", expand_let
);
163 SCM_SYNTAX ("quote", expand_quote
);
164 SCM_SYNTAX ("set!", expand_set_x
);
166 /* Convenient syntax during boot, expands to primitive syntax. Replaced after
168 SCM_SYNTAX ("and", expand_and
);
169 SCM_SYNTAX ("cond", expand_cond
);
170 SCM_SYNTAX ("letrec", expand_letrec
);
171 SCM_SYNTAX ("letrec*", expand_letrec_star
);
172 SCM_SYNTAX ("let*", expand_letstar
);
173 SCM_SYNTAX ("or", expand_or
);
174 SCM_SYNTAX ("lambda*", expand_lambda_star
);
175 SCM_SYNTAX ("case-lambda", expand_case_lambda
);
176 SCM_SYNTAX ("case-lambda*", expand_case_lambda_star
);
179 SCM_GLOBAL_SYMBOL (scm_sym_apply
, "apply");
180 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
181 SCM_GLOBAL_SYMBOL (scm_sym_at
, "@");
182 SCM_GLOBAL_SYMBOL (scm_sym_atat
, "@@");
183 SCM_GLOBAL_SYMBOL (scm_sym_at_call_with_values
, "@call-with-values");
184 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, "@apply");
185 SCM_GLOBAL_SYMBOL (scm_sym_atcall_cc
, "@call-with-current-continuation");
186 SCM_GLOBAL_SYMBOL (scm_sym_begin
, "begin");
187 SCM_GLOBAL_SYMBOL (scm_sym_case
, "case");
188 SCM_GLOBAL_SYMBOL (scm_sym_cond
, "cond");
189 SCM_GLOBAL_SYMBOL (scm_sym_define
, "define");
190 SCM_GLOBAL_SYMBOL (scm_sym_at_dynamic_wind
, "@dynamic-wind");
191 SCM_GLOBAL_SYMBOL (scm_sym_with_fluids
, "with-fluids");
192 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
193 SCM_GLOBAL_SYMBOL (scm_sym_eval_when
, "eval-when");
194 SCM_GLOBAL_SYMBOL (scm_sym_if
, "if");
195 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, "lambda");
196 SCM_GLOBAL_SYMBOL (scm_sym_let
, "let");
197 SCM_GLOBAL_SYMBOL (scm_sym_letrec
, "letrec");
198 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, "let*");
199 SCM_GLOBAL_SYMBOL (scm_sym_or
, "or");
200 SCM_SYMBOL (sym_call_with_prompt
, "call-with-prompt");
201 SCM_GLOBAL_SYMBOL (scm_sym_quote
, "quote");
202 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, "set!");
203 SCM_SYMBOL (sym_lambda_star
, "lambda*");
204 SCM_SYMBOL (sym_eval
, "eval");
205 SCM_SYMBOL (sym_load
, "load");
206 SCM_SYMBOL (sym_primitive
, "primitive");
208 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
209 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, "quasiquote");
210 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
212 SCM_KEYWORD (kw_allow_other_keys
, "allow-other-keys");
213 SCM_KEYWORD (kw_optional
, "optional");
214 SCM_KEYWORD (kw_key
, "key");
215 SCM_KEYWORD (kw_rest
, "rest");
221 /* Signal a syntax error. We distinguish between the form that caused the
222 * error and the enclosing expression. The error message will print out as
223 * shown in the following pattern. The file name and line number are only
224 * given when they can be determined from the erroneous form or from the
225 * enclosing expression.
227 * <filename>: In procedure memoization:
228 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
231 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
233 SCM msg_string
= scm_from_locale_string (msg
);
234 SCM filename
= SCM_BOOL_F
;
235 SCM linenr
= SCM_BOOL_F
;
239 if (scm_is_pair (form
))
241 filename
= scm_source_property (form
, scm_sym_filename
);
242 linenr
= scm_source_property (form
, scm_sym_line
);
245 if (scm_is_false (filename
) && scm_is_false (linenr
) && scm_is_pair (expr
))
247 filename
= scm_source_property (expr
, scm_sym_filename
);
248 linenr
= scm_source_property (expr
, scm_sym_line
);
251 if (!SCM_UNBNDP (expr
))
253 if (scm_is_true (filename
))
255 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
256 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
258 else if (scm_is_true (linenr
))
260 format
= "In line ~S: ~A ~S in expression ~S.";
261 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
265 format
= "~A ~S in expression ~S.";
266 args
= scm_list_3 (msg_string
, form
, expr
);
271 if (scm_is_true (filename
))
273 format
= "In file ~S, line ~S: ~A ~S.";
274 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
276 else if (scm_is_true (linenr
))
278 format
= "In line ~S: ~A ~S.";
279 args
= scm_list_3 (linenr
, msg_string
, form
);
284 args
= scm_list_2 (msg_string
, form
);
288 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
296 expand_env_var_is_free (SCM env
, SCM x
)
298 for (; scm_is_pair (env
); env
= CDR (env
))
299 if (scm_is_eq (x
, CAAR (env
)))
300 return 0; /* bound */
305 expand_env_ref_macro (SCM env
, SCM x
)
308 if (!expand_env_var_is_free (env
, x
))
309 return SCM_BOOL_F
; /* lexical */
311 var
= scm_module_variable (scm_current_module (), x
);
312 if (scm_is_true (var
) && scm_is_true (scm_variable_bound_p (var
))
313 && scm_is_true (scm_macro_p (scm_variable_ref (var
))))
314 return scm_variable_ref (var
);
316 return SCM_BOOL_F
; /* anything else */
320 expand_env_lexical_gensym (SCM env
, SCM name
)
322 for (; scm_is_pair (env
); env
= CDR (env
))
323 if (scm_is_eq (name
, CAAR (env
)))
324 return CDAR (env
); /* bound */
325 return SCM_BOOL_F
; /* free */
329 expand_env_extend (SCM env
, SCM names
, SCM vars
)
331 while (scm_is_pair (names
))
333 env
= scm_acons (CAR (names
), CAR (vars
), env
);
341 expand (SCM exp
, SCM env
)
343 if (scm_is_pair (exp
))
346 scm_t_macro_primitive trans
= NULL
;
347 SCM macro
= SCM_BOOL_F
;
350 if (scm_is_symbol (car
))
351 macro
= expand_env_ref_macro (env
, car
);
353 if (scm_is_true (macro
))
354 trans
= scm_i_macro_primitive (macro
);
357 return trans (exp
, env
);
360 SCM arg_exps
= SCM_EOL
;
362 SCM proc
= expand (CAR (exp
), env
);
364 for (arg_exps
= CDR (exp
); scm_is_pair (arg_exps
);
365 arg_exps
= CDR (arg_exps
))
366 args
= scm_cons (expand (CAR (arg_exps
), env
), args
);
367 args
= scm_reverse_x (args
, SCM_UNDEFINED
);
369 if (!scm_is_null (arg_exps
))
370 syntax_error ("expected a proper list", exp
, SCM_UNDEFINED
);
372 if (SCM_EXPANDED_TYPE (proc
) == SCM_EXPANDED_PRIMITIVE_REF
)
373 return PRIMCALL (scm_source_properties (exp
),
374 SCM_EXPANDED_REF (proc
, PRIMITIVE_REF
, NAME
),
377 return CALL (scm_source_properties (exp
), proc
, args
);
380 else if (scm_is_symbol (exp
))
382 SCM gensym
= expand_env_lexical_gensym (env
, exp
);
383 if (scm_is_true (gensym
))
384 return LEXICAL_REF (SCM_BOOL_F
, exp
, gensym
);
386 return TOPLEVEL_REF (SCM_BOOL_F
, exp
);
389 return CONST_ (SCM_BOOL_F
, exp
);
393 expand_exprs (SCM forms
, const SCM env
)
397 for (; !scm_is_null (forms
); forms
= CDR (forms
))
398 ret
= scm_cons (expand (CAR (forms
), env
), ret
);
399 return scm_reverse_x (ret
, SCM_UNDEFINED
);
403 expand_sequence (const SCM forms
, const SCM env
)
405 ASSERT_SYNTAX (scm_ilength (forms
) >= 1, s_bad_expression
,
406 scm_cons (scm_sym_begin
, forms
));
407 if (scm_is_null (CDR (forms
)))
408 return expand (CAR (forms
), env
);
410 return SEQ (scm_source_properties (forms
),
411 expand (CAR (forms
), env
),
412 expand_sequence (CDR (forms
), env
));
420 expand_at (SCM expr
, SCM env SCM_UNUSED
)
422 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
423 ASSERT_SYNTAX (scm_ilength (CADR (expr
)) > 0, s_bad_expression
, expr
);
424 ASSERT_SYNTAX (scm_is_symbol (CADDR (expr
)), s_bad_expression
, expr
);
426 return MODULE_REF (scm_source_properties (expr
),
427 CADR (expr
), CADDR (expr
), SCM_BOOL_T
);
431 expand_atat (SCM expr
, SCM env SCM_UNUSED
)
433 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
434 ASSERT_SYNTAX (scm_is_symbol (CADDR (expr
)), s_bad_expression
, expr
);
436 if (scm_is_eq (CADR (expr
), sym_primitive
))
437 return PRIMITIVE_REF (scm_source_properties (expr
), CADDR (expr
));
439 ASSERT_SYNTAX (scm_ilength (CADR (expr
)) > 0, s_bad_expression
, expr
);
440 return MODULE_REF (scm_source_properties (expr
),
441 CADR (expr
), CADDR (expr
), SCM_BOOL_F
);
445 expand_and (SCM expr
, SCM env
)
447 const SCM cdr_expr
= CDR (expr
);
449 if (scm_is_null (cdr_expr
))
450 return CONST_ (SCM_BOOL_F
, SCM_BOOL_T
);
452 ASSERT_SYNTAX (scm_is_pair (cdr_expr
), s_bad_expression
, expr
);
454 if (scm_is_null (CDR (cdr_expr
)))
455 return expand (CAR (cdr_expr
), env
);
457 return CONDITIONAL (scm_source_properties (expr
),
458 expand (CAR (cdr_expr
), env
),
459 expand_and (cdr_expr
, env
),
460 CONST_ (SCM_BOOL_F
, SCM_BOOL_F
));
464 expand_begin (SCM expr
, SCM env
)
466 const SCM cdr_expr
= CDR (expr
);
467 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_bad_expression
, expr
);
468 return expand_sequence (cdr_expr
, env
);
472 expand_cond_clauses (SCM clause
, SCM rest
, int elp
, int alp
, SCM env
)
475 const long length
= scm_ilength (clause
);
476 ASSERT_SYNTAX (length
>= 1, s_bad_cond_clause
, clause
);
479 if (scm_is_eq (test
, scm_sym_else
) && elp
)
481 const int last_clause_p
= scm_is_null (rest
);
482 ASSERT_SYNTAX (length
>= 2, s_bad_cond_clause
, clause
);
483 ASSERT_SYNTAX (last_clause_p
, s_misplaced_else_clause
, clause
);
484 return expand_sequence (CDR (clause
), env
);
487 if (scm_is_null (rest
))
488 rest
= VOID_ (SCM_BOOL_F
);
490 rest
= expand_cond_clauses (CAR (rest
), CDR (rest
), elp
, alp
, env
);
493 && scm_is_eq (CADR (clause
), scm_sym_arrow
)
496 SCM tmp
= scm_gensym (scm_from_locale_string ("cond "));
497 SCM new_env
= scm_acons (tmp
, tmp
, env
);
498 ASSERT_SYNTAX (length
> 2, s_missing_recipient
, clause
);
499 ASSERT_SYNTAX (length
== 3, s_extra_expression
, clause
);
500 return LET (SCM_BOOL_F
,
503 scm_list_1 (expand (test
, env
)),
504 CONDITIONAL (SCM_BOOL_F
,
505 LEXICAL_REF (SCM_BOOL_F
, tmp
, tmp
),
507 expand (CADDR (clause
), new_env
),
508 scm_list_1 (LEXICAL_REF (SCM_BOOL_F
,
512 /* FIXME length == 1 case */
514 return CONDITIONAL (SCM_BOOL_F
,
516 expand_sequence (CDR (clause
), env
),
521 expand_cond (SCM expr
, SCM env
)
523 const int else_literal_p
= expand_env_var_is_free (env
, scm_sym_else
);
524 const int arrow_literal_p
= expand_env_var_is_free (env
, scm_sym_arrow
);
525 const SCM clauses
= CDR (expr
);
527 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
528 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
530 return expand_cond_clauses (CAR (clauses
), CDR (clauses
),
531 else_literal_p
, arrow_literal_p
, env
);
534 /* lone forward decl */
535 static SCM
expand_lambda (SCM expr
, SCM env
);
537 /* According to Section 5.2.1 of R5RS we first have to make sure that the
538 variable is bound, and then perform the `(set! variable expression)'
539 operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
540 bound. This means that EXPRESSION won't necessarily be able to assign
541 values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
543 expand_define (SCM expr
, SCM env
)
545 const SCM cdr_expr
= CDR (expr
);
549 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
550 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
551 ASSERT_SYNTAX (!scm_is_pair (env
), s_bad_define
, expr
);
553 body
= CDR (cdr_expr
);
554 variable
= CAR (cdr_expr
);
556 if (scm_is_pair (variable
))
558 ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable
)), s_bad_variable
, variable
, expr
);
559 return TOPLEVEL_DEFINE
560 (scm_source_properties (expr
),
562 expand_lambda (scm_cons (scm_sym_lambda
, scm_cons (CDR (variable
), body
)),
565 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
566 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
567 return TOPLEVEL_DEFINE (scm_source_properties (expr
), variable
,
568 expand (CAR (body
), env
));
572 expand_with_fluids (SCM expr
, SCM env
)
574 SCM binds
, fluids
, vals
;
575 ASSERT_SYNTAX (scm_ilength (expr
) >= 3, s_bad_expression
, expr
);
577 ASSERT_SYNTAX_2 (scm_ilength (binds
) >= 0, s_bad_bindings
, binds
, expr
);
578 for (fluids
= SCM_EOL
, vals
= SCM_EOL
;
582 SCM binding
= CAR (binds
);
583 ASSERT_SYNTAX_2 (scm_ilength (CAR (binds
)) == 2, s_bad_binding
,
585 fluids
= scm_cons (expand (CAR (binding
), env
), fluids
);
586 vals
= scm_cons (expand (CADR (binding
), env
), vals
);
589 return DYNLET (scm_source_properties (expr
),
590 scm_reverse_x (fluids
, SCM_UNDEFINED
),
591 scm_reverse_x (vals
, SCM_UNDEFINED
),
592 expand_sequence (CDDR (expr
), env
));
596 expand_eval_when (SCM expr
, SCM env
)
598 ASSERT_SYNTAX (scm_ilength (expr
) >= 3, s_bad_expression
, expr
);
599 ASSERT_SYNTAX (scm_ilength (CADR (expr
)) > 0, s_bad_expression
, expr
);
601 if (scm_is_true (scm_memq (sym_eval
, CADR (expr
)))
602 || scm_is_true (scm_memq (sym_load
, CADR (expr
))))
603 return expand_sequence (CDDR (expr
), env
);
605 return VOID_ (scm_source_properties (expr
));
609 expand_if (SCM expr
, SCM env SCM_UNUSED
)
611 const SCM cdr_expr
= CDR (expr
);
612 const long length
= scm_ilength (cdr_expr
);
613 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
614 return CONDITIONAL (scm_source_properties (expr
),
615 expand (CADR (expr
), env
),
616 expand (CADDR (expr
), env
),
618 ? expand (CADDDR (expr
), env
)
619 : VOID_ (SCM_BOOL_F
)));
622 /* A helper function for expand_lambda to support checking for duplicate
623 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
624 * LIST or to the CDR of the last cons. Therefore, LIST may have any of the
625 * forms that a formal argument can have:
626 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
628 c_improper_memq (SCM obj
, SCM list
)
630 for (; scm_is_pair (list
); list
= CDR (list
))
632 if (scm_is_eq (CAR (list
), obj
))
635 return scm_is_eq (list
, obj
);
639 expand_lambda_case (SCM clause
, SCM alternate
, SCM env
)
648 ASSERT_SYNTAX (scm_is_pair (clause
) && scm_is_pair (CDR (clause
)),
649 s_bad_expression
, scm_cons (scm_sym_lambda
, clause
));
651 /* Before iterating the list of formal arguments, make sure the formals
652 * actually are given as either a symbol or a non-cyclic list. */
653 formals
= CAR (clause
);
654 if (scm_is_pair (formals
))
656 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
657 * detected, report a 'Bad formals' error. */
660 ASSERT_SYNTAX_2 (scm_is_symbol (formals
) || scm_is_null (formals
),
661 s_bad_formals
, formals
, scm_cons (scm_sym_lambda
, clause
));
663 /* Now iterate the list of formal arguments to check if all formals are
664 * symbols, and that there are no duplicates. */
665 while (scm_is_pair (formals
))
667 const SCM formal
= CAR (formals
);
668 formals
= CDR (formals
);
669 ASSERT_SYNTAX_2 (scm_is_symbol (formal
), s_bad_formal
, formal
,
670 scm_cons (scm_sym_lambda
, clause
));
671 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, formals
), s_duplicate_formal
,
672 formal
, scm_cons (scm_sym_lambda
, clause
));
674 req
= scm_cons (formal
, req
);
675 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
676 env
= scm_acons (formal
, CAR (vars
), env
);
679 ASSERT_SYNTAX_2 (scm_is_null (formals
) || scm_is_symbol (formals
),
680 s_bad_formal
, formals
, scm_cons (scm_sym_lambda
, clause
));
681 if (scm_is_symbol (formals
))
684 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
685 env
= scm_acons (rest
, CAR (vars
), env
);
690 body
= expand_sequence (CDR (clause
), env
);
691 req
= scm_reverse_x (req
, SCM_UNDEFINED
);
692 vars
= scm_reverse_x (vars
, SCM_UNDEFINED
);
694 if (scm_is_true (alternate
) && !(SCM_EXPANDED_P (alternate
) && SCM_EXPANDED_TYPE (alternate
) == SCM_EXPANDED_LAMBDA_CASE
))
697 return LAMBDA_CASE (SCM_BOOL_F
, req
, SCM_BOOL_F
, rest
, SCM_BOOL_F
,
698 SCM_EOL
, vars
, body
, alternate
);
702 expand_lambda (SCM expr
, SCM env
)
704 return LAMBDA (scm_source_properties (expr
),
706 expand_lambda_case (CDR (expr
), SCM_BOOL_F
, env
));
710 expand_lambda_star_case (SCM clause
, SCM alternate
, SCM env
)
712 SCM req
, opt
, kw
, allow_other_keys
, rest
, formals
, vars
, body
, tmp
;
716 const long length
= scm_ilength (clause
);
717 ASSERT_SYNTAX (length
>= 1, s_bad_expression
,
718 scm_cons (sym_lambda_star
, clause
));
719 ASSERT_SYNTAX (length
>= 2, s_missing_expression
,
720 scm_cons (sym_lambda_star
, clause
));
722 formals
= CAR (clause
);
726 req
= opt
= kw
= SCM_EOL
;
727 rest
= allow_other_keys
= SCM_BOOL_F
;
729 while (scm_is_pair (formals
) && scm_is_symbol (CAR (formals
)))
732 req
= scm_cons (CAR (formals
), req
);
733 formals
= scm_cdr (formals
);
736 if (scm_is_pair (formals
) && scm_is_eq (CAR (formals
), kw_optional
))
738 formals
= CDR (formals
);
739 while (scm_is_pair (formals
)
740 && (scm_is_symbol (CAR (formals
)) || scm_is_pair (CAR (formals
))))
743 opt
= scm_cons (CAR (formals
), opt
);
744 formals
= scm_cdr (formals
);
748 if (scm_is_pair (formals
) && scm_is_eq (CAR (formals
), kw_key
))
750 formals
= CDR (formals
);
751 while (scm_is_pair (formals
)
752 && (scm_is_symbol (CAR (formals
)) || scm_is_pair (CAR (formals
))))
754 kw
= scm_cons (CAR (formals
), kw
);
755 formals
= scm_cdr (formals
);
759 if (scm_is_pair (formals
) && scm_is_eq (CAR (formals
), kw_allow_other_keys
))
761 formals
= CDR (formals
);
762 allow_other_keys
= SCM_BOOL_T
;
765 if (scm_is_pair (formals
) && scm_is_eq (CAR (formals
), kw_rest
))
767 ASSERT_SYNTAX (scm_ilength (formals
) == 2, s_bad_formals
,
769 rest
= CADR (formals
);
771 else if (scm_is_symbol (formals
))
775 ASSERT_SYNTAX (scm_is_null (formals
), s_bad_formals
, CAR (clause
));
779 /* Now, iterate through them a second time, building up an expansion-time
780 environment, checking, expanding and canonicalizing the opt/kw init forms,
781 and eventually memoizing the body as well. Note that the rest argument, if
782 any, is expanded before keyword args, thus necessitating the second
785 Also note that the specific environment during expansion of init
786 expressions here needs to coincide with the environment when psyntax
787 expands. A lot of effort for something that is only used in the bootstrap
788 expandr, you say? Yes. Yes it is.
792 req
= scm_reverse_x (req
, SCM_EOL
);
793 for (tmp
= req
; scm_is_pair (tmp
); tmp
= scm_cdr (tmp
))
795 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
796 env
= scm_acons (CAR (tmp
), CAR (vars
), env
);
799 /* Build up opt inits and env */
801 opt
= scm_reverse_x (opt
, SCM_EOL
);
802 for (tmp
= opt
; scm_is_pair (tmp
); tmp
= scm_cdr (tmp
))
805 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
806 env
= scm_acons (x
, CAR (vars
), env
);
807 if (scm_is_symbol (x
))
808 inits
= scm_cons (CONST_ (SCM_BOOL_F
, SCM_BOOL_F
), inits
);
811 ASSERT_SYNTAX (scm_ilength (x
) == 2 && scm_is_symbol (CAR (x
)),
812 s_bad_formals
, CAR (clause
));
813 inits
= scm_cons (expand (CADR (x
), env
), inits
);
815 env
= scm_acons (scm_is_symbol (x
) ? x
: CAR (x
), CAR (vars
), env
);
817 if (scm_is_null (opt
))
820 /* Process rest before keyword args */
821 if (scm_is_true (rest
))
823 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
824 env
= scm_acons (rest
, CAR (vars
), env
);
827 /* Build up kw inits, env, and kw-canon list */
828 if (scm_is_null (kw
))
832 SCM kw_canon
= SCM_EOL
;
833 kw
= scm_reverse_x (kw
, SCM_UNDEFINED
);
834 for (tmp
= kw
; scm_is_pair (tmp
); tmp
= scm_cdr (tmp
))
838 if (scm_is_symbol (x
))
842 k
= scm_symbol_to_keyword (sym
);
844 else if (scm_ilength (x
) == 2 && scm_is_symbol (CAR (x
)))
848 k
= scm_symbol_to_keyword (sym
);
850 else if (scm_ilength (x
) == 3 && scm_is_symbol (CAR (x
))
851 && scm_is_keyword (CADDR (x
)))
858 syntax_error (s_bad_formals
, CAR (clause
), SCM_UNDEFINED
);
860 inits
= scm_cons (expand (init
, env
), inits
);
861 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
862 kw_canon
= scm_cons (scm_list_3 (k
, sym
, CAR (vars
)), kw_canon
);
863 env
= scm_acons (sym
, CAR (vars
), env
);
865 kw_canon
= scm_reverse_x (kw_canon
, SCM_UNDEFINED
);
866 kw
= scm_cons (allow_other_keys
, kw_canon
);
869 /* We should check for no duplicates, but given that psyntax does this
870 already, we can punt on it here... */
872 vars
= scm_reverse_x (vars
, SCM_UNDEFINED
);
873 inits
= scm_reverse_x (inits
, SCM_UNDEFINED
);
874 body
= expand_sequence (body
, env
);
876 return LAMBDA_CASE (SCM_BOOL_F
, req
, opt
, rest
, kw
, inits
, vars
, body
,
881 expand_lambda_star (SCM expr
, SCM env
)
883 return LAMBDA (scm_source_properties (expr
),
885 expand_lambda_star_case (CDR (expr
), SCM_BOOL_F
, env
));
889 expand_case_lambda_clauses (SCM expr
, SCM rest
, SCM env
)
893 if (scm_is_pair (rest
))
894 alt
= expand_case_lambda_clauses (CAR (rest
), CDR (rest
), env
);
898 return expand_lambda_case (expr
, alt
, env
);
902 expand_case_lambda (SCM expr
, SCM env
)
904 ASSERT_SYNTAX (scm_is_pair (CDR (expr
)), s_missing_expression
, expr
);
906 return LAMBDA (scm_source_properties (expr
),
908 expand_case_lambda_clauses (CADR (expr
), CDDR (expr
), env
));
912 expand_case_lambda_star_clauses (SCM expr
, SCM rest
, SCM env
)
916 if (scm_is_pair (rest
))
917 alt
= expand_case_lambda_star_clauses (CAR (rest
), CDR (rest
), env
);
921 return expand_lambda_star_case (expr
, alt
, env
);
925 expand_case_lambda_star (SCM expr
, SCM env
)
927 ASSERT_SYNTAX (scm_is_pair (CDR (expr
)), s_missing_expression
, expr
);
929 return LAMBDA (scm_source_properties (expr
),
931 expand_case_lambda_star_clauses (CADR (expr
), CDDR (expr
), env
));
934 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
936 check_bindings (const SCM bindings
, const SCM expr
)
940 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
941 s_bad_bindings
, bindings
, expr
);
943 binding_idx
= bindings
;
944 for (; !scm_is_null (binding_idx
); binding_idx
= CDR (binding_idx
))
946 SCM name
; /* const */
948 const SCM binding
= CAR (binding_idx
);
949 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
950 s_bad_binding
, binding
, expr
);
952 name
= CAR (binding
);
953 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
957 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
958 * transformed to the lists (vn .. v2 v1) and (i1 i2 ... in). If a duplicate
959 * variable name is detected, an error is signalled. */
961 transform_bindings (const SCM bindings
, const SCM expr
,
962 SCM
*const names
, SCM
*const vars
, SCM
*const initptr
)
964 SCM rnames
= SCM_EOL
;
966 SCM rinits
= SCM_EOL
;
967 SCM binding_idx
= bindings
;
968 for (; !scm_is_null (binding_idx
); binding_idx
= CDR (binding_idx
))
970 const SCM binding
= CAR (binding_idx
);
971 const SCM CDR_binding
= CDR (binding
);
972 const SCM name
= CAR (binding
);
973 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rnames
)),
974 s_duplicate_binding
, name
, expr
);
975 rnames
= scm_cons (name
, rnames
);
976 rvars
= scm_cons (scm_gensym (SCM_UNDEFINED
), rvars
);
977 rinits
= scm_cons (CAR (CDR_binding
), rinits
);
979 *names
= scm_reverse_x (rnames
, SCM_UNDEFINED
);
980 *vars
= scm_reverse_x (rvars
, SCM_UNDEFINED
);
981 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
984 /* FIXME: Remove named let in this boot expander. */
986 expand_named_let (const SCM expr
, SCM env
)
988 SCM var_names
, var_syms
, inits
;
992 const SCM cdr_expr
= CDR (expr
);
993 const SCM name
= CAR (cdr_expr
);
994 const SCM cddr_expr
= CDR (cdr_expr
);
995 const SCM bindings
= CAR (cddr_expr
);
996 check_bindings (bindings
, expr
);
998 transform_bindings (bindings
, expr
, &var_names
, &var_syms
, &inits
);
999 name_sym
= scm_gensym (SCM_UNDEFINED
);
1000 inner_env
= scm_acons (name
, name_sym
, env
);
1001 inner_env
= expand_env_extend (inner_env
, var_names
, var_syms
);
1004 (scm_source_properties (expr
), SCM_BOOL_F
,
1005 scm_list_1 (name
), scm_list_1 (name_sym
),
1006 scm_list_1 (LAMBDA (SCM_BOOL_F
,
1008 LAMBDA_CASE (SCM_BOOL_F
, var_names
, SCM_BOOL_F
, SCM_BOOL_F
,
1009 SCM_BOOL_F
, SCM_BOOL_F
, var_syms
,
1010 expand_sequence (CDDDR (expr
), inner_env
),
1013 LEXICAL_REF (SCM_BOOL_F
, name
, name_sym
),
1014 expand_exprs (inits
, env
)));
1018 expand_let (SCM expr
, SCM env
)
1022 const SCM cdr_expr
= CDR (expr
);
1023 const long length
= scm_ilength (cdr_expr
);
1024 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1025 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1027 bindings
= CAR (cdr_expr
);
1028 if (scm_is_symbol (bindings
))
1030 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1031 return expand_named_let (expr
, env
);
1034 check_bindings (bindings
, expr
);
1035 if (scm_is_null (bindings
))
1036 return expand_sequence (CDDR (expr
), env
);
1039 SCM var_names
, var_syms
, inits
;
1040 transform_bindings (bindings
, expr
, &var_names
, &var_syms
, &inits
);
1041 return LET (SCM_BOOL_F
,
1042 var_names
, var_syms
, expand_exprs (inits
, env
),
1043 expand_sequence (CDDR (expr
),
1044 expand_env_extend (env
, var_names
,
1050 expand_letrec_helper (SCM expr
, SCM env
, SCM in_order_p
)
1054 const SCM cdr_expr
= CDR (expr
);
1055 const long length
= scm_ilength (cdr_expr
);
1056 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1057 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1059 bindings
= CAR (cdr_expr
);
1060 check_bindings (bindings
, expr
);
1061 if (scm_is_null (bindings
))
1062 return expand_sequence (CDDR (expr
), env
);
1065 SCM var_names
, var_syms
, inits
;
1066 transform_bindings (bindings
, expr
, &var_names
, &var_syms
, &inits
);
1067 env
= expand_env_extend (env
, var_names
, var_syms
);
1068 return LETREC (SCM_BOOL_F
, in_order_p
,
1069 var_names
, var_syms
, expand_exprs (inits
, env
),
1070 expand_sequence (CDDR (expr
), env
));
1075 expand_letrec (SCM expr
, SCM env
)
1077 return expand_letrec_helper (expr
, env
, SCM_BOOL_F
);
1081 expand_letrec_star (SCM expr
, SCM env
)
1083 return expand_letrec_helper (expr
, env
, SCM_BOOL_T
);
1087 expand_letstar_clause (SCM bindings
, SCM body
, SCM env SCM_UNUSED
)
1089 if (scm_is_null (bindings
))
1090 return expand_sequence (body
, env
);
1093 SCM bind
, name
, sym
, init
;
1095 ASSERT_SYNTAX (scm_is_pair (bindings
), s_bad_expression
, bindings
);
1096 bind
= CAR (bindings
);
1097 ASSERT_SYNTAX (scm_ilength (bind
) == 2, s_bad_binding
, bind
);
1099 sym
= scm_gensym (SCM_UNDEFINED
);
1102 return LET (SCM_BOOL_F
, scm_list_1 (name
), scm_list_1 (sym
),
1103 scm_list_1 (expand (init
, env
)),
1104 expand_letstar_clause (CDR (bindings
), body
,
1105 scm_acons (name
, sym
, env
)));
1110 expand_letstar (SCM expr
, SCM env SCM_UNUSED
)
1112 const SCM cdr_expr
= CDR (expr
);
1113 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1114 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1116 return expand_letstar_clause (CADR (expr
), CDDR (expr
), env
);
1120 expand_or (SCM expr
, SCM env SCM_UNUSED
)
1122 SCM tail
= CDR (expr
);
1123 const long length
= scm_ilength (tail
);
1125 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1127 if (scm_is_null (CDR (expr
)))
1128 return CONST_ (SCM_BOOL_F
, SCM_BOOL_F
);
1131 SCM tmp
= scm_gensym (SCM_UNDEFINED
);
1132 return LET (SCM_BOOL_F
,
1133 scm_list_1 (tmp
), scm_list_1 (tmp
),
1134 scm_list_1 (expand (CADR (expr
), env
)),
1135 CONDITIONAL (SCM_BOOL_F
,
1136 LEXICAL_REF (SCM_BOOL_F
, tmp
, tmp
),
1137 LEXICAL_REF (SCM_BOOL_F
, tmp
, tmp
),
1138 expand_or (CDR (expr
),
1139 scm_acons (tmp
, tmp
, env
))));
1144 expand_quote (SCM expr
, SCM env SCM_UNUSED
)
1148 const SCM cdr_expr
= CDR (expr
);
1149 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1150 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1151 quotee
= CAR (cdr_expr
);
1152 return CONST_ (scm_source_properties (expr
), quotee
);
1156 expand_set_x (SCM expr
, SCM env
)
1161 const SCM cdr_expr
= CDR (expr
);
1162 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1163 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1164 variable
= CAR (cdr_expr
);
1165 vmem
= expand (variable
, env
);
1167 switch (SCM_EXPANDED_TYPE (vmem
))
1169 case SCM_EXPANDED_LEXICAL_REF
:
1170 return LEXICAL_SET (scm_source_properties (expr
),
1171 SCM_EXPANDED_REF (vmem
, LEXICAL_REF
, NAME
),
1172 SCM_EXPANDED_REF (vmem
, LEXICAL_REF
, GENSYM
),
1173 expand (CADDR (expr
), env
));
1174 case SCM_EXPANDED_TOPLEVEL_REF
:
1175 return TOPLEVEL_SET (scm_source_properties (expr
),
1176 SCM_EXPANDED_REF (vmem
, TOPLEVEL_REF
, NAME
),
1177 expand (CADDR (expr
), env
));
1178 case SCM_EXPANDED_MODULE_REF
:
1179 return MODULE_SET (scm_source_properties (expr
),
1180 SCM_EXPANDED_REF (vmem
, MODULE_REF
, MOD
),
1181 SCM_EXPANDED_REF (vmem
, MODULE_REF
, NAME
),
1182 SCM_EXPANDED_REF (vmem
, MODULE_REF
, PUBLIC
),
1183 expand (CADDR (expr
), env
));
1185 syntax_error (s_bad_variable
, variable
, expr
);
1192 /* This is the boot expander. It is later replaced with psyntax's sc-expand. */
1193 SCM_DEFINE (scm_macroexpand
, "macroexpand", 1, 0, 0,
1195 "Expand the expression @var{exp}.")
1196 #define FUNC_NAME s_scm_macroexpand
1198 return expand (exp
, scm_current_module ());
1202 SCM_DEFINE (scm_macroexpanded_p
, "macroexpanded?", 1, 0, 0,
1204 "Return @code{#t} if @var{exp} is an expanded expression.")
1205 #define FUNC_NAME s_scm_macroexpanded_p
1207 return scm_from_bool (SCM_EXPANDED_P (exp
));
1214 #define DEFINE_NAMES(type) \
1216 static const char *fields[] = SCM_EXPANDED_##type##_FIELD_NAMES; \
1217 exp_field_names[SCM_EXPANDED_##type] = fields; \
1218 exp_names[SCM_EXPANDED_##type] = SCM_EXPANDED_##type##_TYPE_NAME; \
1219 exp_nfields[SCM_EXPANDED_##type] = SCM_NUM_EXPANDED_##type##_FIELDS; \
1223 make_exp_vtable (size_t n
)
1225 SCM layout
, printer
, name
, code
, fields
;
1227 layout
= scm_string_to_symbol
1228 (scm_string_append (scm_make_list (scm_from_size_t (exp_nfields
[n
]),
1229 scm_from_locale_string ("pw"))));
1230 printer
= SCM_BOOL_F
;
1231 name
= scm_from_utf8_symbol (exp_names
[n
]);
1232 code
= scm_from_size_t (n
);
1235 size_t m
= exp_nfields
[n
];
1237 fields
= scm_cons (scm_from_utf8_symbol (exp_field_names
[n
][m
]), fields
);
1240 return scm_c_make_struct (scm_exp_vtable_vtable
, 0, 5,
1241 SCM_UNPACK (layout
), SCM_UNPACK (printer
), SCM_UNPACK (name
),
1242 SCM_UNPACK (code
), SCM_UNPACK (fields
));
1249 SCM exp_vtable_list
= SCM_EOL
;
1251 DEFINE_NAMES (VOID
);
1252 DEFINE_NAMES (CONST
);
1253 DEFINE_NAMES (PRIMITIVE_REF
);
1254 DEFINE_NAMES (LEXICAL_REF
);
1255 DEFINE_NAMES (LEXICAL_SET
);
1256 DEFINE_NAMES (MODULE_REF
);
1257 DEFINE_NAMES (MODULE_SET
);
1258 DEFINE_NAMES (TOPLEVEL_REF
);
1259 DEFINE_NAMES (TOPLEVEL_SET
);
1260 DEFINE_NAMES (TOPLEVEL_DEFINE
);
1261 DEFINE_NAMES (CONDITIONAL
);
1262 DEFINE_NAMES (CALL
);
1263 DEFINE_NAMES (PRIMCALL
);
1265 DEFINE_NAMES (LAMBDA
);
1266 DEFINE_NAMES (LAMBDA_CASE
);
1268 DEFINE_NAMES (LETREC
);
1269 DEFINE_NAMES (DYNLET
);
1271 scm_exp_vtable_vtable
=
1272 scm_make_vtable (scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT
"pwuwpw"),
1275 for (n
= 0; n
< SCM_NUM_EXPANDED_TYPES
; n
++)
1276 exp_vtables
[n
] = make_exp_vtable (n
);
1278 /* Now walk back down, consing in reverse. */
1280 exp_vtable_list
= scm_cons (exp_vtables
[n
], exp_vtable_list
);
1282 scm_c_define ("%expanded-vtables", scm_vector (exp_vtable_list
));
1284 #include "libguile/expand.x"