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