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