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)
92 #define CAR(x) SCM_CAR(x)
93 #define CDR(x) SCM_CDR(x)
94 #define CAAR(x) SCM_CAAR(x)
95 #define CADR(x) SCM_CADR(x)
96 #define CDAR(x) SCM_CDAR(x)
97 #define CDDR(x) SCM_CDDR(x)
98 #define CADDR(x) SCM_CADDR(x)
99 #define CDDDR(x) SCM_CDDDR(x)
100 #define CADDDR(x) SCM_CADDDR(x)
103 static const char s_bad_expression
[] = "Bad expression";
104 static const char s_expression
[] = "Missing or extra expression in";
105 static const char s_missing_expression
[] = "Missing expression in";
106 static const char s_extra_expression
[] = "Extra expression in";
107 static const char s_empty_combination
[] = "Illegal empty combination";
108 static const char s_missing_body_expression
[] = "Missing body expression in";
109 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
110 static const char s_bad_define
[] = "Bad define placement";
111 static const char s_missing_clauses
[] = "Missing clauses";
112 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
113 static const char s_bad_case_clause
[] = "Bad case clause";
114 static const char s_bad_case_labels
[] = "Bad case labels";
115 static const char s_duplicate_case_label
[] = "Duplicate case label";
116 static const char s_bad_cond_clause
[] = "Bad cond clause";
117 static const char s_missing_recipient
[] = "Missing recipient in";
118 static const char s_bad_variable
[] = "Bad variable";
119 static const char s_bad_bindings
[] = "Bad bindings";
120 static const char s_bad_binding
[] = "Bad binding";
121 static const char s_duplicate_binding
[] = "Duplicate binding";
122 static const char s_bad_exit_clause
[] = "Bad exit clause";
123 static const char s_bad_formals
[] = "Bad formals";
124 static const char s_bad_formal
[] = "Bad formal";
125 static const char s_duplicate_formal
[] = "Duplicate formal";
126 static const char s_splicing
[] = "Non-list result for unquote-splicing";
127 static const char s_bad_slot_number
[] = "Bad slot number";
129 static void syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
131 SCM_SYMBOL (syntax_error_key
, "syntax-error");
133 /* Shortcut macros to simplify syntax error handling. */
134 #define ASSERT_SYNTAX(cond, message, form) \
135 { if (SCM_UNLIKELY (!(cond))) \
136 syntax_error (message, form, SCM_UNDEFINED); }
137 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
138 { if (SCM_UNLIKELY (!(cond))) \
139 syntax_error (message, form, expr); }
144 /* Primitive syntax. */
146 #define SCM_SYNTAX(STR, CFN) \
147 SCM_SNARF_HERE(static SCM CFN (SCM xorig, SCM env)) \
148 SCM_SNARF_INIT(scm_c_define (STR, scm_i_make_primitive_macro (STR, CFN)))
151 /* True primitive syntax */
152 SCM_SYNTAX ("@", expand_at
);
153 SCM_SYNTAX ("@@", expand_atat
);
154 SCM_SYNTAX ("begin", expand_begin
);
155 SCM_SYNTAX ("define", expand_define
);
156 SCM_SYNTAX ("eval-when", expand_eval_when
);
157 SCM_SYNTAX ("if", expand_if
);
158 SCM_SYNTAX ("lambda", expand_lambda
);
159 SCM_SYNTAX ("let", expand_let
);
160 SCM_SYNTAX ("quote", expand_quote
);
161 SCM_SYNTAX ("set!", expand_set_x
);
163 /* Convenient syntax during boot, expands to primitive syntax. Replaced after
165 SCM_SYNTAX ("and", expand_and
);
166 SCM_SYNTAX ("cond", expand_cond
);
167 SCM_SYNTAX ("letrec", expand_letrec
);
168 SCM_SYNTAX ("letrec*", expand_letrec_star
);
169 SCM_SYNTAX ("let*", expand_letstar
);
170 SCM_SYNTAX ("or", expand_or
);
171 SCM_SYNTAX ("lambda*", expand_lambda_star
);
172 SCM_SYNTAX ("case-lambda", expand_case_lambda
);
173 SCM_SYNTAX ("case-lambda*", expand_case_lambda_star
);
176 SCM_GLOBAL_SYMBOL (scm_sym_apply
, "apply");
177 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
178 SCM_GLOBAL_SYMBOL (scm_sym_at
, "@");
179 SCM_GLOBAL_SYMBOL (scm_sym_atat
, "@@");
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_else
, "else");
185 SCM_GLOBAL_SYMBOL (scm_sym_eval_when
, "eval-when");
186 SCM_GLOBAL_SYMBOL (scm_sym_if
, "if");
187 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, "lambda");
188 SCM_GLOBAL_SYMBOL (scm_sym_let
, "let");
189 SCM_GLOBAL_SYMBOL (scm_sym_letrec
, "letrec");
190 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, "let*");
191 SCM_GLOBAL_SYMBOL (scm_sym_or
, "or");
192 SCM_SYMBOL (sym_call_with_prompt
, "call-with-prompt");
193 SCM_GLOBAL_SYMBOL (scm_sym_quote
, "quote");
194 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, "set!");
195 SCM_SYMBOL (sym_lambda_star
, "lambda*");
196 SCM_SYMBOL (sym_eval
, "eval");
197 SCM_SYMBOL (sym_load
, "load");
198 SCM_SYMBOL (sym_primitive
, "primitive");
200 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
201 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, "quasiquote");
202 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
204 SCM_KEYWORD (kw_allow_other_keys
, "allow-other-keys");
205 SCM_KEYWORD (kw_optional
, "optional");
206 SCM_KEYWORD (kw_key
, "key");
207 SCM_KEYWORD (kw_rest
, "rest");
213 /* Signal a syntax error. We distinguish between the form that caused the
214 * error and the enclosing expression. The error message will print out as
215 * shown in the following pattern. The file name and line number are only
216 * given when they can be determined from the erroneous form or from the
217 * enclosing expression.
219 * <filename>: In procedure memoization:
220 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
223 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
225 SCM msg_string
= scm_from_locale_string (msg
);
226 SCM filename
= SCM_BOOL_F
;
227 SCM linenr
= SCM_BOOL_F
;
231 if (scm_is_pair (form
))
233 filename
= scm_source_property (form
, scm_sym_filename
);
234 linenr
= scm_source_property (form
, scm_sym_line
);
237 if (scm_is_false (filename
) && scm_is_false (linenr
) && scm_is_pair (expr
))
239 filename
= scm_source_property (expr
, scm_sym_filename
);
240 linenr
= scm_source_property (expr
, scm_sym_line
);
243 if (!SCM_UNBNDP (expr
))
245 if (scm_is_true (filename
))
247 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
248 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
250 else if (scm_is_true (linenr
))
252 format
= "In line ~S: ~A ~S in expression ~S.";
253 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
257 format
= "~A ~S in expression ~S.";
258 args
= scm_list_3 (msg_string
, form
, expr
);
263 if (scm_is_true (filename
))
265 format
= "In file ~S, line ~S: ~A ~S.";
266 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
268 else if (scm_is_true (linenr
))
270 format
= "In line ~S: ~A ~S.";
271 args
= scm_list_3 (linenr
, msg_string
, form
);
276 args
= scm_list_2 (msg_string
, form
);
280 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
288 expand_env_var_is_free (SCM env
, SCM x
)
290 for (; scm_is_pair (env
); env
= CDR (env
))
291 if (scm_is_eq (x
, CAAR (env
)))
292 return 0; /* bound */
297 expand_env_ref_macro (SCM env
, SCM x
)
300 if (!expand_env_var_is_free (env
, x
))
301 return SCM_BOOL_F
; /* lexical */
303 var
= scm_module_variable (scm_current_module (), x
);
304 if (scm_is_true (var
) && scm_is_true (scm_variable_bound_p (var
))
305 && scm_is_true (scm_macro_p (scm_variable_ref (var
))))
306 return scm_variable_ref (var
);
308 return SCM_BOOL_F
; /* anything else */
312 expand_env_lexical_gensym (SCM env
, SCM name
)
314 for (; scm_is_pair (env
); env
= CDR (env
))
315 if (scm_is_eq (name
, CAAR (env
)))
316 return CDAR (env
); /* bound */
317 return SCM_BOOL_F
; /* free */
321 expand_env_extend (SCM env
, SCM names
, SCM vars
)
323 while (scm_is_pair (names
))
325 env
= scm_acons (CAR (names
), CAR (vars
), env
);
333 expand (SCM exp
, SCM env
)
335 if (scm_is_pair (exp
))
338 scm_t_macro_primitive trans
= NULL
;
339 SCM macro
= SCM_BOOL_F
;
342 if (scm_is_symbol (car
))
343 macro
= expand_env_ref_macro (env
, car
);
345 if (scm_is_true (macro
))
346 trans
= scm_i_macro_primitive (macro
);
349 return trans (exp
, env
);
352 SCM arg_exps
= SCM_EOL
;
354 SCM proc
= expand (CAR (exp
), env
);
356 for (arg_exps
= CDR (exp
); scm_is_pair (arg_exps
);
357 arg_exps
= CDR (arg_exps
))
358 args
= scm_cons (expand (CAR (arg_exps
), env
), args
);
359 args
= scm_reverse_x (args
, SCM_UNDEFINED
);
361 if (!scm_is_null (arg_exps
))
362 syntax_error ("expected a proper list", exp
, SCM_UNDEFINED
);
364 if (SCM_EXPANDED_TYPE (proc
) == SCM_EXPANDED_PRIMITIVE_REF
)
365 return PRIMCALL (scm_source_properties (exp
),
366 SCM_EXPANDED_REF (proc
, PRIMITIVE_REF
, NAME
),
369 return CALL (scm_source_properties (exp
), proc
, args
);
372 else if (scm_is_symbol (exp
))
374 SCM gensym
= expand_env_lexical_gensym (env
, exp
);
375 if (scm_is_true (gensym
))
376 return LEXICAL_REF (SCM_BOOL_F
, exp
, gensym
);
378 return TOPLEVEL_REF (SCM_BOOL_F
, exp
);
381 return CONST_ (SCM_BOOL_F
, exp
);
385 expand_exprs (SCM forms
, const SCM env
)
389 for (; !scm_is_null (forms
); forms
= CDR (forms
))
390 ret
= scm_cons (expand (CAR (forms
), env
), ret
);
391 return scm_reverse_x (ret
, SCM_UNDEFINED
);
395 expand_sequence (const SCM forms
, const SCM env
)
397 ASSERT_SYNTAX (scm_ilength (forms
) >= 1, s_bad_expression
,
398 scm_cons (scm_sym_begin
, forms
));
399 if (scm_is_null (CDR (forms
)))
400 return expand (CAR (forms
), env
);
402 return SEQ (scm_source_properties (forms
),
403 expand (CAR (forms
), env
),
404 expand_sequence (CDR (forms
), env
));
412 expand_at (SCM expr
, SCM env SCM_UNUSED
)
414 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
415 ASSERT_SYNTAX (scm_ilength (CADR (expr
)) > 0, s_bad_expression
, expr
);
416 ASSERT_SYNTAX (scm_is_symbol (CADDR (expr
)), s_bad_expression
, expr
);
418 return MODULE_REF (scm_source_properties (expr
),
419 CADR (expr
), CADDR (expr
), SCM_BOOL_T
);
423 expand_atat (SCM expr
, SCM env SCM_UNUSED
)
425 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
426 ASSERT_SYNTAX (scm_is_symbol (CADDR (expr
)), s_bad_expression
, expr
);
428 if (scm_is_eq (CADR (expr
), sym_primitive
))
429 return PRIMITIVE_REF (scm_source_properties (expr
), CADDR (expr
));
431 ASSERT_SYNTAX (scm_ilength (CADR (expr
)) > 0, s_bad_expression
, expr
);
432 return MODULE_REF (scm_source_properties (expr
),
433 CADR (expr
), CADDR (expr
), SCM_BOOL_F
);
437 expand_and (SCM expr
, SCM env
)
439 const SCM cdr_expr
= CDR (expr
);
441 if (scm_is_null (cdr_expr
))
442 return CONST_ (SCM_BOOL_F
, SCM_BOOL_T
);
444 ASSERT_SYNTAX (scm_is_pair (cdr_expr
), s_bad_expression
, expr
);
446 if (scm_is_null (CDR (cdr_expr
)))
447 return expand (CAR (cdr_expr
), env
);
449 return CONDITIONAL (scm_source_properties (expr
),
450 expand (CAR (cdr_expr
), env
),
451 expand_and (cdr_expr
, env
),
452 CONST_ (SCM_BOOL_F
, SCM_BOOL_F
));
456 expand_begin (SCM expr
, SCM env
)
458 const SCM cdr_expr
= CDR (expr
);
459 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_bad_expression
, expr
);
460 return expand_sequence (cdr_expr
, env
);
464 expand_cond_clauses (SCM clause
, SCM rest
, int elp
, int alp
, SCM env
)
467 const long length
= scm_ilength (clause
);
468 ASSERT_SYNTAX (length
>= 1, s_bad_cond_clause
, clause
);
471 if (scm_is_eq (test
, scm_sym_else
) && elp
)
473 const int last_clause_p
= scm_is_null (rest
);
474 ASSERT_SYNTAX (length
>= 2, s_bad_cond_clause
, clause
);
475 ASSERT_SYNTAX (last_clause_p
, s_misplaced_else_clause
, clause
);
476 return expand_sequence (CDR (clause
), env
);
479 if (scm_is_null (rest
))
480 rest
= VOID_ (SCM_BOOL_F
);
482 rest
= expand_cond_clauses (CAR (rest
), CDR (rest
), elp
, alp
, env
);
485 && scm_is_eq (CADR (clause
), scm_sym_arrow
)
488 SCM tmp
= scm_gensym (scm_from_locale_string ("cond "));
489 SCM new_env
= scm_acons (tmp
, tmp
, env
);
490 ASSERT_SYNTAX (length
> 2, s_missing_recipient
, clause
);
491 ASSERT_SYNTAX (length
== 3, s_extra_expression
, clause
);
492 return LET (SCM_BOOL_F
,
495 scm_list_1 (expand (test
, env
)),
496 CONDITIONAL (SCM_BOOL_F
,
497 LEXICAL_REF (SCM_BOOL_F
, tmp
, tmp
),
499 expand (CADDR (clause
), new_env
),
500 scm_list_1 (LEXICAL_REF (SCM_BOOL_F
,
504 /* FIXME length == 1 case */
506 return CONDITIONAL (SCM_BOOL_F
,
508 expand_sequence (CDR (clause
), env
),
513 expand_cond (SCM expr
, SCM env
)
515 const int else_literal_p
= expand_env_var_is_free (env
, scm_sym_else
);
516 const int arrow_literal_p
= expand_env_var_is_free (env
, scm_sym_arrow
);
517 const SCM clauses
= CDR (expr
);
519 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
520 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
522 return expand_cond_clauses (CAR (clauses
), CDR (clauses
),
523 else_literal_p
, arrow_literal_p
, env
);
526 /* lone forward decl */
527 static SCM
expand_lambda (SCM expr
, SCM env
);
529 /* According to Section 5.2.1 of R5RS we first have to make sure that the
530 variable is bound, and then perform the `(set! variable expression)'
531 operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
532 bound. This means that EXPRESSION won't necessarily be able to assign
533 values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
535 expand_define (SCM expr
, SCM env
)
537 const SCM cdr_expr
= CDR (expr
);
541 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
542 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
543 ASSERT_SYNTAX (!scm_is_pair (env
), s_bad_define
, expr
);
545 body
= CDR (cdr_expr
);
546 variable
= CAR (cdr_expr
);
548 if (scm_is_pair (variable
))
550 ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable
)), s_bad_variable
, variable
, expr
);
551 return TOPLEVEL_DEFINE
552 (scm_source_properties (expr
),
554 expand_lambda (scm_cons (scm_sym_lambda
, scm_cons (CDR (variable
), body
)),
557 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
558 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
559 return TOPLEVEL_DEFINE (scm_source_properties (expr
), variable
,
560 expand (CAR (body
), env
));
564 expand_eval_when (SCM expr
, SCM env
)
566 ASSERT_SYNTAX (scm_ilength (expr
) >= 3, s_bad_expression
, expr
);
567 ASSERT_SYNTAX (scm_ilength (CADR (expr
)) > 0, s_bad_expression
, expr
);
569 if (scm_is_true (scm_memq (sym_eval
, CADR (expr
)))
570 || scm_is_true (scm_memq (sym_load
, CADR (expr
))))
571 return expand_sequence (CDDR (expr
), env
);
573 return VOID_ (scm_source_properties (expr
));
577 expand_if (SCM expr
, SCM env SCM_UNUSED
)
579 const SCM cdr_expr
= CDR (expr
);
580 const long length
= scm_ilength (cdr_expr
);
581 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
582 return CONDITIONAL (scm_source_properties (expr
),
583 expand (CADR (expr
), env
),
584 expand (CADDR (expr
), env
),
586 ? expand (CADDDR (expr
), env
)
587 : VOID_ (SCM_BOOL_F
)));
590 /* A helper function for expand_lambda to support checking for duplicate
591 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
592 * LIST or to the CDR of the last cons. Therefore, LIST may have any of the
593 * forms that a formal argument can have:
594 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
596 c_improper_memq (SCM obj
, SCM list
)
598 for (; scm_is_pair (list
); list
= CDR (list
))
600 if (scm_is_eq (CAR (list
), obj
))
603 return scm_is_eq (list
, obj
);
607 expand_lambda_case (SCM clause
, SCM alternate
, SCM env
)
616 ASSERT_SYNTAX (scm_is_pair (clause
) && scm_is_pair (CDR (clause
)),
617 s_bad_expression
, scm_cons (scm_sym_lambda
, clause
));
619 /* Before iterating the list of formal arguments, make sure the formals
620 * actually are given as either a symbol or a non-cyclic list. */
621 formals
= CAR (clause
);
622 if (scm_is_pair (formals
))
624 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
625 * detected, report a 'Bad formals' error. */
628 ASSERT_SYNTAX_2 (scm_is_symbol (formals
) || scm_is_null (formals
),
629 s_bad_formals
, formals
, scm_cons (scm_sym_lambda
, clause
));
631 /* Now iterate the list of formal arguments to check if all formals are
632 * symbols, and that there are no duplicates. */
633 while (scm_is_pair (formals
))
635 const SCM formal
= CAR (formals
);
636 formals
= CDR (formals
);
637 ASSERT_SYNTAX_2 (scm_is_symbol (formal
), s_bad_formal
, formal
,
638 scm_cons (scm_sym_lambda
, clause
));
639 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, formals
), s_duplicate_formal
,
640 formal
, scm_cons (scm_sym_lambda
, clause
));
642 req
= scm_cons (formal
, req
);
643 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
644 env
= scm_acons (formal
, CAR (vars
), env
);
647 ASSERT_SYNTAX_2 (scm_is_null (formals
) || scm_is_symbol (formals
),
648 s_bad_formal
, formals
, scm_cons (scm_sym_lambda
, clause
));
649 if (scm_is_symbol (formals
))
652 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
653 env
= scm_acons (rest
, CAR (vars
), env
);
658 body
= expand_sequence (CDR (clause
), env
);
659 req
= scm_reverse_x (req
, SCM_UNDEFINED
);
660 vars
= scm_reverse_x (vars
, SCM_UNDEFINED
);
662 if (scm_is_true (alternate
) && !(SCM_EXPANDED_P (alternate
) && SCM_EXPANDED_TYPE (alternate
) == SCM_EXPANDED_LAMBDA_CASE
))
665 return LAMBDA_CASE (SCM_BOOL_F
, req
, SCM_BOOL_F
, rest
, SCM_BOOL_F
,
666 SCM_EOL
, vars
, body
, alternate
);
670 expand_lambda (SCM expr
, SCM env
)
672 return LAMBDA (scm_source_properties (expr
),
674 expand_lambda_case (CDR (expr
), SCM_BOOL_F
, env
));
678 expand_lambda_star_case (SCM clause
, SCM alternate
, SCM env
)
680 SCM req
, opt
, kw
, allow_other_keys
, rest
, formals
, vars
, body
, tmp
;
684 const long length
= scm_ilength (clause
);
685 ASSERT_SYNTAX (length
>= 1, s_bad_expression
,
686 scm_cons (sym_lambda_star
, clause
));
687 ASSERT_SYNTAX (length
>= 2, s_missing_expression
,
688 scm_cons (sym_lambda_star
, clause
));
690 formals
= CAR (clause
);
694 req
= opt
= kw
= SCM_EOL
;
695 rest
= allow_other_keys
= SCM_BOOL_F
;
697 while (scm_is_pair (formals
) && scm_is_symbol (CAR (formals
)))
700 req
= scm_cons (CAR (formals
), req
);
701 formals
= scm_cdr (formals
);
704 if (scm_is_pair (formals
) && scm_is_eq (CAR (formals
), kw_optional
))
706 formals
= CDR (formals
);
707 while (scm_is_pair (formals
)
708 && (scm_is_symbol (CAR (formals
)) || scm_is_pair (CAR (formals
))))
711 opt
= scm_cons (CAR (formals
), opt
);
712 formals
= scm_cdr (formals
);
716 if (scm_is_pair (formals
) && scm_is_eq (CAR (formals
), kw_key
))
718 formals
= CDR (formals
);
719 while (scm_is_pair (formals
)
720 && (scm_is_symbol (CAR (formals
)) || scm_is_pair (CAR (formals
))))
722 kw
= scm_cons (CAR (formals
), kw
);
723 formals
= scm_cdr (formals
);
727 if (scm_is_pair (formals
) && scm_is_eq (CAR (formals
), kw_allow_other_keys
))
729 formals
= CDR (formals
);
730 allow_other_keys
= SCM_BOOL_T
;
733 if (scm_is_pair (formals
) && scm_is_eq (CAR (formals
), kw_rest
))
735 ASSERT_SYNTAX (scm_ilength (formals
) == 2, s_bad_formals
,
737 rest
= CADR (formals
);
739 else if (scm_is_symbol (formals
))
743 ASSERT_SYNTAX (scm_is_null (formals
), s_bad_formals
, CAR (clause
));
747 /* Now, iterate through them a second time, building up an expansion-time
748 environment, checking, expanding and canonicalizing the opt/kw init forms,
749 and eventually memoizing the body as well. Note that the rest argument, if
750 any, is expanded before keyword args, thus necessitating the second
753 Also note that the specific environment during expansion of init
754 expressions here needs to coincide with the environment when psyntax
755 expands. A lot of effort for something that is only used in the bootstrap
756 expandr, you say? Yes. Yes it is.
760 req
= scm_reverse_x (req
, SCM_EOL
);
761 for (tmp
= req
; scm_is_pair (tmp
); tmp
= scm_cdr (tmp
))
763 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
764 env
= scm_acons (CAR (tmp
), CAR (vars
), env
);
767 /* Build up opt inits and env */
769 opt
= scm_reverse_x (opt
, SCM_EOL
);
770 for (tmp
= opt
; scm_is_pair (tmp
); tmp
= scm_cdr (tmp
))
773 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
774 env
= scm_acons (x
, CAR (vars
), env
);
775 if (scm_is_symbol (x
))
776 inits
= scm_cons (CONST_ (SCM_BOOL_F
, SCM_BOOL_F
), inits
);
779 ASSERT_SYNTAX (scm_ilength (x
) == 2 && scm_is_symbol (CAR (x
)),
780 s_bad_formals
, CAR (clause
));
781 inits
= scm_cons (expand (CADR (x
), env
), inits
);
783 env
= scm_acons (scm_is_symbol (x
) ? x
: CAR (x
), CAR (vars
), env
);
785 if (scm_is_null (opt
))
788 /* Process rest before keyword args */
789 if (scm_is_true (rest
))
791 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
792 env
= scm_acons (rest
, CAR (vars
), env
);
795 /* Build up kw inits, env, and kw-canon list */
796 if (scm_is_null (kw
))
800 SCM kw_canon
= SCM_EOL
;
801 kw
= scm_reverse_x (kw
, SCM_UNDEFINED
);
802 for (tmp
= kw
; scm_is_pair (tmp
); tmp
= scm_cdr (tmp
))
806 if (scm_is_symbol (x
))
810 k
= scm_symbol_to_keyword (sym
);
812 else if (scm_ilength (x
) == 2 && scm_is_symbol (CAR (x
)))
816 k
= scm_symbol_to_keyword (sym
);
818 else if (scm_ilength (x
) == 3 && scm_is_symbol (CAR (x
))
819 && scm_is_keyword (CADDR (x
)))
826 syntax_error (s_bad_formals
, CAR (clause
), SCM_UNDEFINED
);
828 inits
= scm_cons (expand (init
, env
), inits
);
829 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
830 kw_canon
= scm_cons (scm_list_3 (k
, sym
, CAR (vars
)), kw_canon
);
831 env
= scm_acons (sym
, CAR (vars
), env
);
833 kw_canon
= scm_reverse_x (kw_canon
, SCM_UNDEFINED
);
834 kw
= scm_cons (allow_other_keys
, kw_canon
);
837 /* We should check for no duplicates, but given that psyntax does this
838 already, we can punt on it here... */
840 vars
= scm_reverse_x (vars
, SCM_UNDEFINED
);
841 inits
= scm_reverse_x (inits
, SCM_UNDEFINED
);
842 body
= expand_sequence (body
, env
);
844 return LAMBDA_CASE (SCM_BOOL_F
, req
, opt
, rest
, kw
, inits
, vars
, body
,
849 expand_lambda_star (SCM expr
, SCM env
)
851 return LAMBDA (scm_source_properties (expr
),
853 expand_lambda_star_case (CDR (expr
), SCM_BOOL_F
, env
));
857 expand_case_lambda_clauses (SCM expr
, SCM rest
, SCM env
)
861 if (scm_is_pair (rest
))
862 alt
= expand_case_lambda_clauses (CAR (rest
), CDR (rest
), env
);
866 return expand_lambda_case (expr
, alt
, env
);
870 expand_case_lambda (SCM expr
, SCM env
)
872 ASSERT_SYNTAX (scm_is_pair (CDR (expr
)), s_missing_expression
, expr
);
874 return LAMBDA (scm_source_properties (expr
),
876 expand_case_lambda_clauses (CADR (expr
), CDDR (expr
), env
));
880 expand_case_lambda_star_clauses (SCM expr
, SCM rest
, SCM env
)
884 if (scm_is_pair (rest
))
885 alt
= expand_case_lambda_star_clauses (CAR (rest
), CDR (rest
), env
);
889 return expand_lambda_star_case (expr
, alt
, env
);
893 expand_case_lambda_star (SCM expr
, SCM env
)
895 ASSERT_SYNTAX (scm_is_pair (CDR (expr
)), s_missing_expression
, expr
);
897 return LAMBDA (scm_source_properties (expr
),
899 expand_case_lambda_star_clauses (CADR (expr
), CDDR (expr
), env
));
902 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
904 check_bindings (const SCM bindings
, const SCM expr
)
908 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
909 s_bad_bindings
, bindings
, expr
);
911 binding_idx
= bindings
;
912 for (; !scm_is_null (binding_idx
); binding_idx
= CDR (binding_idx
))
914 SCM name
; /* const */
916 const SCM binding
= CAR (binding_idx
);
917 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
918 s_bad_binding
, binding
, expr
);
920 name
= CAR (binding
);
921 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
925 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
926 * transformed to the lists (vn .. v2 v1) and (i1 i2 ... in). If a duplicate
927 * variable name is detected, an error is signalled. */
929 transform_bindings (const SCM bindings
, const SCM expr
,
930 SCM
*const names
, SCM
*const vars
, SCM
*const initptr
)
932 SCM rnames
= SCM_EOL
;
934 SCM rinits
= SCM_EOL
;
935 SCM binding_idx
= bindings
;
936 for (; !scm_is_null (binding_idx
); binding_idx
= CDR (binding_idx
))
938 const SCM binding
= CAR (binding_idx
);
939 const SCM CDR_binding
= CDR (binding
);
940 const SCM name
= CAR (binding
);
941 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rnames
)),
942 s_duplicate_binding
, name
, expr
);
943 rnames
= scm_cons (name
, rnames
);
944 rvars
= scm_cons (scm_gensym (SCM_UNDEFINED
), rvars
);
945 rinits
= scm_cons (CAR (CDR_binding
), rinits
);
947 *names
= scm_reverse_x (rnames
, SCM_UNDEFINED
);
948 *vars
= scm_reverse_x (rvars
, SCM_UNDEFINED
);
949 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
952 /* FIXME: Remove named let in this boot expander. */
954 expand_named_let (const SCM expr
, SCM env
)
956 SCM var_names
, var_syms
, inits
;
960 const SCM cdr_expr
= CDR (expr
);
961 const SCM name
= CAR (cdr_expr
);
962 const SCM cddr_expr
= CDR (cdr_expr
);
963 const SCM bindings
= CAR (cddr_expr
);
964 check_bindings (bindings
, expr
);
966 transform_bindings (bindings
, expr
, &var_names
, &var_syms
, &inits
);
967 name_sym
= scm_gensym (SCM_UNDEFINED
);
968 inner_env
= scm_acons (name
, name_sym
, env
);
969 inner_env
= expand_env_extend (inner_env
, var_names
, var_syms
);
972 (scm_source_properties (expr
), SCM_BOOL_F
,
973 scm_list_1 (name
), scm_list_1 (name_sym
),
974 scm_list_1 (LAMBDA (SCM_BOOL_F
,
976 LAMBDA_CASE (SCM_BOOL_F
, var_names
, SCM_BOOL_F
, SCM_BOOL_F
,
977 SCM_BOOL_F
, SCM_BOOL_F
, var_syms
,
978 expand_sequence (CDDDR (expr
), inner_env
),
981 LEXICAL_REF (SCM_BOOL_F
, name
, name_sym
),
982 expand_exprs (inits
, env
)));
986 expand_let (SCM expr
, SCM env
)
990 const SCM cdr_expr
= CDR (expr
);
991 const long length
= scm_ilength (cdr_expr
);
992 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
993 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
995 bindings
= CAR (cdr_expr
);
996 if (scm_is_symbol (bindings
))
998 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
999 return expand_named_let (expr
, env
);
1002 check_bindings (bindings
, expr
);
1003 if (scm_is_null (bindings
))
1004 return expand_sequence (CDDR (expr
), env
);
1007 SCM var_names
, var_syms
, inits
;
1008 transform_bindings (bindings
, expr
, &var_names
, &var_syms
, &inits
);
1009 return LET (SCM_BOOL_F
,
1010 var_names
, var_syms
, expand_exprs (inits
, env
),
1011 expand_sequence (CDDR (expr
),
1012 expand_env_extend (env
, var_names
,
1018 expand_letrec_helper (SCM expr
, SCM env
, SCM in_order_p
)
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 check_bindings (bindings
, expr
);
1029 if (scm_is_null (bindings
))
1030 return expand_sequence (CDDR (expr
), env
);
1033 SCM var_names
, var_syms
, inits
;
1034 transform_bindings (bindings
, expr
, &var_names
, &var_syms
, &inits
);
1035 env
= expand_env_extend (env
, var_names
, var_syms
);
1036 return LETREC (SCM_BOOL_F
, in_order_p
,
1037 var_names
, var_syms
, expand_exprs (inits
, env
),
1038 expand_sequence (CDDR (expr
), env
));
1043 expand_letrec (SCM expr
, SCM env
)
1045 return expand_letrec_helper (expr
, env
, SCM_BOOL_F
);
1049 expand_letrec_star (SCM expr
, SCM env
)
1051 return expand_letrec_helper (expr
, env
, SCM_BOOL_T
);
1055 expand_letstar_clause (SCM bindings
, SCM body
, SCM env SCM_UNUSED
)
1057 if (scm_is_null (bindings
))
1058 return expand_sequence (body
, env
);
1061 SCM bind
, name
, sym
, init
;
1063 ASSERT_SYNTAX (scm_is_pair (bindings
), s_bad_expression
, bindings
);
1064 bind
= CAR (bindings
);
1065 ASSERT_SYNTAX (scm_ilength (bind
) == 2, s_bad_binding
, bind
);
1067 sym
= scm_gensym (SCM_UNDEFINED
);
1070 return LET (SCM_BOOL_F
, scm_list_1 (name
), scm_list_1 (sym
),
1071 scm_list_1 (expand (init
, env
)),
1072 expand_letstar_clause (CDR (bindings
), body
,
1073 scm_acons (name
, sym
, env
)));
1078 expand_letstar (SCM expr
, SCM env SCM_UNUSED
)
1080 const SCM cdr_expr
= CDR (expr
);
1081 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1082 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1084 return expand_letstar_clause (CADR (expr
), CDDR (expr
), env
);
1088 expand_or (SCM expr
, SCM env SCM_UNUSED
)
1090 SCM tail
= CDR (expr
);
1091 const long length
= scm_ilength (tail
);
1093 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1095 if (scm_is_null (CDR (expr
)))
1096 return CONST_ (SCM_BOOL_F
, SCM_BOOL_F
);
1099 SCM tmp
= scm_gensym (SCM_UNDEFINED
);
1100 return LET (SCM_BOOL_F
,
1101 scm_list_1 (tmp
), scm_list_1 (tmp
),
1102 scm_list_1 (expand (CADR (expr
), env
)),
1103 CONDITIONAL (SCM_BOOL_F
,
1104 LEXICAL_REF (SCM_BOOL_F
, tmp
, tmp
),
1105 LEXICAL_REF (SCM_BOOL_F
, tmp
, tmp
),
1106 expand_or (CDR (expr
),
1107 scm_acons (tmp
, tmp
, env
))));
1112 expand_quote (SCM expr
, SCM env SCM_UNUSED
)
1116 const SCM cdr_expr
= CDR (expr
);
1117 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1118 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1119 quotee
= CAR (cdr_expr
);
1120 return CONST_ (scm_source_properties (expr
), quotee
);
1124 expand_set_x (SCM expr
, SCM env
)
1129 const SCM cdr_expr
= CDR (expr
);
1130 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1131 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1132 variable
= CAR (cdr_expr
);
1133 vmem
= expand (variable
, env
);
1135 switch (SCM_EXPANDED_TYPE (vmem
))
1137 case SCM_EXPANDED_LEXICAL_REF
:
1138 return LEXICAL_SET (scm_source_properties (expr
),
1139 SCM_EXPANDED_REF (vmem
, LEXICAL_REF
, NAME
),
1140 SCM_EXPANDED_REF (vmem
, LEXICAL_REF
, GENSYM
),
1141 expand (CADDR (expr
), env
));
1142 case SCM_EXPANDED_TOPLEVEL_REF
:
1143 return TOPLEVEL_SET (scm_source_properties (expr
),
1144 SCM_EXPANDED_REF (vmem
, TOPLEVEL_REF
, NAME
),
1145 expand (CADDR (expr
), env
));
1146 case SCM_EXPANDED_MODULE_REF
:
1147 return MODULE_SET (scm_source_properties (expr
),
1148 SCM_EXPANDED_REF (vmem
, MODULE_REF
, MOD
),
1149 SCM_EXPANDED_REF (vmem
, MODULE_REF
, NAME
),
1150 SCM_EXPANDED_REF (vmem
, MODULE_REF
, PUBLIC
),
1151 expand (CADDR (expr
), env
));
1153 syntax_error (s_bad_variable
, variable
, expr
);
1160 /* This is the boot expander. It is later replaced with psyntax's sc-expand. */
1161 SCM_DEFINE (scm_macroexpand
, "macroexpand", 1, 0, 0,
1163 "Expand the expression @var{exp}.")
1164 #define FUNC_NAME s_scm_macroexpand
1166 return expand (exp
, scm_current_module ());
1170 SCM_DEFINE (scm_macroexpanded_p
, "macroexpanded?", 1, 0, 0,
1172 "Return @code{#t} if @var{exp} is an expanded expression.")
1173 #define FUNC_NAME s_scm_macroexpanded_p
1175 return scm_from_bool (SCM_EXPANDED_P (exp
));
1182 #define DEFINE_NAMES(type) \
1184 static const char *fields[] = SCM_EXPANDED_##type##_FIELD_NAMES; \
1185 exp_field_names[SCM_EXPANDED_##type] = fields; \
1186 exp_names[SCM_EXPANDED_##type] = SCM_EXPANDED_##type##_TYPE_NAME; \
1187 exp_nfields[SCM_EXPANDED_##type] = SCM_NUM_EXPANDED_##type##_FIELDS; \
1191 make_exp_vtable (size_t n
)
1193 SCM layout
, printer
, name
, code
, fields
;
1195 layout
= scm_string_to_symbol
1196 (scm_string_append (scm_make_list (scm_from_size_t (exp_nfields
[n
]),
1197 scm_from_locale_string ("pw"))));
1198 printer
= SCM_BOOL_F
;
1199 name
= scm_from_utf8_symbol (exp_names
[n
]);
1200 code
= scm_from_size_t (n
);
1203 size_t m
= exp_nfields
[n
];
1205 fields
= scm_cons (scm_from_utf8_symbol (exp_field_names
[n
][m
]), fields
);
1208 return scm_c_make_struct (scm_exp_vtable_vtable
, 0, 5,
1209 SCM_UNPACK (layout
), SCM_UNPACK (printer
), SCM_UNPACK (name
),
1210 SCM_UNPACK (code
), SCM_UNPACK (fields
));
1217 SCM exp_vtable_list
= SCM_EOL
;
1219 DEFINE_NAMES (VOID
);
1220 DEFINE_NAMES (CONST
);
1221 DEFINE_NAMES (PRIMITIVE_REF
);
1222 DEFINE_NAMES (LEXICAL_REF
);
1223 DEFINE_NAMES (LEXICAL_SET
);
1224 DEFINE_NAMES (MODULE_REF
);
1225 DEFINE_NAMES (MODULE_SET
);
1226 DEFINE_NAMES (TOPLEVEL_REF
);
1227 DEFINE_NAMES (TOPLEVEL_SET
);
1228 DEFINE_NAMES (TOPLEVEL_DEFINE
);
1229 DEFINE_NAMES (CONDITIONAL
);
1230 DEFINE_NAMES (CALL
);
1231 DEFINE_NAMES (PRIMCALL
);
1233 DEFINE_NAMES (LAMBDA
);
1234 DEFINE_NAMES (LAMBDA_CASE
);
1236 DEFINE_NAMES (LETREC
);
1238 scm_exp_vtable_vtable
=
1239 scm_make_vtable (scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT
"pwuwpw"),
1242 for (n
= 0; n
< SCM_NUM_EXPANDED_TYPES
; n
++)
1243 exp_vtables
[n
] = make_exp_vtable (n
);
1245 /* Now walk back down, consing in reverse. */
1247 exp_vtable_list
= scm_cons (exp_vtables
[n
], exp_vtable_list
);
1249 scm_c_define ("%expanded-vtables", scm_vector (exp_vtable_list
));
1251 #include "libguile/expand.x"