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/memoize.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 #define CAR(x) SCM_CAR(x)
46 #define CDR(x) SCM_CDR(x)
47 #define CAAR(x) SCM_CAAR(x)
48 #define CADR(x) SCM_CADR(x)
49 #define CDAR(x) SCM_CDAR(x)
50 #define CDDR(x) SCM_CDDR(x)
51 #define CADDR(x) SCM_CADDR(x)
52 #define CDDDR(x) SCM_CDDDR(x)
53 #define CADDDR(x) SCM_CADDDR(x)
56 static const char s_bad_expression
[] = "Bad expression";
57 static const char s_expression
[] = "Missing or extra expression in";
58 static const char s_missing_expression
[] = "Missing expression in";
59 static const char s_extra_expression
[] = "Extra expression in";
60 static const char s_empty_combination
[] = "Illegal empty combination";
61 static const char s_missing_body_expression
[] = "Missing body expression in";
62 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
63 static const char s_bad_define
[] = "Bad define placement";
64 static const char s_missing_clauses
[] = "Missing clauses";
65 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
66 static const char s_bad_case_clause
[] = "Bad case clause";
67 static const char s_bad_case_labels
[] = "Bad case labels";
68 static const char s_duplicate_case_label
[] = "Duplicate case label";
69 static const char s_bad_cond_clause
[] = "Bad cond clause";
70 static const char s_missing_recipient
[] = "Missing recipient in";
71 static const char s_bad_variable
[] = "Bad variable";
72 static const char s_bad_bindings
[] = "Bad bindings";
73 static const char s_bad_binding
[] = "Bad binding";
74 static const char s_duplicate_binding
[] = "Duplicate binding";
75 static const char s_bad_exit_clause
[] = "Bad exit clause";
76 static const char s_bad_formals
[] = "Bad formals";
77 static const char s_bad_formal
[] = "Bad formal";
78 static const char s_duplicate_formal
[] = "Duplicate formal";
79 static const char s_splicing
[] = "Non-list result for unquote-splicing";
80 static const char s_bad_slot_number
[] = "Bad slot number";
83 /* Signal a syntax error. We distinguish between the form that caused the
84 * error and the enclosing expression. The error message will print out as
85 * shown in the following pattern. The file name and line number are only
86 * given when they can be determined from the erroneous form or from the
87 * enclosing expression.
89 * <filename>: In procedure memoization:
90 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
92 SCM_SYMBOL (syntax_error_key
, "syntax-error");
94 /* The prototype is needed to indicate that the function does not return. */
96 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
99 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
101 SCM msg_string
= scm_from_locale_string (msg
);
102 SCM filename
= SCM_BOOL_F
;
103 SCM linenr
= SCM_BOOL_F
;
107 if (scm_is_pair (form
))
109 filename
= scm_source_property (form
, scm_sym_filename
);
110 linenr
= scm_source_property (form
, scm_sym_line
);
113 if (scm_is_false (filename
) && scm_is_false (linenr
) && scm_is_pair (expr
))
115 filename
= scm_source_property (expr
, scm_sym_filename
);
116 linenr
= scm_source_property (expr
, scm_sym_line
);
119 if (!SCM_UNBNDP (expr
))
121 if (scm_is_true (filename
))
123 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
124 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
126 else if (scm_is_true (linenr
))
128 format
= "In line ~S: ~A ~S in expression ~S.";
129 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
133 format
= "~A ~S in expression ~S.";
134 args
= scm_list_3 (msg_string
, form
, expr
);
139 if (scm_is_true (filename
))
141 format
= "In file ~S, line ~S: ~A ~S.";
142 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
144 else if (scm_is_true (linenr
))
146 format
= "In line ~S: ~A ~S.";
147 args
= scm_list_3 (linenr
, msg_string
, form
);
152 args
= scm_list_2 (msg_string
, form
);
156 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
160 /* Shortcut macros to simplify syntax error handling. */
161 #define ASSERT_SYNTAX(cond, message, form) \
162 { if (SCM_UNLIKELY (!(cond))) \
163 syntax_error (message, form, SCM_UNDEFINED); }
164 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
165 { if (SCM_UNLIKELY (!(cond))) \
166 syntax_error (message, form, expr); }
171 /* {Evaluator memoized expressions}
174 scm_t_bits scm_tc16_memoized
;
176 #define MAKMEMO(n, args) (scm_cell (scm_tc16_memoized | ((n) << 16), (scm_t_bits)(args)))
178 #define MAKMEMO_BEGIN(exps) \
179 MAKMEMO (SCM_M_BEGIN, exps)
180 #define MAKMEMO_IF(test, then, else_) \
181 MAKMEMO (SCM_M_IF, scm_cons (test, scm_cons (then, else_)))
182 #define FIXED_ARITY(nreq) \
183 scm_list_1 (SCM_I_MAKINUM (nreq))
184 #define REST_ARITY(nreq, rest) \
185 scm_list_2 (SCM_I_MAKINUM (nreq), rest)
186 #define FULL_ARITY(nreq, rest, nopt, kw, inits, alt) \
187 scm_list_n (SCM_I_MAKINUM (nreq), rest, SCM_I_MAKINUM (nopt), kw, inits, \
189 #define MAKMEMO_LAMBDA(body, arity) \
190 MAKMEMO (SCM_M_LAMBDA, (scm_cons (body, arity)))
191 #define MAKMEMO_LET(inits, body) \
192 MAKMEMO (SCM_M_LET, scm_cons (inits, body))
193 #define MAKMEMO_QUOTE(exp) \
194 MAKMEMO (SCM_M_QUOTE, exp)
195 #define MAKMEMO_DEFINE(var, val) \
196 MAKMEMO (SCM_M_DEFINE, scm_cons (var, val))
197 #define MAKMEMO_DYNWIND(in, expr, out) \
198 MAKMEMO (SCM_M_DYNWIND, scm_cons (in, scm_cons (expr, out)))
199 #define MAKMEMO_WITH_FLUIDS(fluids, vals, expr) \
200 MAKMEMO (SCM_M_WITH_FLUIDS, scm_cons (fluids, scm_cons (vals, expr)))
201 #define MAKMEMO_APPLY(proc, args)\
202 MAKMEMO (SCM_M_APPLY, scm_list_2 (proc, args))
203 #define MAKMEMO_CONT(proc) \
204 MAKMEMO (SCM_M_CONT, proc)
205 #define MAKMEMO_CALL_WITH_VALUES(prod, cons) \
206 MAKMEMO (SCM_M_CALL_WITH_VALUES, scm_cons (prod, cons))
207 #define MAKMEMO_CALL(proc, nargs, args) \
208 MAKMEMO (SCM_M_CALL, scm_cons (proc, scm_cons (SCM_I_MAKINUM (nargs), args)))
209 #define MAKMEMO_LEX_REF(n) \
210 MAKMEMO (SCM_M_LEXICAL_REF, SCM_I_MAKINUM (n))
211 #define MAKMEMO_LEX_SET(n, val) \
212 MAKMEMO (SCM_M_LEXICAL_SET, scm_cons (SCM_I_MAKINUM (n), val))
213 #define MAKMEMO_TOP_REF(var) \
214 MAKMEMO (SCM_M_TOPLEVEL_REF, var)
215 #define MAKMEMO_TOP_SET(var, val) \
216 MAKMEMO (SCM_M_TOPLEVEL_SET, scm_cons (var, val))
217 #define MAKMEMO_MOD_REF(mod, var, public) \
218 MAKMEMO (SCM_M_MODULE_REF, scm_cons (mod, scm_cons (var, public)))
219 #define MAKMEMO_MOD_SET(val, mod, var, public) \
220 MAKMEMO (SCM_M_MODULE_SET, scm_cons (val, scm_cons (mod, scm_cons (var, public))))
221 #define MAKMEMO_PROMPT(tag, exp, handler) \
222 MAKMEMO (SCM_M_PROMPT, scm_cons (tag, scm_cons (exp, handler)))
225 /* Primitives for the evaluator */
226 scm_t_bits scm_tc16_memoizer
;
227 #define SCM_MEMOIZER_P(x) (SCM_SMOB_PREDICATE (scm_tc16_memoizer, (x)))
228 #define SCM_MEMOIZER(M) (SCM_SMOB_OBJECT_1 (M))
232 /* This table must agree with the list of M_ constants in memoize.h */
233 static const char *const memoized_tags
[] =
257 scm_print_memoized (SCM memoized
, SCM port
, scm_print_state
*pstate
)
259 scm_puts ("#<memoized ", port
);
260 scm_write (scm_unmemoize_expression (memoized
), port
);
261 scm_puts (">", port
);
265 static SCM
scm_m_at (SCM xorig
, SCM env
);
266 static SCM
scm_m_atat (SCM xorig
, SCM env
);
267 static SCM
scm_m_and (SCM xorig
, SCM env
);
268 static SCM
scm_m_begin (SCM xorig
, SCM env
);
269 static SCM
scm_m_cond (SCM xorig
, SCM env
);
270 static SCM
scm_m_define (SCM x
, SCM env
);
271 static SCM
scm_m_with_fluids (SCM xorig
, SCM env
);
272 static SCM
scm_m_eval_when (SCM xorig
, SCM env
);
273 static SCM
scm_m_if (SCM xorig
, SCM env
);
274 static SCM
scm_m_lambda (SCM xorig
, SCM env
);
275 static SCM
scm_m_lambda_star (SCM xorig
, SCM env
);
276 static SCM
scm_m_case_lambda (SCM xorig
, SCM env
);
277 static SCM
scm_m_case_lambda_star (SCM xorig
, SCM env
);
278 static SCM
scm_m_let (SCM xorig
, SCM env
);
279 static SCM
scm_m_letrec (SCM xorig
, SCM env
);
280 static SCM
scm_m_letstar (SCM xorig
, SCM env
);
281 static SCM
scm_m_or (SCM xorig
, SCM env
);
282 static SCM
scm_m_quote (SCM xorig
, SCM env
);
283 static SCM
scm_m_set_x (SCM xorig
, SCM env
);
289 memoize_env_ref_macro (SCM env
, SCM x
)
292 for (; scm_is_pair (env
); env
= CDR (env
))
293 if (scm_is_eq (x
, CAR (env
)))
294 return SCM_BOOL_F
; /* lexical */
296 var
= scm_module_variable (env
, x
);
297 if (scm_is_true (var
) && scm_is_true (scm_variable_bound_p (var
))
298 && (scm_is_true (scm_macro_p (scm_variable_ref (var
)))
299 || SCM_MEMOIZER_P (scm_variable_ref (var
))))
300 return scm_variable_ref (var
);
302 return SCM_BOOL_F
; /* anything else */
306 memoize_env_var_is_free (SCM env
, SCM x
)
308 for (; scm_is_pair (env
); env
= CDR (env
))
309 if (scm_is_eq (x
, CAR (env
)))
310 return 0; /* bound */
315 memoize_env_lexical_index (SCM env
, SCM x
)
318 for (; scm_is_pair (env
); env
= CDR (env
), i
++)
319 if (scm_is_eq (x
, CAR (env
)))
320 return i
; /* bound */
321 return -1; /* free */
325 memoize_env_extend (SCM env
, SCM vars
)
327 return scm_append (scm_list_2 (vars
, env
));
331 memoize (SCM exp
, SCM env
)
333 if (scm_is_pair (exp
))
336 scm_t_macro_primitive trans
= NULL
;
337 SCM macro
= SCM_BOOL_F
, memoizer
= SCM_BOOL_F
;
340 if (scm_is_symbol (car
))
341 macro
= memoize_env_ref_macro (env
, car
);
343 if (scm_is_true (scm_macro_p (macro
)))
344 trans
= scm_i_macro_primitive (macro
);
345 else if (SCM_MEMOIZER_P (macro
))
346 memoizer
= SCM_MEMOIZER (macro
);
349 return trans (exp
, env
);
354 SCM proc
= CAR (exp
);
356 for (exp
= CDR (exp
); scm_is_pair (exp
); exp
= CDR (exp
), nargs
++)
357 args
= scm_cons (memoize (CAR (exp
), env
), args
);
358 if (scm_is_null (exp
))
360 if (scm_is_true (memoizer
))
361 return scm_apply (memoizer
, scm_reverse_x (args
, SCM_UNDEFINED
),
364 return MAKMEMO_CALL (memoize (proc
, env
),
366 scm_reverse_x (args
, SCM_UNDEFINED
));
370 syntax_error ("expected a proper list", exp
, SCM_UNDEFINED
);
373 else if (scm_is_symbol (exp
))
375 int i
= memoize_env_lexical_index (env
, exp
);
377 return MAKMEMO_TOP_REF (exp
);
379 return MAKMEMO_LEX_REF (i
);
382 return MAKMEMO_QUOTE (exp
);
386 memoize_exprs (SCM forms
, const SCM env
)
390 for (; !scm_is_null (forms
); forms
= CDR (forms
))
391 ret
= scm_cons (memoize (CAR (forms
), env
), ret
);
392 return scm_reverse_x (ret
, SCM_UNDEFINED
);
396 memoize_sequence (const SCM forms
, const SCM env
)
398 ASSERT_SYNTAX (scm_ilength (forms
) >= 1, s_bad_expression
,
399 scm_cons (scm_sym_begin
, forms
));
400 if (scm_is_null (CDR (forms
)))
401 return memoize (CAR (forms
), env
);
403 return MAKMEMO_BEGIN (memoize_exprs (forms
, env
));
410 #define SCM_SYNTAX(RANAME, STR, CFN) \
411 SCM_SNARF_HERE(static const char RANAME[]=STR)\
412 SCM_SNARF_INIT(scm_c_define (RANAME, scm_i_make_primitive_macro (RANAME, CFN)))
415 /* True primitive syntax */
416 SCM_SYNTAX (s_at
, "@", scm_m_at
);
417 SCM_SYNTAX (s_atat
, "@@", scm_m_atat
);
418 SCM_SYNTAX (s_begin
, "begin", scm_m_begin
);
419 SCM_SYNTAX (s_define
, "define", scm_m_define
);
420 SCM_SYNTAX (s_with_fluids
, "with-fluids", scm_m_with_fluids
);
421 SCM_SYNTAX (s_eval_when
, "eval-when", scm_m_eval_when
);
422 SCM_SYNTAX (s_if
, "if", scm_m_if
);
423 SCM_SYNTAX (s_lambda
, "lambda", scm_m_lambda
);
424 SCM_SYNTAX (s_let
, "let", scm_m_let
);
425 SCM_SYNTAX (s_quote
, "quote", scm_m_quote
);
426 SCM_SYNTAX (s_set_x
, "set!", scm_m_set_x
);
428 /* Convenient syntax during boot, expands to primitive syntax. Replaced after
430 SCM_SYNTAX (s_and
, "and", scm_m_and
);
431 SCM_SYNTAX (s_cond
, "cond", scm_m_cond
);
432 SCM_SYNTAX (s_letrec
, "letrec", scm_m_letrec
);
433 SCM_SYNTAX (s_letstar
, "let*", scm_m_letstar
);
434 SCM_SYNTAX (s_or
, "or", scm_m_or
);
435 SCM_SYNTAX (s_lambda_star
, "lambda*", scm_m_lambda_star
);
436 SCM_SYNTAX (s_case_lambda
, "case-lambda", scm_m_case_lambda
);
437 SCM_SYNTAX (s_case_lambda_star
, "case-lambda*", scm_m_case_lambda_star
);
439 SCM_GLOBAL_SYMBOL (scm_sym_apply
, "apply");
440 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
441 SCM_GLOBAL_SYMBOL (scm_sym_at
, "@");
442 SCM_GLOBAL_SYMBOL (scm_sym_atat
, "@@");
443 SCM_GLOBAL_SYMBOL (scm_sym_at_call_with_values
, "@call-with-values");
444 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, "@apply");
445 SCM_GLOBAL_SYMBOL (scm_sym_atcall_cc
, "@call-with-current-continuation");
446 SCM_GLOBAL_SYMBOL (scm_sym_begin
, "begin");
447 SCM_GLOBAL_SYMBOL (scm_sym_case
, "case");
448 SCM_GLOBAL_SYMBOL (scm_sym_cond
, "cond");
449 SCM_GLOBAL_SYMBOL (scm_sym_define
, "define");
450 SCM_GLOBAL_SYMBOL (scm_sym_at_dynamic_wind
, "@dynamic-wind");
451 SCM_GLOBAL_SYMBOL (scm_sym_with_fluids
, "with-fluids");
452 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
453 SCM_GLOBAL_SYMBOL (scm_sym_eval_when
, "eval-when");
454 SCM_GLOBAL_SYMBOL (scm_sym_if
, "if");
455 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, "lambda");
456 SCM_GLOBAL_SYMBOL (scm_sym_let
, "let");
457 SCM_GLOBAL_SYMBOL (scm_sym_letrec
, "letrec");
458 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, "let*");
459 SCM_GLOBAL_SYMBOL (scm_sym_or
, "or");
460 SCM_GLOBAL_SYMBOL (scm_sym_at_prompt
, "@prompt");
461 SCM_GLOBAL_SYMBOL (scm_sym_quote
, "quote");
462 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, "set!");
463 SCM_SYMBOL (sym_lambda_star
, "lambda*");
464 SCM_SYMBOL (sym_case_lambda
, "case-lambda");
465 SCM_SYMBOL (sym_case_lambda_star
, "case-lambda*");
466 SCM_SYMBOL (sym_eval
, "eval");
467 SCM_SYMBOL (sym_load
, "load");
469 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
470 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, "quasiquote");
471 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
473 SCM_KEYWORD (kw_allow_other_keys
, "allow-other-keys");
474 SCM_KEYWORD (kw_optional
, "optional");
475 SCM_KEYWORD (kw_key
, "key");
476 SCM_KEYWORD (kw_rest
, "rest");
480 scm_m_at (SCM expr
, SCM env SCM_UNUSED
)
482 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
483 ASSERT_SYNTAX (scm_ilength (CADR (expr
)) > 0, s_bad_expression
, expr
);
484 ASSERT_SYNTAX (scm_is_symbol (CADDR (expr
)), s_bad_expression
, expr
);
486 return MAKMEMO_MOD_REF (CADR (expr
), CADDR (expr
), SCM_BOOL_T
);
490 scm_m_atat (SCM expr
, SCM env SCM_UNUSED
)
492 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
493 ASSERT_SYNTAX (scm_ilength (CADR (expr
)) > 0, s_bad_expression
, expr
);
494 ASSERT_SYNTAX (scm_is_symbol (CADDR (expr
)), s_bad_expression
, expr
);
496 return MAKMEMO_MOD_REF (CADR (expr
), CADDR (expr
), SCM_BOOL_F
);
500 scm_m_and (SCM expr
, SCM env
)
502 const SCM cdr_expr
= CDR (expr
);
504 if (scm_is_null (cdr_expr
))
505 return MAKMEMO_QUOTE (SCM_BOOL_T
);
506 ASSERT_SYNTAX (scm_is_pair (cdr_expr
), s_bad_expression
, expr
);
508 if (scm_is_null (CDR (cdr_expr
)))
509 return memoize (CAR (cdr_expr
), env
);
511 return MAKMEMO_IF (memoize (CAR (cdr_expr
), env
),
512 scm_m_and (cdr_expr
, env
),
513 MAKMEMO_QUOTE (SCM_BOOL_F
));
517 scm_m_begin (SCM expr
, SCM env
)
519 const SCM cdr_expr
= CDR (expr
);
520 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_bad_expression
, expr
);
521 return MAKMEMO_BEGIN (memoize_exprs (cdr_expr
, env
));
525 scm_m_cond (SCM expr
, SCM env
)
527 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
528 const int else_literal_p
= memoize_env_var_is_free (env
, scm_sym_else
);
529 const int arrow_literal_p
= memoize_env_var_is_free (env
, scm_sym_arrow
);
531 const SCM clauses
= CDR (expr
);
535 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
536 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
538 ret
= scm_cons (SCM_UNDEFINED
, MAKMEMO_QUOTE (SCM_UNSPECIFIED
));
541 for (clause_idx
= clauses
;
542 !scm_is_null (clause_idx
);
543 clause_idx
= CDR (clause_idx
))
547 const SCM clause
= CAR (clause_idx
);
548 const long length
= scm_ilength (clause
);
549 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
552 if (scm_is_eq (test
, scm_sym_else
) && else_literal_p
)
554 const int last_clause_p
= scm_is_null (CDR (clause_idx
));
555 ASSERT_SYNTAX_2 (length
>= 2,
556 s_bad_cond_clause
, clause
, expr
);
557 ASSERT_SYNTAX_2 (last_clause_p
,
558 s_misplaced_else_clause
, clause
, expr
);
560 memoize (scm_cons (scm_sym_begin
, CDR (clause
)), env
));
563 && scm_is_eq (CADR (clause
), scm_sym_arrow
)
566 SCM tmp
= scm_gensym (scm_from_locale_string ("cond "));
568 SCM new_env
= scm_cons (tmp
, env
);
569 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
570 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
571 i
= MAKMEMO_IF (MAKMEMO_LEX_REF (0),
572 MAKMEMO_CALL (memoize (CADDR (clause
),
573 scm_cons (tmp
, new_env
)),
575 scm_list_1 (MAKMEMO_LEX_REF (0))),
576 MAKMEMO_QUOTE (SCM_UNSPECIFIED
));
578 MAKMEMO_LET (scm_list_1 (memoize (CAR (clause
), env
)),
581 loc
= scm_last_pair (SCM_MEMOIZED_ARGS (i
));
583 /* FIXME length == 1 case */
586 SCM i
= MAKMEMO_IF (memoize (CAR (clause
), env
),
587 memoize (scm_cons (scm_sym_begin
, CDR (clause
)), env
),
588 MAKMEMO_QUOTE (SCM_UNSPECIFIED
));
590 loc
= scm_last_pair (SCM_MEMOIZED_ARGS (i
));
597 /* According to Section 5.2.1 of R5RS we first have to make sure that the
598 variable is bound, and then perform the `(set! variable expression)'
599 operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
600 bound. This means that EXPRESSION won't necessarily be able to assign
601 values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
603 scm_m_define (SCM expr
, SCM env
)
605 const SCM cdr_expr
= CDR (expr
);
609 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
610 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
611 ASSERT_SYNTAX (!scm_is_pair (env
), s_bad_define
, expr
);
613 body
= CDR (cdr_expr
);
614 variable
= CAR (cdr_expr
);
616 if (scm_is_pair (variable
))
618 ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable
)), s_bad_variable
, variable
, expr
);
619 return MAKMEMO_DEFINE (CAR (variable
),
620 memoize (scm_cons (scm_sym_lambda
,
621 scm_cons (CDR (variable
), body
)),
624 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
625 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
626 return MAKMEMO_DEFINE (variable
, memoize (CAR (body
), env
));
630 scm_m_with_fluids (SCM expr
, SCM env
)
632 SCM binds
, fluids
, vals
;
633 ASSERT_SYNTAX (scm_ilength (expr
) >= 3, s_bad_expression
, expr
);
635 ASSERT_SYNTAX_2 (scm_ilength (binds
) >= 0, s_bad_bindings
, binds
, expr
);
636 for (fluids
= SCM_EOL
, vals
= SCM_EOL
;
640 SCM binding
= CAR (binds
);
641 ASSERT_SYNTAX_2 (scm_ilength (CAR (binds
)) == 2, s_bad_binding
,
643 fluids
= scm_cons (memoize (CAR (binding
), env
), fluids
);
644 vals
= scm_cons (memoize (CADR (binding
), env
), vals
);
647 return MAKMEMO_WITH_FLUIDS (scm_reverse_x (fluids
, SCM_UNDEFINED
),
648 scm_reverse_x (vals
, SCM_UNDEFINED
),
649 memoize_sequence (CDDR (expr
), env
));
653 scm_m_eval_when (SCM expr
, SCM env
)
655 ASSERT_SYNTAX (scm_ilength (expr
) >= 3, s_bad_expression
, expr
);
656 ASSERT_SYNTAX (scm_ilength (CADR (expr
)) > 0, s_bad_expression
, expr
);
658 if (scm_is_true (scm_memq (sym_eval
, CADR (expr
)))
659 || scm_is_true (scm_memq (sym_load
, CADR (expr
))))
660 return MAKMEMO_BEGIN (memoize_exprs (CDDR (expr
), env
));
662 return MAKMEMO_QUOTE (SCM_UNSPECIFIED
);
666 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
668 const SCM cdr_expr
= CDR (expr
);
669 const long length
= scm_ilength (cdr_expr
);
670 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
671 return MAKMEMO_IF (memoize (CADR (expr
), env
),
672 memoize (CADDR (expr
), env
),
674 ? memoize (CADDDR (expr
), env
)
675 : MAKMEMO_QUOTE (SCM_UNSPECIFIED
)));
678 /* A helper function for memoize_lambda to support checking for duplicate
679 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
680 * LIST or to the CDR of the last cons. Therefore, LIST may have any of the
681 * forms that a formal argument can have:
682 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
684 c_improper_memq (SCM obj
, SCM list
)
686 for (; scm_is_pair (list
); list
= CDR (list
))
688 if (scm_is_eq (CAR (list
), obj
))
691 return scm_is_eq (list
, obj
);
695 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
699 SCM formal_vars
= SCM_EOL
;
703 const SCM cdr_expr
= CDR (expr
);
704 const long length
= scm_ilength (cdr_expr
);
705 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
706 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
708 /* Before iterating the list of formal arguments, make sure the formals
709 * actually are given as either a symbol or a non-cyclic list. */
710 formals
= CAR (cdr_expr
);
711 if (scm_is_pair (formals
))
713 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
714 * detected, report a 'Bad formals' error. */
718 ASSERT_SYNTAX_2 (scm_is_symbol (formals
) || scm_is_null (formals
),
719 s_bad_formals
, formals
, expr
);
722 /* Now iterate the list of formal arguments to check if all formals are
723 * symbols, and that there are no duplicates. */
724 formals_idx
= formals
;
725 while (scm_is_pair (formals_idx
))
727 const SCM formal
= CAR (formals_idx
);
728 const SCM next_idx
= CDR (formals_idx
);
729 ASSERT_SYNTAX_2 (scm_is_symbol (formal
), s_bad_formal
, formal
, expr
);
730 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
731 s_duplicate_formal
, formal
, expr
);
733 formal_vars
= scm_cons (formal
, formal_vars
);
734 formals_idx
= next_idx
;
736 ASSERT_SYNTAX_2 (scm_is_null (formals_idx
) || scm_is_symbol (formals_idx
),
737 s_bad_formal
, formals_idx
, expr
);
738 if (scm_is_symbol (formals_idx
))
739 formal_vars
= scm_cons (formals_idx
, formal_vars
);
741 body
= memoize_sequence (CDDR (expr
), memoize_env_extend (env
, formal_vars
));
743 if (scm_is_symbol (formals_idx
))
744 return MAKMEMO_LAMBDA (body
, REST_ARITY (nreq
, SCM_BOOL_T
));
746 return MAKMEMO_LAMBDA (body
, FIXED_ARITY (nreq
));
750 scm_m_lambda_star (SCM expr
, SCM env
)
752 SCM req
, opt
, kw
, allow_other_keys
, rest
, formals
, body
;
753 SCM inits
, kw_indices
;
756 const long length
= scm_ilength (expr
);
757 ASSERT_SYNTAX (length
>= 1, s_bad_expression
, expr
);
758 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
760 formals
= CADR (expr
);
764 req
= opt
= kw
= SCM_EOL
;
765 rest
= allow_other_keys
= SCM_BOOL_F
;
767 while (scm_is_pair (formals
) && scm_is_symbol (CAR (formals
)))
770 req
= scm_cons (CAR (formals
), req
);
771 formals
= scm_cdr (formals
);
774 if (scm_is_pair (formals
) && scm_is_eq (CAR (formals
), kw_optional
))
776 formals
= CDR (formals
);
777 while (scm_is_pair (formals
)
778 && (scm_is_symbol (CAR (formals
)) || scm_is_pair (CAR (formals
))))
781 opt
= scm_cons (CAR (formals
), opt
);
782 formals
= scm_cdr (formals
);
786 if (scm_is_pair (formals
) && scm_is_eq (CAR (formals
), kw_key
))
788 formals
= CDR (formals
);
789 while (scm_is_pair (formals
)
790 && (scm_is_symbol (CAR (formals
)) || scm_is_pair (CAR (formals
))))
792 kw
= scm_cons (CAR (formals
), kw
);
793 formals
= scm_cdr (formals
);
797 if (scm_is_pair (formals
) && scm_is_eq (CAR (formals
), kw_allow_other_keys
))
799 formals
= CDR (formals
);
800 allow_other_keys
= SCM_BOOL_T
;
803 if (scm_is_pair (formals
) && scm_is_eq (CAR (formals
), kw_rest
))
805 if (scm_ilength (formals
) != 2)
806 syntax_error (s_bad_formals
, CADR (expr
), expr
);
808 rest
= CADR (formals
);
810 else if (scm_is_symbol (formals
))
812 else if (!scm_is_null (formals
))
813 syntax_error (s_bad_formals
, CADR (expr
), expr
);
817 /* Now, iterate through them a second time, building up an expansion-time
818 environment, checking, expanding and canonicalizing the opt/kw init forms,
819 and eventually memoizing the body as well. Note that the rest argument, if
820 any, is expanded before keyword args, thus necessitating the second
823 Also note that the specific environment during expansion of init
824 expressions here needs to coincide with the environment when psyntax
825 expands. A lot of effort for something that is only used in the bootstrap
826 memoizer, you say? Yes. Yes it is.
831 /* nreq is already set, and req is already reversed: simply extend. */
832 env
= memoize_env_extend (env
, req
);
834 /* Build up opt inits and env */
835 opt
= scm_reverse_x (opt
, SCM_EOL
);
836 while (scm_is_pair (opt
))
839 if (scm_is_symbol (x
))
840 inits
= scm_cons (MAKMEMO_QUOTE (SCM_BOOL_F
), inits
);
841 else if (scm_ilength (x
) == 2 && scm_is_symbol (CAR (x
)))
842 inits
= scm_cons (memoize (CADR (x
), env
), inits
);
844 syntax_error (s_bad_formals
, CADR (expr
), expr
);
845 env
= scm_cons (scm_is_symbol (x
) ? x
: CAR (x
), env
);
849 /* Process rest before keyword args */
850 if (scm_is_true (rest
))
851 env
= scm_cons (rest
, env
);
853 /* Build up kw inits, env, and kw-indices alist */
854 if (scm_is_null (kw
))
855 kw_indices
= SCM_BOOL_F
;
858 int idx
= nreq
+ nopt
+ (scm_is_true (rest
) ? 1 : 0);
860 kw_indices
= SCM_EOL
;
861 kw
= scm_reverse_x (kw
, SCM_EOL
);
862 while (scm_is_pair (kw
))
866 if (scm_is_symbol (x
))
870 k
= scm_symbol_to_keyword (sym
);
872 else if (scm_ilength (x
) == 2 && scm_is_symbol (CAR (x
)))
876 k
= scm_symbol_to_keyword (sym
);
878 else if (scm_ilength (x
) == 3 && scm_is_symbol (CAR (x
))
879 && scm_is_keyword (CADDR (x
)))
886 syntax_error (s_bad_formals
, CADR (expr
), expr
);
888 kw_indices
= scm_acons (k
, SCM_I_MAKINUM (idx
++), kw_indices
);
889 inits
= scm_cons (memoize (init
, env
), inits
);
890 env
= scm_cons (sym
, env
);
893 kw_indices
= scm_cons (allow_other_keys
,
894 scm_reverse_x (kw_indices
, SCM_UNDEFINED
));
897 /* We should check for no duplicates, but given that psyntax does this
898 already, we can punt on it here... */
900 inits
= scm_reverse_x (inits
, SCM_UNDEFINED
);
901 body
= memoize_sequence (body
, env
);
903 if (scm_is_false (kw_indices
) && scm_is_false (rest
) && !nopt
)
904 return MAKMEMO_LAMBDA (body
, FIXED_ARITY (nreq
));
905 if (scm_is_false (kw_indices
) && !nopt
)
906 return MAKMEMO_LAMBDA (body
, REST_ARITY (nreq
, SCM_BOOL_T
));
908 return MAKMEMO_LAMBDA (body
, FULL_ARITY (nreq
, rest
, nopt
, kw_indices
, inits
,
913 patch_case_lambda (SCM a
, SCM b
)
915 SCM mx
, body
, rest
, kw_indices
, inits
;
918 mx
= SCM_SMOB_OBJECT_1 (a
);
922 if (scm_is_null (CDR (mx
)))
924 nreq
= scm_to_int16 (CAR (mx
));
927 kw_indices
= SCM_BOOL_F
;
930 else if (scm_is_null (CDDR (mx
)))
932 nreq
= scm_to_int16 (CAR (mx
));
935 kw_indices
= SCM_BOOL_F
;
940 nreq
= scm_to_int16 (CAR (mx
));
942 nopt
= scm_to_int16 (CADDR (mx
));
943 kw_indices
= CADDDR (mx
);
944 inits
= CADR (CDDDR (mx
));
947 return MAKMEMO_LAMBDA
948 (body
, FULL_ARITY (nreq
, rest
, nopt
, kw_indices
, inits
, b
));
952 scm_m_case_lambda (SCM expr
, SCM env
)
956 const long length
= scm_ilength (expr
);
957 ASSERT_SYNTAX (length
>= 1, s_bad_expression
, expr
);
958 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
960 clauses
= scm_reverse (CDR (expr
));
963 for (; scm_is_pair (clauses
); clauses
= CDR (clauses
))
964 ret
= patch_case_lambda
965 (scm_m_lambda (scm_cons (scm_sym_lambda
, CAR (clauses
)), env
), ret
);
971 scm_m_case_lambda_star (SCM expr
, SCM env
)
975 const long length
= scm_ilength (expr
);
976 ASSERT_SYNTAX (length
>= 1, s_bad_expression
, expr
);
977 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
979 clauses
= scm_reverse (CDR (expr
));
982 for (; scm_is_pair (clauses
); clauses
= CDR (clauses
))
983 ret
= patch_case_lambda
984 (scm_m_lambda_star (scm_cons (sym_lambda_star
, CAR (clauses
)), env
), ret
);
989 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
991 check_bindings (const SCM bindings
, const SCM expr
)
995 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
996 s_bad_bindings
, bindings
, expr
);
998 binding_idx
= bindings
;
999 for (; !scm_is_null (binding_idx
); binding_idx
= CDR (binding_idx
))
1001 SCM name
; /* const */
1003 const SCM binding
= CAR (binding_idx
);
1004 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1005 s_bad_binding
, binding
, expr
);
1007 name
= CAR (binding
);
1008 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1012 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1013 * transformed to the lists (vn .. v2 v1) and (i1 i2 ... in). If a duplicate
1014 * variable name is detected, an error is signalled. */
1016 transform_bindings (const SCM bindings
, const SCM expr
,
1017 SCM
*const rvarptr
, SCM
*const initptr
)
1019 SCM rvariables
= SCM_EOL
;
1020 SCM rinits
= SCM_EOL
;
1021 SCM binding_idx
= bindings
;
1023 for (; !scm_is_null (binding_idx
); binding_idx
= CDR (binding_idx
))
1025 const SCM binding
= CAR (binding_idx
);
1026 const SCM CDR_binding
= CDR (binding
);
1027 const SCM name
= CAR (binding
);
1028 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rvariables
)),
1029 s_duplicate_binding
, name
, expr
);
1030 rvariables
= scm_cons (name
, rvariables
);
1031 rinits
= scm_cons (CAR (CDR_binding
), rinits
);
1034 *rvarptr
= rvariables
;
1035 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1039 /* This function is a helper function for memoize_let. It transforms
1040 * (let name ((var init) ...) body ...) into
1041 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1042 * and memoizes the expression. It is assumed that the caller has checked
1043 * that name is a symbol and that there are bindings and a body. */
1045 memoize_named_let (const SCM expr
, SCM env
)
1051 const SCM cdr_expr
= CDR (expr
);
1052 const SCM name
= CAR (cdr_expr
);
1053 const SCM cddr_expr
= CDR (cdr_expr
);
1054 const SCM bindings
= CAR (cddr_expr
);
1055 check_bindings (bindings
, expr
);
1057 nreq
= transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1059 env
= scm_cons (name
, env
);
1061 (scm_list_1 (MAKMEMO_QUOTE (SCM_UNDEFINED
)),
1063 (scm_list_2 (MAKMEMO_LEX_SET
1065 MAKMEMO_LAMBDA (memoize_sequence
1067 memoize_env_extend (env
, rvariables
)),
1068 FIXED_ARITY (nreq
))),
1069 MAKMEMO_CALL (MAKMEMO_LEX_REF (0),
1071 memoize_exprs (inits
, env
)))));
1074 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1075 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1077 scm_m_let (SCM expr
, SCM env
)
1081 const SCM cdr_expr
= CDR (expr
);
1082 const long length
= scm_ilength (cdr_expr
);
1083 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1084 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1086 bindings
= CAR (cdr_expr
);
1087 if (scm_is_symbol (bindings
))
1089 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1090 return memoize_named_let (expr
, env
);
1093 check_bindings (bindings
, expr
);
1094 if (scm_is_null (bindings
))
1095 return memoize_sequence (CDDR (expr
), env
);
1100 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1101 return MAKMEMO_LET (memoize_exprs (inits
, env
),
1102 memoize_sequence (CDDR (expr
),
1103 memoize_env_extend (env
, rvariables
)));
1108 scm_m_letrec (SCM expr
, SCM env
)
1112 const SCM cdr_expr
= CDR (expr
);
1113 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1114 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1116 bindings
= CAR (cdr_expr
);
1117 if (scm_is_null (bindings
))
1118 return memoize_sequence (CDDR (expr
), env
);
1124 SCM undefs
= SCM_EOL
;
1129 int n
= transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1131 new_env
= memoize_env_extend (env
, rvariables
);
1132 for (v
= scm_reverse (rvariables
), i
= inits
; scm_is_pair (v
);
1133 v
= CDR (v
), i
= CDR (i
), n
--)
1135 undefs
= scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED
), undefs
);
1136 vals
= scm_cons (memoize (CAR (i
), new_env
), vals
);
1137 sets
= scm_cons (MAKMEMO_LEX_SET ((n
-1) + offset
,
1138 MAKMEMO_LEX_REF (n
-1)),
1143 MAKMEMO_BEGIN (scm_list_2 (MAKMEMO_LET (scm_reverse (vals
),
1144 MAKMEMO_BEGIN (sets
)),
1145 memoize_sequence (CDDR (expr
),
1151 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1155 const SCM cdr_expr
= CDR (expr
);
1156 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1157 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1159 bindings
= CAR (cdr_expr
);
1160 if (scm_is_null (bindings
))
1161 return memoize_sequence (CDDR (expr
), env
);
1168 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1169 variables
= scm_reverse (rvariables
);
1170 ret
= scm_cons (SCM_UNDEFINED
, SCM_UNSPECIFIED
);
1172 for (; scm_is_pair (variables
);
1173 variables
= CDR (variables
), inits
= CDR (inits
))
1174 { SCM x
= MAKMEMO_LET (scm_list_1 (memoize (CAR (inits
), env
)),
1175 MAKMEMO_QUOTE (SCM_UNSPECIFIED
));
1176 SCM_SETCDR (loc
, x
);
1177 loc
= scm_last_pair (SCM_MEMOIZED_ARGS (x
));
1178 env
= scm_cons (CAR (variables
), env
);
1180 SCM_SETCDR (loc
, memoize_sequence (CDDR (expr
), env
));
1186 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1188 SCM tail
= CDR (expr
);
1190 const long length
= scm_ilength (tail
);
1192 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1194 ret
= scm_cons (SCM_UNDEFINED
, SCM_UNSPECIFIED
);
1196 for (; scm_is_pair (tail
); tail
= CDR (tail
))
1198 SCM tmp
= scm_gensym (scm_from_locale_string ("cond "));
1199 SCM x
= MAKMEMO_IF (MAKMEMO_LEX_REF (0),
1200 MAKMEMO_LEX_REF (0),
1201 MAKMEMO_QUOTE (SCM_UNSPECIFIED
));
1202 SCM new_env
= scm_cons (tmp
, env
);
1203 SCM_SETCDR (loc
, MAKMEMO_LET (scm_list_1 (memoize (CAR (tail
),
1207 loc
= scm_last_pair (SCM_MEMOIZED_ARGS (x
));
1209 SCM_SETCDR (loc
, MAKMEMO_QUOTE (SCM_BOOL_F
));
1214 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1218 const SCM cdr_expr
= CDR (expr
);
1219 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1220 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1221 quotee
= CAR (cdr_expr
);
1222 return MAKMEMO_QUOTE (quotee
);
1226 scm_m_set_x (SCM expr
, SCM env
)
1231 const SCM cdr_expr
= CDR (expr
);
1232 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1233 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1234 variable
= CAR (cdr_expr
);
1235 vmem
= memoize (variable
, env
);
1237 switch (SCM_MEMOIZED_TAG (vmem
))
1239 case SCM_M_LEXICAL_REF
:
1240 return MAKMEMO_LEX_SET (SCM_I_INUM (SCM_MEMOIZED_ARGS (vmem
)),
1241 memoize (CADDR (expr
), env
));
1242 case SCM_M_TOPLEVEL_REF
:
1243 return MAKMEMO_TOP_SET (variable
,
1244 memoize (CADDR (expr
), env
));
1245 case SCM_M_MODULE_REF
:
1246 return MAKMEMO_MOD_SET (memoize (CADDR (expr
), env
),
1247 CAR (SCM_MEMOIZED_ARGS (vmem
)),
1248 CADR (SCM_MEMOIZED_ARGS (vmem
)),
1249 CDDR (SCM_MEMOIZED_ARGS (vmem
)));
1251 syntax_error (s_bad_variable
, variable
, expr
);
1258 SCM_DEFINE (scm_memoize_expression
, "memoize-expression", 1, 0, 0,
1260 "Memoize the expression @var{exp}.")
1261 #define FUNC_NAME s_scm_memoize_expression
1263 return memoize (exp
, scm_current_module ());
1270 #define SCM_MAKE_MEMOIZER(STR, MEMOIZER, N) \
1271 (scm_cell (scm_tc16_memoizer, \
1272 (scm_t_bits)(scm_c_make_gsubr (STR, N, 0, 0, MEMOIZER))))
1273 #define SCM_DEFINE_MEMOIZER(STR, MEMOIZER, N) \
1274 SCM_SNARF_INIT(scm_c_define (STR, SCM_MAKE_MEMOIZER (STR, MEMOIZER, N)))
1276 static SCM
m_apply (SCM proc
, SCM args
);
1277 static SCM
m_call_cc (SCM proc
);
1278 static SCM
m_call_values (SCM prod
, SCM cons
);
1279 static SCM
m_dynamic_wind (SCM pre
, SCM exp
, SCM post
);
1280 static SCM
m_prompt (SCM tag
, SCM exp
, SCM handler
);
1282 SCM_DEFINE_MEMOIZER ("@apply", m_apply
, 2);
1283 SCM_DEFINE_MEMOIZER ("@call-with-current-continuation", m_call_cc
, 1);
1284 SCM_DEFINE_MEMOIZER ("@call-with-values", m_call_values
, 2);
1285 SCM_DEFINE_MEMOIZER ("@dynamic-wind", m_dynamic_wind
, 3);
1286 SCM_DEFINE_MEMOIZER ("@prompt", m_prompt
, 3);
1291 static SCM
m_apply (SCM proc
, SCM args
)
1292 #define FUNC_NAME "@apply"
1294 SCM_VALIDATE_MEMOIZED (1, proc
);
1295 SCM_VALIDATE_MEMOIZED (2, args
);
1296 return MAKMEMO_APPLY (proc
, args
);
1300 static SCM
m_call_cc (SCM proc
)
1301 #define FUNC_NAME "@call-with-current-continuation"
1303 SCM_VALIDATE_MEMOIZED (1, proc
);
1304 return MAKMEMO_CONT (proc
);
1308 static SCM
m_call_values (SCM prod
, SCM cons
)
1309 #define FUNC_NAME "@call-with-values"
1311 SCM_VALIDATE_MEMOIZED (1, prod
);
1312 SCM_VALIDATE_MEMOIZED (2, cons
);
1313 return MAKMEMO_CALL_WITH_VALUES (prod
, cons
);
1317 static SCM
m_dynamic_wind (SCM in
, SCM expr
, SCM out
)
1318 #define FUNC_NAME "memoize-dynwind"
1320 SCM_VALIDATE_MEMOIZED (1, in
);
1321 SCM_VALIDATE_MEMOIZED (2, expr
);
1322 SCM_VALIDATE_MEMOIZED (3, out
);
1323 return MAKMEMO_DYNWIND (in
, expr
, out
);
1327 static SCM
m_prompt (SCM tag
, SCM exp
, SCM handler
)
1328 #define FUNC_NAME "@prompt"
1330 SCM_VALIDATE_MEMOIZED (1, tag
);
1331 SCM_VALIDATE_MEMOIZED (2, exp
);
1332 SCM_VALIDATE_MEMOIZED (3, handler
);
1333 return MAKMEMO_PROMPT (tag
, exp
, handler
);
1337 SCM_DEFINE (scm_memoizer_p
, "memoizer?", 1, 0, 0,
1340 return scm_from_bool (SCM_MEMOIZER_P (x
));
1343 SCM_DEFINE (scm_memoizer
, "memoizer", 1, 0, 0,
1346 SCM_ASSERT (SCM_MEMOIZER_P (memoizer
), memoizer
, 1, "memoizer?");
1347 return SCM_MEMOIZER (memoizer
);
1353 SCM_SYMBOL (sym_placeholder
, "_");
1355 static SCM
unmemoize (SCM expr
);
1358 unmemoize_exprs (SCM exprs
)
1361 if (scm_is_null (exprs
))
1363 ret
= scm_list_1 (unmemoize (CAR (exprs
)));
1365 for (exprs
= CDR (exprs
); !scm_is_null (exprs
); exprs
= CDR (exprs
))
1367 SCM_SETCDR (tail
, scm_list_1 (unmemoize (CAR (exprs
))));
1374 unmemoize_bindings (SCM inits
)
1377 if (scm_is_null (inits
))
1379 ret
= scm_list_1 (scm_list_2 (sym_placeholder
, unmemoize (CAR (inits
))));
1381 for (inits
= CDR (inits
); !scm_is_null (inits
); inits
= CDR (inits
))
1383 SCM_SETCDR (tail
, scm_list_1 (scm_list_2 (sym_placeholder
,
1384 unmemoize (CAR (inits
)))));
1391 unmemoize_lexical (SCM n
)
1395 snprintf (buf
, 15, "<%u>", scm_to_uint32 (n
));
1396 return scm_from_locale_symbol (buf
);
1400 unmemoize (const SCM expr
)
1404 if (!SCM_MEMOIZED_P (expr
))
1407 args
= SCM_MEMOIZED_ARGS (expr
);
1408 switch (SCM_MEMOIZED_TAG (expr
))
1411 return scm_cons (scm_sym_atapply
, unmemoize_exprs (args
));
1413 return scm_cons (scm_sym_begin
, unmemoize_exprs (args
));
1415 return scm_cons (unmemoize (CAR (args
)), unmemoize_exprs (CDDR (args
)));
1417 return scm_list_2 (scm_sym_atcall_cc
, unmemoize (args
));
1418 case SCM_M_CALL_WITH_VALUES
:
1419 return scm_list_3 (scm_sym_at_call_with_values
,
1420 unmemoize (CAR (args
)), unmemoize (CDR (args
)));
1422 return scm_list_3 (scm_sym_define
, CAR (args
), unmemoize (CDR (args
)));
1424 return scm_list_4 (scm_sym_at_dynamic_wind
,
1425 unmemoize (CAR (args
)),
1426 unmemoize (CADR (args
)),
1427 unmemoize (CDDR (args
)));
1428 case SCM_M_WITH_FLUIDS
:
1430 SCM binds
= SCM_EOL
, fluids
, vals
;
1431 for (fluids
= CAR (args
), vals
= CADR (args
); scm_is_pair (fluids
);
1432 fluids
= CDR (fluids
), vals
= CDR (vals
))
1433 binds
= scm_cons (scm_list_2 (unmemoize (CAR (fluids
)),
1434 unmemoize (CAR (vals
))),
1436 return scm_list_3 (scm_sym_with_fluids
,
1437 scm_reverse_x (binds
, SCM_UNDEFINED
),
1438 unmemoize (CDDR (args
)));
1441 return scm_list_4 (scm_sym_if
, unmemoize (scm_car (args
)),
1442 unmemoize (scm_cadr (args
)), unmemoize (scm_cddr (args
)));
1444 if (scm_is_null (CDDR (args
)))
1445 return scm_list_3 (scm_sym_lambda
,
1446 scm_make_list (CADR (args
), sym_placeholder
),
1447 unmemoize (CAR (args
)));
1448 else if (scm_is_null (CDDDR (args
)))
1450 SCM formals
= scm_make_list (CADR (args
), sym_placeholder
);
1451 return scm_list_3 (scm_sym_lambda
,
1452 scm_is_true (CADDR (args
))
1453 ? scm_cons_star (sym_placeholder
, formals
)
1455 unmemoize (CAR (args
)));
1459 SCM body
= CAR (args
), spec
= CDR (args
), alt
, tail
;
1461 alt
= CADDR (CDDDR (spec
));
1462 if (scm_is_true (alt
))
1463 tail
= CDR (unmemoize (alt
));
1468 (sym_case_lambda_star
,
1469 scm_cons (scm_list_2 (scm_list_5 (CAR (spec
),
1473 unmemoize_exprs (CADR (CDDDR (spec
)))),
1478 return scm_list_3 (scm_sym_let
,
1479 unmemoize_bindings (CAR (args
)),
1480 unmemoize (CDR (args
)));
1482 return scm_list_2 (scm_sym_quote
, args
);
1483 case SCM_M_LEXICAL_REF
:
1484 return unmemoize_lexical (args
);
1485 case SCM_M_LEXICAL_SET
:
1486 return scm_list_3 (scm_sym_set_x
, unmemoize_lexical (CAR (args
)),
1487 unmemoize (CDR (args
)));
1488 case SCM_M_TOPLEVEL_REF
:
1490 case SCM_M_TOPLEVEL_SET
:
1491 return scm_list_3 (scm_sym_set_x
, CAR (args
), unmemoize (CDR (args
)));
1492 case SCM_M_MODULE_REF
:
1493 return SCM_VARIABLEP (args
) ? args
1494 : scm_list_3 (scm_is_true (CDDR (args
)) ? scm_sym_at
: scm_sym_atat
,
1495 scm_i_finite_list_copy (CAR (args
)),
1497 case SCM_M_MODULE_SET
:
1498 return scm_list_3 (scm_sym_set_x
,
1499 SCM_VARIABLEP (CDR (args
)) ? CDR (args
)
1500 : scm_list_3 (scm_is_true (CDDDR (args
))
1501 ? scm_sym_at
: scm_sym_atat
,
1502 scm_i_finite_list_copy (CADR (args
)),
1504 unmemoize (CAR (args
)));
1506 return scm_list_4 (scm_sym_at_prompt
,
1507 unmemoize (CAR (args
)),
1508 unmemoize (CADR (args
)),
1509 unmemoize (CDDR (args
)));
1518 SCM_DEFINE (scm_memoized_p
, "memoized?", 1, 0, 0,
1520 "Return @code{#t} if @var{obj} is memoized.")
1521 #define FUNC_NAME s_scm_memoized_p
1523 return scm_from_bool (SCM_MEMOIZED_P (obj
));
1527 SCM_DEFINE (scm_unmemoize_expression
, "unmemoize-expression", 1, 0, 0,
1529 "Unmemoize the memoized expression @var{m}.")
1530 #define FUNC_NAME s_scm_unmemoize_expression
1532 SCM_VALIDATE_MEMOIZED (1, m
);
1533 return unmemoize (m
);
1537 SCM_DEFINE (scm_memoized_expression_typecode
, "memoized-expression-typecode", 1, 0, 0,
1539 "Return the typecode from the memoized expression @var{m}.")
1540 #define FUNC_NAME s_scm_memoized_expression_typecode
1542 SCM_VALIDATE_MEMOIZED (1, m
);
1544 /* The tag is a 16-bit integer so it fits in an inum. */
1545 return SCM_I_MAKINUM (SCM_MEMOIZED_TAG (m
));
1549 SCM_DEFINE (scm_memoized_expression_data
, "memoized-expression-data", 1, 0, 0,
1551 "Return the data from the memoized expression @var{m}.")
1552 #define FUNC_NAME s_scm_memoized_expression_data
1554 SCM_VALIDATE_MEMOIZED (1, m
);
1555 return SCM_MEMOIZED_ARGS (m
);
1559 SCM_DEFINE (scm_memoized_typecode
, "memoized-typecode", 1, 0, 0,
1561 "Return the memoized typecode corresponding to the symbol @var{sym}.")
1562 #define FUNC_NAME s_scm_memoized_typecode
1566 SCM_VALIDATE_SYMBOL (1, sym
);
1568 for (i
= 0; i
< sizeof(memoized_tags
)/sizeof(const char*); i
++)
1569 if (strcmp (scm_i_symbol_chars (sym
), memoized_tags
[i
]) == 0)
1570 return scm_from_int32 (i
);
1576 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
1577 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
1578 static void error_unbound_variable (SCM symbol
)
1580 scm_error (scm_unbound_variable_key
, NULL
, "Unbound variable: ~S",
1581 scm_list_1 (symbol
), SCM_BOOL_F
);
1584 SCM_DEFINE (scm_memoize_variable_access_x
, "memoize-variable-access!", 2, 0, 0,
1586 "Look up and cache the variable that @var{m} will access, returning the variable.")
1587 #define FUNC_NAME s_scm_memoize_variable_access_x
1590 SCM_VALIDATE_MEMOIZED (1, m
);
1591 mx
= SCM_MEMOIZED_ARGS (m
);
1592 switch (SCM_MEMOIZED_TAG (m
))
1594 case SCM_M_TOPLEVEL_REF
:
1595 if (SCM_VARIABLEP (mx
))
1599 SCM var
= scm_module_variable (mod
, mx
);
1600 if (scm_is_false (var
) || scm_is_false (scm_variable_bound_p (var
)))
1601 error_unbound_variable (mx
);
1602 SCM_SET_SMOB_OBJECT (m
, var
);
1606 case SCM_M_TOPLEVEL_SET
:
1609 if (SCM_VARIABLEP (var
))
1613 var
= scm_module_variable (mod
, var
);
1614 if (scm_is_false (var
))
1615 error_unbound_variable (CAR (mx
));
1616 SCM_SETCAR (mx
, var
);
1621 case SCM_M_MODULE_REF
:
1622 if (SCM_VARIABLEP (mx
))
1627 mod
= scm_resolve_module (CAR (mx
));
1628 if (scm_is_true (CDDR (mx
)))
1629 mod
= scm_module_public_interface (mod
);
1630 var
= scm_module_lookup (mod
, CADR (mx
));
1631 if (scm_is_false (scm_variable_bound_p (var
)))
1632 error_unbound_variable (CADR (mx
));
1633 SCM_SET_SMOB_OBJECT (m
, var
);
1637 case SCM_M_MODULE_SET
:
1638 /* FIXME: not quite threadsafe */
1639 if (SCM_VARIABLEP (CDR (mx
)))
1644 mod
= scm_resolve_module (CADR (mx
));
1645 if (scm_is_true (CDDDR (mx
)))
1646 mod
= scm_module_public_interface (mod
);
1647 var
= scm_module_lookup (mod
, CADDR (mx
));
1648 SCM_SETCDR (mx
, var
);
1653 scm_wrong_type_arg (FUNC_NAME
, 1, m
);
1665 scm_tc16_memoized
= scm_make_smob_type ("%memoized", 0);
1666 scm_set_smob_mark (scm_tc16_memoized
, scm_markcdr
);
1667 scm_set_smob_print (scm_tc16_memoized
, scm_print_memoized
);
1669 scm_tc16_memoizer
= scm_make_smob_type ("memoizer", 0);
1671 #include "libguile/memoize.x"
1673 scm_c_define ("macroexpand",
1674 scm_variable_ref (scm_c_lookup ("memoize-expression")));