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 MAKMEMO_LAMBDA(nreq, rest, body) \
183 MAKMEMO (SCM_M_LAMBDA, scm_cons (SCM_I_MAKINUM (nreq), scm_cons (rest, body)))
184 #define MAKMEMO_LET(inits, body) \
185 MAKMEMO (SCM_M_LET, scm_cons (inits, body))
186 #define MAKMEMO_QUOTE(exp) \
187 MAKMEMO (SCM_M_QUOTE, exp)
188 #define MAKMEMO_DEFINE(var, val) \
189 MAKMEMO (SCM_M_DEFINE, scm_cons (var, val))
190 #define MAKMEMO_DYNWIND(in, expr, out) \
191 MAKMEMO (SCM_M_DYNWIND, scm_cons (in, scm_cons (expr, out)))
192 #define MAKMEMO_WITH_FLUIDS(fluids, vals, expr) \
193 MAKMEMO (SCM_M_WITH_FLUIDS, scm_cons (fluids, scm_cons (vals, expr)))
194 #define MAKMEMO_APPLY(exp) \
195 MAKMEMO (SCM_M_APPLY, exp)
196 #define MAKMEMO_CONT(proc) \
197 MAKMEMO (SCM_M_CONT, proc)
198 #define MAKMEMO_CALL_WITH_VALUES(prod, cons) \
199 MAKMEMO (SCM_M_CALL_WITH_VALUES, scm_cons (prod, cons))
200 #define MAKMEMO_CALL(proc, nargs, args) \
201 MAKMEMO (SCM_M_CALL, scm_cons (proc, scm_cons (SCM_I_MAKINUM (nargs), args)))
202 #define MAKMEMO_LEX_REF(n) \
203 MAKMEMO (SCM_M_LEXICAL_REF, SCM_I_MAKINUM (n))
204 #define MAKMEMO_LEX_SET(n, val) \
205 MAKMEMO (SCM_M_LEXICAL_SET, scm_cons (SCM_I_MAKINUM (n), val))
206 #define MAKMEMO_TOP_REF(var) \
207 MAKMEMO (SCM_M_TOPLEVEL_REF, var)
208 #define MAKMEMO_TOP_SET(var, val) \
209 MAKMEMO (SCM_M_TOPLEVEL_SET, scm_cons (var, val))
210 #define MAKMEMO_MOD_REF(mod, var, public) \
211 MAKMEMO (SCM_M_MODULE_REF, scm_cons (mod, scm_cons (var, public)))
212 #define MAKMEMO_MOD_SET(val, mod, var, public) \
213 MAKMEMO (SCM_M_MODULE_SET, scm_cons (val, scm_cons (mod, scm_cons (var, public))))
214 #define MAKMEMO_PROMPT(tag, exp, handler) \
215 MAKMEMO (SCM_M_PROMPT, scm_cons (tag, scm_cons (exp, handler)))
219 /* This table must agree with the list of M_ constants in memoize.h */
220 static const char *const memoized_tags
[] =
244 scm_print_memoized (SCM memoized
, SCM port
, scm_print_state
*pstate
)
246 scm_puts ("#<memoized ", port
);
247 scm_write (scm_unmemoize_expression (memoized
), port
);
248 scm_puts (">", port
);
252 static SCM
scm_m_at (SCM xorig
, SCM env
);
253 static SCM
scm_m_atat (SCM xorig
, SCM env
);
254 static SCM
scm_m_and (SCM xorig
, SCM env
);
255 static SCM
scm_m_apply (SCM xorig
, SCM env
);
256 static SCM
scm_m_begin (SCM xorig
, SCM env
);
257 static SCM
scm_m_cont (SCM xorig
, SCM env
);
258 static SCM
scm_m_at_call_with_values (SCM xorig
, SCM env
);
259 static SCM
scm_m_cond (SCM xorig
, SCM env
);
260 static SCM
scm_m_define (SCM x
, SCM env
);
261 static SCM
scm_m_at_dynamic_wind (SCM xorig
, SCM env
);
262 static SCM
scm_m_with_fluids (SCM xorig
, SCM env
);
263 static SCM
scm_m_eval_when (SCM xorig
, SCM env
);
264 static SCM
scm_m_if (SCM xorig
, SCM env
);
265 static SCM
scm_m_lambda (SCM xorig
, SCM env
);
266 static SCM
scm_m_let (SCM xorig
, SCM env
);
267 static SCM
scm_m_letrec (SCM xorig
, SCM env
);
268 static SCM
scm_m_letstar (SCM xorig
, SCM env
);
269 static SCM
scm_m_or (SCM xorig
, SCM env
);
270 static SCM
scm_m_at_prompt (SCM xorig
, SCM env
);
271 static SCM
scm_m_quote (SCM xorig
, SCM env
);
272 static SCM
scm_m_set_x (SCM xorig
, SCM env
);
278 static scm_t_macro_primitive
279 memoize_env_ref_transformer (SCM env
, SCM x
)
282 for (; scm_is_pair (env
); env
= CDR (env
))
283 if (scm_is_eq (x
, CAR (env
)))
284 return NULL
; /* lexical */
286 var
= scm_module_variable (env
, x
);
287 if (scm_is_true (var
) && scm_is_true (scm_variable_bound_p (var
))
288 && scm_is_true (scm_macro_p (scm_variable_ref (var
))))
289 return scm_i_macro_primitive (scm_variable_ref (var
));
291 return NULL
; /* anything else */
295 memoize_env_var_is_free (SCM env
, SCM x
)
297 for (; scm_is_pair (env
); env
= CDR (env
))
298 if (scm_is_eq (x
, CAR (env
)))
299 return 0; /* bound */
304 memoize_env_lexical_index (SCM env
, SCM x
)
307 for (; scm_is_pair (env
); env
= CDR (env
), i
++)
308 if (scm_is_eq (x
, CAR (env
)))
309 return i
; /* bound */
310 return -1; /* free */
314 memoize_env_extend (SCM env
, SCM vars
)
316 return scm_append (scm_list_2 (vars
, env
));
320 memoize (SCM exp
, SCM env
)
322 if (scm_is_pair (exp
))
325 scm_t_macro_primitive trans
;
328 if (scm_is_symbol (CAR
))
329 trans
= memoize_env_ref_transformer (env
, CAR
);
334 return trans (exp
, env
);
340 proc
= memoize (CAR (exp
), env
);
341 for (exp
= CDR (exp
); scm_is_pair (exp
); exp
= CDR (exp
), nargs
++)
342 args
= scm_cons (memoize (CAR (exp
), env
), args
);
343 if (scm_is_null (exp
))
344 return MAKMEMO_CALL (proc
, nargs
,
345 scm_reverse_x (args
, SCM_UNDEFINED
));
347 syntax_error ("expected a proper list", exp
, SCM_UNDEFINED
);
350 else if (scm_is_symbol (exp
))
352 int i
= memoize_env_lexical_index (env
, exp
);
354 return MAKMEMO_TOP_REF (exp
);
356 return MAKMEMO_LEX_REF (i
);
359 return MAKMEMO_QUOTE (exp
);
363 memoize_exprs (SCM forms
, const SCM env
)
367 for (; !scm_is_null (forms
); forms
= CDR (forms
))
368 ret
= scm_cons (memoize (CAR (forms
), env
), ret
);
369 return scm_reverse_x (ret
, SCM_UNDEFINED
);
373 memoize_sequence (const SCM forms
, const SCM env
)
375 ASSERT_SYNTAX (scm_ilength (forms
) >= 1, s_bad_expression
,
376 scm_cons (scm_sym_begin
, forms
));
377 if (scm_is_null (CDR (forms
)))
378 return memoize (CAR (forms
), env
);
380 return MAKMEMO_BEGIN (memoize_exprs (forms
, env
));
387 #define SCM_SYNTAX(RANAME, STR, CFN) \
388 SCM_SNARF_HERE(static const char RANAME[]=STR)\
389 SCM_SNARF_INIT(scm_c_define (RANAME, scm_i_make_primitive_macro (RANAME, CFN)))
391 SCM_SYNTAX (s_at
, "@", scm_m_at
);
392 SCM_SYNTAX (s_atat
, "@@", scm_m_atat
);
393 SCM_SYNTAX (s_and
, "and", scm_m_and
);
394 SCM_SYNTAX (s_begin
, "begin", scm_m_begin
);
395 SCM_SYNTAX (s_atcall_cc
, "@call-with-current-continuation", scm_m_cont
);
396 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_m_at_call_with_values
);
397 SCM_SYNTAX (s_cond
, "cond", scm_m_cond
);
398 SCM_SYNTAX (s_define
, "define", scm_m_define
);
399 SCM_SYNTAX (s_at_dynamic_wind
, "@dynamic-wind", scm_m_at_dynamic_wind
);
400 SCM_SYNTAX (s_with_fluids
, "with-fluids", scm_m_with_fluids
);
401 SCM_SYNTAX (s_eval_when
, "eval-when", scm_m_eval_when
);
402 SCM_SYNTAX (s_if
, "if", scm_m_if
);
403 SCM_SYNTAX (s_lambda
, "lambda", scm_m_lambda
);
404 SCM_SYNTAX (s_let
, "let", scm_m_let
);
405 SCM_SYNTAX (s_letrec
, "letrec", scm_m_letrec
);
406 SCM_SYNTAX (s_letstar
, "let*", scm_m_letstar
);
407 SCM_SYNTAX (s_or
, "or", scm_m_or
);
408 SCM_SYNTAX (s_at_prompt
, "@prompt", scm_m_at_prompt
);
409 SCM_SYNTAX (s_quote
, "quote", scm_m_quote
);
410 SCM_SYNTAX (s_set_x
, "set!", scm_m_set_x
);
411 SCM_SYNTAX (s_atapply
, "@apply", scm_m_apply
);
414 SCM_GLOBAL_SYMBOL (scm_sym_apply
, "apply");
415 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
416 SCM_GLOBAL_SYMBOL (scm_sym_at
, "@");
417 SCM_GLOBAL_SYMBOL (scm_sym_atat
, "@@");
418 SCM_GLOBAL_SYMBOL (scm_sym_at_call_with_values
, "@call-with-values");
419 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, "@apply");
420 SCM_GLOBAL_SYMBOL (scm_sym_atcall_cc
, "@call-with-current-continuation");
421 SCM_GLOBAL_SYMBOL (scm_sym_begin
, "begin");
422 SCM_GLOBAL_SYMBOL (scm_sym_case
, "case");
423 SCM_GLOBAL_SYMBOL (scm_sym_cond
, "cond");
424 SCM_GLOBAL_SYMBOL (scm_sym_define
, "define");
425 SCM_GLOBAL_SYMBOL (scm_sym_at_dynamic_wind
, "@dynamic-wind");
426 SCM_GLOBAL_SYMBOL (scm_sym_with_fluids
, "with-fluids");
427 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
428 SCM_GLOBAL_SYMBOL (scm_sym_eval_when
, "eval-when");
429 SCM_GLOBAL_SYMBOL (scm_sym_if
, "if");
430 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, "lambda");
431 SCM_GLOBAL_SYMBOL (scm_sym_let
, "let");
432 SCM_GLOBAL_SYMBOL (scm_sym_letrec
, "letrec");
433 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, "let*");
434 SCM_GLOBAL_SYMBOL (scm_sym_or
, "or");
435 SCM_GLOBAL_SYMBOL (scm_sym_at_prompt
, "@prompt");
436 SCM_GLOBAL_SYMBOL (scm_sym_quote
, "quote");
437 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, "set!");
438 SCM_SYMBOL (sym_eval
, "eval");
439 SCM_SYMBOL (sym_load
, "load");
441 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
442 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, "quasiquote");
443 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
447 scm_m_at (SCM expr
, SCM env SCM_UNUSED
)
449 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
450 ASSERT_SYNTAX (scm_ilength (CADR (expr
)) > 0, s_bad_expression
, expr
);
451 ASSERT_SYNTAX (scm_is_symbol (CADDR (expr
)), s_bad_expression
, expr
);
453 return MAKMEMO_MOD_REF (CADR (expr
), CADDR (expr
), SCM_BOOL_T
);
457 scm_m_atat (SCM expr
, SCM env SCM_UNUSED
)
459 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
460 ASSERT_SYNTAX (scm_ilength (CADR (expr
)) > 0, s_bad_expression
, expr
);
461 ASSERT_SYNTAX (scm_is_symbol (CADDR (expr
)), s_bad_expression
, expr
);
463 return MAKMEMO_MOD_REF (CADR (expr
), CADDR (expr
), SCM_BOOL_F
);
467 scm_m_and (SCM expr
, SCM env
)
469 const SCM cdr_expr
= CDR (expr
);
471 if (scm_is_null (cdr_expr
))
472 return MAKMEMO_QUOTE (SCM_BOOL_T
);
473 ASSERT_SYNTAX (scm_is_pair (cdr_expr
), s_bad_expression
, expr
);
475 if (scm_is_null (CDR (cdr_expr
)))
476 return memoize (CAR (cdr_expr
), env
);
478 return MAKMEMO_IF (memoize (CAR (cdr_expr
), env
),
479 scm_m_and (cdr_expr
, env
),
480 MAKMEMO_QUOTE (SCM_BOOL_F
));
484 scm_m_apply (SCM expr
, SCM env
)
486 const SCM cdr_expr
= CDR (expr
);
487 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
488 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
490 return MAKMEMO_APPLY (memoize_exprs (cdr_expr
, env
));
494 scm_m_begin (SCM expr
, SCM env
)
496 const SCM cdr_expr
= CDR (expr
);
497 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_bad_expression
, expr
);
498 return MAKMEMO_BEGIN (memoize_exprs (cdr_expr
, env
));
502 scm_m_cont (SCM expr
, SCM env
)
504 const SCM cdr_expr
= CDR (expr
);
505 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
506 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
508 return MAKMEMO_CONT (memoize (CADR (expr
), env
));
512 scm_m_at_call_with_values (SCM expr
, SCM env
)
514 const SCM cdr_expr
= CDR (expr
);
515 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
516 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
518 return MAKMEMO_CALL_WITH_VALUES (memoize (CADR (expr
), env
),
519 memoize (CADDR (expr
), env
));
523 scm_m_cond (SCM expr
, SCM env
)
525 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
526 const int else_literal_p
= memoize_env_var_is_free (env
, scm_sym_else
);
527 const int arrow_literal_p
= memoize_env_var_is_free (env
, scm_sym_arrow
);
529 const SCM clauses
= CDR (expr
);
533 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
534 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
536 ret
= scm_cons (SCM_UNDEFINED
, MAKMEMO_QUOTE (SCM_UNSPECIFIED
));
539 for (clause_idx
= clauses
;
540 !scm_is_null (clause_idx
);
541 clause_idx
= CDR (clause_idx
))
545 const SCM clause
= CAR (clause_idx
);
546 const long length
= scm_ilength (clause
);
547 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
550 if (scm_is_eq (test
, scm_sym_else
) && else_literal_p
)
552 const int last_clause_p
= scm_is_null (CDR (clause_idx
));
553 ASSERT_SYNTAX_2 (length
>= 2,
554 s_bad_cond_clause
, clause
, expr
);
555 ASSERT_SYNTAX_2 (last_clause_p
,
556 s_misplaced_else_clause
, clause
, expr
);
558 memoize (scm_cons (scm_sym_begin
, CDR (clause
)), env
));
561 && scm_is_eq (CADR (clause
), scm_sym_arrow
)
564 SCM tmp
= scm_gensym (scm_from_locale_string ("cond "));
566 SCM new_env
= scm_cons (tmp
, env
);
567 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
568 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
569 i
= MAKMEMO_IF (MAKMEMO_LEX_REF (0),
570 MAKMEMO_CALL (memoize (CADDR (clause
),
571 scm_cons (tmp
, new_env
)),
573 scm_list_1 (MAKMEMO_LEX_REF (0))),
574 MAKMEMO_QUOTE (SCM_UNSPECIFIED
));
576 MAKMEMO_LET (scm_list_1 (memoize (CAR (clause
), env
)),
579 loc
= scm_last_pair (SCM_MEMOIZED_ARGS (i
));
581 /* FIXME length == 1 case */
584 SCM i
= MAKMEMO_IF (memoize (CAR (clause
), env
),
585 memoize (scm_cons (scm_sym_begin
, CDR (clause
)), env
),
586 MAKMEMO_QUOTE (SCM_UNSPECIFIED
));
588 loc
= scm_last_pair (SCM_MEMOIZED_ARGS (i
));
595 /* According to Section 5.2.1 of R5RS we first have to make sure that the
596 variable is bound, and then perform the `(set! variable expression)'
597 operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
598 bound. This means that EXPRESSION won't necessarily be able to assign
599 values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
601 scm_m_define (SCM expr
, SCM env
)
603 const SCM cdr_expr
= CDR (expr
);
607 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
608 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
609 ASSERT_SYNTAX (!scm_is_pair (env
), s_bad_define
, expr
);
611 body
= CDR (cdr_expr
);
612 variable
= CAR (cdr_expr
);
614 if (scm_is_pair (variable
))
616 ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable
)), s_bad_variable
, variable
, expr
);
617 return MAKMEMO_DEFINE (CAR (variable
),
618 memoize (scm_cons (scm_sym_lambda
,
619 scm_cons (CDR (variable
), body
)),
622 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
623 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
624 return MAKMEMO_DEFINE (variable
, memoize (CAR (body
), env
));
628 scm_m_at_dynamic_wind (SCM expr
, SCM env
)
630 const SCM cdr_expr
= CDR (expr
);
631 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_bad_expression
, expr
);
633 return MAKMEMO_DYNWIND (memoize (CADR (expr
), env
),
634 memoize (CADDR (expr
), env
),
635 memoize (CADDDR (expr
), env
));
639 scm_m_with_fluids (SCM expr
, SCM env
)
641 SCM binds
, fluids
, vals
;
642 ASSERT_SYNTAX (scm_ilength (expr
) >= 3, s_bad_expression
, expr
);
644 ASSERT_SYNTAX_2 (scm_ilength (binds
) >= 0, s_bad_bindings
, binds
, expr
);
645 for (fluids
= SCM_EOL
, vals
= SCM_EOL
;
649 SCM binding
= CAR (binds
);
650 ASSERT_SYNTAX_2 (scm_ilength (CAR (binds
)) == 2, s_bad_binding
,
652 fluids
= scm_cons (memoize (CAR (binding
), env
), fluids
);
653 vals
= scm_cons (memoize (CADR (binding
), env
), vals
);
656 return MAKMEMO_WITH_FLUIDS (scm_reverse_x (fluids
, SCM_UNDEFINED
),
657 scm_reverse_x (vals
, SCM_UNDEFINED
),
658 memoize_sequence (CDDR (expr
), env
));
662 scm_m_eval_when (SCM expr
, SCM env
)
664 ASSERT_SYNTAX (scm_ilength (expr
) >= 3, s_bad_expression
, expr
);
665 ASSERT_SYNTAX (scm_ilength (CADR (expr
)) > 0, s_bad_expression
, expr
);
667 if (scm_is_true (scm_memq (sym_eval
, CADR (expr
)))
668 || scm_is_true (scm_memq (sym_load
, CADR (expr
))))
669 return MAKMEMO_BEGIN (memoize_exprs (CDDR (expr
), env
));
671 return MAKMEMO_QUOTE (SCM_UNSPECIFIED
);
675 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
677 const SCM cdr_expr
= CDR (expr
);
678 const long length
= scm_ilength (cdr_expr
);
679 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
680 return MAKMEMO_IF (memoize (CADR (expr
), env
),
681 memoize (CADDR (expr
), env
),
683 ? memoize (CADDDR (expr
), env
)
684 : MAKMEMO_QUOTE (SCM_UNSPECIFIED
)));
687 /* A helper function for memoize_lambda to support checking for duplicate
688 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
689 * LIST or to the CDR of the last cons. Therefore, LIST may have any of the
690 * forms that a formal argument can have:
691 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
693 c_improper_memq (SCM obj
, SCM list
)
695 for (; scm_is_pair (list
); list
= CDR (list
))
697 if (scm_is_eq (CAR (list
), obj
))
700 return scm_is_eq (list
, obj
);
704 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
708 SCM formal_vars
= SCM_EOL
;
711 const SCM cdr_expr
= CDR (expr
);
712 const long length
= scm_ilength (cdr_expr
);
713 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
714 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
716 /* Before iterating the list of formal arguments, make sure the formals
717 * actually are given as either a symbol or a non-cyclic list. */
718 formals
= CAR (cdr_expr
);
719 if (scm_is_pair (formals
))
721 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
722 * detected, report a 'Bad formals' error. */
726 ASSERT_SYNTAX_2 (scm_is_symbol (formals
) || scm_is_null (formals
),
727 s_bad_formals
, formals
, expr
);
730 /* Now iterate the list of formal arguments to check if all formals are
731 * symbols, and that there are no duplicates. */
732 formals_idx
= formals
;
733 while (scm_is_pair (formals_idx
))
735 const SCM formal
= CAR (formals_idx
);
736 const SCM next_idx
= CDR (formals_idx
);
737 ASSERT_SYNTAX_2 (scm_is_symbol (formal
), s_bad_formal
, formal
, expr
);
738 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
739 s_duplicate_formal
, formal
, expr
);
741 formal_vars
= scm_cons (formal
, formal_vars
);
742 formals_idx
= next_idx
;
744 ASSERT_SYNTAX_2 (scm_is_null (formals_idx
) || scm_is_symbol (formals_idx
),
745 s_bad_formal
, formals_idx
, expr
);
746 if (scm_is_symbol (formals_idx
))
747 formal_vars
= scm_cons (formals_idx
, formal_vars
);
748 return MAKMEMO_LAMBDA (nreq
, scm_symbol_p (formals_idx
),
749 memoize_sequence (CDDR (expr
),
750 memoize_env_extend (env
, formal_vars
)));
753 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
755 check_bindings (const SCM bindings
, const SCM expr
)
759 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
760 s_bad_bindings
, bindings
, expr
);
762 binding_idx
= bindings
;
763 for (; !scm_is_null (binding_idx
); binding_idx
= CDR (binding_idx
))
765 SCM name
; /* const */
767 const SCM binding
= CAR (binding_idx
);
768 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
769 s_bad_binding
, binding
, expr
);
771 name
= CAR (binding
);
772 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
776 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
777 * transformed to the lists (vn .. v2 v1) and (i1 i2 ... in). If a duplicate
778 * variable name is detected, an error is signalled. */
780 transform_bindings (const SCM bindings
, const SCM expr
,
781 SCM
*const rvarptr
, SCM
*const initptr
)
783 SCM rvariables
= SCM_EOL
;
784 SCM rinits
= SCM_EOL
;
785 SCM binding_idx
= bindings
;
787 for (; !scm_is_null (binding_idx
); binding_idx
= CDR (binding_idx
))
789 const SCM binding
= CAR (binding_idx
);
790 const SCM CDR_binding
= CDR (binding
);
791 const SCM name
= CAR (binding
);
792 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rvariables
)),
793 s_duplicate_binding
, name
, expr
);
794 rvariables
= scm_cons (name
, rvariables
);
795 rinits
= scm_cons (CAR (CDR_binding
), rinits
);
798 *rvarptr
= rvariables
;
799 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
803 /* This function is a helper function for memoize_let. It transforms
804 * (let name ((var init) ...) body ...) into
805 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
806 * and memoizes the expression. It is assumed that the caller has checked
807 * that name is a symbol and that there are bindings and a body. */
809 memoize_named_let (const SCM expr
, SCM env
)
815 const SCM cdr_expr
= CDR (expr
);
816 const SCM name
= CAR (cdr_expr
);
817 const SCM cddr_expr
= CDR (cdr_expr
);
818 const SCM bindings
= CAR (cddr_expr
);
819 check_bindings (bindings
, expr
);
821 nreq
= transform_bindings (bindings
, expr
, &rvariables
, &inits
);
823 env
= scm_cons (name
, env
);
825 (scm_list_1 (MAKMEMO_QUOTE (SCM_UNDEFINED
)),
827 (scm_list_2 (MAKMEMO_LEX_SET
831 memoize_sequence (CDDDR (expr
),
832 memoize_env_extend (env
, rvariables
)))),
833 MAKMEMO_CALL (MAKMEMO_LEX_REF (0),
835 memoize_exprs (inits
, env
)))));
838 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
839 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
841 scm_m_let (SCM expr
, SCM env
)
845 const SCM cdr_expr
= CDR (expr
);
846 const long length
= scm_ilength (cdr_expr
);
847 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
848 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
850 bindings
= CAR (cdr_expr
);
851 if (scm_is_symbol (bindings
))
853 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
854 return memoize_named_let (expr
, env
);
857 check_bindings (bindings
, expr
);
858 if (scm_is_null (bindings
))
859 return memoize_sequence (CDDR (expr
), env
);
864 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
865 return MAKMEMO_LET (memoize_exprs (inits
, env
),
866 memoize_sequence (CDDR (expr
),
867 memoize_env_extend (env
, rvariables
)));
872 scm_m_letrec (SCM expr
, SCM env
)
876 const SCM cdr_expr
= CDR (expr
);
877 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
878 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
880 bindings
= CAR (cdr_expr
);
881 if (scm_is_null (bindings
))
882 return memoize_sequence (CDDR (expr
), env
);
888 SCM undefs
= SCM_EOL
;
893 int n
= transform_bindings (bindings
, expr
, &rvariables
, &inits
);
895 new_env
= memoize_env_extend (env
, rvariables
);
896 for (v
= scm_reverse (rvariables
), i
= inits
; scm_is_pair (v
);
897 v
= CDR (v
), i
= CDR (i
), n
--)
899 undefs
= scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED
), undefs
);
900 vals
= scm_cons (memoize (CAR (i
), new_env
), vals
);
901 sets
= scm_cons (MAKMEMO_LEX_SET ((n
-1) + offset
,
902 MAKMEMO_LEX_REF (n
-1)),
907 MAKMEMO_BEGIN (scm_list_2 (MAKMEMO_LET (scm_reverse (vals
),
908 MAKMEMO_BEGIN (sets
)),
909 memoize_sequence (CDDR (expr
),
915 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
919 const SCM cdr_expr
= CDR (expr
);
920 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
921 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
923 bindings
= CAR (cdr_expr
);
924 if (scm_is_null (bindings
))
925 return memoize_sequence (CDDR (expr
), env
);
932 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
933 variables
= scm_reverse (rvariables
);
934 ret
= scm_cons (SCM_UNDEFINED
, SCM_UNSPECIFIED
);
936 for (; scm_is_pair (variables
);
937 variables
= CDR (variables
), inits
= CDR (inits
))
938 { SCM x
= MAKMEMO_LET (scm_list_1 (memoize (CAR (inits
), env
)),
939 MAKMEMO_QUOTE (SCM_UNSPECIFIED
));
941 loc
= scm_last_pair (SCM_MEMOIZED_ARGS (x
));
942 env
= scm_cons (CAR (variables
), env
);
944 SCM_SETCDR (loc
, memoize_sequence (CDDR (expr
), env
));
950 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
952 SCM tail
= CDR (expr
);
954 const long length
= scm_ilength (tail
);
956 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
958 ret
= scm_cons (SCM_UNDEFINED
, SCM_UNSPECIFIED
);
960 for (; scm_is_pair (tail
); tail
= CDR (tail
))
962 SCM tmp
= scm_gensym (scm_from_locale_string ("cond "));
963 SCM x
= MAKMEMO_IF (MAKMEMO_LEX_REF (0),
965 MAKMEMO_QUOTE (SCM_UNSPECIFIED
));
966 SCM new_env
= scm_cons (tmp
, env
);
967 SCM_SETCDR (loc
, MAKMEMO_LET (scm_list_1 (memoize (CAR (tail
),
971 loc
= scm_last_pair (SCM_MEMOIZED_ARGS (x
));
973 SCM_SETCDR (loc
, MAKMEMO_QUOTE (SCM_BOOL_F
));
978 scm_m_at_prompt (SCM expr
, SCM env
)
980 ASSERT_SYNTAX (scm_ilength (expr
) >= 0, s_bad_expression
, expr
);
981 ASSERT_SYNTAX (scm_ilength (expr
) == 4, s_expression
, expr
);
983 return MAKMEMO_PROMPT (memoize (CADR (expr
), env
),
984 memoize (CADDR (expr
), env
),
985 memoize (CADDDR (expr
), env
));
989 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
993 const SCM cdr_expr
= CDR (expr
);
994 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
995 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
996 quotee
= CAR (cdr_expr
);
997 return MAKMEMO_QUOTE (quotee
);
1001 scm_m_set_x (SCM expr
, SCM env
)
1006 const SCM cdr_expr
= CDR (expr
);
1007 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1008 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1009 variable
= CAR (cdr_expr
);
1010 vmem
= memoize (variable
, env
);
1012 switch (SCM_MEMOIZED_TAG (vmem
))
1014 case SCM_M_LEXICAL_REF
:
1015 return MAKMEMO_LEX_SET (SCM_I_INUM (SCM_MEMOIZED_ARGS (vmem
)),
1016 memoize (CADDR (expr
), env
));
1017 case SCM_M_TOPLEVEL_REF
:
1018 return MAKMEMO_TOP_SET (variable
,
1019 memoize (CADDR (expr
), env
));
1020 case SCM_M_MODULE_REF
:
1021 return MAKMEMO_MOD_SET (memoize (CADDR (expr
), env
),
1022 CAR (SCM_MEMOIZED_ARGS (vmem
)),
1023 CADR (SCM_MEMOIZED_ARGS (vmem
)),
1024 CDDR (SCM_MEMOIZED_ARGS (vmem
)));
1026 syntax_error (s_bad_variable
, variable
, expr
);
1033 SCM_DEFINE (scm_memoize_expression
, "memoize-expression", 1, 0, 0,
1035 "Memoize the expression @var{exp}.")
1036 #define FUNC_NAME s_scm_memoize_expression
1038 return memoize (exp
, scm_current_module ());
1045 SCM_SYMBOL (sym_placeholder
, "_");
1047 static SCM
unmemoize (SCM expr
);
1050 unmemoize_exprs (SCM exprs
)
1053 if (scm_is_null (exprs
))
1055 ret
= scm_list_1 (unmemoize (CAR (exprs
)));
1057 for (exprs
= CDR (exprs
); !scm_is_null (exprs
); exprs
= CDR (exprs
))
1059 SCM_SETCDR (tail
, scm_list_1 (unmemoize (CAR (exprs
))));
1066 unmemoize_bindings (SCM inits
)
1069 if (scm_is_null (inits
))
1071 ret
= scm_list_1 (scm_list_2 (sym_placeholder
, unmemoize (CAR (inits
))));
1073 for (inits
= CDR (inits
); !scm_is_null (inits
); inits
= CDR (inits
))
1075 SCM_SETCDR (tail
, scm_list_1 (scm_list_2 (sym_placeholder
,
1076 unmemoize (CAR (inits
)))));
1083 unmemoize_lexical (SCM n
)
1087 snprintf (buf
, 15, "<%u>", scm_to_uint32 (n
));
1088 return scm_from_locale_symbol (buf
);
1092 unmemoize (const SCM expr
)
1096 if (!SCM_MEMOIZED_P (expr
))
1099 args
= SCM_MEMOIZED_ARGS (expr
);
1100 switch (SCM_MEMOIZED_TAG (expr
))
1103 return scm_cons (scm_sym_atapply
, unmemoize_exprs (args
));
1105 return scm_cons (scm_sym_begin
, unmemoize_exprs (args
));
1107 return scm_cons (unmemoize (CAR (args
)), unmemoize_exprs (CDDR (args
)));
1109 return scm_list_2 (scm_sym_atcall_cc
, unmemoize (args
));
1110 case SCM_M_CALL_WITH_VALUES
:
1111 return scm_list_3 (scm_sym_at_call_with_values
,
1112 unmemoize (CAR (args
)), unmemoize (CDR (args
)));
1114 return scm_list_3 (scm_sym_define
, CAR (args
), unmemoize (CDR (args
)));
1116 return scm_list_4 (scm_sym_at_dynamic_wind
,
1117 unmemoize (CAR (args
)),
1118 unmemoize (CADR (args
)),
1119 unmemoize (CDDR (args
)));
1120 case SCM_M_WITH_FLUIDS
:
1122 SCM binds
= SCM_EOL
, fluids
, vals
;
1123 for (fluids
= CAR (args
), vals
= CADR (args
); scm_is_pair (fluids
);
1124 fluids
= CDR (fluids
), vals
= CDR (vals
))
1125 binds
= scm_cons (scm_list_2 (unmemoize (CAR (fluids
)),
1126 unmemoize (CAR (vals
))),
1128 return scm_list_3 (scm_sym_with_fluids
,
1129 scm_reverse_x (binds
, SCM_UNDEFINED
),
1130 unmemoize (CDDR (args
)));
1133 return scm_list_4 (scm_sym_if
, unmemoize (scm_car (args
)),
1134 unmemoize (scm_cadr (args
)), unmemoize (scm_cddr (args
)));
1136 return scm_list_3 (scm_sym_lambda
,
1137 scm_make_list (CAR (args
), sym_placeholder
),
1138 unmemoize (CDDR (args
)));
1140 return scm_list_3 (scm_sym_let
,
1141 unmemoize_bindings (CAR (args
)),
1142 unmemoize (CDR (args
)));
1144 return scm_list_2 (scm_sym_quote
, args
);
1145 case SCM_M_LEXICAL_REF
:
1146 return unmemoize_lexical (args
);
1147 case SCM_M_LEXICAL_SET
:
1148 return scm_list_3 (scm_sym_set_x
, unmemoize_lexical (CAR (args
)),
1149 unmemoize (CDR (args
)));
1150 case SCM_M_TOPLEVEL_REF
:
1152 case SCM_M_TOPLEVEL_SET
:
1153 return scm_list_3 (scm_sym_set_x
, CAR (args
), unmemoize (CDR (args
)));
1154 case SCM_M_MODULE_REF
:
1155 return SCM_VARIABLEP (args
) ? args
1156 : scm_list_3 (scm_is_true (CDDR (args
)) ? scm_sym_at
: scm_sym_atat
,
1157 scm_i_finite_list_copy (CAR (args
)),
1159 case SCM_M_MODULE_SET
:
1160 return scm_list_3 (scm_sym_set_x
,
1161 SCM_VARIABLEP (CDR (args
)) ? CDR (args
)
1162 : scm_list_3 (scm_is_true (CDDDR (args
))
1163 ? scm_sym_at
: scm_sym_atat
,
1164 scm_i_finite_list_copy (CADR (args
)),
1166 unmemoize (CAR (args
)));
1168 return scm_list_4 (scm_sym_at_prompt
,
1169 unmemoize (CAR (args
)),
1170 unmemoize (CADR (args
)),
1171 unmemoize (CDDR (args
)));
1177 SCM_DEFINE (scm_memoized_p
, "memoized?", 1, 0, 0,
1179 "Return @code{#t} if @var{obj} is memoized.")
1180 #define FUNC_NAME s_scm_memoized_p
1182 return scm_from_bool (SCM_MEMOIZED_P (obj
));
1186 SCM_DEFINE (scm_unmemoize_expression
, "unmemoize-expression", 1, 0, 0,
1188 "Unmemoize the memoized expression @var{m}.")
1189 #define FUNC_NAME s_scm_unmemoize_expression
1191 SCM_VALIDATE_MEMOIZED (1, m
);
1192 return unmemoize (m
);
1196 SCM_DEFINE (scm_memoized_expression_typecode
, "memoized-expression-typecode", 1, 0, 0,
1198 "Return the typecode from the memoized expression @var{m}.")
1199 #define FUNC_NAME s_scm_memoized_expression_typecode
1201 SCM_VALIDATE_MEMOIZED (1, m
);
1203 /* The tag is a 16-bit integer so it fits in an inum. */
1204 return SCM_I_MAKINUM (SCM_MEMOIZED_TAG (m
));
1208 SCM_DEFINE (scm_memoized_expression_data
, "memoized-expression-data", 1, 0, 0,
1210 "Return the data from the memoized expression @var{m}.")
1211 #define FUNC_NAME s_scm_memoized_expression_data
1213 SCM_VALIDATE_MEMOIZED (1, m
);
1214 return SCM_MEMOIZED_ARGS (m
);
1218 SCM_DEFINE (scm_memoized_typecode
, "memoized-typecode", 1, 0, 0,
1220 "Return the memoized typecode corresponding to the symbol @var{sym}.")
1221 #define FUNC_NAME s_scm_memoized_typecode
1225 SCM_VALIDATE_SYMBOL (1, sym
);
1227 for (i
= 0; i
< sizeof(memoized_tags
)/sizeof(const char*); i
++)
1228 if (strcmp (scm_i_symbol_chars (sym
), memoized_tags
[i
]) == 0)
1229 return scm_from_int32 (i
);
1235 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
1236 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
1237 static void error_unbound_variable (SCM symbol
)
1239 scm_error (scm_unbound_variable_key
, NULL
, "Unbound variable: ~S",
1240 scm_list_1 (symbol
), SCM_BOOL_F
);
1243 SCM_DEFINE (scm_memoize_variable_access_x
, "memoize-variable-access!", 2, 0, 0,
1245 "Look up and cache the variable that @var{m} will access, returning the variable.")
1246 #define FUNC_NAME s_scm_memoize_variable_access_x
1249 SCM_VALIDATE_MEMOIZED (1, m
);
1250 mx
= SCM_MEMOIZED_ARGS (m
);
1251 switch (SCM_MEMOIZED_TAG (m
))
1253 case SCM_M_TOPLEVEL_REF
:
1254 if (SCM_VARIABLEP (mx
))
1258 SCM var
= scm_module_variable (mod
, mx
);
1259 if (scm_is_false (var
) || scm_is_false (scm_variable_bound_p (var
)))
1260 error_unbound_variable (mx
);
1261 SCM_SET_SMOB_OBJECT (m
, var
);
1265 case SCM_M_TOPLEVEL_SET
:
1268 if (SCM_VARIABLEP (var
))
1272 var
= scm_module_variable (mod
, var
);
1273 if (scm_is_false (var
))
1274 error_unbound_variable (CAR (mx
));
1275 SCM_SETCAR (mx
, var
);
1280 case SCM_M_MODULE_REF
:
1281 if (SCM_VARIABLEP (mx
))
1286 mod
= scm_resolve_module (CAR (mx
));
1287 if (scm_is_true (CDDR (mx
)))
1288 mod
= scm_module_public_interface (mod
);
1289 var
= scm_module_lookup (mod
, CADR (mx
));
1290 if (scm_is_false (scm_variable_bound_p (var
)))
1291 error_unbound_variable (CADR (mx
));
1292 SCM_SET_SMOB_OBJECT (m
, var
);
1296 case SCM_M_MODULE_SET
:
1297 /* FIXME: not quite threadsafe */
1298 if (SCM_VARIABLEP (CDR (mx
)))
1303 mod
= scm_resolve_module (CADR (mx
));
1304 if (scm_is_true (CDDDR (mx
)))
1305 mod
= scm_module_public_interface (mod
);
1306 var
= scm_module_lookup (mod
, CADDR (mx
));
1307 SCM_SETCDR (mx
, var
);
1312 scm_wrong_type_arg (FUNC_NAME
, 1, m
);
1324 scm_tc16_memoized
= scm_make_smob_type ("%memoized", 0);
1325 scm_set_smob_mark (scm_tc16_memoized
, scm_markcdr
);
1326 scm_set_smob_print (scm_tc16_memoized
, scm_print_memoized
);
1328 #include "libguile/memoize.x"