HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
add SCM_SMOB_TYPE_BITS and SCM_SMOB_TYPE_MASK
[bpt/guile.git] / libguile / memoize.c
CommitLineData
b7742c6b
AW		 1/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
2 * Free Software Foundation, Inc.
3 *
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.
8 *
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.
13 *
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
17 * 02110-1301 USA
18 */
19
20\f
21
22#ifdef HAVE_CONFIG_H
23# include <config.h>
24#endif
25
b7742c6b
AW		 26#include "libguile/__scm.h"
27
28#include <assert.h>
29#include "libguile/_scm.h"
30#include "libguile/continuations.h"
31#include "libguile/eq.h"
32#include "libguile/list.h"
33#include "libguile/macros.h"
34#include "libguile/memoize.h"
35#include "libguile/modules.h"
36#include "libguile/srcprop.h"
37#include "libguile/ports.h"
38#include "libguile/print.h"
39#include "libguile/strings.h"
40#include "libguile/throw.h"
41#include "libguile/validate.h"
42
43
44\f
45
46
47#if 0
48#define CAR(x) SCM_CAR(x)
49#define CDR(x) SCM_CDR(x)
50#define CAAR(x) SCM_CAAR(x)
51#define CADR(x) SCM_CADR(x)
52#define CDAR(x) SCM_CDAR(x)
53#define CDDR(x) SCM_CDDR(x)
54#define CADDR(x) SCM_CADDR(x)
55#define CDDDR(x) SCM_CDDDR(x)
56#define CADDDR(x) SCM_CDDDR(x)
57#else
58#define CAR(x) scm_car(x)
59#define CDR(x) scm_cdr(x)
60#define CAAR(x) scm_caar(x)
61#define CADR(x) scm_cadr(x)
62#define CDAR(x) scm_cdar(x)
63#define CDDR(x) scm_cddr(x)
64#define CADDR(x) scm_caddr(x)
65#define CDDDR(x) scm_cdddr(x)
66#define CADDDR(x) scm_cadddr(x)
67#endif
68
69
70static const char s_bad_expression[] = "Bad expression";
71static const char s_expression[] = "Missing or extra expression in";
72static const char s_missing_expression[] = "Missing expression in";
73static const char s_extra_expression[] = "Extra expression in";
74static const char s_empty_combination[] = "Illegal empty combination";
75static const char s_missing_body_expression[] = "Missing body expression in";
76static const char s_mixed_body_forms[] = "Mixed definitions and expressions in";
77static const char s_bad_define[] = "Bad define placement";
78static const char s_missing_clauses[] = "Missing clauses";
79static const char s_misplaced_else_clause[] = "Misplaced else clause";
80static const char s_bad_case_clause[] = "Bad case clause";
81static const char s_bad_case_labels[] = "Bad case labels";
82static const char s_duplicate_case_label[] = "Duplicate case label";
83static const char s_bad_cond_clause[] = "Bad cond clause";
84static const char s_missing_recipient[] = "Missing recipient in";
85static const char s_bad_variable[] = "Bad variable";
86static const char s_bad_bindings[] = "Bad bindings";
87static const char s_bad_binding[] = "Bad binding";
88static const char s_duplicate_binding[] = "Duplicate binding";
89static const char s_bad_exit_clause[] = "Bad exit clause";
90static const char s_bad_formals[] = "Bad formals";
91static const char s_bad_formal[] = "Bad formal";
92static const char s_duplicate_formal[] = "Duplicate formal";
93static const char s_splicing[] = "Non-list result for unquote-splicing";
94static const char s_bad_slot_number[] = "Bad slot number";
95
96
97/* Signal a syntax error. We distinguish between the form that caused the
98 * error and the enclosing expression. The error message will print out as
99 * shown in the following pattern. The file name and line number are only
100 * given when they can be determined from the erroneous form or from the
101 * enclosing expression.
102 *
103 * <filename>: In procedure memoization:
104 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
105
106SCM_SYMBOL (syntax_error_key, "syntax-error");
107
108/* The prototype is needed to indicate that the function does not return. */
109static void
110syntax_error (const char* const, const SCM, const SCM) SCM_NORETURN;
111
112static void
113syntax_error (const char* const msg, const SCM form, const SCM expr)
114{
115 SCM msg_string = scm_from_locale_string (msg);
116 SCM filename = SCM_BOOL_F;
117 SCM linenr = SCM_BOOL_F;
118 const char *format;
119 SCM args;
120
121 if (scm_is_pair (form))
122 {
123 filename = scm_source_property (form, scm_sym_filename);
124 linenr = scm_source_property (form, scm_sym_line);
125 }
126
127 if (scm_is_false (filename) && scm_is_false (linenr) && scm_is_pair (expr))
128 {
129 filename = scm_source_property (expr, scm_sym_filename);
130 linenr = scm_source_property (expr, scm_sym_line);
131 }
132
133 if (!SCM_UNBNDP (expr))
134 {
135 if (scm_is_true (filename))
136 {
137 format = "In file ~S, line ~S: ~A ~S in expression ~S.";
138 args = scm_list_5 (filename, linenr, msg_string, form, expr);
139 }
140 else if (scm_is_true (linenr))
141 {
142 format = "In line ~S: ~A ~S in expression ~S.";
143 args = scm_list_4 (linenr, msg_string, form, expr);
144 }
145 else
146 {
147 format = "~A ~S in expression ~S.";
148 args = scm_list_3 (msg_string, form, expr);
149 }
150 }
151 else
152 {
153 if (scm_is_true (filename))
154 {
155 format = "In file ~S, line ~S: ~A ~S.";
156 args = scm_list_4 (filename, linenr, msg_string, form);
157 }
158 else if (scm_is_true (linenr))
159 {
160 format = "In line ~S: ~A ~S.";
161 args = scm_list_3 (linenr, msg_string, form);
162 }
163 else
164 {
165 format = "~A ~S.";
166 args = scm_list_2 (msg_string, form);
167 }
168 }
169
170 scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F);
171}
172
173
174/* Shortcut macros to simplify syntax error handling. */
175#define ASSERT_SYNTAX(cond, message, form) \
176 { if (SCM_UNLIKELY (!(cond))) \
177 syntax_error (message, form, SCM_UNDEFINED); }
178#define ASSERT_SYNTAX_2(cond, message, form, expr) \
179 { if (SCM_UNLIKELY (!(cond))) \
180 syntax_error (message, form, expr); }
181
182\f
183
184
185/* {Evaluator memoized expressions}
186 */
187
188scm_t_bits scm_tc16_memoized;
189
190#define MAKMEMO(n, args) (scm_cell (scm_tc16_memoized | ((n) << 16), (scm_t_bits)(args)))
191
192#define MAKMEMO_BEGIN(exps) \
193 MAKMEMO (SCM_M_BEGIN, exps)
194#define MAKMEMO_IF(test, then, else_) \
195 MAKMEMO (SCM_M_IF, scm_cons (test, scm_cons (then, else_)))
196#define MAKMEMO_LAMBDA(nreq, rest, body) \
197 MAKMEMO (SCM_M_LAMBDA, scm_cons (SCM_I_MAKINUM (nreq), scm_cons (rest, body)))
198#define MAKMEMO_LET(inits, body) \
199 MAKMEMO (SCM_M_LET, scm_cons (inits, body))
200#define MAKMEMO_QUOTE(exp) \
201 MAKMEMO (SCM_M_QUOTE, exp)
202#define MAKMEMO_DEFINE(var, val) \
203 MAKMEMO (SCM_M_DEFINE, scm_cons (var, val))
204#define MAKMEMO_APPLY(exp) \
205 MAKMEMO (SCM_M_APPLY, exp)
206#define MAKMEMO_CONT(proc) \
207 MAKMEMO (SCM_M_CONT, proc)
208#define MAKMEMO_CALL_WITH_VALUES(prod, cons) \
209 MAKMEMO (SCM_M_CALL_WITH_VALUES, scm_cons (prod, cons))
210#define MAKMEMO_CALL(proc, args) \
211 MAKMEMO (SCM_M_CALL, scm_cons (proc, args))
212#define MAKMEMO_LEX_REF(n) \
213 MAKMEMO (SCM_M_LEXICAL_REF, SCM_I_MAKINUM (n))
214#define MAKMEMO_LEX_SET(n, val) \
215 MAKMEMO (SCM_M_LEXICAL_SET, scm_cons (SCM_I_MAKINUM (n), val))
216#define MAKMEMO_TOP_REF(var) \
217 MAKMEMO (SCM_M_TOPLEVEL_REF, var)
218#define MAKMEMO_TOP_SET(var, val) \
219 MAKMEMO (SCM_M_TOPLEVEL_SET, scm_cons (var, val))
220#define MAKMEMO_MOD_REF(mod, var, public) \
221 MAKMEMO (SCM_M_MODULE_REF, scm_cons (mod, scm_cons (var, public)))
222#define MAKMEMO_MOD_SET(val, mod, var, public) \
223 MAKMEMO (SCM_M_MODULE_SET, scm_cons (val, scm_cons (mod, scm_cons (var, public))))
224
225\f
226
227/* This table must agree with the list of M_ constants in memoize.h */
228static const char *const memoized_tags[] =
229{
230 "begin",
231 "if",
232 "lambda",
233 "let",
234 "quote",
235 "define",
236 "apply",
3149a5b6 237 "call/cc",
b7742c6b
AW		 238 "call-with-values",
239 "call",
240 "lexical-ref",
241 "lexical-set!",
242 "toplevel-ref",
243 "toplevel-set!",
244 "module-ref",
3149a5b6 245 "module-set!",
b7742c6b
AW		 246};
247
248static int
249scm_print_memoized (SCM memoized, SCM port, scm_print_state *pstate)
250{
251 scm_puts ("#<memoized ", port);
252 scm_write (scm_unmemoize_expression (memoized), port);
253 scm_puts (">", port);
254 return 1;
255}
256
257static SCM scm_m_at (SCM xorig, SCM env);
258static SCM scm_m_atat (SCM xorig, SCM env);
259static SCM scm_m_and (SCM xorig, SCM env);
260static SCM scm_m_apply (SCM xorig, SCM env);
261static SCM scm_m_begin (SCM xorig, SCM env);
262static SCM scm_m_cont (SCM xorig, SCM env);
263static SCM scm_m_at_call_with_values (SCM xorig, SCM env);
264static SCM scm_m_cond (SCM xorig, SCM env);
265static SCM scm_m_define (SCM x, SCM env);
266static SCM scm_m_eval_when (SCM xorig, SCM env);
267static SCM scm_m_if (SCM xorig, SCM env);
268static SCM scm_m_lambda (SCM xorig, SCM env);
269static SCM scm_m_let (SCM xorig, SCM env);
270static SCM scm_m_letrec (SCM xorig, SCM env);
271static SCM scm_m_letstar (SCM xorig, SCM env);
272static SCM scm_m_or (SCM xorig, SCM env);
273static SCM scm_m_quote (SCM xorig, SCM env);
274static SCM scm_m_set_x (SCM xorig, SCM env);
275
276
277\f
278
279
280typedef SCM (*t_syntax_transformer) (SCM, SCM);
281
282static t_syntax_transformer
283memoize_env_ref_transformer (SCM env, SCM x)
284{
285 SCM var;
286 for (; scm_is_pair (env); env = CDR (env))
287 if (scm_is_eq (x, CAR (env)))
288 return NULL; /* lexical */
289
290 var = scm_module_variable (env, x);
291 if (scm_is_true (var) && scm_is_true (scm_variable_bound_p (var))
292 && SCM_MACROP (scm_variable_ref (var)))
293 {
294 SCM mac = scm_variable_ref (var);
295 if (SCM_IMP (SCM_MACRO_CODE (mac))
df338a22 296 || (SCM_TYP7 (SCM_MACRO_CODE (mac)) != scm_tc7_gsubr))
b7742c6b
AW		 297 syntax_error ("bad macro", x, SCM_UNDEFINED);
298 else
299 return (t_syntax_transformer)SCM_SUBRF (SCM_MACRO_CODE (mac)); /* global macro */
300 }
301 else
302 return NULL; /* anything else */
303}
304
305static int
306memoize_env_var_is_free (SCM env, SCM x)
307{
308 for (; scm_is_pair (env); env = CDR (env))
309 if (scm_is_eq (x, CAR (env)))
310 return 0; /* bound */
311 return 1; /* free */
312}
313
314static int
315memoize_env_lexical_index (SCM env, SCM x)
316{
317 int i = 0;
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 */
322}
323
324static SCM
325memoize_env_extend (SCM env, SCM vars)
326{
327 return scm_append (scm_list_2 (vars, env));
328}
329
330static SCM
331memoize (SCM exp, SCM env)
332{
333 if (scm_is_pair (exp))
334 {
335 SCM CAR;
336 t_syntax_transformer trans;
337
338 CAR = CAR (exp);
339 if (scm_is_symbol (CAR))
340 trans = memoize_env_ref_transformer (env, CAR);
341 else
342 trans = NULL;
343
344 if (trans)
345 return trans (exp, env);
346 else
347 {
348 SCM args = SCM_EOL;
349 for (; scm_is_pair (exp); exp = CDR (exp))
350 args = scm_cons (memoize (CAR (exp), env), args);
351 if (scm_is_null (exp))
352 return MAKMEMO (SCM_M_CALL, scm_reverse_x (args, SCM_UNDEFINED));
353 else
354 syntax_error ("expected a proper list", exp, SCM_UNDEFINED);
355 }
356 }
357 else if (scm_is_symbol (exp))
358 {
359 int i = memoize_env_lexical_index (env, exp);
360 if (i < 0)
361 return MAKMEMO_TOP_REF (exp);
362 else
363 return MAKMEMO_LEX_REF (i);
364 }
365 else
366 return MAKMEMO_QUOTE (exp);
367}
368
369static SCM
370memoize_exprs (SCM forms, const SCM env)
371{
372 SCM ret = SCM_EOL;
373
374 for (; !scm_is_null (forms); forms = CDR (forms))
375 ret = scm_cons (memoize (CAR (forms), env), ret);
376 return scm_reverse_x (ret, SCM_UNDEFINED);
377}
378
379static SCM
380memoize_sequence (const SCM forms, const SCM env)
381{
382 ASSERT_SYNTAX (scm_ilength (forms) >= 1, s_bad_expression,
383 scm_cons (scm_sym_begin, forms));
384 return MAKMEMO_BEGIN (memoize_exprs (forms, env));
385}
386
387
388\f
389/* Memoization. */
390
391/* bimacros (built-in macros) have isym codes.
392 mmacros don't exist at runtime, they just expand out to more primitive
393 forms. */
394SCM_SYNTAX (s_at, "@", scm_i_makbimacro, scm_m_at);
395SCM_SYNTAX (s_atat, "@@", scm_i_makbimacro, scm_m_atat);
396SCM_SYNTAX (s_and, "and", scm_makmmacro, scm_m_and);
397SCM_SYNTAX (s_begin, "begin", scm_i_makbimacro, scm_m_begin);
398SCM_SYNTAX (s_atcall_cc, "@call-with-current-continuation", scm_i_makbimacro, scm_m_cont);
399SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_i_makbimacro, scm_m_at_call_with_values);
400SCM_SYNTAX (s_cond, "cond", scm_makmmacro, scm_m_cond);
401SCM_SYNTAX (s_define, "define", scm_i_makbimacro, scm_m_define);
402SCM_SYNTAX (s_eval_when, "eval-when", scm_makmmacro, scm_m_eval_when);
403SCM_SYNTAX (s_if, "if", scm_i_makbimacro, scm_m_if);
404SCM_SYNTAX (s_lambda, "lambda", scm_i_makbimacro, scm_m_lambda);
405SCM_SYNTAX (s_let, "let", scm_i_makbimacro, scm_m_let);
406SCM_SYNTAX (s_letrec, "letrec", scm_makmmacro, scm_m_letrec);
407SCM_SYNTAX (s_letstar, "let*", scm_makmmacro, scm_m_letstar);
408SCM_SYNTAX (s_or, "or", scm_makmmacro, scm_m_or);
409SCM_SYNTAX (s_quote, "quote", scm_i_makbimacro, scm_m_quote);
410SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x);
411SCM_SYNTAX (s_atapply, "@apply", scm_i_makbimacro, scm_m_apply);
412
413
414SCM_GLOBAL_SYMBOL (scm_sym_apply, "apply");
415SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
416SCM_GLOBAL_SYMBOL (scm_sym_at, "@");
417SCM_GLOBAL_SYMBOL (scm_sym_atat, "@@");
418SCM_GLOBAL_SYMBOL (scm_sym_at_call_with_values, "@call-with-values");
419SCM_GLOBAL_SYMBOL (scm_sym_atapply, "@apply");
420SCM_GLOBAL_SYMBOL (scm_sym_atcall_cc, "@call-with-current-continuation");
421SCM_GLOBAL_SYMBOL (scm_sym_begin, "begin");
422SCM_GLOBAL_SYMBOL (scm_sym_case, "case");
423SCM_GLOBAL_SYMBOL (scm_sym_cond, "cond");
424SCM_GLOBAL_SYMBOL (scm_sym_define, "define");
425SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
426SCM_GLOBAL_SYMBOL (scm_sym_eval_when, "eval-when");
427SCM_GLOBAL_SYMBOL (scm_sym_if, "if");
428SCM_GLOBAL_SYMBOL (scm_sym_lambda, "lambda");
429SCM_GLOBAL_SYMBOL (scm_sym_let, "let");
430SCM_GLOBAL_SYMBOL (scm_sym_letrec, "letrec");
431SCM_GLOBAL_SYMBOL (scm_sym_letstar, "let*");
432SCM_GLOBAL_SYMBOL (scm_sym_or, "or");
433SCM_GLOBAL_SYMBOL (scm_sym_quote, "quote");
434SCM_GLOBAL_SYMBOL (scm_sym_set_x, "set!");
435SCM_SYMBOL (sym_eval, "eval");
436SCM_SYMBOL (sym_load, "load");
437
438SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
439SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, "quasiquote");
440SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
441
442
443static SCM
444scm_m_at (SCM expr, SCM env SCM_UNUSED)
445{
446 ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
447 ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
448 ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);
449
450 return MAKMEMO_MOD_REF (CADR (expr), CADDR (expr), SCM_BOOL_T);
451}
452
453static SCM
454scm_m_atat (SCM expr, SCM env SCM_UNUSED)
455{
456 ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
457 ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
458 ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);
459
460 return MAKMEMO_MOD_REF (CADR (expr), CADDR (expr), SCM_BOOL_F);
461}
462
463static SCM
464scm_m_and (SCM expr, SCM env)
465{
466 const SCM cdr_expr = CDR (expr);
467
468 if (scm_is_null (cdr_expr))
469 return MAKMEMO_QUOTE (SCM_BOOL_T);
470 ASSERT_SYNTAX (scm_is_pair (cdr_expr), s_bad_expression, expr);
471
472 if (scm_is_null (CDR (cdr_expr)))
473 return memoize (CAR (cdr_expr), env);
474 else
475 return MAKMEMO_IF (memoize (CAR (cdr_expr), env),
476 scm_m_and (cdr_expr, env),
477 MAKMEMO_QUOTE (SCM_BOOL_F));
478}
479
480static SCM
481scm_m_apply (SCM expr, SCM env)
482{
483 const SCM cdr_expr = CDR (expr);
484 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
485 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_missing_expression, expr);
486
487 return MAKMEMO_APPLY (memoize_exprs (cdr_expr, env));
488}
489
490static SCM
491scm_m_begin (SCM expr, SCM env)
492{
493 const SCM cdr_expr = CDR (expr);
494 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 1, s_bad_expression, expr);
495 return MAKMEMO_BEGIN (memoize_exprs (cdr_expr, env));
496}
497
498static SCM
499scm_m_cont (SCM expr, SCM env)
500{
501 const SCM cdr_expr = CDR (expr);
502 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
503 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
504
505 return MAKMEMO_CONT (memoize (CADR (expr), env));
506}
507
508static SCM
509scm_m_at_call_with_values (SCM expr, SCM env)
510{
511 const SCM cdr_expr = CDR (expr);
512 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
513 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
514
515 return MAKMEMO_CALL_WITH_VALUES (memoize (CADR (expr), env),
516 memoize (CADDR (expr), env));
517}
518
519static SCM
520scm_m_cond (SCM expr, SCM env)
521{
522 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
523 const int else_literal_p = memoize_env_var_is_free (env, scm_sym_else);
524 const int arrow_literal_p = memoize_env_var_is_free (env, scm_sym_arrow);
525
526 const SCM clauses = CDR (expr);
527 SCM clause_idx;
528 SCM ret, loc;
529
530 ASSERT_SYNTAX (scm_ilength (clauses) >= 0, s_bad_expression, expr);
531 ASSERT_SYNTAX (scm_ilength (clauses) >= 1, s_missing_clauses, expr);
532
533 ret = scm_cons (SCM_UNDEFINED, MAKMEMO_QUOTE (SCM_UNSPECIFIED));
534 loc = ret;
535
536 for (clause_idx = clauses;
537 !scm_is_null (clause_idx);
538 clause_idx = CDR (clause_idx))
539 {
540 SCM test;
541
542 const SCM clause = CAR (clause_idx);
543 const long length = scm_ilength (clause);
544 ASSERT_SYNTAX_2 (length >= 1, s_bad_cond_clause, clause, expr);
545
546 test = CAR (clause);
547 if (scm_is_eq (test, scm_sym_else) && else_literal_p)
548 {
549 const int last_clause_p = scm_is_null (CDR (clause_idx));
550 ASSERT_SYNTAX_2 (length >= 2,
551 s_bad_cond_clause, clause, expr);
552 ASSERT_SYNTAX_2 (last_clause_p,
553 s_misplaced_else_clause, clause, expr);
554 SCM_SETCDR (loc,
555 memoize (scm_cons (scm_sym_begin, CDR (clause)), env));
556 }
557 else if (length >= 2
558 && scm_is_eq (CADR (clause), scm_sym_arrow)
559 && arrow_literal_p)
560 {
561 SCM tmp = scm_gensym (scm_from_locale_string ("cond "));
562 SCM i;
563 SCM new_env = scm_cons (tmp, env);
564 ASSERT_SYNTAX_2 (length > 2, s_missing_recipient, clause, expr);
565 ASSERT_SYNTAX_2 (length == 3, s_extra_expression, clause, expr);
566 i = MAKMEMO_IF (MAKMEMO_LEX_REF (0),
567 MAKMEMO_CALL (memoize (CADDR (clause),
568 scm_cons (tmp, new_env)),
569 scm_list_1 (MAKMEMO_LEX_REF (0))),
570 MAKMEMO_QUOTE (SCM_UNSPECIFIED));
571 SCM_SETCDR (loc,
572 MAKMEMO_LET (scm_list_1 (memoize (CAR (clause), env)),
573 i));
574 env = new_env;
575 loc = scm_last_pair (SCM_MEMOIZED_ARGS (i));
576 }
577 /* FIXME length == 1 case */
578 else
579 {
580 SCM i = MAKMEMO_IF (memoize (CAR (clause), env),
581 memoize (scm_cons (scm_sym_begin, CDR (clause)), env),
582 MAKMEMO_QUOTE (SCM_UNSPECIFIED));
583 SCM_SETCDR (loc, i);
584 loc = scm_last_pair (SCM_MEMOIZED_ARGS (i));
585 }
586 }
587
588 return CDR (ret);
589}
590
591/* According to Section 5.2.1 of R5RS we first have to make sure that the
592 variable is bound, and then perform the `(set! variable expression)'
593 operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
594 bound. This means that EXPRESSION won't necessarily be able to assign
595 values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
596static SCM
597scm_m_define (SCM expr, SCM env)
598{
599 const SCM cdr_expr = CDR (expr);
600 SCM body;
601 SCM variable;
602
603 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
604 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
605 ASSERT_SYNTAX (!scm_is_pair (env), s_bad_define, expr);
606
607 body = CDR (cdr_expr);
608 variable = CAR (cdr_expr);
609
610 if (scm_is_pair (variable))
611 {
612 ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable)), s_bad_variable, variable, expr);
613 return MAKMEMO_DEFINE (CAR (variable),
614 memoize (scm_cons (scm_sym_lambda,
615 scm_cons (CDR (variable), body)),
616 env));
617 }
618 ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
619 ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr);
620 return MAKMEMO_DEFINE (variable, memoize (CAR (body), env));
621}
622
623static SCM
624scm_m_eval_when (SCM expr, SCM env)
625{
626 ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
627 ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
628
629 if (scm_is_true (scm_memq (sym_eval, CADR (expr)))
630 || scm_is_true (scm_memq (sym_load, CADR (expr))))
631 return MAKMEMO_BEGIN (memoize_exprs (CDDR (expr), env));
632 else
633 return MAKMEMO_QUOTE (SCM_UNSPECIFIED);
634}
635
636static SCM
637scm_m_if (SCM expr, SCM env SCM_UNUSED)
638{
639 const SCM cdr_expr = CDR (expr);
640 const long length = scm_ilength (cdr_expr);
641 ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr);
642 return MAKMEMO_IF (memoize (CADR (expr), env),
643 memoize (CADDR (expr), env),
644 ((length == 3)
645 ? memoize (CADDDR (expr), env)
646 : MAKMEMO_QUOTE (SCM_UNSPECIFIED)));
647}
648
649/* A helper function for memoize_lambda to support checking for duplicate
650 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
651 * LIST or to the CDR of the last cons. Therefore, LIST may have any of the
652 * forms that a formal argument can have:
653 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
654static int
655c_improper_memq (SCM obj, SCM list)
656{
657 for (; scm_is_pair (list); list = CDR (list))
658 {
659 if (scm_is_eq (CAR (list), obj))
660 return 1;
661 }
662 return scm_is_eq (list, obj);
663}
664
665static SCM
666scm_m_lambda (SCM expr, SCM env SCM_UNUSED)
667{
668 SCM formals;
669 SCM formals_idx;
670 SCM formal_vars = SCM_EOL;
671 int nreq = 0;
672
673 const SCM cdr_expr = CDR (expr);
674 const long length = scm_ilength (cdr_expr);
675 ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
676 ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
677
678 /* Before iterating the list of formal arguments, make sure the formals
679 * actually are given as either a symbol or a non-cyclic list. */
680 formals = CAR (cdr_expr);
681 if (scm_is_pair (formals))
682 {
683 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
684 * detected, report a 'Bad formals' error. */
685 }
686 else
687 {
688 ASSERT_SYNTAX_2 (scm_is_symbol (formals) || scm_is_null (formals),
689 s_bad_formals, formals, expr);
690 }
691
692 /* Now iterate the list of formal arguments to check if all formals are
693 * symbols, and that there are no duplicates. */
694 formals_idx = formals;
695 while (scm_is_pair (formals_idx))
696 {
697 const SCM formal = CAR (formals_idx);
698 const SCM next_idx = CDR (formals_idx);
699 ASSERT_SYNTAX_2 (scm_is_symbol (formal), s_bad_formal, formal, expr);
700 ASSERT_SYNTAX_2 (!c_improper_memq (formal, next_idx),
701 s_duplicate_formal, formal, expr);
702 nreq++;
703 formal_vars = scm_cons (formal, formal_vars);
704 formals_idx = next_idx;
705 }
706 ASSERT_SYNTAX_2 (scm_is_null (formals_idx) || scm_is_symbol (formals_idx),
707 s_bad_formal, formals_idx, expr);
708 if (scm_is_symbol (formals_idx))
709 formal_vars = scm_cons (formals_idx, formal_vars);
710 return MAKMEMO_LAMBDA (nreq, scm_symbol_p (formals_idx),
711 memoize_sequence (CDDR (expr),
712 memoize_env_extend (env, formal_vars)));
713}
714
715/* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
716static void
717check_bindings (const SCM bindings, const SCM expr)
718{
719 SCM binding_idx;
720
721 ASSERT_SYNTAX_2 (scm_ilength (bindings) >= 0,
722 s_bad_bindings, bindings, expr);
723
724 binding_idx = bindings;
725 for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
726 {
727 SCM name; /* const */
728
729 const SCM binding = CAR (binding_idx);
730 ASSERT_SYNTAX_2 (scm_ilength (binding) == 2,
731 s_bad_binding, binding, expr);
732
733 name = CAR (binding);
734 ASSERT_SYNTAX_2 (scm_is_symbol (name), s_bad_variable, name, expr);
735 }
736}
737
738/* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
739 * transformed to the lists (vn .. v2 v1) and (i1 i2 ... in). If a duplicate
740 * variable name is detected, an error is signalled. */
741static int
742transform_bindings (const SCM bindings, const SCM expr,
743 SCM *const rvarptr, SCM *const initptr)
744{
745 SCM rvariables = SCM_EOL;
746 SCM rinits = SCM_EOL;
747 SCM binding_idx = bindings;
748 int n = 0;
749 for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
750 {
751 const SCM binding = CAR (binding_idx);
752 const SCM CDR_binding = CDR (binding);
753 const SCM name = CAR (binding);
754 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name, rvariables)),
755 s_duplicate_binding, name, expr);
756 rvariables = scm_cons (name, rvariables);
757 rinits = scm_cons (CAR (CDR_binding), rinits);
758 n++;
759 }
760 *rvarptr = rvariables;
761 *initptr = scm_reverse_x (rinits, SCM_UNDEFINED);
762 return n;
763}
764
765/* This function is a helper function for memoize_let. It transforms
766 * (let name ((var init) ...) body ...) into
767 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
768 * and memoizes the expression. It is assumed that the caller has checked
769 * that name is a symbol and that there are bindings and a body. */
770static SCM
771memoize_named_let (const SCM expr, SCM env)
772{
773 SCM rvariables;
774 SCM inits;
775 int nreq;
776
777 const SCM cdr_expr = CDR (expr);
778 const SCM name = CAR (cdr_expr);
779 const SCM cddr_expr = CDR (cdr_expr);
780 const SCM bindings = CAR (cddr_expr);
781 check_bindings (bindings, expr);
782
783 nreq = transform_bindings (bindings, expr, &rvariables, &inits);
784
785 env = scm_cons (name, env);
786 return MAKMEMO_LET
787 (scm_list_1 (MAKMEMO_QUOTE (SCM_UNDEFINED)),
788 MAKMEMO_BEGIN
789 (scm_list_2 (MAKMEMO_LEX_SET
790 (0,
791 MAKMEMO_LAMBDA
792 (nreq, SCM_BOOL_F,
793 memoize_sequence (CDDDR (expr),
794 memoize_env_extend (env, rvariables)))),
795 MAKMEMO_CALL (MAKMEMO_LEX_REF (0),
796 memoize_exprs (inits, env)))));
797}
798
799/* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
800 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
801static SCM
802scm_m_let (SCM expr, SCM env)
803{
804 SCM bindings;
805
806 const SCM cdr_expr = CDR (expr);
807 const long length = scm_ilength (cdr_expr);
808 ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
809 ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
810
811 bindings = CAR (cdr_expr);
812 if (scm_is_symbol (bindings))
813 {
814 ASSERT_SYNTAX (length >= 3, s_missing_expression, expr);
815 return memoize_named_let (expr, env);
816 }
817
818 check_bindings (bindings, expr);
819 if (scm_is_null (bindings))
820 return memoize_sequence (CDDR (expr), env);
821 else
822 {
823 SCM rvariables;
824 SCM inits;
825 transform_bindings (bindings, expr, &rvariables, &inits);
826 return MAKMEMO_LET (memoize_exprs (inits, env),
827 memoize_sequence (CDDR (expr),
828 memoize_env_extend (env, rvariables)));
829 }
830}
831
832static SCM
833scm_m_letrec (SCM expr, SCM env)
834{
835 SCM bindings;
836
837 const SCM cdr_expr = CDR (expr);
838 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
839 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
840
841 bindings = CAR (cdr_expr);
842 if (scm_is_null (bindings))
843 return memoize_sequence (CDDR (expr), env);
844 else
845 {
846 SCM rvariables;
847 SCM inits;
848 SCM v, i;
849 SCM undefs = SCM_EOL;
850 SCM vals = SCM_EOL;
851 SCM sets = SCM_EOL;
852 SCM new_env;
853 int offset;
854 int n = transform_bindings (bindings, expr, &rvariables, &inits);
855 offset = n;
856 new_env = memoize_env_extend (env, rvariables);
857 for (v = scm_reverse (rvariables), i = inits; scm_is_pair (v);
858 v = CDR (v), i = CDR (i), n--)
859 {
860 undefs = scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED), undefs);
861 vals = scm_cons (memoize (CAR (i), new_env), vals);
862 sets = scm_cons (MAKMEMO_LEX_SET ((n-1) + offset,
863 MAKMEMO_LEX_REF (n-1)),
864 sets);
865 }
866 return MAKMEMO_LET
867 (undefs,
868 MAKMEMO_BEGIN (scm_list_2 (MAKMEMO_LET (scm_reverse (vals),
869 MAKMEMO_BEGIN (sets)),
870 memoize_sequence (CDDR (expr),
871 new_env))));
872 }
873}
874
875static SCM
876scm_m_letstar (SCM expr, SCM env SCM_UNUSED)
877{
878 SCM bindings;
879
880 const SCM cdr_expr = CDR (expr);
881 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
882 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
883
884 bindings = CAR (cdr_expr);
885 if (scm_is_null (bindings))
886 return memoize_sequence (CDDR (expr), env);
887 else
888 {
889 SCM rvariables;
890 SCM variables;
891 SCM inits;
892 SCM ret, loc;
893 transform_bindings (bindings, expr, &rvariables, &inits);
894 variables = scm_reverse (rvariables);
895 ret = scm_cons (SCM_UNDEFINED, SCM_UNSPECIFIED);
896 loc = ret;
897 for (; scm_is_pair (variables);
898 variables = CDR (variables), inits = CDR (inits))
899 { SCM x = MAKMEMO_LET (scm_list_1 (memoize (CAR (inits), env)),
900 MAKMEMO_QUOTE (SCM_UNSPECIFIED));
901 SCM_SETCDR (loc, x);
902 loc = scm_last_pair (SCM_MEMOIZED_ARGS (x));
903 env = scm_cons (CAR (variables), env);
904 }
905 SCM_SETCDR (loc, memoize_sequence (CDDR (expr), env));
906 return CDR (ret);
907 }
908}
909
910static SCM
911scm_m_or (SCM expr, SCM env SCM_UNUSED)
912{
913 SCM tail = CDR (expr);
914 SCM ret, loc;
915 const long length = scm_ilength (tail);
916
917 ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
918
919 ret = scm_cons (SCM_UNDEFINED, SCM_UNSPECIFIED);
920 loc = ret;
921 for (; scm_is_pair (tail); tail = CDR (tail))
922 {
923 SCM tmp = scm_gensym (scm_from_locale_string ("cond "));
924 SCM x = MAKMEMO_IF (MAKMEMO_LEX_REF (0),
925 MAKMEMO_LEX_REF (0),
926 MAKMEMO_QUOTE (SCM_UNSPECIFIED));
927 SCM new_env = scm_cons (tmp, env);
928 SCM_SETCDR (loc, MAKMEMO_LET (scm_list_1 (memoize (CAR (tail),
929 env)),
930 x));
931 env = new_env;
932 loc = scm_last_pair (SCM_MEMOIZED_ARGS (x));
933 }
934 SCM_SETCDR (loc, MAKMEMO_QUOTE (SCM_BOOL_F));
935 return CDR (ret);
936}
937
938static SCM
939scm_m_quote (SCM expr, SCM env SCM_UNUSED)
940{
941 SCM quotee;
942
943 const SCM cdr_expr = CDR (expr);
944 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
945 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
946 quotee = CAR (cdr_expr);
947 return MAKMEMO_QUOTE (quotee);
948}
949
950static SCM
951scm_m_set_x (SCM expr, SCM env)
952{
953 SCM variable;
954 SCM vmem;
955
956 const SCM cdr_expr = CDR (expr);
957 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
958 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
959 variable = CAR (cdr_expr);
960 vmem = memoize (variable, env);
961
962 switch (SCM_MEMOIZED_TAG (vmem))
963 {
964 case SCM_M_LEXICAL_REF:
965 return MAKMEMO_LEX_SET (SCM_I_INUM (SCM_MEMOIZED_ARGS (vmem)),
966 memoize (CADDR (expr), env));
967 case SCM_M_TOPLEVEL_REF:
968 return MAKMEMO_TOP_SET (variable,
969 memoize (CADDR (expr), env));
970 case SCM_M_MODULE_REF:
971 return MAKMEMO_MOD_SET (memoize (CADDR (expr), env),
972 CAR (SCM_MEMOIZED_ARGS (vmem)),
973 CADR (SCM_MEMOIZED_ARGS (vmem)),
974 CDDR (SCM_MEMOIZED_ARGS (vmem)));
975 default:
976 syntax_error (s_bad_variable, variable, expr);
977 }
978}
979
980
981\f
982
983SCM_DEFINE (scm_memoize_expression, "memoize-expression", 1, 0, 0,
984 (SCM exp),
985 "Memoize the expression @var{exp}.")
986#define FUNC_NAME s_scm_memoize_expression
987{
988 return memoize (exp, scm_current_module ());
989}
990#undef FUNC_NAME
991
992\f
993
994
995SCM_SYMBOL (sym_placeholder, "_");
996
997static SCM unmemoize (SCM expr);
998
999static SCM
1000unmemoize_exprs (SCM exprs)
1001{
1002 SCM ret, tail;
1003 if (scm_is_null (exprs))
1004 return SCM_EOL;
1005 ret = scm_list_1 (unmemoize (CAR (exprs)));
1006 tail = ret;
1007 for (exprs = CDR (exprs); !scm_is_null (exprs); exprs = CDR (exprs))
1008 {
1009 SCM_SETCDR (tail, scm_list_1 (unmemoize (CAR (exprs))));
1010 tail = CDR (tail);
1011 }
1012 return ret;
1013}
1014
1015static SCM
1016unmemoize_bindings (SCM inits)
1017{
1018 SCM ret, tail;
1019 if (scm_is_null (inits))
1020 return SCM_EOL;
1021 ret = scm_list_1 (scm_list_2 (sym_placeholder, unmemoize (CAR (inits))));
1022 tail = ret;
1023 for (inits = CDR (inits); !scm_is_null (inits); inits = CDR (inits))
1024 {
1025 SCM_SETCDR (tail, scm_list_1 (scm_list_2 (sym_placeholder,
1026 unmemoize (CAR (inits)))));
1027 tail = CDR (tail);
1028 }
1029 return ret;
1030}
1031
1032static SCM
1033unmemoize_lexical (SCM n)
1034{
1035 char buf[16];
1036 buf[15] = 0;
1037 snprintf (buf, 15, "<%u>", scm_to_uint32 (n));
1038 return scm_from_locale_symbol (buf);
1039}
1040
1041static SCM
1042unmemoize (const SCM expr)
1043{
1044 SCM args;
1045
1046 if (!SCM_MEMOIZED_P (expr))
1047 abort ();
1048
1049 args = SCM_MEMOIZED_ARGS (expr);
1050 switch (SCM_MEMOIZED_TAG (expr))
1051 {
1052 case SCM_M_APPLY:
1053 return scm_cons (scm_sym_atapply, unmemoize_exprs (args));
1054 case SCM_M_BEGIN:
1055 return scm_cons (scm_sym_begin, unmemoize_exprs (args));
1056 case SCM_M_CALL:
1057 return unmemoize_exprs (args);
1058 case SCM_M_CONT:
1059 return scm_list_2 (scm_sym_atcall_cc, unmemoize (args));
1060 case SCM_M_CALL_WITH_VALUES:
1061 return scm_list_3 (scm_sym_at_call_with_values,
1062 unmemoize (CAR (args)), unmemoize (CDR (args)));
1063 case SCM_M_DEFINE:
1064 return scm_list_3 (scm_sym_define, CAR (args), unmemoize (CDR (args)));
1065 case SCM_M_IF:
1066 return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)),
1067 unmemoize (scm_cadr (args)), unmemoize (scm_cddr (args)));
1068 case SCM_M_LAMBDA:
1069 return scm_list_3 (scm_sym_lambda,
1070 scm_make_list (CAR (args), sym_placeholder),
1071 unmemoize (CDDR (args)));
1072 case SCM_M_LET:
1073 return scm_list_3 (scm_sym_let,
1074 unmemoize_bindings (CAR (args)),
1075 unmemoize (CDR (args)));
1076 case SCM_M_QUOTE:
1077 return scm_list_2 (scm_sym_quote, args);
1078 case SCM_M_LEXICAL_REF:
1079 return unmemoize_lexical (args);
1080 case SCM_M_LEXICAL_SET:
1081 return scm_list_3 (scm_sym_set_x, unmemoize_lexical (CAR (args)),
1082 unmemoize (CDR (args)));
1083 case SCM_M_TOPLEVEL_REF:
1084 return args;
1085 case SCM_M_TOPLEVEL_SET:
1086 return scm_list_3 (scm_sym_set_x, CAR (args), unmemoize (CDR (args)));
1087 case SCM_M_MODULE_REF:
1088 return scm_list_3 (scm_is_true (CDDR (args)) ? scm_sym_at : scm_sym_atat,
1089 scm_i_finite_list_copy (CAR (args)),
1090 CADR (args));
1091 case SCM_M_MODULE_SET:
1092 return scm_list_3 (scm_sym_set_x,
1093 scm_list_3 (scm_is_true (CDDDR (args))
1094 ? scm_sym_at : scm_sym_atat,
1095 scm_i_finite_list_copy (CADR (args)),
1096 CADDR (args)),
1097 unmemoize (CAR (args)));
1098 default:
1099 abort ();
1100 }
1101}
1102
1103SCM_DEFINE (scm_memoized_p, "memoized?", 1, 0, 0,
1104 (SCM obj),
1105 "Return @code{#t} if @var{obj} is memoized.")
1106#define FUNC_NAME s_scm_memoized_p
1107{
1108 return scm_from_bool (SCM_MEMOIZED_P (obj));
1109}
1110#undef FUNC_NAME
1111
1112SCM_DEFINE (scm_unmemoize_expression, "unmemoize-expression", 1, 0, 0,
1113 (SCM m),
1114 "Unmemoize the memoized expression @var{m}.")
1115#define FUNC_NAME s_scm_unmemoize_expression
1116{
1117 SCM_VALIDATE_MEMOIZED (1, m);
1118 return unmemoize (m);
1119}
1120#undef FUNC_NAME
1121
3149a5b6
AW		 1122SCM_DEFINE (scm_memoized_expression_typecode, "memoized-expression-typecode", 1, 0, 0,
1123 (SCM m),
1124 "Return the typecode from the memoized expression @var{m}.")
1125#define FUNC_NAME s_scm_memoized_expression_typecode
1126{
1127 SCM_VALIDATE_MEMOIZED (1, m);
1128 return scm_from_uint16 (SCM_MEMOIZED_TAG (m));
1129}
1130#undef FUNC_NAME
1131
1132SCM_DEFINE (scm_memoized_expression_data, "memoized-expression-data", 1, 0, 0,
1133 (SCM m),
1134 "Return the data from the memoized expression @var{m}.")
1135#define FUNC_NAME s_scm_memoized_expression_data
1136{
1137 SCM_VALIDATE_MEMOIZED (1, m);
1138 return SCM_MEMOIZED_ARGS (m);
1139}
1140#undef FUNC_NAME
1141
1142SCM_DEFINE (scm_memoized_typecode, "memoized-typecode", 1, 0, 0,
1143 (SCM sym),
1144 "Return the memoized typecode corresponding to the symbol @var{sym}.")
1145#define FUNC_NAME s_scm_memoized_typecode
1146{
1147 int i;
1148
1149 SCM_VALIDATE_SYMBOL (1, sym);
1150
1151 for (i = 0; i < sizeof(memoized_tags)/sizeof(const char*); i++)
1152 if (strcmp (scm_i_symbol_chars (sym), memoized_tags[i]) == 0)
1153 return scm_from_int32 (i);
1154
1155 return SCM_BOOL_F;
1156}
1157#undef FUNC_NAME
1158
1159SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
1160static void error_unbound_variable (SCM symbol) SCM_NORETURN;
1161static void error_unbound_variable (SCM symbol)
1162{
1163 scm_error (scm_unbound_variable_key, NULL, "Unbound variable: ~S",
1164 scm_list_1 (symbol), SCM_BOOL_F);
1165}
1166
1167SCM_DEFINE (scm_memoize_variable_access_x, "memoize-variable-access!", 2, 0, 0,
1168 (SCM m, SCM mod),
1169 "Look up and cache the variable that @var{m} will access, returning the variable.")
1170#define FUNC_NAME s_scm_memoized_expression_data
1171{
1172 SCM mx;
1173 SCM_VALIDATE_MEMOIZED (1, m);
1174 mx = SCM_MEMOIZED_ARGS (m);
1175 switch (SCM_MEMOIZED_TAG (m))
1176 {
1177 case SCM_M_TOPLEVEL_REF:
1178 if (SCM_VARIABLEP (mx))
1179 return mx;
1180 else
1181 {
1182 SCM var = scm_module_variable (mod, mx);
1183 if (scm_is_false (var) || scm_is_false (scm_variable_bound_p (var)))
1184 error_unbound_variable (mx);
1185 SCM_SET_SMOB_OBJECT (m, var);
1186 return var;
1187 }
1188
1189 case SCM_M_TOPLEVEL_SET:
1190 {
1191 SCM var = CAR (mx);
1192 if (SCM_VARIABLEP (var))
1193 return var;
1194 else
1195 {
1196 var = scm_module_variable (mod, var);
1197 if (scm_is_false (var))
1198 error_unbound_variable (CAR (mx));
1199 SCM_SETCAR (mx, var);
1200 return var;
1201 }
1202 }
1203
1204 case SCM_M_MODULE_REF:
1205 if (SCM_VARIABLEP (mx))
1206 return mx;
1207 else
1208 {
1209 SCM var;
1210 mod = scm_resolve_module (CAR (mx));
1211 if (scm_is_true (CDDR (mx)))
1212 mod = scm_module_public_interface (mod);
1213 var = scm_module_lookup (mod, CADR (mx));
1214 if (scm_is_false (scm_variable_bound_p (var)))
1215 error_unbound_variable (CADR (mx));
1216 SCM_SET_SMOB_OBJECT (m, var);
1217 return var;
1218 }
1219
1220 case SCM_M_MODULE_SET:
1221 /* FIXME: not quite threadsafe */
1222 if (SCM_VARIABLEP (CDR (mx)))
1223 return CDR (mx);
1224 else
1225 {
1226 SCM var;
1227 mod = scm_resolve_module (CADR (mx));
1228 if (scm_is_true (CDDDR (mx)))
1229 mod = scm_module_public_interface (mod);
1230 var = scm_module_lookup (mod, CADDR (mx));
1231 SCM_SETCDR (mx, var);
1232 return var;
1233 }
1234
1235 default:
1236 scm_wrong_type_arg (FUNC_NAME, 1, m);
1237 return SCM_BOOL_F;
1238 }
1239}
1240#undef FUNC_NAME
1241
b7742c6b
AW		 1242
1243\f
1244
1245void
1246scm_init_memoize ()
1247{
1248 scm_tc16_memoized = scm_make_smob_type ("%memoized", 0);
1249 scm_set_smob_mark (scm_tc16_memoized, scm_markcdr);
1250 scm_set_smob_print (scm_tc16_memoized, scm_print_memoized);
1251
1252#include "libguile/memoize.x"
1253}
1254
1255/*
1256 Local Variables:
1257 c-file-style: "gnu"
1258 End:
1259*/
Unnamed repository; edit this file 'description' to name the repository.