1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012,2013,2014
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 SCM const_unbound
;
49 static const char* exp_names
[SCM_NUM_EXPANDED_TYPES
];
50 static const char** exp_field_names
[SCM_NUM_EXPANDED_TYPES
];
53 /* The trailing underscores on these first to are to avoid spurious
54 conflicts with macros defined on MinGW. */
57 SCM_MAKE_EXPANDED_VOID(src)
58 #define CONST_(src, exp) \
59 SCM_MAKE_EXPANDED_CONST(src, exp)
60 #define PRIMITIVE_REF(src, name) \
61 SCM_MAKE_EXPANDED_PRIMITIVE_REF(src, name)
62 #define LEXICAL_REF(src, name, gensym) \
63 SCM_MAKE_EXPANDED_LEXICAL_REF(src, name, gensym)
64 #define LEXICAL_SET(src, name, gensym, exp) \
65 SCM_MAKE_EXPANDED_LEXICAL_SET(src, name, gensym, exp)
66 #define MODULE_REF(src, mod, name, public) \
67 SCM_MAKE_EXPANDED_MODULE_REF(src, mod, name, public)
68 #define MODULE_SET(src, mod, name, public, exp) \
69 SCM_MAKE_EXPANDED_MODULE_SET(src, mod, name, public, exp)
70 #define TOPLEVEL_REF(src, name) \
71 SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, name)
72 #define TOPLEVEL_SET(src, name, exp) \
73 SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, name, exp)
74 #define TOPLEVEL_DEFINE(src, name, exp) \
75 SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, name, exp)
76 #define CONDITIONAL(src, test, consequent, alternate) \
77 SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate)
78 #define PRIMCALL(src, name, exps) \
79 SCM_MAKE_EXPANDED_PRIMCALL(src, name, exps)
80 #define CALL(src, proc, exps) \
81 SCM_MAKE_EXPANDED_CALL(src, proc, exps)
82 #define SEQ(src, head, tail) \
83 SCM_MAKE_EXPANDED_SEQ(src, head, tail)
84 #define LAMBDA(src, meta, body) \
85 SCM_MAKE_EXPANDED_LAMBDA(src, meta, body)
86 #define LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate) \
87 SCM_MAKE_EXPANDED_LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate)
88 #define LET(src, names, gensyms, vals, body) \
89 SCM_MAKE_EXPANDED_LET(src, names, gensyms, vals, body)
90 #define LETREC(src, in_order_p, names, gensyms, vals, body) \
91 SCM_MAKE_EXPANDED_LETREC(src, in_order_p, names, gensyms, vals, body)
93 #define CAR(x) SCM_CAR(x)
94 #define CDR(x) SCM_CDR(x)
95 #define CAAR(x) SCM_CAAR(x)
96 #define CADR(x) SCM_CADR(x)
97 #define CDAR(x) SCM_CDAR(x)
98 #define CDDR(x) SCM_CDDR(x)
99 #define CADDR(x) SCM_CADDR(x)
100 #define CDDDR(x) SCM_CDDDR(x)
101 #define CADDDR(x) SCM_CADDDR(x)
103 /* Abbreviate SCM_EXPANDED_REF. */
104 #define REF(x,type,field) \
105 (scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field)))
108 static const char s_bad_expression
[] = "Bad expression";
109 static const char s_expression
[] = "Missing or extra expression in";
110 static const char s_missing_expression
[] = "Missing expression in";
111 static const char s_extra_expression
[] = "Extra expression in";
112 static const char s_empty_combination
[] = "Illegal empty combination";
113 static const char s_missing_body_expression
[] = "Missing body expression in";
114 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
115 static const char s_bad_define
[] = "Bad define placement";
116 static const char s_missing_clauses
[] = "Missing clauses";
117 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
118 static const char s_bad_case_clause
[] = "Bad case clause";
119 static const char s_bad_case_labels
[] = "Bad case labels";
120 static const char s_duplicate_case_label
[] = "Duplicate case label";
121 static const char s_bad_cond_clause
[] = "Bad cond clause";
122 static const char s_missing_recipient
[] = "Missing recipient in";
123 static const char s_bad_variable
[] = "Bad variable";
124 static const char s_bad_bindings
[] = "Bad bindings";
125 static const char s_bad_binding
[] = "Bad binding";
126 static const char s_duplicate_binding
[] = "Duplicate binding";
127 static const char s_bad_exit_clause
[] = "Bad exit clause";
128 static const char s_bad_formals
[] = "Bad formals";
129 static const char s_bad_formal
[] = "Bad formal";
130 static const char s_duplicate_formal
[] = "Duplicate formal";
131 static const char s_splicing
[] = "Non-list result for unquote-splicing";
132 static const char s_bad_slot_number
[] = "Bad slot number";
134 static void syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
136 SCM_SYMBOL (syntax_error_key
, "syntax-error");
138 /* Shortcut macros to simplify syntax error handling. */
139 #define ASSERT_SYNTAX(cond, message, form) \
140 { if (SCM_UNLIKELY (!(cond))) \
141 syntax_error (message, form, SCM_UNDEFINED); }
142 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
143 { if (SCM_UNLIKELY (!(cond))) \
144 syntax_error (message, form, expr); }
149 /* Primitive syntax. */
151 #define SCM_SYNTAX(STR, CFN) \
152 SCM_SNARF_HERE(static SCM CFN (SCM xorig, SCM env)) \
153 SCM_SNARF_INIT(scm_c_define (STR, scm_i_make_primitive_macro (STR, CFN)))
156 /* True primitive syntax */
157 SCM_SYNTAX ("@", expand_at
);
158 SCM_SYNTAX ("@@", expand_atat
);
159 SCM_SYNTAX ("begin", expand_begin
);
160 SCM_SYNTAX ("define", expand_define
);
161 SCM_SYNTAX ("eval-when", expand_eval_when
);
162 SCM_SYNTAX ("if", expand_if
);
163 SCM_SYNTAX ("lambda", expand_lambda
);
164 SCM_SYNTAX ("let", expand_let
);
165 SCM_SYNTAX ("quote", expand_quote
);
166 SCM_SYNTAX ("set!", expand_set_x
);
168 /* Convenient syntax during boot, expands to primitive syntax. Replaced after
170 SCM_SYNTAX ("and", expand_and
);
171 SCM_SYNTAX ("cond", expand_cond
);
172 SCM_SYNTAX ("letrec", expand_letrec
);
173 SCM_SYNTAX ("letrec*", expand_letrec_star
);
174 SCM_SYNTAX ("let*", expand_letstar
);
175 SCM_SYNTAX ("or", expand_or
);
176 SCM_SYNTAX ("lambda*", expand_lambda_star
);
177 SCM_SYNTAX ("case-lambda", expand_case_lambda
);
178 SCM_SYNTAX ("case-lambda*", expand_case_lambda_star
);
181 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
182 SCM_GLOBAL_SYMBOL (scm_sym_at
, "@");
183 SCM_GLOBAL_SYMBOL (scm_sym_atat
, "@@");
184 SCM_GLOBAL_SYMBOL (scm_sym_begin
, "begin");
185 SCM_GLOBAL_SYMBOL (scm_sym_case
, "case");
186 SCM_GLOBAL_SYMBOL (scm_sym_cond
, "cond");
187 SCM_GLOBAL_SYMBOL (scm_sym_define
, "define");
188 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
189 SCM_GLOBAL_SYMBOL (scm_sym_eval_when
, "eval-when");
190 SCM_GLOBAL_SYMBOL (scm_sym_if
, "if");
191 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, "lambda");
192 SCM_GLOBAL_SYMBOL (scm_sym_let
, "let");
193 SCM_GLOBAL_SYMBOL (scm_sym_letrec
, "letrec");
194 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, "let*");
195 SCM_GLOBAL_SYMBOL (scm_sym_or
, "or");
196 SCM_SYMBOL (sym_call_with_prompt
, "call-with-prompt");
197 SCM_GLOBAL_SYMBOL (scm_sym_quote
, "quote");
198 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, "set!");
199 SCM_SYMBOL (sym_lambda_star
, "lambda*");
200 SCM_SYMBOL (sym_eval
, "eval");
201 SCM_SYMBOL (sym_load
, "load");
202 SCM_SYMBOL (sym_primitive
, "primitive");
204 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
205 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, "quasiquote");
206 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
208 SCM_KEYWORD (kw_allow_other_keys
, "allow-other-keys");
209 SCM_KEYWORD (kw_optional
, "optional");
210 SCM_KEYWORD (kw_key
, "key");
211 SCM_KEYWORD (kw_rest
, "rest");
217 /* Signal a syntax error. We distinguish between the form that caused the
218 * error and the enclosing expression. The error message will print out as
219 * shown in the following pattern. The file name and line number are only
220 * given when they can be determined from the erroneous form or from the
221 * enclosing expression.
223 * <filename>: In procedure memoization:
224 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
227 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
229 SCM msg_string
= scm_from_locale_string (msg
);
230 SCM filename
= SCM_BOOL_F
;
231 SCM linenr
= SCM_BOOL_F
;
235 if (scm_is_pair (form
))
237 filename
= scm_source_property (form
, scm_sym_filename
);
238 linenr
= scm_source_property (form
, scm_sym_line
);
241 if (scm_is_false (filename
) && scm_is_false (linenr
) && scm_is_pair (expr
))
243 filename
= scm_source_property (expr
, scm_sym_filename
);
244 linenr
= scm_source_property (expr
, scm_sym_line
);
247 if (!SCM_UNBNDP (expr
))
249 if (scm_is_true (filename
))
251 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
252 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
254 else if (scm_is_true (linenr
))
256 format
= "In line ~S: ~A ~S in expression ~S.";
257 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
261 format
= "~A ~S in expression ~S.";
262 args
= scm_list_3 (msg_string
, form
, expr
);
267 if (scm_is_true (filename
))
269 format
= "In file ~S, line ~S: ~A ~S.";
270 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
272 else if (scm_is_true (linenr
))
274 format
= "In line ~S: ~A ~S.";
275 args
= scm_list_3 (linenr
, msg_string
, form
);
280 args
= scm_list_2 (msg_string
, form
);
284 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
292 expand_env_var_is_free (SCM env
, SCM x
)
294 for (; scm_is_pair (env
); env
= CDR (env
))
295 if (scm_is_eq (x
, CAAR (env
)))
296 return 0; /* bound */
301 expand_env_ref_macro (SCM env
, SCM x
)
304 if (!expand_env_var_is_free (env
, x
))
305 return SCM_BOOL_F
; /* lexical */
307 var
= scm_module_variable (scm_current_module (), x
);
308 if (scm_is_true (var
) && scm_is_true (scm_variable_bound_p (var
))
309 && scm_is_true (scm_macro_p (scm_variable_ref (var
))))
310 return scm_variable_ref (var
);
312 return SCM_BOOL_F
; /* anything else */
316 expand_env_lexical_gensym (SCM env
, SCM name
)
318 for (; scm_is_pair (env
); env
= CDR (env
))
319 if (scm_is_eq (name
, CAAR (env
)))
320 return CDAR (env
); /* bound */
321 return SCM_BOOL_F
; /* free */
325 expand_env_extend (SCM env
, SCM names
, SCM vars
)
327 while (scm_is_pair (names
))
329 env
= scm_acons (CAR (names
), CAR (vars
), env
);
337 expand (SCM exp
, SCM env
)
339 if (scm_is_pair (exp
))
342 scm_t_macro_primitive trans
= NULL
;
343 SCM macro
= SCM_BOOL_F
;
346 if (scm_is_symbol (car
))
347 macro
= expand_env_ref_macro (env
, car
);
349 if (scm_is_true (macro
))
350 trans
= scm_i_macro_primitive (macro
);
353 return trans (exp
, env
);
356 SCM arg_exps
= SCM_EOL
;
358 SCM proc
= expand (CAR (exp
), env
);
360 for (arg_exps
= CDR (exp
); scm_is_pair (arg_exps
);
361 arg_exps
= CDR (arg_exps
))
362 args
= scm_cons (expand (CAR (arg_exps
), env
), args
);
363 args
= scm_reverse_x (args
, SCM_UNDEFINED
);
365 if (!scm_is_null (arg_exps
))
366 syntax_error ("expected a proper list", exp
, SCM_UNDEFINED
);
368 if (SCM_EXPANDED_TYPE (proc
) == SCM_EXPANDED_PRIMITIVE_REF
)
369 return PRIMCALL (scm_source_properties (exp
),
370 SCM_EXPANDED_REF (proc
, PRIMITIVE_REF
, NAME
),
373 return CALL (scm_source_properties (exp
), proc
, args
);
376 else if (scm_is_symbol (exp
))
378 SCM gensym
= expand_env_lexical_gensym (env
, exp
);
379 if (scm_is_true (gensym
))
380 return LEXICAL_REF (SCM_BOOL_F
, exp
, gensym
);
382 return TOPLEVEL_REF (SCM_BOOL_F
, exp
);
385 return CONST_ (SCM_BOOL_F
, exp
);
389 expand_exprs (SCM forms
, const SCM env
)
393 for (; !scm_is_null (forms
); forms
= CDR (forms
))
394 ret
= scm_cons (expand (CAR (forms
), env
), ret
);
395 return scm_reverse_x (ret
, SCM_UNDEFINED
);
399 expand_sequence (const SCM forms
, const SCM env
)
401 ASSERT_SYNTAX (scm_ilength (forms
) >= 1, s_bad_expression
,
402 scm_cons (scm_sym_begin
, forms
));
403 if (scm_is_null (CDR (forms
)))
404 return expand (CAR (forms
), env
);
406 return SEQ (scm_source_properties (forms
),
407 expand (CAR (forms
), env
),
408 expand_sequence (CDR (forms
), env
));
416 expand_at (SCM expr
, SCM env SCM_UNUSED
)
418 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
419 ASSERT_SYNTAX (scm_ilength (CADR (expr
)) > 0, s_bad_expression
, expr
);
420 ASSERT_SYNTAX (scm_is_symbol (CADDR (expr
)), s_bad_expression
, expr
);
422 return MODULE_REF (scm_source_properties (expr
),
423 CADR (expr
), CADDR (expr
), SCM_BOOL_T
);
427 expand_atat (SCM expr
, SCM env SCM_UNUSED
)
429 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
430 ASSERT_SYNTAX (scm_is_symbol (CADDR (expr
)), s_bad_expression
, expr
);
432 if (scm_is_eq (CADR (expr
), sym_primitive
))
433 return PRIMITIVE_REF (scm_source_properties (expr
), CADDR (expr
));
435 ASSERT_SYNTAX (scm_ilength (CADR (expr
)) > 0, s_bad_expression
, expr
);
436 return MODULE_REF (scm_source_properties (expr
),
437 CADR (expr
), CADDR (expr
), SCM_BOOL_F
);
441 expand_and (SCM expr
, SCM env
)
443 const SCM cdr_expr
= CDR (expr
);
445 if (scm_is_null (cdr_expr
))
446 return CONST_ (SCM_BOOL_F
, SCM_BOOL_T
);
448 ASSERT_SYNTAX (scm_is_pair (cdr_expr
), s_bad_expression
, expr
);
450 if (scm_is_null (CDR (cdr_expr
)))
451 return expand (CAR (cdr_expr
), env
);
453 return CONDITIONAL (scm_source_properties (expr
),
454 expand (CAR (cdr_expr
), env
),
455 expand_and (cdr_expr
, env
),
456 CONST_ (SCM_BOOL_F
, SCM_BOOL_F
));
460 expand_begin (SCM expr
, SCM env
)
462 const SCM cdr_expr
= CDR (expr
);
463 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_bad_expression
, expr
);
464 return expand_sequence (cdr_expr
, env
);
468 expand_cond_clauses (SCM clause
, SCM rest
, int elp
, int alp
, SCM env
)
471 const long length
= scm_ilength (clause
);
472 ASSERT_SYNTAX (length
>= 1, s_bad_cond_clause
, clause
);
475 if (scm_is_eq (test
, scm_sym_else
) && elp
)
477 const int last_clause_p
= scm_is_null (rest
);
478 ASSERT_SYNTAX (length
>= 2, s_bad_cond_clause
, clause
);
479 ASSERT_SYNTAX (last_clause_p
, s_misplaced_else_clause
, clause
);
480 return expand_sequence (CDR (clause
), env
);
483 if (scm_is_null (rest
))
484 rest
= VOID_ (SCM_BOOL_F
);
486 rest
= expand_cond_clauses (CAR (rest
), CDR (rest
), elp
, alp
, env
);
489 && scm_is_eq (CADR (clause
), scm_sym_arrow
)
492 SCM tmp
= scm_gensym (scm_from_locale_string ("cond "));
493 SCM new_env
= scm_acons (tmp
, tmp
, env
);
494 ASSERT_SYNTAX (length
> 2, s_missing_recipient
, clause
);
495 ASSERT_SYNTAX (length
== 3, s_extra_expression
, clause
);
496 return LET (SCM_BOOL_F
,
499 scm_list_1 (expand (test
, env
)),
500 CONDITIONAL (SCM_BOOL_F
,
501 LEXICAL_REF (SCM_BOOL_F
, tmp
, tmp
),
503 expand (CADDR (clause
), new_env
),
504 scm_list_1 (LEXICAL_REF (SCM_BOOL_F
,
508 /* FIXME length == 1 case */
510 return CONDITIONAL (SCM_BOOL_F
,
512 expand_sequence (CDR (clause
), env
),
517 expand_cond (SCM expr
, SCM env
)
519 const int else_literal_p
= expand_env_var_is_free (env
, scm_sym_else
);
520 const int arrow_literal_p
= expand_env_var_is_free (env
, scm_sym_arrow
);
521 const SCM clauses
= CDR (expr
);
523 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
524 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
526 return expand_cond_clauses (CAR (clauses
), CDR (clauses
),
527 else_literal_p
, arrow_literal_p
, env
);
530 /* lone forward decl */
531 static SCM
expand_lambda (SCM expr
, SCM env
);
533 /* According to Section 5.2.1 of R5RS we first have to make sure that the
534 variable is bound, and then perform the `(set! variable expression)'
535 operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
536 bound. This means that EXPRESSION won't necessarily be able to assign
537 values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
539 expand_define (SCM expr
, SCM env
)
541 const SCM cdr_expr
= CDR (expr
);
545 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
546 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
547 ASSERT_SYNTAX (!scm_is_pair (env
), s_bad_define
, expr
);
549 body
= CDR (cdr_expr
);
550 variable
= CAR (cdr_expr
);
552 if (scm_is_pair (variable
))
554 ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable
)), s_bad_variable
, variable
, expr
);
555 return TOPLEVEL_DEFINE
556 (scm_source_properties (expr
),
558 expand_lambda (scm_cons (scm_sym_lambda
, scm_cons (CDR (variable
), body
)),
561 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
562 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
563 return TOPLEVEL_DEFINE (scm_source_properties (expr
), variable
,
564 expand (CAR (body
), env
));
568 expand_eval_when (SCM expr
, SCM env
)
570 ASSERT_SYNTAX (scm_ilength (expr
) >= 3, s_bad_expression
, expr
);
571 ASSERT_SYNTAX (scm_ilength (CADR (expr
)) > 0, s_bad_expression
, expr
);
573 if (scm_is_true (scm_memq (sym_eval
, CADR (expr
)))
574 || scm_is_true (scm_memq (sym_load
, CADR (expr
))))
575 return expand_sequence (CDDR (expr
), env
);
577 return VOID_ (scm_source_properties (expr
));
581 expand_if (SCM expr
, SCM env SCM_UNUSED
)
583 const SCM cdr_expr
= CDR (expr
);
584 const long length
= scm_ilength (cdr_expr
);
585 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
586 return CONDITIONAL (scm_source_properties (expr
),
587 expand (CADR (expr
), env
),
588 expand (CADDR (expr
), env
),
590 ? expand (CADDDR (expr
), env
)
591 : VOID_ (SCM_BOOL_F
)));
594 /* A helper function for expand_lambda to support checking for duplicate
595 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
596 * LIST or to the CDR of the last cons. Therefore, LIST may have any of the
597 * forms that a formal argument can have:
598 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
600 c_improper_memq (SCM obj
, SCM list
)
602 for (; scm_is_pair (list
); list
= CDR (list
))
604 if (scm_is_eq (CAR (list
), obj
))
607 return scm_is_eq (list
, obj
);
611 expand_lambda_case (SCM clause
, SCM alternate
, SCM env
)
620 ASSERT_SYNTAX (scm_is_pair (clause
) && scm_is_pair (CDR (clause
)),
621 s_bad_expression
, scm_cons (scm_sym_lambda
, clause
));
623 /* Before iterating the list of formal arguments, make sure the formals
624 * actually are given as either a symbol or a non-cyclic list. */
625 formals
= CAR (clause
);
626 if (scm_is_pair (formals
))
628 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
629 * detected, report a 'Bad formals' error. */
632 ASSERT_SYNTAX_2 (scm_is_symbol (formals
) || scm_is_null (formals
),
633 s_bad_formals
, formals
, scm_cons (scm_sym_lambda
, clause
));
635 /* Now iterate the list of formal arguments to check if all formals are
636 * symbols, and that there are no duplicates. */
637 while (scm_is_pair (formals
))
639 const SCM formal
= CAR (formals
);
640 formals
= CDR (formals
);
641 ASSERT_SYNTAX_2 (scm_is_symbol (formal
), s_bad_formal
, formal
,
642 scm_cons (scm_sym_lambda
, clause
));
643 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, formals
), s_duplicate_formal
,
644 formal
, scm_cons (scm_sym_lambda
, clause
));
646 req
= scm_cons (formal
, req
);
647 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
648 env
= scm_acons (formal
, CAR (vars
), env
);
651 ASSERT_SYNTAX_2 (scm_is_null (formals
) || scm_is_symbol (formals
),
652 s_bad_formal
, formals
, scm_cons (scm_sym_lambda
, clause
));
653 if (scm_is_symbol (formals
))
656 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
657 env
= scm_acons (rest
, CAR (vars
), env
);
662 body
= expand_sequence (CDR (clause
), env
);
663 req
= scm_reverse_x (req
, SCM_UNDEFINED
);
664 vars
= scm_reverse_x (vars
, SCM_UNDEFINED
);
666 if (scm_is_true (alternate
) && !(SCM_EXPANDED_P (alternate
) && SCM_EXPANDED_TYPE (alternate
) == SCM_EXPANDED_LAMBDA_CASE
))
669 return LAMBDA_CASE (SCM_BOOL_F
, req
, SCM_BOOL_F
, rest
, SCM_BOOL_F
,
670 SCM_EOL
, vars
, body
, alternate
);
674 expand_lambda (SCM expr
, SCM env
)
676 return LAMBDA (scm_source_properties (expr
),
678 expand_lambda_case (CDR (expr
), SCM_BOOL_F
, env
));
682 expand_lambda_star_case (SCM clause
, SCM alternate
, SCM env
)
684 SCM req
, opt
, kw
, allow_other_keys
, rest
, formals
, vars
, body
, tmp
;
688 const long length
= scm_ilength (clause
);
689 ASSERT_SYNTAX (length
>= 1, s_bad_expression
,
690 scm_cons (sym_lambda_star
, clause
));
691 ASSERT_SYNTAX (length
>= 2, s_missing_expression
,
692 scm_cons (sym_lambda_star
, clause
));
694 formals
= CAR (clause
);
698 req
= opt
= kw
= SCM_EOL
;
699 rest
= allow_other_keys
= SCM_BOOL_F
;
701 while (scm_is_pair (formals
) && scm_is_symbol (CAR (formals
)))
704 req
= scm_cons (CAR (formals
), req
);
705 formals
= scm_cdr (formals
);
708 if (scm_is_pair (formals
) && scm_is_eq (CAR (formals
), kw_optional
))
710 formals
= CDR (formals
);
711 while (scm_is_pair (formals
)
712 && (scm_is_symbol (CAR (formals
)) || scm_is_pair (CAR (formals
))))
715 opt
= scm_cons (CAR (formals
), opt
);
716 formals
= scm_cdr (formals
);
720 if (scm_is_pair (formals
) && scm_is_eq (CAR (formals
), kw_key
))
722 formals
= CDR (formals
);
723 while (scm_is_pair (formals
)
724 && (scm_is_symbol (CAR (formals
)) || scm_is_pair (CAR (formals
))))
726 kw
= scm_cons (CAR (formals
), kw
);
727 formals
= scm_cdr (formals
);
731 if (scm_is_pair (formals
) && scm_is_eq (CAR (formals
), kw_allow_other_keys
))
733 formals
= CDR (formals
);
734 allow_other_keys
= SCM_BOOL_T
;
737 if (scm_is_pair (formals
) && scm_is_eq (CAR (formals
), kw_rest
))
739 ASSERT_SYNTAX (scm_ilength (formals
) == 2, s_bad_formals
,
741 rest
= CADR (formals
);
743 else if (scm_is_symbol (formals
))
747 ASSERT_SYNTAX (scm_is_null (formals
), s_bad_formals
, CAR (clause
));
751 /* Now, iterate through them a second time, building up an expansion-time
752 environment, checking, expanding and canonicalizing the opt/kw init forms,
753 and eventually memoizing the body as well. Note that the rest argument, if
754 any, is expanded before keyword args, thus necessitating the second
757 Also note that the specific environment during expansion of init
758 expressions here needs to coincide with the environment when psyntax
759 expands. A lot of effort for something that is only used in the bootstrap
760 expandr, you say? Yes. Yes it is.
764 req
= scm_reverse_x (req
, SCM_EOL
);
765 for (tmp
= req
; scm_is_pair (tmp
); tmp
= scm_cdr (tmp
))
767 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
768 env
= scm_acons (CAR (tmp
), CAR (vars
), env
);
771 /* Build up opt inits and env */
773 opt
= scm_reverse_x (opt
, SCM_EOL
);
774 for (tmp
= opt
; scm_is_pair (tmp
); tmp
= scm_cdr (tmp
))
777 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
778 env
= scm_acons (x
, CAR (vars
), env
);
779 if (scm_is_symbol (x
))
780 inits
= scm_cons (CONST_ (SCM_BOOL_F
, SCM_BOOL_F
), inits
);
783 ASSERT_SYNTAX (scm_ilength (x
) == 2 && scm_is_symbol (CAR (x
)),
784 s_bad_formals
, CAR (clause
));
785 inits
= scm_cons (expand (CADR (x
), env
), inits
);
787 env
= scm_acons (scm_is_symbol (x
) ? x
: CAR (x
), CAR (vars
), env
);
789 if (scm_is_null (opt
))
792 /* Process rest before keyword args */
793 if (scm_is_true (rest
))
795 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
796 env
= scm_acons (rest
, CAR (vars
), env
);
799 /* Build up kw inits, env, and kw-canon list */
800 if (scm_is_null (kw
))
804 SCM kw_canon
= SCM_EOL
;
805 kw
= scm_reverse_x (kw
, SCM_UNDEFINED
);
806 for (tmp
= kw
; scm_is_pair (tmp
); tmp
= scm_cdr (tmp
))
810 if (scm_is_symbol (x
))
814 k
= scm_symbol_to_keyword (sym
);
816 else if (scm_ilength (x
) == 2 && scm_is_symbol (CAR (x
)))
820 k
= scm_symbol_to_keyword (sym
);
822 else if (scm_ilength (x
) == 3 && scm_is_symbol (CAR (x
))
823 && scm_is_keyword (CADDR (x
)))
830 syntax_error (s_bad_formals
, CAR (clause
), SCM_UNDEFINED
);
832 inits
= scm_cons (expand (init
, env
), inits
);
833 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
834 kw_canon
= scm_cons (scm_list_3 (k
, sym
, CAR (vars
)), kw_canon
);
835 env
= scm_acons (sym
, CAR (vars
), env
);
837 kw_canon
= scm_reverse_x (kw_canon
, SCM_UNDEFINED
);
838 kw
= scm_cons (allow_other_keys
, kw_canon
);
841 /* We should check for no duplicates, but given that psyntax does this
842 already, we can punt on it here... */
844 vars
= scm_reverse_x (vars
, SCM_UNDEFINED
);
845 inits
= scm_reverse_x (inits
, SCM_UNDEFINED
);
846 body
= expand_sequence (body
, env
);
848 return LAMBDA_CASE (SCM_BOOL_F
, req
, opt
, rest
, kw
, inits
, vars
, body
,
853 expand_lambda_star (SCM expr
, SCM env
)
855 return LAMBDA (scm_source_properties (expr
),
857 expand_lambda_star_case (CDR (expr
), SCM_BOOL_F
, env
));
861 expand_case_lambda_clauses (SCM expr
, SCM rest
, SCM env
)
865 if (scm_is_pair (rest
))
866 alt
= expand_case_lambda_clauses (CAR (rest
), CDR (rest
), env
);
870 return expand_lambda_case (expr
, alt
, env
);
874 expand_case_lambda (SCM expr
, SCM env
)
876 ASSERT_SYNTAX (scm_is_pair (CDR (expr
)), s_missing_expression
, expr
);
878 return LAMBDA (scm_source_properties (expr
),
880 expand_case_lambda_clauses (CADR (expr
), CDDR (expr
), env
));
884 expand_case_lambda_star_clauses (SCM expr
, SCM rest
, SCM env
)
888 if (scm_is_pair (rest
))
889 alt
= expand_case_lambda_star_clauses (CAR (rest
), CDR (rest
), env
);
893 return expand_lambda_star_case (expr
, alt
, env
);
897 expand_case_lambda_star (SCM expr
, SCM env
)
899 ASSERT_SYNTAX (scm_is_pair (CDR (expr
)), s_missing_expression
, expr
);
901 return LAMBDA (scm_source_properties (expr
),
903 expand_case_lambda_star_clauses (CADR (expr
), CDDR (expr
), env
));
906 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
908 check_bindings (const SCM bindings
, const SCM expr
)
912 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
913 s_bad_bindings
, bindings
, expr
);
915 binding_idx
= bindings
;
916 for (; !scm_is_null (binding_idx
); binding_idx
= CDR (binding_idx
))
918 SCM name
; /* const */
920 const SCM binding
= CAR (binding_idx
);
921 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
922 s_bad_binding
, binding
, expr
);
924 name
= CAR (binding
);
925 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
929 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
930 * transformed to the lists (vn .. v2 v1) and (i1 i2 ... in). If a duplicate
931 * variable name is detected, an error is signalled. */
933 transform_bindings (const SCM bindings
, const SCM expr
,
934 SCM
*const names
, SCM
*const vars
, SCM
*const initptr
)
936 SCM rnames
= SCM_EOL
;
938 SCM rinits
= SCM_EOL
;
939 SCM binding_idx
= bindings
;
940 for (; !scm_is_null (binding_idx
); binding_idx
= CDR (binding_idx
))
942 const SCM binding
= CAR (binding_idx
);
943 const SCM CDR_binding
= CDR (binding
);
944 const SCM name
= CAR (binding
);
945 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rnames
)),
946 s_duplicate_binding
, name
, expr
);
947 rnames
= scm_cons (name
, rnames
);
948 rvars
= scm_cons (scm_gensym (SCM_UNDEFINED
), rvars
);
949 rinits
= scm_cons (CAR (CDR_binding
), rinits
);
951 *names
= scm_reverse_x (rnames
, SCM_UNDEFINED
);
952 *vars
= scm_reverse_x (rvars
, SCM_UNDEFINED
);
953 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
956 /* FIXME: Remove named let in this boot expander. */
958 expand_named_let (const SCM expr
, SCM env
)
960 SCM var_names
, var_syms
, inits
;
964 const SCM cdr_expr
= CDR (expr
);
965 const SCM name
= CAR (cdr_expr
);
966 const SCM cddr_expr
= CDR (cdr_expr
);
967 const SCM bindings
= CAR (cddr_expr
);
968 check_bindings (bindings
, expr
);
970 transform_bindings (bindings
, expr
, &var_names
, &var_syms
, &inits
);
971 name_sym
= scm_gensym (SCM_UNDEFINED
);
972 inner_env
= scm_acons (name
, name_sym
, env
);
973 inner_env
= expand_env_extend (inner_env
, var_names
, var_syms
);
976 (scm_source_properties (expr
), SCM_BOOL_F
,
977 scm_list_1 (name
), scm_list_1 (name_sym
),
978 scm_list_1 (LAMBDA (SCM_BOOL_F
,
980 LAMBDA_CASE (SCM_BOOL_F
, var_names
, SCM_BOOL_F
, SCM_BOOL_F
,
981 SCM_BOOL_F
, SCM_BOOL_F
, var_syms
,
982 expand_sequence (CDDDR (expr
), inner_env
),
985 LEXICAL_REF (SCM_BOOL_F
, name
, name_sym
),
986 expand_exprs (inits
, env
)));
990 expand_let (SCM expr
, SCM env
)
994 const SCM cdr_expr
= CDR (expr
);
995 const long length
= scm_ilength (cdr_expr
);
996 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
997 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
999 bindings
= CAR (cdr_expr
);
1000 if (scm_is_symbol (bindings
))
1002 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1003 return expand_named_let (expr
, env
);
1006 check_bindings (bindings
, expr
);
1007 if (scm_is_null (bindings
))
1008 return expand_sequence (CDDR (expr
), env
);
1011 SCM var_names
, var_syms
, inits
;
1012 transform_bindings (bindings
, expr
, &var_names
, &var_syms
, &inits
);
1013 return LET (SCM_BOOL_F
,
1014 var_names
, var_syms
, expand_exprs (inits
, env
),
1015 expand_sequence (CDDR (expr
),
1016 expand_env_extend (env
, var_names
,
1022 expand_letrec_helper (SCM expr
, SCM env
, SCM in_order_p
)
1026 const SCM cdr_expr
= CDR (expr
);
1027 const long length
= scm_ilength (cdr_expr
);
1028 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1029 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1031 bindings
= CAR (cdr_expr
);
1032 check_bindings (bindings
, expr
);
1033 if (scm_is_null (bindings
))
1034 return expand_sequence (CDDR (expr
), env
);
1037 SCM var_names
, var_syms
, inits
;
1038 transform_bindings (bindings
, expr
, &var_names
, &var_syms
, &inits
);
1039 env
= expand_env_extend (env
, var_names
, var_syms
);
1040 return LETREC (SCM_BOOL_F
, in_order_p
,
1041 var_names
, var_syms
, expand_exprs (inits
, env
),
1042 expand_sequence (CDDR (expr
), env
));
1047 expand_letrec (SCM expr
, SCM env
)
1049 return expand_letrec_helper (expr
, env
, SCM_BOOL_F
);
1053 expand_letrec_star (SCM expr
, SCM env
)
1055 return expand_letrec_helper (expr
, env
, SCM_BOOL_T
);
1059 expand_letstar_clause (SCM bindings
, SCM body
, SCM env SCM_UNUSED
)
1061 if (scm_is_null (bindings
))
1062 return expand_sequence (body
, env
);
1065 SCM bind
, name
, sym
, init
;
1067 ASSERT_SYNTAX (scm_is_pair (bindings
), s_bad_expression
, bindings
);
1068 bind
= CAR (bindings
);
1069 ASSERT_SYNTAX (scm_ilength (bind
) == 2, s_bad_binding
, bind
);
1071 sym
= scm_gensym (SCM_UNDEFINED
);
1074 return LET (SCM_BOOL_F
, scm_list_1 (name
), scm_list_1 (sym
),
1075 scm_list_1 (expand (init
, env
)),
1076 expand_letstar_clause (CDR (bindings
), body
,
1077 scm_acons (name
, sym
, env
)));
1082 expand_letstar (SCM expr
, SCM env SCM_UNUSED
)
1084 const SCM cdr_expr
= CDR (expr
);
1085 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1086 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1088 return expand_letstar_clause (CADR (expr
), CDDR (expr
), env
);
1092 expand_or (SCM expr
, SCM env SCM_UNUSED
)
1094 SCM tail
= CDR (expr
);
1095 const long length
= scm_ilength (tail
);
1097 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1099 if (scm_is_null (CDR (expr
)))
1100 return CONST_ (SCM_BOOL_F
, SCM_BOOL_F
);
1103 SCM tmp
= scm_gensym (SCM_UNDEFINED
);
1104 return LET (SCM_BOOL_F
,
1105 scm_list_1 (tmp
), scm_list_1 (tmp
),
1106 scm_list_1 (expand (CADR (expr
), env
)),
1107 CONDITIONAL (SCM_BOOL_F
,
1108 LEXICAL_REF (SCM_BOOL_F
, tmp
, tmp
),
1109 LEXICAL_REF (SCM_BOOL_F
, tmp
, tmp
),
1110 expand_or (CDR (expr
),
1111 scm_acons (tmp
, tmp
, env
))));
1116 expand_quote (SCM expr
, SCM env SCM_UNUSED
)
1120 const SCM cdr_expr
= CDR (expr
);
1121 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1122 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1123 quotee
= CAR (cdr_expr
);
1124 return CONST_ (scm_source_properties (expr
), quotee
);
1128 expand_set_x (SCM expr
, SCM env
)
1133 const SCM cdr_expr
= CDR (expr
);
1134 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1135 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1136 variable
= CAR (cdr_expr
);
1137 vmem
= expand (variable
, env
);
1139 switch (SCM_EXPANDED_TYPE (vmem
))
1141 case SCM_EXPANDED_LEXICAL_REF
:
1142 return LEXICAL_SET (scm_source_properties (expr
),
1143 SCM_EXPANDED_REF (vmem
, LEXICAL_REF
, NAME
),
1144 SCM_EXPANDED_REF (vmem
, LEXICAL_REF
, GENSYM
),
1145 expand (CADDR (expr
), env
));
1146 case SCM_EXPANDED_TOPLEVEL_REF
:
1147 return TOPLEVEL_SET (scm_source_properties (expr
),
1148 SCM_EXPANDED_REF (vmem
, TOPLEVEL_REF
, NAME
),
1149 expand (CADDR (expr
), env
));
1150 case SCM_EXPANDED_MODULE_REF
:
1151 return MODULE_SET (scm_source_properties (expr
),
1152 SCM_EXPANDED_REF (vmem
, MODULE_REF
, MOD
),
1153 SCM_EXPANDED_REF (vmem
, MODULE_REF
, NAME
),
1154 SCM_EXPANDED_REF (vmem
, MODULE_REF
, PUBLIC
),
1155 expand (CADDR (expr
), env
));
1157 syntax_error (s_bad_variable
, variable
, expr
);
1164 /* This is the boot expander. It is later replaced with psyntax's sc-expand. */
1165 SCM_DEFINE (scm_macroexpand
, "macroexpand", 1, 0, 0,
1167 "Expand the expression @var{exp}.")
1168 #define FUNC_NAME s_scm_macroexpand
1170 return expand (exp
, scm_current_module ());
1174 SCM_DEFINE (scm_macroexpanded_p
, "macroexpanded?", 1, 0, 0,
1176 "Return @code{#t} if @var{exp} is an expanded expression.")
1177 #define FUNC_NAME s_scm_macroexpanded_p
1179 return scm_from_bool (SCM_EXPANDED_P (exp
));
1187 compute_assigned (SCM exp
, SCM assigned
)
1189 if (scm_is_null (exp
) || scm_is_false (exp
))
1192 if (scm_is_pair (exp
))
1194 compute_assigned (CAR (exp
), assigned
);
1195 compute_assigned (CDR (exp
), assigned
);
1199 if (!SCM_EXPANDED_P (exp
))
1202 switch (SCM_EXPANDED_TYPE (exp
))
1204 case SCM_EXPANDED_VOID
:
1205 case SCM_EXPANDED_CONST
:
1206 case SCM_EXPANDED_PRIMITIVE_REF
:
1207 case SCM_EXPANDED_LEXICAL_REF
:
1208 case SCM_EXPANDED_MODULE_REF
:
1209 case SCM_EXPANDED_TOPLEVEL_REF
:
1212 case SCM_EXPANDED_LEXICAL_SET
:
1213 scm_hashq_set_x (assigned
, REF (exp
, LEXICAL_SET
, GENSYM
), SCM_BOOL_T
);
1214 compute_assigned (REF (exp
, LEXICAL_SET
, EXP
), assigned
);
1217 case SCM_EXPANDED_MODULE_SET
:
1218 compute_assigned (REF (exp
, MODULE_SET
, EXP
), assigned
);
1221 case SCM_EXPANDED_TOPLEVEL_SET
:
1222 compute_assigned (REF (exp
, TOPLEVEL_SET
, EXP
), assigned
);
1225 case SCM_EXPANDED_TOPLEVEL_DEFINE
:
1226 compute_assigned (REF (exp
, TOPLEVEL_DEFINE
, EXP
), assigned
);
1229 case SCM_EXPANDED_CONDITIONAL
:
1230 compute_assigned (REF (exp
, CONDITIONAL
, TEST
), assigned
);
1231 compute_assigned (REF (exp
, CONDITIONAL
, CONSEQUENT
), assigned
);
1232 compute_assigned (REF (exp
, CONDITIONAL
, ALTERNATE
), assigned
);
1235 case SCM_EXPANDED_CALL
:
1236 compute_assigned (REF (exp
, CALL
, PROC
), assigned
);
1237 compute_assigned (REF (exp
, CALL
, ARGS
), assigned
);
1240 case SCM_EXPANDED_PRIMCALL
:
1241 compute_assigned (REF (exp
, PRIMCALL
, ARGS
), assigned
);
1244 case SCM_EXPANDED_SEQ
:
1245 compute_assigned (REF (exp
, SEQ
, HEAD
), assigned
);
1246 compute_assigned (REF (exp
, SEQ
, TAIL
), assigned
);
1249 case SCM_EXPANDED_LAMBDA
:
1250 compute_assigned (REF (exp
, LAMBDA
, BODY
), assigned
);
1253 case SCM_EXPANDED_LAMBDA_CASE
:
1254 compute_assigned (REF (exp
, LAMBDA_CASE
, INITS
), assigned
);
1255 compute_assigned (REF (exp
, LAMBDA_CASE
, BODY
), assigned
);
1256 compute_assigned (REF (exp
, LAMBDA_CASE
, ALTERNATE
), assigned
);
1259 case SCM_EXPANDED_LET
:
1260 compute_assigned (REF (exp
, LET
, VALS
), assigned
);
1261 compute_assigned (REF (exp
, LET
, BODY
), assigned
);
1264 case SCM_EXPANDED_LETREC
:
1266 SCM syms
= REF (exp
, LETREC
, GENSYMS
);
1267 /* We lower letrec in this same pass, so mark these variables as
1269 for (; scm_is_pair (syms
); syms
= CDR (syms
))
1270 scm_hashq_set_x (assigned
, CAR (syms
), SCM_BOOL_T
);
1272 compute_assigned (REF (exp
, LETREC
, VALS
), assigned
);
1273 compute_assigned (REF (exp
, LETREC
, BODY
), assigned
);
1284 return PRIMCALL (SCM_BOOL_F
, scm_from_latin1_symbol ("make-variable"),
1289 box_lexical (SCM name
, SCM sym
)
1291 return LEXICAL_SET (SCM_BOOL_F
, name
, sym
,
1292 box_value (LEXICAL_REF (SCM_BOOL_F
, name
, sym
)));
1296 init_if_unbound (SCM src
, SCM name
, SCM sym
, SCM init
)
1298 return CONDITIONAL (src
,
1300 scm_from_latin1_symbol ("eq?"),
1301 scm_list_2 (LEXICAL_REF (src
, name
, sym
),
1303 LEXICAL_SET (src
, name
, sym
, init
),
1308 init_boxes (SCM names
, SCM syms
, SCM vals
, SCM body
)
1310 if (scm_is_null (names
)) return body
;
1312 return SEQ (SCM_BOOL_F
,
1315 scm_from_latin1_symbol ("variable-set!"),
1316 scm_list_2 (LEXICAL_REF (SCM_BOOL_F
, CAR (names
), CAR (syms
)),
1318 init_boxes (CDR (names
), CDR (syms
), CDR (vals
), body
));
1322 convert_assignment (SCM exp
, SCM assigned
)
1324 if (scm_is_null (exp
) || scm_is_false (exp
))
1327 if (scm_is_pair (exp
))
1328 return scm_cons (convert_assignment (CAR (exp
), assigned
),
1329 convert_assignment (CDR (exp
), assigned
));
1331 if (!SCM_EXPANDED_P (exp
))
1334 switch (SCM_EXPANDED_TYPE (exp
))
1336 case SCM_EXPANDED_VOID
:
1337 case SCM_EXPANDED_CONST
:
1338 case SCM_EXPANDED_PRIMITIVE_REF
:
1339 case SCM_EXPANDED_MODULE_REF
:
1340 case SCM_EXPANDED_TOPLEVEL_REF
:
1343 case SCM_EXPANDED_LEXICAL_REF
:
1345 SCM sym
= REF (exp
, LEXICAL_REF
, GENSYM
);
1347 if (scm_is_true (scm_hashq_ref (assigned
, sym
, SCM_BOOL_F
)))
1349 (REF (exp
, LEXICAL_REF
, SRC
),
1350 scm_from_latin1_symbol ("variable-ref"),
1355 case SCM_EXPANDED_LEXICAL_SET
:
1357 (REF (exp
, LEXICAL_SET
, SRC
),
1358 scm_from_latin1_symbol ("variable-set!"),
1359 scm_list_2 (LEXICAL_REF (REF (exp
, LEXICAL_SET
, SRC
),
1360 REF (exp
, LEXICAL_SET
, NAME
),
1361 REF (exp
, LEXICAL_SET
, GENSYM
)),
1362 convert_assignment (REF (exp
, LEXICAL_SET
, EXP
),
1365 case SCM_EXPANDED_MODULE_SET
:
1367 (REF (exp
, MODULE_SET
, SRC
),
1368 REF (exp
, MODULE_SET
, MOD
),
1369 REF (exp
, MODULE_SET
, NAME
),
1370 REF (exp
, MODULE_SET
, PUBLIC
),
1371 convert_assignment (REF (exp
, MODULE_SET
, EXP
), assigned
));
1373 case SCM_EXPANDED_TOPLEVEL_SET
:
1375 (REF (exp
, TOPLEVEL_SET
, SRC
),
1376 REF (exp
, TOPLEVEL_SET
, NAME
),
1377 convert_assignment (REF (exp
, TOPLEVEL_SET
, EXP
), assigned
));
1379 case SCM_EXPANDED_TOPLEVEL_DEFINE
:
1380 return TOPLEVEL_DEFINE
1381 (REF (exp
, TOPLEVEL_DEFINE
, SRC
),
1382 REF (exp
, TOPLEVEL_DEFINE
, NAME
),
1383 convert_assignment (REF (exp
, TOPLEVEL_DEFINE
, EXP
),
1386 case SCM_EXPANDED_CONDITIONAL
:
1388 (REF (exp
, CONDITIONAL
, SRC
),
1389 convert_assignment (REF (exp
, CONDITIONAL
, TEST
), assigned
),
1390 convert_assignment (REF (exp
, CONDITIONAL
, CONSEQUENT
), assigned
),
1391 convert_assignment (REF (exp
, CONDITIONAL
, ALTERNATE
), assigned
));
1393 case SCM_EXPANDED_CALL
:
1395 (REF (exp
, CALL
, SRC
),
1396 convert_assignment (REF (exp
, CALL
, PROC
), assigned
),
1397 convert_assignment (REF (exp
, CALL
, ARGS
), assigned
));
1399 case SCM_EXPANDED_PRIMCALL
:
1401 (REF (exp
, PRIMCALL
, SRC
),
1402 REF (exp
, PRIMCALL
, NAME
),
1403 convert_assignment (REF (exp
, PRIMCALL
, ARGS
), assigned
));
1405 case SCM_EXPANDED_SEQ
:
1407 (REF (exp
, SEQ
, SRC
),
1408 convert_assignment (REF (exp
, SEQ
, HEAD
), assigned
),
1409 convert_assignment (REF (exp
, SEQ
, TAIL
), assigned
));
1411 case SCM_EXPANDED_LAMBDA
:
1413 (REF (exp
, LAMBDA
, SRC
),
1414 REF (exp
, LAMBDA
, META
),
1415 convert_assignment (REF (exp
, LAMBDA
, BODY
), assigned
));
1417 case SCM_EXPANDED_LAMBDA_CASE
:
1419 SCM src
, req
, opt
, rest
, kw
, inits
, syms
, body
, alt
;
1420 SCM namewalk
, symwalk
, new_inits
, seq
;
1422 /* Box assigned formals. Since initializers can capture
1423 previous formals, we convert initializers to be in the body
1424 instead of in the "header". */
1426 src
= REF (exp
, LAMBDA_CASE
, SRC
);
1427 req
= REF (exp
, LAMBDA_CASE
, REQ
);
1428 opt
= REF (exp
, LAMBDA_CASE
, OPT
);
1429 rest
= REF (exp
, LAMBDA_CASE
, REST
);
1430 kw
= REF (exp
, LAMBDA_CASE
, KW
);
1431 inits
= convert_assignment (REF (exp
, LAMBDA_CASE
, INITS
), assigned
);
1432 syms
= REF (exp
, LAMBDA_CASE
, GENSYMS
);
1433 body
= convert_assignment (REF (exp
, LAMBDA_CASE
, BODY
), assigned
);
1434 alt
= convert_assignment (REF (exp
, LAMBDA_CASE
, ALTERNATE
), assigned
);
1436 new_inits
= scm_make_list (scm_length (inits
), const_unbound
);
1438 seq
= SCM_EOL
, symwalk
= syms
;
1440 /* Required arguments may need boxing. */
1441 for (namewalk
= req
;
1442 scm_is_pair (namewalk
);
1443 namewalk
= CDR (namewalk
), symwalk
= CDR (symwalk
))
1445 SCM name
= CAR (namewalk
), sym
= CAR (symwalk
);
1446 if (scm_is_true (scm_hashq_ref (assigned
, sym
, SCM_BOOL_F
)))
1447 seq
= scm_cons (box_lexical (name
, sym
), seq
);
1449 /* Optional arguments may need initialization and/or boxing. */
1450 for (namewalk
= opt
;
1451 scm_is_pair (namewalk
);
1452 namewalk
= CDR (namewalk
), symwalk
= CDR (symwalk
),
1453 inits
= CDR (inits
))
1455 SCM name
= CAR (namewalk
), sym
= CAR (symwalk
), init
= CAR (inits
);
1456 seq
= scm_cons (init_if_unbound (src
, name
, sym
, init
), seq
);
1457 if (scm_is_true (scm_hashq_ref (assigned
, sym
, SCM_BOOL_F
)))
1458 seq
= scm_cons (box_lexical (name
, sym
), seq
);
1460 /* Rest arguments may need boxing. */
1461 if (scm_is_true (rest
))
1463 SCM sym
= CAR (symwalk
);
1464 symwalk
= CDR (symwalk
);
1465 if (scm_is_true (scm_hashq_ref (assigned
, sym
, SCM_BOOL_F
)))
1466 seq
= scm_cons (box_lexical (rest
, sym
), seq
);
1468 /* The rest of the arguments, if any, are keyword arguments,
1469 which may need initialization and/or boxing. */
1471 scm_is_pair (symwalk
);
1472 symwalk
= CDR (symwalk
), inits
= CDR (inits
))
1474 SCM sym
= CAR (symwalk
), init
= CAR (inits
);
1475 seq
= scm_cons (init_if_unbound (src
, SCM_BOOL_F
, sym
, init
), seq
);
1476 if (scm_is_true (scm_hashq_ref (assigned
, sym
, SCM_BOOL_F
)))
1477 seq
= scm_cons (box_lexical (SCM_BOOL_F
, sym
), seq
);
1480 for (; scm_is_pair (seq
); seq
= CDR (seq
))
1481 body
= SEQ (src
, CAR (seq
), body
);
1484 (src
, req
, opt
, rest
, kw
, new_inits
, syms
, body
, alt
);
1487 case SCM_EXPANDED_LET
:
1489 SCM src
, names
, syms
, vals
, body
, new_vals
, walk
;
1491 src
= REF (exp
, LET
, SRC
);
1492 names
= REF (exp
, LET
, NAMES
);
1493 syms
= REF (exp
, LET
, GENSYMS
);
1494 vals
= convert_assignment (REF (exp
, LET
, VALS
), assigned
);
1495 body
= convert_assignment (REF (exp
, LET
, BODY
), assigned
);
1497 for (new_vals
= SCM_EOL
, walk
= syms
;
1499 vals
= CDR (vals
), walk
= CDR (walk
))
1501 SCM sym
= CAR (walk
), val
= CAR (vals
);
1502 if (scm_is_true (scm_hashq_ref (assigned
, sym
, SCM_BOOL_F
)))
1503 new_vals
= scm_cons (box_value (val
), new_vals
);
1505 new_vals
= scm_cons (val
, new_vals
);
1507 new_vals
= scm_reverse (new_vals
);
1509 return LET (src
, names
, syms
, new_vals
, body
);
1512 case SCM_EXPANDED_LETREC
:
1514 SCM src
, names
, syms
, vals
, unbound
, boxes
, body
;
1516 src
= REF (exp
, LETREC
, SRC
);
1517 names
= REF (exp
, LETREC
, NAMES
);
1518 syms
= REF (exp
, LETREC
, GENSYMS
);
1519 vals
= convert_assignment (REF (exp
, LETREC
, VALS
), assigned
);
1520 body
= convert_assignment (REF (exp
, LETREC
, BODY
), assigned
);
1522 unbound
= PRIMCALL (SCM_BOOL_F
,
1523 scm_from_latin1_symbol ("make-undefined-variable"),
1525 boxes
= scm_make_list (scm_length (names
), unbound
);
1527 if (scm_is_true (REF (exp
, LETREC
, IN_ORDER_P
)))
1529 (src
, names
, syms
, boxes
,
1530 init_boxes (names
, syms
, vals
, body
));
1533 SCM walk
, tmps
= SCM_EOL
, inits
= SCM_EOL
;
1535 for (walk
= syms
; scm_is_pair (walk
); walk
= CDR (walk
))
1537 SCM tmp
= scm_gensym (SCM_UNDEFINED
);
1538 tmps
= scm_cons (tmp
, tmps
);
1539 inits
= scm_cons (LEXICAL_REF (SCM_BOOL_F
, SCM_BOOL_F
, tmp
),
1542 tmps
= scm_reverse (tmps
);
1543 inits
= scm_reverse (inits
);
1546 (src
, names
, syms
, boxes
,
1548 LET (src
, names
, tmps
, vals
,
1549 init_boxes (names
, syms
, inits
, VOID_ (src
))),
1560 scm_convert_assignment (SCM exp
)
1562 SCM assigned
= scm_c_make_hash_table (0);
1564 compute_assigned (exp
, assigned
);
1565 return convert_assignment (exp
, assigned
);
1571 #define DEFINE_NAMES(type) \
1573 static const char *fields[] = SCM_EXPANDED_##type##_FIELD_NAMES; \
1574 exp_field_names[SCM_EXPANDED_##type] = fields; \
1575 exp_names[SCM_EXPANDED_##type] = SCM_EXPANDED_##type##_TYPE_NAME; \
1576 exp_nfields[SCM_EXPANDED_##type] = SCM_NUM_EXPANDED_##type##_FIELDS; \
1580 make_exp_vtable (size_t n
)
1582 SCM layout
, printer
, name
, code
, fields
;
1584 layout
= scm_string_to_symbol
1585 (scm_string_append (scm_make_list (scm_from_size_t (exp_nfields
[n
]),
1586 scm_from_locale_string ("pw"))));
1587 printer
= SCM_BOOL_F
;
1588 name
= scm_from_utf8_symbol (exp_names
[n
]);
1589 code
= scm_from_size_t (n
);
1592 size_t m
= exp_nfields
[n
];
1594 fields
= scm_cons (scm_from_utf8_symbol (exp_field_names
[n
][m
]), fields
);
1597 return scm_c_make_struct (scm_exp_vtable_vtable
, 0, 5,
1598 SCM_UNPACK (layout
), SCM_UNPACK (printer
), SCM_UNPACK (name
),
1599 SCM_UNPACK (code
), SCM_UNPACK (fields
));
1606 SCM exp_vtable_list
= SCM_EOL
;
1608 DEFINE_NAMES (VOID
);
1609 DEFINE_NAMES (CONST
);
1610 DEFINE_NAMES (PRIMITIVE_REF
);
1611 DEFINE_NAMES (LEXICAL_REF
);
1612 DEFINE_NAMES (LEXICAL_SET
);
1613 DEFINE_NAMES (MODULE_REF
);
1614 DEFINE_NAMES (MODULE_SET
);
1615 DEFINE_NAMES (TOPLEVEL_REF
);
1616 DEFINE_NAMES (TOPLEVEL_SET
);
1617 DEFINE_NAMES (TOPLEVEL_DEFINE
);
1618 DEFINE_NAMES (CONDITIONAL
);
1619 DEFINE_NAMES (CALL
);
1620 DEFINE_NAMES (PRIMCALL
);
1622 DEFINE_NAMES (LAMBDA
);
1623 DEFINE_NAMES (LAMBDA_CASE
);
1625 DEFINE_NAMES (LETREC
);
1627 scm_exp_vtable_vtable
=
1628 scm_make_vtable (scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT
"pwuwpw"),
1631 for (n
= 0; n
< SCM_NUM_EXPANDED_TYPES
; n
++)
1632 exp_vtables
[n
] = make_exp_vtable (n
);
1634 /* Now walk back down, consing in reverse. */
1636 exp_vtable_list
= scm_cons (exp_vtables
[n
], exp_vtable_list
);
1639 CONST_ (SCM_BOOL_F
, scm_list_1 (scm_from_latin1_symbol ("unbound")));
1641 scm_c_define_gsubr ("convert-assignment", 1, 0, 0, scm_convert_assignment
);
1643 scm_c_define ("%expanded-vtables", scm_vector (exp_vtable_list
));
1645 #include "libguile/expand.x"