1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
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
];
53 SCM_MAKE_EXPANDED_VOID(src)
54 #define CONST(src, exp) \
55 SCM_MAKE_EXPANDED_CONST(src, exp)
56 #define PRIMITIVE_REF_TYPE(src, name) \
57 SCM_MAKE_EXPANDED_PRIMITIVE_REF_TYPE(src, name)
58 #define LEXICAL_REF(src, name, gensym) \
59 SCM_MAKE_EXPANDED_LEXICAL_REF(src, name, gensym)
60 #define LEXICAL_SET(src, name, gensym, exp) \
61 SCM_MAKE_EXPANDED_LEXICAL_SET(src, name, gensym, exp)
62 #define MODULE_REF(src, mod, name, public) \
63 SCM_MAKE_EXPANDED_MODULE_REF(src, mod, name, public)
64 #define MODULE_SET(src, mod, name, public, exp) \
65 SCM_MAKE_EXPANDED_MODULE_SET(src, mod, name, public, exp)
66 #define TOPLEVEL_REF(src, name) \
67 SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, name)
68 #define TOPLEVEL_SET(src, name, exp) \
69 SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, name, exp)
70 #define TOPLEVEL_DEFINE(src, name, exp) \
71 SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, name, exp)
72 #define CONDITIONAL(src, test, consequent, alternate) \
73 SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate)
74 #define APPLICATION(src, proc, exps) \
75 SCM_MAKE_EXPANDED_APPLICATION(src, proc, exps)
76 #define SEQUENCE(src, exps) \
77 SCM_MAKE_EXPANDED_SEQUENCE(src, exps)
78 #define LAMBDA(src, meta, body) \
79 SCM_MAKE_EXPANDED_LAMBDA(src, meta, body)
80 #define LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate) \
81 SCM_MAKE_EXPANDED_LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate)
82 #define LET(src, names, gensyms, vals, body) \
83 SCM_MAKE_EXPANDED_LET(src, names, gensyms, vals, body)
84 #define LETREC(src, names, gensyms, vals, body) \
85 SCM_MAKE_EXPANDED_LETREC(src, names, gensyms, vals, body)
86 #define DYNLET(src, fluids, vals, body) \
87 SCM_MAKE_EXPANDED_DYNLET(src, fluids, vals, body)
89 #define CAR(x) SCM_CAR(x)
90 #define CDR(x) SCM_CDR(x)
91 #define CAAR(x) SCM_CAAR(x)
92 #define CADR(x) SCM_CADR(x)
93 #define CDAR(x) SCM_CDAR(x)
94 #define CDDR(x) SCM_CDDR(x)
95 #define CADDR(x) SCM_CADDR(x)
96 #define CDDDR(x) SCM_CDDDR(x)
97 #define CADDDR(x) SCM_CADDDR(x)
100 static const char s_bad_expression
[] = "Bad expression";
101 static const char s_expression
[] = "Missing or extra expression in";
102 static const char s_missing_expression
[] = "Missing expression in";
103 static const char s_extra_expression
[] = "Extra expression in";
104 static const char s_empty_combination
[] = "Illegal empty combination";
105 static const char s_missing_body_expression
[] = "Missing body expression in";
106 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
107 static const char s_bad_define
[] = "Bad define placement";
108 static const char s_missing_clauses
[] = "Missing clauses";
109 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
110 static const char s_bad_case_clause
[] = "Bad case clause";
111 static const char s_bad_case_labels
[] = "Bad case labels";
112 static const char s_duplicate_case_label
[] = "Duplicate case label";
113 static const char s_bad_cond_clause
[] = "Bad cond clause";
114 static const char s_missing_recipient
[] = "Missing recipient in";
115 static const char s_bad_variable
[] = "Bad variable";
116 static const char s_bad_bindings
[] = "Bad bindings";
117 static const char s_bad_binding
[] = "Bad binding";
118 static const char s_duplicate_binding
[] = "Duplicate binding";
119 static const char s_bad_exit_clause
[] = "Bad exit clause";
120 static const char s_bad_formals
[] = "Bad formals";
121 static const char s_bad_formal
[] = "Bad formal";
122 static const char s_duplicate_formal
[] = "Duplicate formal";
123 static const char s_splicing
[] = "Non-list result for unquote-splicing";
124 static const char s_bad_slot_number
[] = "Bad slot number";
126 static void syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
128 SCM_SYMBOL (syntax_error_key
, "syntax-error");
130 /* Shortcut macros to simplify syntax error handling. */
131 #define ASSERT_SYNTAX(cond, message, form) \
132 { if (SCM_UNLIKELY (!(cond))) \
133 syntax_error (message, form, SCM_UNDEFINED); }
134 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
135 { if (SCM_UNLIKELY (!(cond))) \
136 syntax_error (message, form, expr); }
141 /* Primitive syntax. */
143 #define SCM_SYNTAX(STR, CFN) \
144 SCM_SNARF_HERE(static SCM CFN (SCM xorig, SCM env)) \
145 SCM_SNARF_INIT(scm_c_define (STR, scm_i_make_primitive_macro (STR, CFN)))
148 /* True primitive syntax */
149 SCM_SYNTAX ("@", expand_at
);
150 SCM_SYNTAX ("@@", expand_atat
);
151 SCM_SYNTAX ("begin", expand_begin
);
152 SCM_SYNTAX ("define", expand_define
);
153 SCM_SYNTAX ("with-fluids", expand_with_fluids
);
154 SCM_SYNTAX ("eval-when", expand_eval_when
);
155 SCM_SYNTAX ("if", expand_if
);
156 SCM_SYNTAX ("lambda", expand_lambda
);
157 SCM_SYNTAX ("let", expand_let
);
158 SCM_SYNTAX ("quote", expand_quote
);
159 SCM_SYNTAX ("set!", expand_set_x
);
161 /* Convenient syntax during boot, expands to primitive syntax. Replaced after
163 SCM_SYNTAX ("and", expand_and
);
164 SCM_SYNTAX ("cond", expand_cond
);
165 SCM_SYNTAX ("letrec", expand_letrec
);
166 SCM_SYNTAX ("let*", expand_letstar
);
167 SCM_SYNTAX ("or", expand_or
);
168 SCM_SYNTAX ("lambda*", expand_lambda_star
);
169 SCM_SYNTAX ("case-lambda", expand_case_lambda
);
170 SCM_SYNTAX ("case-lambda*", expand_case_lambda_star
);
173 SCM_GLOBAL_SYMBOL (scm_sym_apply
, "apply");
174 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
175 SCM_GLOBAL_SYMBOL (scm_sym_at
, "@");
176 SCM_GLOBAL_SYMBOL (scm_sym_atat
, "@@");
177 SCM_GLOBAL_SYMBOL (scm_sym_at_call_with_values
, "@call-with-values");
178 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, "@apply");
179 SCM_GLOBAL_SYMBOL (scm_sym_atcall_cc
, "@call-with-current-continuation");
180 SCM_GLOBAL_SYMBOL (scm_sym_begin
, "begin");
181 SCM_GLOBAL_SYMBOL (scm_sym_case
, "case");
182 SCM_GLOBAL_SYMBOL (scm_sym_cond
, "cond");
183 SCM_GLOBAL_SYMBOL (scm_sym_define
, "define");
184 SCM_GLOBAL_SYMBOL (scm_sym_at_dynamic_wind
, "@dynamic-wind");
185 SCM_GLOBAL_SYMBOL (scm_sym_with_fluids
, "with-fluids");
186 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
187 SCM_GLOBAL_SYMBOL (scm_sym_eval_when
, "eval-when");
188 SCM_GLOBAL_SYMBOL (scm_sym_if
, "if");
189 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, "lambda");
190 SCM_GLOBAL_SYMBOL (scm_sym_let
, "let");
191 SCM_GLOBAL_SYMBOL (scm_sym_letrec
, "letrec");
192 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, "let*");
193 SCM_GLOBAL_SYMBOL (scm_sym_or
, "or");
194 SCM_GLOBAL_SYMBOL (scm_sym_at_prompt
, "@prompt");
195 SCM_GLOBAL_SYMBOL (scm_sym_quote
, "quote");
196 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, "set!");
197 SCM_SYMBOL (sym_lambda_star
, "lambda*");
198 SCM_SYMBOL (sym_eval
, "eval");
199 SCM_SYMBOL (sym_load
, "load");
201 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
202 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, "quasiquote");
203 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
205 SCM_KEYWORD (kw_allow_other_keys
, "allow-other-keys");
206 SCM_KEYWORD (kw_optional
, "optional");
207 SCM_KEYWORD (kw_key
, "key");
208 SCM_KEYWORD (kw_rest
, "rest");
214 /* Signal a syntax error. We distinguish between the form that caused the
215 * error and the enclosing expression. The error message will print out as
216 * shown in the following pattern. The file name and line number are only
217 * given when they can be determined from the erroneous form or from the
218 * enclosing expression.
220 * <filename>: In procedure memoization:
221 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
224 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
226 SCM msg_string
= scm_from_locale_string (msg
);
227 SCM filename
= SCM_BOOL_F
;
228 SCM linenr
= SCM_BOOL_F
;
232 if (scm_is_pair (form
))
234 filename
= scm_source_property (form
, scm_sym_filename
);
235 linenr
= scm_source_property (form
, scm_sym_line
);
238 if (scm_is_false (filename
) && scm_is_false (linenr
) && scm_is_pair (expr
))
240 filename
= scm_source_property (expr
, scm_sym_filename
);
241 linenr
= scm_source_property (expr
, scm_sym_line
);
244 if (!SCM_UNBNDP (expr
))
246 if (scm_is_true (filename
))
248 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
249 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
251 else if (scm_is_true (linenr
))
253 format
= "In line ~S: ~A ~S in expression ~S.";
254 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
258 format
= "~A ~S in expression ~S.";
259 args
= scm_list_3 (msg_string
, form
, expr
);
264 if (scm_is_true (filename
))
266 format
= "In file ~S, line ~S: ~A ~S.";
267 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
269 else if (scm_is_true (linenr
))
271 format
= "In line ~S: ~A ~S.";
272 args
= scm_list_3 (linenr
, msg_string
, form
);
277 args
= scm_list_2 (msg_string
, form
);
281 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
289 expand_env_var_is_free (SCM env
, SCM x
)
291 for (; scm_is_pair (env
); env
= CDR (env
))
292 if (scm_is_eq (x
, CAAR (env
)))
293 return 0; /* bound */
298 expand_env_ref_macro (SCM env
, SCM x
)
301 if (!expand_env_var_is_free (env
, x
))
302 return SCM_BOOL_F
; /* lexical */
304 var
= scm_module_variable (scm_current_module (), x
);
305 if (scm_is_true (var
) && scm_is_true (scm_variable_bound_p (var
))
306 && scm_is_true (scm_macro_p (scm_variable_ref (var
))))
307 return scm_variable_ref (var
);
309 return SCM_BOOL_F
; /* anything else */
313 expand_env_lexical_gensym (SCM env
, SCM name
)
315 for (; scm_is_pair (env
); env
= CDR (env
))
316 if (scm_is_eq (name
, CAAR (env
)))
317 return CDAR (env
); /* bound */
318 return SCM_BOOL_F
; /* free */
322 expand_env_extend (SCM env
, SCM names
, SCM vars
)
324 while (scm_is_pair (names
))
326 env
= scm_acons (CAR (names
), CAR (vars
), env
);
334 expand (SCM exp
, SCM env
)
336 if (scm_is_pair (exp
))
339 scm_t_macro_primitive trans
= NULL
;
340 SCM macro
= SCM_BOOL_F
;
343 if (scm_is_symbol (car
))
344 macro
= expand_env_ref_macro (env
, car
);
346 if (scm_is_true (macro
))
347 trans
= scm_i_macro_primitive (macro
);
350 return trans (exp
, env
);
353 SCM arg_exps
= SCM_EOL
;
355 SCM proc
= CAR (exp
);
357 for (arg_exps
= CDR (exp
); scm_is_pair (arg_exps
);
358 arg_exps
= CDR (arg_exps
))
359 args
= scm_cons (expand (CAR (arg_exps
), env
), args
);
360 if (scm_is_null (arg_exps
))
361 return APPLICATION (scm_source_properties (exp
),
363 scm_reverse_x (args
, SCM_UNDEFINED
));
365 syntax_error ("expected a proper list", exp
, SCM_UNDEFINED
);
368 else if (scm_is_symbol (exp
))
370 SCM gensym
= expand_env_lexical_gensym (env
, exp
);
371 if (scm_is_true (gensym
))
372 return LEXICAL_REF (SCM_BOOL_F
, exp
, gensym
);
374 return TOPLEVEL_REF (SCM_BOOL_F
, exp
);
377 return CONST (SCM_BOOL_F
, exp
);
381 expand_exprs (SCM forms
, const SCM env
)
385 for (; !scm_is_null (forms
); forms
= CDR (forms
))
386 ret
= scm_cons (expand (CAR (forms
), env
), ret
);
387 return scm_reverse_x (ret
, SCM_UNDEFINED
);
391 expand_sequence (const SCM forms
, const SCM env
)
393 ASSERT_SYNTAX (scm_ilength (forms
) >= 1, s_bad_expression
,
394 scm_cons (scm_sym_begin
, forms
));
395 if (scm_is_null (CDR (forms
)))
396 return expand (CAR (forms
), env
);
398 return SEQUENCE (SCM_BOOL_F
, expand_exprs (forms
, env
));
406 expand_at (SCM expr
, SCM env SCM_UNUSED
)
408 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
409 ASSERT_SYNTAX (scm_ilength (CADR (expr
)) > 0, s_bad_expression
, expr
);
410 ASSERT_SYNTAX (scm_is_symbol (CADDR (expr
)), s_bad_expression
, expr
);
412 return MODULE_REF (scm_source_properties (expr
),
413 CADR (expr
), CADDR (expr
), SCM_BOOL_T
);
417 expand_atat (SCM expr
, SCM env SCM_UNUSED
)
419 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
420 ASSERT_SYNTAX (scm_ilength (CADR (expr
)) > 0, s_bad_expression
, expr
);
421 ASSERT_SYNTAX (scm_is_symbol (CADDR (expr
)), s_bad_expression
, expr
);
423 return MODULE_REF (scm_source_properties (expr
),
424 CADR (expr
), CADDR (expr
), SCM_BOOL_F
);
428 expand_and (SCM expr
, SCM env
)
430 const SCM cdr_expr
= CDR (expr
);
432 if (scm_is_null (cdr_expr
))
433 return CONST (SCM_BOOL_F
, SCM_BOOL_T
);
435 ASSERT_SYNTAX (scm_is_pair (cdr_expr
), s_bad_expression
, expr
);
437 if (scm_is_null (CDR (cdr_expr
)))
438 return expand (CAR (cdr_expr
), env
);
440 return CONDITIONAL (scm_source_properties (expr
),
441 expand (CAR (cdr_expr
), env
),
442 expand_and (cdr_expr
, env
),
443 CONST (SCM_BOOL_F
, SCM_BOOL_F
));
447 expand_begin (SCM expr
, SCM env
)
449 const SCM cdr_expr
= CDR (expr
);
450 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_bad_expression
, expr
);
451 return expand_sequence (cdr_expr
, env
);
455 expand_cond_clauses (SCM clause
, SCM rest
, int elp
, int alp
, SCM env
)
458 const long length
= scm_ilength (clause
);
459 ASSERT_SYNTAX (length
>= 1, s_bad_cond_clause
, clause
);
462 if (scm_is_eq (test
, scm_sym_else
) && elp
)
464 const int last_clause_p
= scm_is_null (rest
);
465 ASSERT_SYNTAX (length
>= 2, s_bad_cond_clause
, clause
);
466 ASSERT_SYNTAX (last_clause_p
, s_misplaced_else_clause
, clause
);
467 return expand_sequence (CDR (clause
), env
);
470 if (scm_is_null (rest
))
471 rest
= VOID (SCM_BOOL_F
);
473 rest
= expand_cond_clauses (CAR (rest
), CDR (rest
), elp
, alp
, env
);
476 && scm_is_eq (CADR (clause
), scm_sym_arrow
)
479 SCM tmp
= scm_gensym (scm_from_locale_string ("cond "));
480 SCM new_env
= scm_acons (tmp
, tmp
, env
);
481 ASSERT_SYNTAX (length
> 2, s_missing_recipient
, clause
);
482 ASSERT_SYNTAX (length
== 3, s_extra_expression
, clause
);
483 return LET (SCM_BOOL_F
,
486 scm_list_1 (expand (test
, env
)),
487 CONDITIONAL (SCM_BOOL_F
,
488 LEXICAL_REF (SCM_BOOL_F
, tmp
, tmp
),
489 APPLICATION (SCM_BOOL_F
,
490 expand (CADDR (clause
), new_env
),
491 scm_list_1 (LEXICAL_REF (SCM_BOOL_F
,
495 /* FIXME length == 1 case */
497 return CONDITIONAL (SCM_BOOL_F
,
499 expand_sequence (CDR (clause
), env
),
504 expand_cond (SCM expr
, SCM env
)
506 const int else_literal_p
= expand_env_var_is_free (env
, scm_sym_else
);
507 const int arrow_literal_p
= expand_env_var_is_free (env
, scm_sym_arrow
);
508 const SCM clauses
= CDR (expr
);
510 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
511 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
513 return expand_cond_clauses (CAR (clauses
), CDR (clauses
),
514 else_literal_p
, arrow_literal_p
, env
);
517 /* lone forward decl */
518 static SCM
expand_lambda (SCM expr
, SCM env
);
520 /* According to Section 5.2.1 of R5RS we first have to make sure that the
521 variable is bound, and then perform the `(set! variable expression)'
522 operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
523 bound. This means that EXPRESSION won't necessarily be able to assign
524 values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
526 expand_define (SCM expr
, SCM env
)
528 const SCM cdr_expr
= CDR (expr
);
532 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
533 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
534 ASSERT_SYNTAX (!scm_is_pair (env
), s_bad_define
, expr
);
536 body
= CDR (cdr_expr
);
537 variable
= CAR (cdr_expr
);
539 if (scm_is_pair (variable
))
541 ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable
)), s_bad_variable
, variable
, expr
);
542 return TOPLEVEL_DEFINE
543 (scm_source_properties (expr
),
545 expand_lambda (scm_cons (scm_sym_lambda
, scm_cons (CDR (variable
), body
)),
548 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
549 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
550 return TOPLEVEL_DEFINE (scm_source_properties (expr
), variable
,
551 expand (CAR (body
), env
));
555 expand_with_fluids (SCM expr
, SCM env
)
557 SCM binds
, fluids
, vals
;
558 ASSERT_SYNTAX (scm_ilength (expr
) >= 3, s_bad_expression
, expr
);
560 ASSERT_SYNTAX_2 (scm_ilength (binds
) >= 0, s_bad_bindings
, binds
, expr
);
561 for (fluids
= SCM_EOL
, vals
= SCM_EOL
;
565 SCM binding
= CAR (binds
);
566 ASSERT_SYNTAX_2 (scm_ilength (CAR (binds
)) == 2, s_bad_binding
,
568 fluids
= scm_cons (expand (CAR (binding
), env
), fluids
);
569 vals
= scm_cons (expand (CADR (binding
), env
), vals
);
572 return DYNLET (scm_source_properties (expr
),
573 scm_reverse_x (fluids
, SCM_UNDEFINED
),
574 scm_reverse_x (vals
, SCM_UNDEFINED
),
575 expand_sequence (CDDR (expr
), env
));
579 expand_eval_when (SCM expr
, SCM env
)
581 ASSERT_SYNTAX (scm_ilength (expr
) >= 3, s_bad_expression
, expr
);
582 ASSERT_SYNTAX (scm_ilength (CADR (expr
)) > 0, s_bad_expression
, expr
);
584 if (scm_is_true (scm_memq (sym_eval
, CADR (expr
)))
585 || scm_is_true (scm_memq (sym_load
, CADR (expr
))))
586 return expand_sequence (CDDR (expr
), env
);
588 return VOID (scm_source_properties (expr
));
592 expand_if (SCM expr
, SCM env SCM_UNUSED
)
594 const SCM cdr_expr
= CDR (expr
);
595 const long length
= scm_ilength (cdr_expr
);
596 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
597 return CONDITIONAL (scm_source_properties (expr
),
598 expand (CADR (expr
), env
),
599 expand (CADDR (expr
), env
),
601 ? expand (CADDDR (expr
), env
)
602 : VOID (SCM_BOOL_F
)));
605 /* A helper function for expand_lambda to support checking for duplicate
606 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
607 * LIST or to the CDR of the last cons. Therefore, LIST may have any of the
608 * forms that a formal argument can have:
609 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
611 c_improper_memq (SCM obj
, SCM list
)
613 for (; scm_is_pair (list
); list
= CDR (list
))
615 if (scm_is_eq (CAR (list
), obj
))
618 return scm_is_eq (list
, obj
);
622 expand_lambda_case (SCM clause
, SCM alternate
, SCM env
)
631 ASSERT_SYNTAX (scm_is_pair (clause
) && scm_is_pair (CDR (clause
)),
632 s_bad_expression
, scm_cons (scm_sym_lambda
, clause
));
634 /* Before iterating the list of formal arguments, make sure the formals
635 * actually are given as either a symbol or a non-cyclic list. */
636 formals
= CAR (clause
);
637 if (scm_is_pair (formals
))
639 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
640 * detected, report a 'Bad formals' error. */
643 ASSERT_SYNTAX_2 (scm_is_symbol (formals
) || scm_is_null (formals
),
644 s_bad_formals
, formals
, scm_cons (scm_sym_lambda
, clause
));
646 /* Now iterate the list of formal arguments to check if all formals are
647 * symbols, and that there are no duplicates. */
648 while (scm_is_pair (formals
))
650 const SCM formal
= CAR (formals
);
651 formals
= CDR (formals
);
652 ASSERT_SYNTAX_2 (scm_is_symbol (formal
), s_bad_formal
, formal
,
653 scm_cons (scm_sym_lambda
, clause
));
654 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, formals
), s_duplicate_formal
,
655 formal
, scm_cons (scm_sym_lambda
, clause
));
657 req
= scm_cons (formal
, req
);
658 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
659 env
= scm_acons (formal
, CAR (vars
), env
);
662 ASSERT_SYNTAX_2 (scm_is_null (formals
) || scm_is_symbol (formals
),
663 s_bad_formal
, formals
, scm_cons (scm_sym_lambda
, clause
));
664 if (scm_is_symbol (formals
))
667 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
668 env
= scm_acons (rest
, CAR (vars
), env
);
673 body
= expand_sequence (CDR (clause
), env
);
674 req
= scm_reverse_x (req
, SCM_UNDEFINED
);
675 vars
= scm_reverse_x (vars
, SCM_UNDEFINED
);
677 if (scm_is_true (alternate
) && !(SCM_EXPANDED_P (alternate
) && SCM_EXPANDED_TYPE (alternate
) == SCM_EXPANDED_LAMBDA_CASE
))
680 return LAMBDA_CASE (SCM_BOOL_F
, req
, SCM_BOOL_F
, rest
, SCM_BOOL_F
,
681 SCM_EOL
, vars
, body
, alternate
);
685 expand_lambda (SCM expr
, SCM env
)
687 return LAMBDA (scm_source_properties (expr
),
689 expand_lambda_case (CDR (expr
), SCM_BOOL_F
, env
));
693 expand_lambda_star_case (SCM clause
, SCM alternate
, SCM env
)
695 SCM req
, opt
, kw
, allow_other_keys
, rest
, formals
, vars
, body
, tmp
;
699 const long length
= scm_ilength (clause
);
700 ASSERT_SYNTAX (length
>= 1, s_bad_expression
,
701 scm_cons (sym_lambda_star
, clause
));
702 ASSERT_SYNTAX (length
>= 2, s_missing_expression
,
703 scm_cons (sym_lambda_star
, clause
));
705 formals
= CAR (clause
);
709 req
= opt
= kw
= SCM_EOL
;
710 rest
= allow_other_keys
= SCM_BOOL_F
;
712 while (scm_is_pair (formals
) && scm_is_symbol (CAR (formals
)))
715 req
= scm_cons (CAR (formals
), req
);
716 formals
= scm_cdr (formals
);
719 if (scm_is_pair (formals
) && scm_is_eq (CAR (formals
), kw_optional
))
721 formals
= CDR (formals
);
722 while (scm_is_pair (formals
)
723 && (scm_is_symbol (CAR (formals
)) || scm_is_pair (CAR (formals
))))
726 opt
= scm_cons (CAR (formals
), opt
);
727 formals
= scm_cdr (formals
);
731 if (scm_is_pair (formals
) && scm_is_eq (CAR (formals
), kw_key
))
733 formals
= CDR (formals
);
734 while (scm_is_pair (formals
)
735 && (scm_is_symbol (CAR (formals
)) || scm_is_pair (CAR (formals
))))
737 kw
= scm_cons (CAR (formals
), kw
);
738 formals
= scm_cdr (formals
);
742 if (scm_is_pair (formals
) && scm_is_eq (CAR (formals
), kw_allow_other_keys
))
744 formals
= CDR (formals
);
745 allow_other_keys
= SCM_BOOL_T
;
748 if (scm_is_pair (formals
) && scm_is_eq (CAR (formals
), kw_rest
))
750 ASSERT_SYNTAX (scm_ilength (formals
) == 2, s_bad_formals
,
752 rest
= CADR (formals
);
754 else if (scm_is_symbol (formals
))
758 ASSERT_SYNTAX (scm_is_null (formals
), s_bad_formals
, CAR (clause
));
762 /* Now, iterate through them a second time, building up an expansion-time
763 environment, checking, expanding and canonicalizing the opt/kw init forms,
764 and eventually memoizing the body as well. Note that the rest argument, if
765 any, is expanded before keyword args, thus necessitating the second
768 Also note that the specific environment during expansion of init
769 expressions here needs to coincide with the environment when psyntax
770 expands. A lot of effort for something that is only used in the bootstrap
771 expandr, you say? Yes. Yes it is.
775 req
= scm_reverse_x (req
, SCM_EOL
);
776 for (tmp
= req
; scm_is_pair (tmp
); tmp
= scm_cdr (tmp
))
778 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
779 env
= scm_acons (CAR (tmp
), CAR (vars
), env
);
782 /* Build up opt inits and env */
784 opt
= scm_reverse_x (opt
, SCM_EOL
);
785 for (tmp
= opt
; scm_is_pair (tmp
); tmp
= scm_cdr (tmp
))
788 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
789 env
= scm_acons (x
, CAR (vars
), env
);
790 if (scm_is_symbol (x
))
791 inits
= scm_cons (CONST (SCM_BOOL_F
, SCM_BOOL_F
), inits
);
794 ASSERT_SYNTAX (scm_ilength (x
) == 2 && scm_is_symbol (CAR (x
)),
795 s_bad_formals
, CAR (clause
));
796 inits
= scm_cons (expand (CADR (x
), env
), inits
);
798 env
= scm_acons (scm_is_symbol (x
) ? x
: CAR (x
), CAR (vars
), env
);
800 if (scm_is_null (opt
))
803 /* Process rest before keyword args */
804 if (scm_is_true (rest
))
806 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
807 env
= scm_acons (rest
, CAR (vars
), env
);
810 /* Build up kw inits, env, and kw-canon list */
811 if (scm_is_null (kw
))
815 SCM kw_canon
= SCM_EOL
;
816 kw
= scm_reverse_x (kw
, SCM_UNDEFINED
);
817 for (tmp
= kw
; scm_is_pair (tmp
); tmp
= scm_cdr (tmp
))
821 if (scm_is_symbol (x
))
825 k
= scm_symbol_to_keyword (sym
);
827 else if (scm_ilength (x
) == 2 && scm_is_symbol (CAR (x
)))
831 k
= scm_symbol_to_keyword (sym
);
833 else if (scm_ilength (x
) == 3 && scm_is_symbol (CAR (x
))
834 && scm_is_keyword (CADDR (x
)))
841 syntax_error (s_bad_formals
, CAR (clause
), SCM_UNDEFINED
);
843 inits
= scm_cons (expand (init
, env
), inits
);
844 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
845 kw_canon
= scm_cons (scm_list_3 (k
, sym
, CAR (vars
)), kw_canon
);
846 env
= scm_acons (sym
, CAR (vars
), env
);
848 kw_canon
= scm_reverse_x (kw_canon
, SCM_UNDEFINED
);
849 kw
= scm_cons (allow_other_keys
, kw_canon
);
852 /* We should check for no duplicates, but given that psyntax does this
853 already, we can punt on it here... */
855 vars
= scm_reverse_x (vars
, SCM_UNDEFINED
);
856 inits
= scm_reverse_x (inits
, SCM_UNDEFINED
);
857 body
= expand_sequence (body
, env
);
859 return LAMBDA_CASE (SCM_BOOL_F
, req
, opt
, rest
, kw
, inits
, vars
, body
,
864 expand_lambda_star (SCM expr
, SCM env
)
866 return LAMBDA (scm_source_properties (expr
),
868 expand_lambda_star_case (CDR (expr
), SCM_BOOL_F
, env
));
872 expand_case_lambda_clauses (SCM expr
, SCM rest
, SCM env
)
876 if (scm_is_pair (rest
))
877 alt
= expand_case_lambda_clauses (CAR (rest
), CDR (rest
), env
);
881 return expand_lambda_case (expr
, alt
, env
);
885 expand_case_lambda (SCM expr
, SCM env
)
887 ASSERT_SYNTAX (scm_is_pair (CDR (expr
)), s_missing_expression
, expr
);
889 return LAMBDA (scm_source_properties (expr
),
891 expand_case_lambda_clauses (CADR (expr
), CDDR (expr
), env
));
895 expand_case_lambda_star_clauses (SCM expr
, SCM rest
, SCM env
)
899 if (scm_is_pair (rest
))
900 alt
= expand_case_lambda_star_clauses (CAR (rest
), CDR (rest
), env
);
904 return expand_lambda_star_case (expr
, alt
, env
);
908 expand_case_lambda_star (SCM expr
, SCM env
)
910 ASSERT_SYNTAX (scm_is_pair (CDR (expr
)), s_missing_expression
, expr
);
912 return LAMBDA (scm_source_properties (expr
),
914 expand_case_lambda_star_clauses (CADR (expr
), CDDR (expr
), env
));
917 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
919 check_bindings (const SCM bindings
, const SCM expr
)
923 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
924 s_bad_bindings
, bindings
, expr
);
926 binding_idx
= bindings
;
927 for (; !scm_is_null (binding_idx
); binding_idx
= CDR (binding_idx
))
929 SCM name
; /* const */
931 const SCM binding
= CAR (binding_idx
);
932 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
933 s_bad_binding
, binding
, expr
);
935 name
= CAR (binding
);
936 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
940 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
941 * transformed to the lists (vn .. v2 v1) and (i1 i2 ... in). If a duplicate
942 * variable name is detected, an error is signalled. */
944 transform_bindings (const SCM bindings
, const SCM expr
,
945 SCM
*const names
, SCM
*const vars
, SCM
*const initptr
)
947 SCM rnames
= SCM_EOL
;
949 SCM rinits
= SCM_EOL
;
950 SCM binding_idx
= bindings
;
951 for (; !scm_is_null (binding_idx
); binding_idx
= CDR (binding_idx
))
953 const SCM binding
= CAR (binding_idx
);
954 const SCM CDR_binding
= CDR (binding
);
955 const SCM name
= CAR (binding
);
956 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rnames
)),
957 s_duplicate_binding
, name
, expr
);
958 rnames
= scm_cons (name
, rnames
);
959 rvars
= scm_cons (scm_gensym (SCM_UNDEFINED
), rvars
);
960 rinits
= scm_cons (CAR (CDR_binding
), rinits
);
962 *names
= scm_reverse_x (rnames
, SCM_UNDEFINED
);
963 *vars
= scm_reverse_x (rvars
, SCM_UNDEFINED
);
964 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
967 /* FIXME: Remove named let in this boot expander. */
969 expand_named_let (const SCM expr
, SCM env
)
971 SCM var_names
, var_syms
, inits
;
975 const SCM cdr_expr
= CDR (expr
);
976 const SCM name
= CAR (cdr_expr
);
977 const SCM cddr_expr
= CDR (cdr_expr
);
978 const SCM bindings
= CAR (cddr_expr
);
979 check_bindings (bindings
, expr
);
981 transform_bindings (bindings
, expr
, &var_names
, &var_syms
, &inits
);
982 name_sym
= scm_gensym (SCM_UNDEFINED
);
983 inner_env
= scm_acons (name
, name_sym
, env
);
984 inner_env
= expand_env_extend (inner_env
, var_names
, var_syms
);
987 (scm_source_properties (expr
),
988 scm_list_1 (name
), scm_list_1 (name_sym
),
989 scm_list_1 (LAMBDA (SCM_BOOL_F
,
991 LAMBDA_CASE (SCM_BOOL_F
, var_names
, SCM_BOOL_F
, SCM_BOOL_F
,
992 SCM_BOOL_F
, SCM_BOOL_F
, var_syms
,
993 expand_sequence (CDDDR (expr
), inner_env
),
995 APPLICATION (SCM_BOOL_F
,
996 LEXICAL_REF (SCM_BOOL_F
, name
, name_sym
),
997 expand_exprs (inits
, env
)));
1001 expand_let (SCM expr
, SCM env
)
1005 const SCM cdr_expr
= CDR (expr
);
1006 const long length
= scm_ilength (cdr_expr
);
1007 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1008 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1010 bindings
= CAR (cdr_expr
);
1011 if (scm_is_symbol (bindings
))
1013 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1014 return expand_named_let (expr
, env
);
1017 check_bindings (bindings
, expr
);
1018 if (scm_is_null (bindings
))
1019 return expand_sequence (CDDR (expr
), env
);
1022 SCM var_names
, var_syms
, inits
;
1023 transform_bindings (bindings
, expr
, &var_names
, &var_syms
, &inits
);
1024 return LET (SCM_BOOL_F
,
1025 var_names
, var_syms
, expand_exprs (inits
, env
),
1026 expand_sequence (CDDR (expr
),
1027 expand_env_extend (env
, var_names
,
1033 expand_letrec (SCM expr
, SCM env
)
1037 const SCM cdr_expr
= CDR (expr
);
1038 const long length
= scm_ilength (cdr_expr
);
1039 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1040 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1042 bindings
= CAR (cdr_expr
);
1043 check_bindings (bindings
, expr
);
1044 if (scm_is_null (bindings
))
1045 return expand_sequence (CDDR (expr
), env
);
1048 SCM var_names
, var_syms
, inits
;
1049 transform_bindings (bindings
, expr
, &var_names
, &var_syms
, &inits
);
1050 env
= expand_env_extend (env
, var_names
, var_syms
);
1051 return LETREC (SCM_BOOL_F
,
1052 var_names
, var_syms
, expand_exprs (inits
, env
),
1053 expand_sequence (CDDR (expr
), env
));
1058 expand_letstar_clause (SCM bindings
, SCM body
, SCM env SCM_UNUSED
)
1060 if (scm_is_null (bindings
))
1061 return expand_sequence (body
, env
);
1064 SCM bind
, name
, sym
, init
;
1066 ASSERT_SYNTAX (scm_is_pair (bindings
), s_bad_expression
, bindings
);
1067 bind
= CAR (bindings
);
1068 ASSERT_SYNTAX (scm_ilength (bind
) == 2, s_bad_binding
, bind
);
1070 sym
= scm_gensym (SCM_UNDEFINED
);
1073 return LET (SCM_BOOL_F
, scm_list_1 (name
), scm_list_1 (sym
),
1074 scm_list_1 (expand (init
, env
)),
1075 expand_letstar_clause (CDR (bindings
), body
,
1076 scm_acons (name
, sym
, env
)));
1081 expand_letstar (SCM expr
, SCM env SCM_UNUSED
)
1083 const SCM cdr_expr
= CDR (expr
);
1084 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1085 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1087 return expand_letstar_clause (CADR (expr
), CDDR (expr
), env
);
1091 expand_or (SCM expr
, SCM env SCM_UNUSED
)
1093 SCM tail
= CDR (expr
);
1094 const long length
= scm_ilength (tail
);
1096 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1098 if (scm_is_null (CDR (expr
)))
1099 return CONST (SCM_BOOL_F
, SCM_BOOL_F
);
1102 SCM tmp
= scm_gensym (SCM_UNDEFINED
);
1103 return LET (SCM_BOOL_F
,
1104 scm_list_1 (tmp
), scm_list_1 (tmp
),
1105 scm_list_1 (expand (CADR (expr
), env
)),
1106 CONDITIONAL (SCM_BOOL_F
,
1107 LEXICAL_REF (SCM_BOOL_F
, tmp
, tmp
),
1108 LEXICAL_REF (SCM_BOOL_F
, tmp
, tmp
),
1109 expand_or (CDR (expr
),
1110 scm_acons (tmp
, tmp
, env
))));
1115 expand_quote (SCM expr
, SCM env SCM_UNUSED
)
1119 const SCM cdr_expr
= CDR (expr
);
1120 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1121 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1122 quotee
= CAR (cdr_expr
);
1123 return CONST (scm_source_properties (expr
), quotee
);
1127 expand_set_x (SCM expr
, SCM env
)
1132 const SCM cdr_expr
= CDR (expr
);
1133 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1134 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1135 variable
= CAR (cdr_expr
);
1136 vmem
= expand (variable
, env
);
1138 switch (SCM_EXPANDED_TYPE (vmem
))
1140 case SCM_EXPANDED_LEXICAL_REF
:
1141 return LEXICAL_SET (scm_source_properties (expr
),
1142 SCM_EXPANDED_REF (vmem
, LEXICAL_REF
, NAME
),
1143 SCM_EXPANDED_REF (vmem
, LEXICAL_REF
, GENSYM
),
1144 expand (CADDR (expr
), env
));
1145 case SCM_EXPANDED_TOPLEVEL_REF
:
1146 return TOPLEVEL_SET (scm_source_properties (expr
),
1147 SCM_EXPANDED_REF (vmem
, TOPLEVEL_REF
, NAME
),
1148 expand (CADDR (expr
), env
));
1149 case SCM_EXPANDED_MODULE_REF
:
1150 return MODULE_SET (scm_source_properties (expr
),
1151 SCM_EXPANDED_REF (vmem
, MODULE_REF
, MOD
),
1152 SCM_EXPANDED_REF (vmem
, MODULE_REF
, NAME
),
1153 SCM_EXPANDED_REF (vmem
, MODULE_REF
, PUBLIC
),
1154 expand (CADDR (expr
), env
));
1156 syntax_error (s_bad_variable
, variable
, expr
);
1163 /* This is the boot expander. It is later replaced with psyntax's sc-expand. */
1164 SCM_DEFINE (scm_macroexpand
, "macroexpand", 1, 0, 0,
1166 "Expand the expression @var{exp}.")
1167 #define FUNC_NAME s_scm_macroexpand
1169 return expand (exp
, scm_current_module ());
1173 SCM_DEFINE (scm_macroexpanded_p
, "macroexpanded?", 1, 0, 0,
1175 "Return @code{#t} if @var{exp} is an expanded expression.")
1176 #define FUNC_NAME s_scm_macroexpanded_p
1178 return scm_from_bool (SCM_EXPANDED_P (exp
));
1185 #define DEFINE_NAMES(type) \
1187 static const char *fields[] = SCM_EXPANDED_##type##_FIELD_NAMES; \
1188 exp_field_names[SCM_EXPANDED_##type] = fields; \
1189 exp_names[SCM_EXPANDED_##type] = SCM_EXPANDED_##type##_TYPE_NAME; \
1190 exp_nfields[SCM_EXPANDED_##type] = SCM_NUM_EXPANDED_##type##_FIELDS; \
1194 make_exp_vtable (size_t n
)
1196 SCM layout
, printer
, name
, code
, fields
;
1198 layout
= scm_string_to_symbol
1199 (scm_string_append (scm_make_list (scm_from_size_t (exp_nfields
[n
]),
1200 scm_from_locale_string ("pw"))));
1201 printer
= SCM_BOOL_F
;
1202 name
= scm_from_locale_symbol (exp_names
[n
]);
1203 code
= scm_from_size_t (n
);
1206 size_t m
= exp_nfields
[n
];
1208 fields
= scm_cons (scm_from_locale_symbol (exp_field_names
[n
][m
]), fields
);
1211 return scm_c_make_struct (scm_exp_vtable_vtable
, 0, 5,
1212 SCM_UNPACK (layout
), SCM_UNPACK (printer
), SCM_UNPACK (name
),
1213 SCM_UNPACK (code
), SCM_UNPACK (fields
));
1220 SCM exp_vtable_list
= SCM_EOL
;
1222 DEFINE_NAMES (VOID
);
1223 DEFINE_NAMES (CONST
);
1224 DEFINE_NAMES (PRIMITIVE_REF
);
1225 DEFINE_NAMES (LEXICAL_REF
);
1226 DEFINE_NAMES (LEXICAL_SET
);
1227 DEFINE_NAMES (MODULE_REF
);
1228 DEFINE_NAMES (MODULE_SET
);
1229 DEFINE_NAMES (TOPLEVEL_REF
);
1230 DEFINE_NAMES (TOPLEVEL_SET
);
1231 DEFINE_NAMES (TOPLEVEL_DEFINE
);
1232 DEFINE_NAMES (CONDITIONAL
);
1233 DEFINE_NAMES (APPLICATION
);
1234 DEFINE_NAMES (SEQUENCE
);
1235 DEFINE_NAMES (LAMBDA
);
1236 DEFINE_NAMES (LAMBDA_CASE
);
1238 DEFINE_NAMES (LETREC
);
1239 DEFINE_NAMES (DYNLET
);
1241 scm_exp_vtable_vtable
=
1242 scm_make_vtable (scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT
"pwuwpw"),
1245 for (n
= 0; n
< SCM_NUM_EXPANDED_TYPES
; n
++)
1246 exp_vtables
[n
] = make_exp_vtable (n
);
1248 /* Now walk back down, consing in reverse. */
1250 exp_vtable_list
= scm_cons (exp_vtables
[n
], exp_vtable_list
);
1252 scm_c_define ("%expanded-vtables", scm_vector (exp_vtable_list
));
1254 #include "libguile/expand.x"