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_arrow
, "=>");
177 SCM_GLOBAL_SYMBOL (scm_sym_at
, "@");
178 SCM_GLOBAL_SYMBOL (scm_sym_atat
, "@@");
179 SCM_GLOBAL_SYMBOL (scm_sym_begin
, "begin");
180 SCM_GLOBAL_SYMBOL (scm_sym_case
, "case");
181 SCM_GLOBAL_SYMBOL (scm_sym_cond
, "cond");
182 SCM_GLOBAL_SYMBOL (scm_sym_define
, "define");
183 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
184 SCM_GLOBAL_SYMBOL (scm_sym_eval_when
, "eval-when");
185 SCM_GLOBAL_SYMBOL (scm_sym_if
, "if");
186 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, "lambda");
187 SCM_GLOBAL_SYMBOL (scm_sym_let
, "let");
188 SCM_GLOBAL_SYMBOL (scm_sym_letrec
, "letrec");
189 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, "let*");
190 SCM_GLOBAL_SYMBOL (scm_sym_or
, "or");
191 SCM_SYMBOL (sym_call_with_prompt
, "call-with-prompt");
192 SCM_GLOBAL_SYMBOL (scm_sym_quote
, "quote");
193 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, "set!");
194 SCM_SYMBOL (sym_lambda_star
, "lambda*");
195 SCM_SYMBOL (sym_eval
, "eval");
196 SCM_SYMBOL (sym_load
, "load");
197 SCM_SYMBOL (sym_primitive
, "primitive");
199 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
200 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, "quasiquote");
201 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
203 SCM_KEYWORD (kw_allow_other_keys
, "allow-other-keys");
204 SCM_KEYWORD (kw_optional
, "optional");
205 SCM_KEYWORD (kw_key
, "key");
206 SCM_KEYWORD (kw_rest
, "rest");
212 /* Signal a syntax error. We distinguish between the form that caused the
213 * error and the enclosing expression. The error message will print out as
214 * shown in the following pattern. The file name and line number are only
215 * given when they can be determined from the erroneous form or from the
216 * enclosing expression.
218 * <filename>: In procedure memoization:
219 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
222 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
224 SCM msg_string
= scm_from_locale_string (msg
);
225 SCM filename
= SCM_BOOL_F
;
226 SCM linenr
= SCM_BOOL_F
;
230 if (scm_is_pair (form
))
232 filename
= scm_source_property (form
, scm_sym_filename
);
233 linenr
= scm_source_property (form
, scm_sym_line
);
236 if (scm_is_false (filename
) && scm_is_false (linenr
) && scm_is_pair (expr
))
238 filename
= scm_source_property (expr
, scm_sym_filename
);
239 linenr
= scm_source_property (expr
, scm_sym_line
);
242 if (!SCM_UNBNDP (expr
))
244 if (scm_is_true (filename
))
246 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
247 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
249 else if (scm_is_true (linenr
))
251 format
= "In line ~S: ~A ~S in expression ~S.";
252 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
256 format
= "~A ~S in expression ~S.";
257 args
= scm_list_3 (msg_string
, form
, expr
);
262 if (scm_is_true (filename
))
264 format
= "In file ~S, line ~S: ~A ~S.";
265 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
267 else if (scm_is_true (linenr
))
269 format
= "In line ~S: ~A ~S.";
270 args
= scm_list_3 (linenr
, msg_string
, form
);
275 args
= scm_list_2 (msg_string
, form
);
279 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
287 expand_env_var_is_free (SCM env
, SCM x
)
289 for (; scm_is_pair (env
); env
= CDR (env
))
290 if (scm_is_eq (x
, CAAR (env
)))
291 return 0; /* bound */
296 expand_env_ref_macro (SCM env
, SCM x
)
299 if (!expand_env_var_is_free (env
, x
))
300 return SCM_BOOL_F
; /* lexical */
302 var
= scm_module_variable (scm_current_module (), x
);
303 if (scm_is_true (var
) && scm_is_true (scm_variable_bound_p (var
))
304 && scm_is_true (scm_macro_p (scm_variable_ref (var
))))
305 return scm_variable_ref (var
);
307 return SCM_BOOL_F
; /* anything else */
311 expand_env_lexical_gensym (SCM env
, SCM name
)
313 for (; scm_is_pair (env
); env
= CDR (env
))
314 if (scm_is_eq (name
, CAAR (env
)))
315 return CDAR (env
); /* bound */
316 return SCM_BOOL_F
; /* free */
320 expand_env_extend (SCM env
, SCM names
, SCM vars
)
322 while (scm_is_pair (names
))
324 env
= scm_acons (CAR (names
), CAR (vars
), env
);
332 expand (SCM exp
, SCM env
)
334 if (scm_is_pair (exp
))
337 scm_t_macro_primitive trans
= NULL
;
338 SCM macro
= SCM_BOOL_F
;
341 if (scm_is_symbol (car
))
342 macro
= expand_env_ref_macro (env
, car
);
344 if (scm_is_true (macro
))
345 trans
= scm_i_macro_primitive (macro
);
348 return trans (exp
, env
);
351 SCM arg_exps
= SCM_EOL
;
353 SCM proc
= expand (CAR (exp
), env
);
355 for (arg_exps
= CDR (exp
); scm_is_pair (arg_exps
);
356 arg_exps
= CDR (arg_exps
))
357 args
= scm_cons (expand (CAR (arg_exps
), env
), args
);
358 args
= scm_reverse_x (args
, SCM_UNDEFINED
);
360 if (!scm_is_null (arg_exps
))
361 syntax_error ("expected a proper list", exp
, SCM_UNDEFINED
);
363 if (SCM_EXPANDED_TYPE (proc
) == SCM_EXPANDED_PRIMITIVE_REF
)
364 return PRIMCALL (scm_source_properties (exp
),
365 SCM_EXPANDED_REF (proc
, PRIMITIVE_REF
, NAME
),
368 return CALL (scm_source_properties (exp
), proc
, args
);
371 else if (scm_is_symbol (exp
))
373 SCM gensym
= expand_env_lexical_gensym (env
, exp
);
374 if (scm_is_true (gensym
))
375 return LEXICAL_REF (SCM_BOOL_F
, exp
, gensym
);
377 return TOPLEVEL_REF (SCM_BOOL_F
, exp
);
380 return CONST_ (SCM_BOOL_F
, exp
);
384 expand_exprs (SCM forms
, const SCM env
)
388 for (; !scm_is_null (forms
); forms
= CDR (forms
))
389 ret
= scm_cons (expand (CAR (forms
), env
), ret
);
390 return scm_reverse_x (ret
, SCM_UNDEFINED
);
394 expand_sequence (const SCM forms
, const SCM env
)
396 ASSERT_SYNTAX (scm_ilength (forms
) >= 1, s_bad_expression
,
397 scm_cons (scm_sym_begin
, forms
));
398 if (scm_is_null (CDR (forms
)))
399 return expand (CAR (forms
), env
);
401 return SEQ (scm_source_properties (forms
),
402 expand (CAR (forms
), env
),
403 expand_sequence (CDR (forms
), env
));
411 expand_at (SCM expr
, SCM env SCM_UNUSED
)
413 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
414 ASSERT_SYNTAX (scm_ilength (CADR (expr
)) > 0, s_bad_expression
, expr
);
415 ASSERT_SYNTAX (scm_is_symbol (CADDR (expr
)), s_bad_expression
, expr
);
417 return MODULE_REF (scm_source_properties (expr
),
418 CADR (expr
), CADDR (expr
), SCM_BOOL_T
);
422 expand_atat (SCM expr
, SCM env SCM_UNUSED
)
424 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
425 ASSERT_SYNTAX (scm_is_symbol (CADDR (expr
)), s_bad_expression
, expr
);
427 if (scm_is_eq (CADR (expr
), sym_primitive
))
428 return PRIMITIVE_REF (scm_source_properties (expr
), CADDR (expr
));
430 ASSERT_SYNTAX (scm_ilength (CADR (expr
)) > 0, s_bad_expression
, expr
);
431 return MODULE_REF (scm_source_properties (expr
),
432 CADR (expr
), CADDR (expr
), SCM_BOOL_F
);
436 expand_and (SCM expr
, SCM env
)
438 const SCM cdr_expr
= CDR (expr
);
440 if (scm_is_null (cdr_expr
))
441 return CONST_ (SCM_BOOL_F
, SCM_BOOL_T
);
443 ASSERT_SYNTAX (scm_is_pair (cdr_expr
), s_bad_expression
, expr
);
445 if (scm_is_null (CDR (cdr_expr
)))
446 return expand (CAR (cdr_expr
), env
);
448 return CONDITIONAL (scm_source_properties (expr
),
449 expand (CAR (cdr_expr
), env
),
450 expand_and (cdr_expr
, env
),
451 CONST_ (SCM_BOOL_F
, SCM_BOOL_F
));
455 expand_begin (SCM expr
, SCM env
)
457 const SCM cdr_expr
= CDR (expr
);
458 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_bad_expression
, expr
);
459 return expand_sequence (cdr_expr
, env
);
463 expand_cond_clauses (SCM clause
, SCM rest
, int elp
, int alp
, SCM env
)
466 const long length
= scm_ilength (clause
);
467 ASSERT_SYNTAX (length
>= 1, s_bad_cond_clause
, clause
);
470 if (scm_is_eq (test
, scm_sym_else
) && elp
)
472 const int last_clause_p
= scm_is_null (rest
);
473 ASSERT_SYNTAX (length
>= 2, s_bad_cond_clause
, clause
);
474 ASSERT_SYNTAX (last_clause_p
, s_misplaced_else_clause
, clause
);
475 return expand_sequence (CDR (clause
), env
);
478 if (scm_is_null (rest
))
479 rest
= VOID_ (SCM_BOOL_F
);
481 rest
= expand_cond_clauses (CAR (rest
), CDR (rest
), elp
, alp
, env
);
484 && scm_is_eq (CADR (clause
), scm_sym_arrow
)
487 SCM tmp
= scm_gensym (scm_from_locale_string ("cond "));
488 SCM new_env
= scm_acons (tmp
, tmp
, env
);
489 ASSERT_SYNTAX (length
> 2, s_missing_recipient
, clause
);
490 ASSERT_SYNTAX (length
== 3, s_extra_expression
, clause
);
491 return LET (SCM_BOOL_F
,
494 scm_list_1 (expand (test
, env
)),
495 CONDITIONAL (SCM_BOOL_F
,
496 LEXICAL_REF (SCM_BOOL_F
, tmp
, tmp
),
498 expand (CADDR (clause
), new_env
),
499 scm_list_1 (LEXICAL_REF (SCM_BOOL_F
,
503 /* FIXME length == 1 case */
505 return CONDITIONAL (SCM_BOOL_F
,
507 expand_sequence (CDR (clause
), env
),
512 expand_cond (SCM expr
, SCM env
)
514 const int else_literal_p
= expand_env_var_is_free (env
, scm_sym_else
);
515 const int arrow_literal_p
= expand_env_var_is_free (env
, scm_sym_arrow
);
516 const SCM clauses
= CDR (expr
);
518 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
519 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
521 return expand_cond_clauses (CAR (clauses
), CDR (clauses
),
522 else_literal_p
, arrow_literal_p
, env
);
525 /* lone forward decl */
526 static SCM
expand_lambda (SCM expr
, SCM env
);
528 /* According to Section 5.2.1 of R5RS we first have to make sure that the
529 variable is bound, and then perform the `(set! variable expression)'
530 operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
531 bound. This means that EXPRESSION won't necessarily be able to assign
532 values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
534 expand_define (SCM expr
, SCM env
)
536 const SCM cdr_expr
= CDR (expr
);
540 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
541 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
542 ASSERT_SYNTAX (!scm_is_pair (env
), s_bad_define
, expr
);
544 body
= CDR (cdr_expr
);
545 variable
= CAR (cdr_expr
);
547 if (scm_is_pair (variable
))
549 ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable
)), s_bad_variable
, variable
, expr
);
550 return TOPLEVEL_DEFINE
551 (scm_source_properties (expr
),
553 expand_lambda (scm_cons (scm_sym_lambda
, scm_cons (CDR (variable
), body
)),
556 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
557 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
558 return TOPLEVEL_DEFINE (scm_source_properties (expr
), variable
,
559 expand (CAR (body
), env
));
563 expand_eval_when (SCM expr
, SCM env
)
565 ASSERT_SYNTAX (scm_ilength (expr
) >= 3, s_bad_expression
, expr
);
566 ASSERT_SYNTAX (scm_ilength (CADR (expr
)) > 0, s_bad_expression
, expr
);
568 if (scm_is_true (scm_memq (sym_eval
, CADR (expr
)))
569 || scm_is_true (scm_memq (sym_load
, CADR (expr
))))
570 return expand_sequence (CDDR (expr
), env
);
572 return VOID_ (scm_source_properties (expr
));
576 expand_if (SCM expr
, SCM env SCM_UNUSED
)
578 const SCM cdr_expr
= CDR (expr
);
579 const long length
= scm_ilength (cdr_expr
);
580 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
581 return CONDITIONAL (scm_source_properties (expr
),
582 expand (CADR (expr
), env
),
583 expand (CADDR (expr
), env
),
585 ? expand (CADDDR (expr
), env
)
586 : VOID_ (SCM_BOOL_F
)));
589 /* A helper function for expand_lambda to support checking for duplicate
590 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
591 * LIST or to the CDR of the last cons. Therefore, LIST may have any of the
592 * forms that a formal argument can have:
593 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
595 c_improper_memq (SCM obj
, SCM list
)
597 for (; scm_is_pair (list
); list
= CDR (list
))
599 if (scm_is_eq (CAR (list
), obj
))
602 return scm_is_eq (list
, obj
);
606 expand_lambda_case (SCM clause
, SCM alternate
, SCM env
)
615 ASSERT_SYNTAX (scm_is_pair (clause
) && scm_is_pair (CDR (clause
)),
616 s_bad_expression
, scm_cons (scm_sym_lambda
, clause
));
618 /* Before iterating the list of formal arguments, make sure the formals
619 * actually are given as either a symbol or a non-cyclic list. */
620 formals
= CAR (clause
);
621 if (scm_is_pair (formals
))
623 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
624 * detected, report a 'Bad formals' error. */
627 ASSERT_SYNTAX_2 (scm_is_symbol (formals
) || scm_is_null (formals
),
628 s_bad_formals
, formals
, scm_cons (scm_sym_lambda
, clause
));
630 /* Now iterate the list of formal arguments to check if all formals are
631 * symbols, and that there are no duplicates. */
632 while (scm_is_pair (formals
))
634 const SCM formal
= CAR (formals
);
635 formals
= CDR (formals
);
636 ASSERT_SYNTAX_2 (scm_is_symbol (formal
), s_bad_formal
, formal
,
637 scm_cons (scm_sym_lambda
, clause
));
638 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, formals
), s_duplicate_formal
,
639 formal
, scm_cons (scm_sym_lambda
, clause
));
641 req
= scm_cons (formal
, req
);
642 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
643 env
= scm_acons (formal
, CAR (vars
), env
);
646 ASSERT_SYNTAX_2 (scm_is_null (formals
) || scm_is_symbol (formals
),
647 s_bad_formal
, formals
, scm_cons (scm_sym_lambda
, clause
));
648 if (scm_is_symbol (formals
))
651 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
652 env
= scm_acons (rest
, CAR (vars
), env
);
657 body
= expand_sequence (CDR (clause
), env
);
658 req
= scm_reverse_x (req
, SCM_UNDEFINED
);
659 vars
= scm_reverse_x (vars
, SCM_UNDEFINED
);
661 if (scm_is_true (alternate
) && !(SCM_EXPANDED_P (alternate
) && SCM_EXPANDED_TYPE (alternate
) == SCM_EXPANDED_LAMBDA_CASE
))
664 return LAMBDA_CASE (SCM_BOOL_F
, req
, SCM_BOOL_F
, rest
, SCM_BOOL_F
,
665 SCM_EOL
, vars
, body
, alternate
);
669 expand_lambda (SCM expr
, SCM env
)
671 return LAMBDA (scm_source_properties (expr
),
673 expand_lambda_case (CDR (expr
), SCM_BOOL_F
, env
));
677 expand_lambda_star_case (SCM clause
, SCM alternate
, SCM env
)
679 SCM req
, opt
, kw
, allow_other_keys
, rest
, formals
, vars
, body
, tmp
;
683 const long length
= scm_ilength (clause
);
684 ASSERT_SYNTAX (length
>= 1, s_bad_expression
,
685 scm_cons (sym_lambda_star
, clause
));
686 ASSERT_SYNTAX (length
>= 2, s_missing_expression
,
687 scm_cons (sym_lambda_star
, clause
));
689 formals
= CAR (clause
);
693 req
= opt
= kw
= SCM_EOL
;
694 rest
= allow_other_keys
= SCM_BOOL_F
;
696 while (scm_is_pair (formals
) && scm_is_symbol (CAR (formals
)))
699 req
= scm_cons (CAR (formals
), req
);
700 formals
= scm_cdr (formals
);
703 if (scm_is_pair (formals
) && scm_is_eq (CAR (formals
), kw_optional
))
705 formals
= CDR (formals
);
706 while (scm_is_pair (formals
)
707 && (scm_is_symbol (CAR (formals
)) || scm_is_pair (CAR (formals
))))
710 opt
= scm_cons (CAR (formals
), opt
);
711 formals
= scm_cdr (formals
);
715 if (scm_is_pair (formals
) && scm_is_eq (CAR (formals
), kw_key
))
717 formals
= CDR (formals
);
718 while (scm_is_pair (formals
)
719 && (scm_is_symbol (CAR (formals
)) || scm_is_pair (CAR (formals
))))
721 kw
= scm_cons (CAR (formals
), kw
);
722 formals
= scm_cdr (formals
);
726 if (scm_is_pair (formals
) && scm_is_eq (CAR (formals
), kw_allow_other_keys
))
728 formals
= CDR (formals
);
729 allow_other_keys
= SCM_BOOL_T
;
732 if (scm_is_pair (formals
) && scm_is_eq (CAR (formals
), kw_rest
))
734 ASSERT_SYNTAX (scm_ilength (formals
) == 2, s_bad_formals
,
736 rest
= CADR (formals
);
738 else if (scm_is_symbol (formals
))
742 ASSERT_SYNTAX (scm_is_null (formals
), s_bad_formals
, CAR (clause
));
746 /* Now, iterate through them a second time, building up an expansion-time
747 environment, checking, expanding and canonicalizing the opt/kw init forms,
748 and eventually memoizing the body as well. Note that the rest argument, if
749 any, is expanded before keyword args, thus necessitating the second
752 Also note that the specific environment during expansion of init
753 expressions here needs to coincide with the environment when psyntax
754 expands. A lot of effort for something that is only used in the bootstrap
755 expandr, you say? Yes. Yes it is.
759 req
= scm_reverse_x (req
, SCM_EOL
);
760 for (tmp
= req
; scm_is_pair (tmp
); tmp
= scm_cdr (tmp
))
762 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
763 env
= scm_acons (CAR (tmp
), CAR (vars
), env
);
766 /* Build up opt inits and env */
768 opt
= scm_reverse_x (opt
, SCM_EOL
);
769 for (tmp
= opt
; scm_is_pair (tmp
); tmp
= scm_cdr (tmp
))
772 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
773 env
= scm_acons (x
, CAR (vars
), env
);
774 if (scm_is_symbol (x
))
775 inits
= scm_cons (CONST_ (SCM_BOOL_F
, SCM_BOOL_F
), inits
);
778 ASSERT_SYNTAX (scm_ilength (x
) == 2 && scm_is_symbol (CAR (x
)),
779 s_bad_formals
, CAR (clause
));
780 inits
= scm_cons (expand (CADR (x
), env
), inits
);
782 env
= scm_acons (scm_is_symbol (x
) ? x
: CAR (x
), CAR (vars
), env
);
784 if (scm_is_null (opt
))
787 /* Process rest before keyword args */
788 if (scm_is_true (rest
))
790 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
791 env
= scm_acons (rest
, CAR (vars
), env
);
794 /* Build up kw inits, env, and kw-canon list */
795 if (scm_is_null (kw
))
799 SCM kw_canon
= SCM_EOL
;
800 kw
= scm_reverse_x (kw
, SCM_UNDEFINED
);
801 for (tmp
= kw
; scm_is_pair (tmp
); tmp
= scm_cdr (tmp
))
805 if (scm_is_symbol (x
))
809 k
= scm_symbol_to_keyword (sym
);
811 else if (scm_ilength (x
) == 2 && scm_is_symbol (CAR (x
)))
815 k
= scm_symbol_to_keyword (sym
);
817 else if (scm_ilength (x
) == 3 && scm_is_symbol (CAR (x
))
818 && scm_is_keyword (CADDR (x
)))
825 syntax_error (s_bad_formals
, CAR (clause
), SCM_UNDEFINED
);
827 inits
= scm_cons (expand (init
, env
), inits
);
828 vars
= scm_cons (scm_gensym (SCM_UNDEFINED
), vars
);
829 kw_canon
= scm_cons (scm_list_3 (k
, sym
, CAR (vars
)), kw_canon
);
830 env
= scm_acons (sym
, CAR (vars
), env
);
832 kw_canon
= scm_reverse_x (kw_canon
, SCM_UNDEFINED
);
833 kw
= scm_cons (allow_other_keys
, kw_canon
);
836 /* We should check for no duplicates, but given that psyntax does this
837 already, we can punt on it here... */
839 vars
= scm_reverse_x (vars
, SCM_UNDEFINED
);
840 inits
= scm_reverse_x (inits
, SCM_UNDEFINED
);
841 body
= expand_sequence (body
, env
);
843 return LAMBDA_CASE (SCM_BOOL_F
, req
, opt
, rest
, kw
, inits
, vars
, body
,
848 expand_lambda_star (SCM expr
, SCM env
)
850 return LAMBDA (scm_source_properties (expr
),
852 expand_lambda_star_case (CDR (expr
), SCM_BOOL_F
, env
));
856 expand_case_lambda_clauses (SCM expr
, SCM rest
, SCM env
)
860 if (scm_is_pair (rest
))
861 alt
= expand_case_lambda_clauses (CAR (rest
), CDR (rest
), env
);
865 return expand_lambda_case (expr
, alt
, env
);
869 expand_case_lambda (SCM expr
, SCM env
)
871 ASSERT_SYNTAX (scm_is_pair (CDR (expr
)), s_missing_expression
, expr
);
873 return LAMBDA (scm_source_properties (expr
),
875 expand_case_lambda_clauses (CADR (expr
), CDDR (expr
), env
));
879 expand_case_lambda_star_clauses (SCM expr
, SCM rest
, SCM env
)
883 if (scm_is_pair (rest
))
884 alt
= expand_case_lambda_star_clauses (CAR (rest
), CDR (rest
), env
);
888 return expand_lambda_star_case (expr
, alt
, env
);
892 expand_case_lambda_star (SCM expr
, SCM env
)
894 ASSERT_SYNTAX (scm_is_pair (CDR (expr
)), s_missing_expression
, expr
);
896 return LAMBDA (scm_source_properties (expr
),
898 expand_case_lambda_star_clauses (CADR (expr
), CDDR (expr
), env
));
901 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
903 check_bindings (const SCM bindings
, const SCM expr
)
907 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
908 s_bad_bindings
, bindings
, expr
);
910 binding_idx
= bindings
;
911 for (; !scm_is_null (binding_idx
); binding_idx
= CDR (binding_idx
))
913 SCM name
; /* const */
915 const SCM binding
= CAR (binding_idx
);
916 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
917 s_bad_binding
, binding
, expr
);
919 name
= CAR (binding
);
920 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
924 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
925 * transformed to the lists (vn .. v2 v1) and (i1 i2 ... in). If a duplicate
926 * variable name is detected, an error is signalled. */
928 transform_bindings (const SCM bindings
, const SCM expr
,
929 SCM
*const names
, SCM
*const vars
, SCM
*const initptr
)
931 SCM rnames
= SCM_EOL
;
933 SCM rinits
= SCM_EOL
;
934 SCM binding_idx
= bindings
;
935 for (; !scm_is_null (binding_idx
); binding_idx
= CDR (binding_idx
))
937 const SCM binding
= CAR (binding_idx
);
938 const SCM CDR_binding
= CDR (binding
);
939 const SCM name
= CAR (binding
);
940 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rnames
)),
941 s_duplicate_binding
, name
, expr
);
942 rnames
= scm_cons (name
, rnames
);
943 rvars
= scm_cons (scm_gensym (SCM_UNDEFINED
), rvars
);
944 rinits
= scm_cons (CAR (CDR_binding
), rinits
);
946 *names
= scm_reverse_x (rnames
, SCM_UNDEFINED
);
947 *vars
= scm_reverse_x (rvars
, SCM_UNDEFINED
);
948 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
951 /* FIXME: Remove named let in this boot expander. */
953 expand_named_let (const SCM expr
, SCM env
)
955 SCM var_names
, var_syms
, inits
;
959 const SCM cdr_expr
= CDR (expr
);
960 const SCM name
= CAR (cdr_expr
);
961 const SCM cddr_expr
= CDR (cdr_expr
);
962 const SCM bindings
= CAR (cddr_expr
);
963 check_bindings (bindings
, expr
);
965 transform_bindings (bindings
, expr
, &var_names
, &var_syms
, &inits
);
966 name_sym
= scm_gensym (SCM_UNDEFINED
);
967 inner_env
= scm_acons (name
, name_sym
, env
);
968 inner_env
= expand_env_extend (inner_env
, var_names
, var_syms
);
971 (scm_source_properties (expr
), SCM_BOOL_F
,
972 scm_list_1 (name
), scm_list_1 (name_sym
),
973 scm_list_1 (LAMBDA (SCM_BOOL_F
,
975 LAMBDA_CASE (SCM_BOOL_F
, var_names
, SCM_BOOL_F
, SCM_BOOL_F
,
976 SCM_BOOL_F
, SCM_BOOL_F
, var_syms
,
977 expand_sequence (CDDDR (expr
), inner_env
),
980 LEXICAL_REF (SCM_BOOL_F
, name
, name_sym
),
981 expand_exprs (inits
, env
)));
985 expand_let (SCM expr
, SCM env
)
989 const SCM cdr_expr
= CDR (expr
);
990 const long length
= scm_ilength (cdr_expr
);
991 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
992 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
994 bindings
= CAR (cdr_expr
);
995 if (scm_is_symbol (bindings
))
997 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
998 return expand_named_let (expr
, env
);
1001 check_bindings (bindings
, expr
);
1002 if (scm_is_null (bindings
))
1003 return expand_sequence (CDDR (expr
), env
);
1006 SCM var_names
, var_syms
, inits
;
1007 transform_bindings (bindings
, expr
, &var_names
, &var_syms
, &inits
);
1008 return LET (SCM_BOOL_F
,
1009 var_names
, var_syms
, expand_exprs (inits
, env
),
1010 expand_sequence (CDDR (expr
),
1011 expand_env_extend (env
, var_names
,
1017 expand_letrec_helper (SCM expr
, SCM env
, SCM in_order_p
)
1021 const SCM cdr_expr
= CDR (expr
);
1022 const long length
= scm_ilength (cdr_expr
);
1023 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1024 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1026 bindings
= CAR (cdr_expr
);
1027 check_bindings (bindings
, expr
);
1028 if (scm_is_null (bindings
))
1029 return expand_sequence (CDDR (expr
), env
);
1032 SCM var_names
, var_syms
, inits
;
1033 transform_bindings (bindings
, expr
, &var_names
, &var_syms
, &inits
);
1034 env
= expand_env_extend (env
, var_names
, var_syms
);
1035 return LETREC (SCM_BOOL_F
, in_order_p
,
1036 var_names
, var_syms
, expand_exprs (inits
, env
),
1037 expand_sequence (CDDR (expr
), env
));
1042 expand_letrec (SCM expr
, SCM env
)
1044 return expand_letrec_helper (expr
, env
, SCM_BOOL_F
);
1048 expand_letrec_star (SCM expr
, SCM env
)
1050 return expand_letrec_helper (expr
, env
, SCM_BOOL_T
);
1054 expand_letstar_clause (SCM bindings
, SCM body
, SCM env SCM_UNUSED
)
1056 if (scm_is_null (bindings
))
1057 return expand_sequence (body
, env
);
1060 SCM bind
, name
, sym
, init
;
1062 ASSERT_SYNTAX (scm_is_pair (bindings
), s_bad_expression
, bindings
);
1063 bind
= CAR (bindings
);
1064 ASSERT_SYNTAX (scm_ilength (bind
) == 2, s_bad_binding
, bind
);
1066 sym
= scm_gensym (SCM_UNDEFINED
);
1069 return LET (SCM_BOOL_F
, scm_list_1 (name
), scm_list_1 (sym
),
1070 scm_list_1 (expand (init
, env
)),
1071 expand_letstar_clause (CDR (bindings
), body
,
1072 scm_acons (name
, sym
, env
)));
1077 expand_letstar (SCM expr
, SCM env SCM_UNUSED
)
1079 const SCM cdr_expr
= CDR (expr
);
1080 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1081 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1083 return expand_letstar_clause (CADR (expr
), CDDR (expr
), env
);
1087 expand_or (SCM expr
, SCM env SCM_UNUSED
)
1089 SCM tail
= CDR (expr
);
1090 const long length
= scm_ilength (tail
);
1092 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1094 if (scm_is_null (CDR (expr
)))
1095 return CONST_ (SCM_BOOL_F
, SCM_BOOL_F
);
1098 SCM tmp
= scm_gensym (SCM_UNDEFINED
);
1099 return LET (SCM_BOOL_F
,
1100 scm_list_1 (tmp
), scm_list_1 (tmp
),
1101 scm_list_1 (expand (CADR (expr
), env
)),
1102 CONDITIONAL (SCM_BOOL_F
,
1103 LEXICAL_REF (SCM_BOOL_F
, tmp
, tmp
),
1104 LEXICAL_REF (SCM_BOOL_F
, tmp
, tmp
),
1105 expand_or (CDR (expr
),
1106 scm_acons (tmp
, tmp
, env
))));
1111 expand_quote (SCM expr
, SCM env SCM_UNUSED
)
1115 const SCM cdr_expr
= CDR (expr
);
1116 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1117 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1118 quotee
= CAR (cdr_expr
);
1119 return CONST_ (scm_source_properties (expr
), quotee
);
1123 expand_set_x (SCM expr
, SCM env
)
1128 const SCM cdr_expr
= CDR (expr
);
1129 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1130 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1131 variable
= CAR (cdr_expr
);
1132 vmem
= expand (variable
, env
);
1134 switch (SCM_EXPANDED_TYPE (vmem
))
1136 case SCM_EXPANDED_LEXICAL_REF
:
1137 return LEXICAL_SET (scm_source_properties (expr
),
1138 SCM_EXPANDED_REF (vmem
, LEXICAL_REF
, NAME
),
1139 SCM_EXPANDED_REF (vmem
, LEXICAL_REF
, GENSYM
),
1140 expand (CADDR (expr
), env
));
1141 case SCM_EXPANDED_TOPLEVEL_REF
:
1142 return TOPLEVEL_SET (scm_source_properties (expr
),
1143 SCM_EXPANDED_REF (vmem
, TOPLEVEL_REF
, NAME
),
1144 expand (CADDR (expr
), env
));
1145 case SCM_EXPANDED_MODULE_REF
:
1146 return MODULE_SET (scm_source_properties (expr
),
1147 SCM_EXPANDED_REF (vmem
, MODULE_REF
, MOD
),
1148 SCM_EXPANDED_REF (vmem
, MODULE_REF
, NAME
),
1149 SCM_EXPANDED_REF (vmem
, MODULE_REF
, PUBLIC
),
1150 expand (CADDR (expr
), env
));
1152 syntax_error (s_bad_variable
, variable
, expr
);
1159 /* This is the boot expander. It is later replaced with psyntax's sc-expand. */
1160 SCM_DEFINE (scm_macroexpand
, "macroexpand", 1, 0, 0,
1162 "Expand the expression @var{exp}.")
1163 #define FUNC_NAME s_scm_macroexpand
1165 return expand (exp
, scm_current_module ());
1169 SCM_DEFINE (scm_macroexpanded_p
, "macroexpanded?", 1, 0, 0,
1171 "Return @code{#t} if @var{exp} is an expanded expression.")
1172 #define FUNC_NAME s_scm_macroexpanded_p
1174 return scm_from_bool (SCM_EXPANDED_P (exp
));
1181 #define DEFINE_NAMES(type) \
1183 static const char *fields[] = SCM_EXPANDED_##type##_FIELD_NAMES; \
1184 exp_field_names[SCM_EXPANDED_##type] = fields; \
1185 exp_names[SCM_EXPANDED_##type] = SCM_EXPANDED_##type##_TYPE_NAME; \
1186 exp_nfields[SCM_EXPANDED_##type] = SCM_NUM_EXPANDED_##type##_FIELDS; \
1190 make_exp_vtable (size_t n
)
1192 SCM layout
, printer
, name
, code
, fields
;
1194 layout
= scm_string_to_symbol
1195 (scm_string_append (scm_make_list (scm_from_size_t (exp_nfields
[n
]),
1196 scm_from_locale_string ("pw"))));
1197 printer
= SCM_BOOL_F
;
1198 name
= scm_from_utf8_symbol (exp_names
[n
]);
1199 code
= scm_from_size_t (n
);
1202 size_t m
= exp_nfields
[n
];
1204 fields
= scm_cons (scm_from_utf8_symbol (exp_field_names
[n
][m
]), fields
);
1207 return scm_c_make_struct (scm_exp_vtable_vtable
, 0, 5,
1208 SCM_UNPACK (layout
), SCM_UNPACK (printer
), SCM_UNPACK (name
),
1209 SCM_UNPACK (code
), SCM_UNPACK (fields
));
1216 SCM exp_vtable_list
= SCM_EOL
;
1218 DEFINE_NAMES (VOID
);
1219 DEFINE_NAMES (CONST
);
1220 DEFINE_NAMES (PRIMITIVE_REF
);
1221 DEFINE_NAMES (LEXICAL_REF
);
1222 DEFINE_NAMES (LEXICAL_SET
);
1223 DEFINE_NAMES (MODULE_REF
);
1224 DEFINE_NAMES (MODULE_SET
);
1225 DEFINE_NAMES (TOPLEVEL_REF
);
1226 DEFINE_NAMES (TOPLEVEL_SET
);
1227 DEFINE_NAMES (TOPLEVEL_DEFINE
);
1228 DEFINE_NAMES (CONDITIONAL
);
1229 DEFINE_NAMES (CALL
);
1230 DEFINE_NAMES (PRIMCALL
);
1232 DEFINE_NAMES (LAMBDA
);
1233 DEFINE_NAMES (LAMBDA_CASE
);
1235 DEFINE_NAMES (LETREC
);
1237 scm_exp_vtable_vtable
=
1238 scm_make_vtable (scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT
"pwuwpw"),
1241 for (n
= 0; n
< SCM_NUM_EXPANDED_TYPES
; n
++)
1242 exp_vtables
[n
] = make_exp_vtable (n
);
1244 /* Now walk back down, consing in reverse. */
1246 exp_vtable_list
= scm_cons (exp_vtables
[n
], exp_vtable_list
);
1248 scm_c_define ("%expanded-vtables", scm_vector (exp_vtable_list
));
1250 #include "libguile/expand.x"