HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
remove @call-with-values memoizer
[bpt/guile.git] / libguile / memoize.c
CommitLineData
c438cd71 1/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
aac01de6 2 * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013
c438cd71
LC		 3 * Free Software Foundation, Inc.
4 *
b7742c6b
AW		 5 * This library is free software; you can redistribute it and/or
6 * modify it under the terms of the GNU Lesser General Public License
7 * as published by the Free Software Foundation; either version 3 of
8 * the License, or (at your option) any later version.
9 *
10 * This library is distributed in the hope that it will be useful, but
11 * WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 * Lesser General Public License for more details.
14 *
15 * You should have received a copy of the GNU Lesser General Public
16 * License along with this library; if not, write to the Free Software
17 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
18 * 02110-1301 USA
19 */
20
21\f
22
23#ifdef HAVE_CONFIG_H
24# include <config.h>
25#endif
26
b7742c6b 27#include "libguile/__scm.h"
b7742c6b
AW		 28#include "libguile/_scm.h"
29#include "libguile/continuations.h"
30#include "libguile/eq.h"
dc3e203e 31#include "libguile/expand.h"
b7742c6b
AW		 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
b7742c6b
AW		 47#define CAR(x) SCM_CAR(x)
48#define CDR(x) SCM_CDR(x)
49#define CAAR(x) SCM_CAAR(x)
50#define CADR(x) SCM_CADR(x)
51#define CDAR(x) SCM_CDAR(x)
52#define CDDR(x) SCM_CDDR(x)
53#define CADDR(x) SCM_CADDR(x)
54#define CDDDR(x) SCM_CDDDR(x)
b7ecadca 55#define CADDDR(x) SCM_CADDDR(x)
b7742c6b
AW		 56
57
dc3e203e 58SCM_SYMBOL (sym_case_lambda_star, "case-lambda*");
b7742c6b
AW		 59
60\f
61
62
63/* {Evaluator memoized expressions}
64 */
65
66scm_t_bits scm_tc16_memoized;
67
b2b33168
AW		 68#define MAKMEMO(n, args) \
69 (scm_cell (scm_tc16_memoized | ((n) << 16), SCM_UNPACK (args)))
b7742c6b 70
6fc3eae4
AW		 71#define MAKMEMO_SEQ(head,tail) \
72 MAKMEMO (SCM_M_SEQ, scm_cons (head, tail))
b7742c6b
AW		 73#define MAKMEMO_IF(test, then, else_) \
74 MAKMEMO (SCM_M_IF, scm_cons (test, scm_cons (then, else_)))
8f9c5b58
AW		 75#define FIXED_ARITY(nreq) \
76 scm_list_1 (SCM_I_MAKINUM (nreq))
77#define REST_ARITY(nreq, rest) \
78 scm_list_2 (SCM_I_MAKINUM (nreq), rest)
9658182d
AW		 79#define FULL_ARITY(nreq, rest, nopt, kw, inits, alt) \
80 scm_list_n (SCM_I_MAKINUM (nreq), rest, SCM_I_MAKINUM (nopt), kw, inits, \
81 alt, SCM_UNDEFINED)
c438cd71
LC		 82#define MAKMEMO_LAMBDA(body, arity, docstring) \
83 MAKMEMO (SCM_M_LAMBDA, \
84 scm_cons (body, scm_cons (docstring, arity)))
b7742c6b
AW		 85#define MAKMEMO_LET(inits, body) \
86 MAKMEMO (SCM_M_LET, scm_cons (inits, body))
87#define MAKMEMO_QUOTE(exp) \
88 MAKMEMO (SCM_M_QUOTE, exp)
89#define MAKMEMO_DEFINE(var, val) \
90 MAKMEMO (SCM_M_DEFINE, scm_cons (var, val))
d69531e2
AW		 91#define MAKMEMO_DYNWIND(in, expr, out) \
92 MAKMEMO (SCM_M_DYNWIND, scm_cons (in, scm_cons (expr, out)))
bb0229b5
AW		 93#define MAKMEMO_WITH_FLUIDS(fluids, vals, expr) \
94 MAKMEMO (SCM_M_WITH_FLUIDS, scm_cons (fluids, scm_cons (vals, expr)))
2cd72a84
AW		 95#define MAKMEMO_APPLY(proc, args)\
96 MAKMEMO (SCM_M_APPLY, scm_list_2 (proc, args))
b7742c6b
AW		 97#define MAKMEMO_CONT(proc) \
98 MAKMEMO (SCM_M_CONT, proc)
99#define MAKMEMO_CALL_WITH_VALUES(prod, cons) \
100 MAKMEMO (SCM_M_CALL_WITH_VALUES, scm_cons (prod, cons))
9331f91c
AW		 101#define MAKMEMO_CALL(proc, nargs, args) \
102 MAKMEMO (SCM_M_CALL, scm_cons (proc, scm_cons (SCM_I_MAKINUM (nargs), args)))
b7742c6b
AW		 103#define MAKMEMO_LEX_REF(n) \
104 MAKMEMO (SCM_M_LEXICAL_REF, SCM_I_MAKINUM (n))
105#define MAKMEMO_LEX_SET(n, val) \
106 MAKMEMO (SCM_M_LEXICAL_SET, scm_cons (SCM_I_MAKINUM (n), val))
107#define MAKMEMO_TOP_REF(var) \
108 MAKMEMO (SCM_M_TOPLEVEL_REF, var)
109#define MAKMEMO_TOP_SET(var, val) \
110 MAKMEMO (SCM_M_TOPLEVEL_SET, scm_cons (var, val))
111#define MAKMEMO_MOD_REF(mod, var, public) \
112 MAKMEMO (SCM_M_MODULE_REF, scm_cons (mod, scm_cons (var, public)))
113#define MAKMEMO_MOD_SET(val, mod, var, public) \
114 MAKMEMO (SCM_M_MODULE_SET, scm_cons (val, scm_cons (mod, scm_cons (var, public))))
1773bc7d
AW		 115#define MAKMEMO_CALL_WITH_PROMPT(tag, thunk, handler) \
116 MAKMEMO (SCM_M_CALL_WITH_PROMPT, scm_cons (tag, scm_cons (thunk, handler)))
b7742c6b 117
2cd72a84
AW		 118
119/* Primitives for the evaluator */
120scm_t_bits scm_tc16_memoizer;
121#define SCM_MEMOIZER_P(x) (SCM_SMOB_PREDICATE (scm_tc16_memoizer, (x)))
122#define SCM_MEMOIZER(M) (SCM_SMOB_OBJECT_1 (M))
123
b7742c6b
AW		 124\f
125
126/* This table must agree with the list of M_ constants in memoize.h */
127static const char *const memoized_tags[] =
128{
6fc3eae4 129 "seq",
b7742c6b
AW		 130 "if",
131 "lambda",
132 "let",
133 "quote",
134 "define",
d69531e2 135 "dynwind",
bb0229b5 136 "with-fluids",
b7742c6b 137 "apply",
3149a5b6 138 "call/cc",
b7742c6b
AW		 139 "call-with-values",
140 "call",
141 "lexical-ref",
142 "lexical-set!",
143 "toplevel-ref",
144 "toplevel-set!",
145 "module-ref",
3149a5b6 146 "module-set!",
1773bc7d 147 "call-with-prompt",
b7742c6b
AW		 148};
149
150static int
151scm_print_memoized (SCM memoized, SCM port, scm_print_state *pstate)
152{
0607ebbf 153 scm_puts_unlocked ("#<memoized ", port);
b7742c6b 154 scm_write (scm_unmemoize_expression (memoized), port);
0607ebbf 155 scm_puts_unlocked (">", port);
b7742c6b
AW		 156 return 1;
157}
158
b7742c6b 159
b7742c6b
AW		 160\f
161
162
b7742c6b 163static int
dc3e203e 164lookup (SCM x, SCM env)
b7742c6b
AW		 165{
166 int i = 0;
167 for (; scm_is_pair (env); env = CDR (env), i++)
168 if (scm_is_eq (x, CAR (env)))
169 return i; /* bound */
dc3e203e 170 abort ();
b7742c6b
AW		 171}
172
b7742c6b 173
dc3e203e
AW		 174/* Abbreviate SCM_EXPANDED_REF. Copied because I'm not sure about symbol pasting */
175#define REF(x,type,field) \
176 (scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field)))
b7742c6b 177
dc3e203e 178static SCM list_of_guile = SCM_BOOL_F;
b7742c6b 179
dc3e203e 180static SCM memoize (SCM exp, SCM env);
b7742c6b
AW		 181
182static SCM
dc3e203e 183memoize_exps (SCM exps, SCM env)
b7742c6b 184{
dc3e203e
AW		 185 SCM ret;
186 for (ret = SCM_EOL; scm_is_pair (exps); exps = CDR (exps))
187 ret = scm_cons (memoize (CAR (exps), env), ret);
188 return scm_reverse_x (ret, SCM_UNDEFINED);
7572ee52 189}
7572ee52 190
7572ee52 191static SCM
dc3e203e 192memoize (SCM exp, SCM env)
b7742c6b 193{
dc3e203e
AW		 194 if (!SCM_EXPANDED_P (exp))
195 abort ();
b7742c6b 196
dc3e203e 197 switch (SCM_EXPANDED_TYPE (exp))
b7742c6b 198 {
dc3e203e
AW		 199 case SCM_EXPANDED_VOID:
200 return MAKMEMO_QUOTE (SCM_UNSPECIFIED);
201
202 case SCM_EXPANDED_CONST:
203 return MAKMEMO_QUOTE (REF (exp, CONST, EXP));
b7742c6b 204
dc3e203e
AW		 205 case SCM_EXPANDED_PRIMITIVE_REF:
206 if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
207 return MAKMEMO_TOP_REF (REF (exp, PRIMITIVE_REF, NAME));
208 else
209 return MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMITIVE_REF, NAME),
210 SCM_BOOL_F);
211
212 case SCM_EXPANDED_LEXICAL_REF:
213 return MAKMEMO_LEX_REF (lookup (REF (exp, LEXICAL_REF, GENSYM), env));
214
215 case SCM_EXPANDED_LEXICAL_SET:
216 return MAKMEMO_LEX_SET (lookup (REF (exp, LEXICAL_SET, GENSYM), env),
217 memoize (REF (exp, LEXICAL_SET, EXP), env));
218
219 case SCM_EXPANDED_MODULE_REF:
220 return MAKMEMO_MOD_REF (REF (exp, MODULE_REF, MOD),
221 REF (exp, MODULE_REF, NAME),
222 REF (exp, MODULE_REF, PUBLIC));
223
224 case SCM_EXPANDED_MODULE_SET:
225 return MAKMEMO_MOD_SET (memoize (REF (exp, MODULE_SET, EXP), env),
226 REF (exp, MODULE_SET, MOD),
227 REF (exp, MODULE_SET, NAME),
228 REF (exp, MODULE_SET, PUBLIC));
229
230 case SCM_EXPANDED_TOPLEVEL_REF:
231 return MAKMEMO_TOP_REF (REF (exp, TOPLEVEL_REF, NAME));
232
233 case SCM_EXPANDED_TOPLEVEL_SET:
234 return MAKMEMO_TOP_SET (REF (exp, TOPLEVEL_SET, NAME),
235 memoize (REF (exp, TOPLEVEL_SET, EXP), env));
236
237 case SCM_EXPANDED_TOPLEVEL_DEFINE:
238 return MAKMEMO_DEFINE (REF (exp, TOPLEVEL_DEFINE, NAME),
239 memoize (REF (exp, TOPLEVEL_DEFINE, EXP), env));
240
241 case SCM_EXPANDED_CONDITIONAL:
242 return MAKMEMO_IF (memoize (REF (exp, CONDITIONAL, TEST), env),
243 memoize (REF (exp, CONDITIONAL, CONSEQUENT), env),
244 memoize (REF (exp, CONDITIONAL, ALTERNATE), env));
245
7081d4f9 246 case SCM_EXPANDED_CALL:
dc3e203e
AW		 247 {
248 SCM proc, args;
b7742c6b 249
7081d4f9
AW		 250 proc = REF (exp, CALL, PROC);
251 args = memoize_exps (REF (exp, CALL, ARGS), env);
b7742c6b 252
dc3e203e
AW		 253 if (SCM_EXPANDED_TYPE (proc) == SCM_EXPANDED_TOPLEVEL_REF)
254 {
255 SCM var = scm_module_variable (scm_current_module (),
256 REF (proc, TOPLEVEL_REF, NAME));
257 if (SCM_VARIABLEP (var))
258 {
259 SCM val = SCM_VARIABLE_REF (var);
260 if (SCM_MEMOIZER_P (val))
261 return scm_apply (SCM_SMOB_OBJECT_1 (val), args, SCM_EOL);
262 }
263 }
264 /* otherwise we all fall down here */
265 return MAKMEMO_CALL (memoize (proc, env), scm_ilength (args), args);
266 }
b7742c6b 267
a881a4ae
AW		 268 case SCM_EXPANDED_PRIMCALL:
269 {
1773bc7d
AW		 270 SCM name, args;
271 int nargs;
a881a4ae 272
1773bc7d 273 name = REF (exp, PRIMCALL, NAME);
a881a4ae 274 args = memoize_exps (REF (exp, PRIMCALL, ARGS), env);
1773bc7d
AW		 275 nargs = scm_ilength (args);
276
277 if (nargs == 3
278 && scm_is_eq (name, scm_from_latin1_symbol ("call-with-prompt")))
279 return MAKMEMO_CALL_WITH_PROMPT (CAR (args),
280 CADR (args),
281 CADDR (args));
39caffe7
AW		 282 else if (nargs == 2
283 && scm_is_eq (name, scm_from_latin1_symbol ("apply")))
284 return MAKMEMO_APPLY (CAR (args), CADR (args));
bc056057
AW		 285 else if (nargs == 1
286 && scm_is_eq (name,
287 scm_from_latin1_symbol
288 ("call-with-current-continuation")))
289 return MAKMEMO_CONT (CAR (args));
0fcc39a0
AW		 290 else if (nargs == 2
291 && scm_is_eq (name,
292 scm_from_latin1_symbol ("call-with-values")))
293 return MAKMEMO_CALL_WITH_VALUES (CAR (args), CADR (args));
1773bc7d
AW		 294 else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
295 return MAKMEMO_CALL (MAKMEMO_TOP_REF (name), nargs, args);
296 else
297 return MAKMEMO_CALL (MAKMEMO_MOD_REF (list_of_guile, name,
298 SCM_BOOL_F),
299 nargs,
300 args);
a881a4ae
AW		 301 }
302
6fc3eae4
AW		 303 case SCM_EXPANDED_SEQ:
304 return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env),
305 memoize (REF (exp, SEQ, TAIL), env));
b7742c6b 306
dc3e203e 307 case SCM_EXPANDED_LAMBDA:
19113f1c 308 /* The body will be a lambda-case or #f. */
c438cd71 309 {
19113f1c 310 SCM meta, docstring, body, proc;
c438cd71
LC		 311
312 meta = REF (exp, LAMBDA, META);
313 docstring = scm_assoc_ref (meta, scm_sym_documentation);
314
19113f1c
AW		 315 body = REF (exp, LAMBDA, BODY);
316 if (scm_is_false (body))
317 /* Give a body to case-lambda with no clauses. */
318 proc = MAKMEMO_LAMBDA
319 (MAKMEMO_CALL
320 (MAKMEMO_MOD_REF (list_of_guile,
321 scm_from_latin1_symbol ("throw"),
322 SCM_BOOL_F),
323 5,
324 scm_list_5 (MAKMEMO_QUOTE (scm_args_number_key),
325 MAKMEMO_QUOTE (SCM_BOOL_F),
326 MAKMEMO_QUOTE (scm_from_latin1_string
327 ("Wrong number of arguments")),
328 MAKMEMO_QUOTE (SCM_EOL),
329 MAKMEMO_QUOTE (SCM_BOOL_F))),
330 FIXED_ARITY (0),
331 SCM_BOOL_F /* docstring */);
332 else
333 proc = memoize (body, env);
334
c438cd71
LC		 335 if (scm_is_string (docstring))
336 {
337 SCM args = SCM_MEMOIZED_ARGS (proc);
338 SCM_SETCAR (SCM_CDR (args), docstring);
339 }
340
341 return proc;
342 }
b7742c6b 343
dc3e203e
AW		 344 case SCM_EXPANDED_LAMBDA_CASE:
345 {
346 SCM req, rest, opt, kw, inits, vars, body, alt;
347 SCM walk, minits, arity, new_env;
632ddbf0 348 int nreq, nopt, ntotal;
dc3e203e
AW		 349
350 req = REF (exp, LAMBDA_CASE, REQ);
d61d6686 351 rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST)));
dc3e203e
AW		 352 opt = REF (exp, LAMBDA_CASE, OPT);
353 kw = REF (exp, LAMBDA_CASE, KW);
354 inits = REF (exp, LAMBDA_CASE, INITS);
355 vars = REF (exp, LAMBDA_CASE, GENSYMS);
356 body = REF (exp, LAMBDA_CASE, BODY);
357 alt = REF (exp, LAMBDA_CASE, ALTERNATE);
358
359 nreq = scm_ilength (req);
360 nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0;
632ddbf0 361 ntotal = scm_ilength (vars);
dc3e203e
AW		 362
363 /* The vars are the gensyms, according to the divine plan. But we need
364 to memoize the inits within their appropriate environment,
365 complicating things. */
366 new_env = env;
367 for (walk = req; scm_is_pair (walk);
368 walk = CDR (walk), vars = CDR (vars))
369 new_env = scm_cons (CAR (vars), new_env);
370
371 minits = SCM_EOL;
372 for (walk = opt; scm_is_pair (walk);
373 walk = CDR (walk), vars = CDR (vars), inits = CDR (inits))
374 {
375 minits = scm_cons (memoize (CAR (inits), new_env), minits);
376 new_env = scm_cons (CAR (vars), new_env);
377 }
b7742c6b 378
dc3e203e
AW		 379 if (scm_is_true (rest))
380 {
381 new_env = scm_cons (CAR (vars), new_env);
382 vars = CDR (vars);
383 }
b7742c6b 384
dc3e203e
AW		 385 for (; scm_is_pair (inits); vars = CDR (vars), inits = CDR (inits))
386 {
387 minits = scm_cons (memoize (CAR (inits), new_env), minits);
388 new_env = scm_cons (CAR (vars), new_env);
389 }
390 if (!scm_is_null (vars))
391 abort ();
b7742c6b 392
dc3e203e 393 minits = scm_reverse_x (minits, SCM_UNDEFINED);
b7742c6b 394
632ddbf0
AW		 395 if (scm_is_true (kw))
396 {
397 /* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */
398 SCM aok = CAR (kw), indices = SCM_EOL;
399 for (kw = CDR (kw); scm_is_pair (kw); kw = CDR (kw))
400 {
401 SCM k;
402 int idx;
403
404 k = CAR (CAR (kw));
405 idx = ntotal - 1 - lookup (CADDR (CAR (kw)), new_env);
406 indices = scm_acons (k, SCM_I_MAKINUM (idx), indices);
407 }
408 kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED));
409 }
410
dc3e203e
AW		 411 if (scm_is_false (alt) && scm_is_false (kw) && scm_is_false (opt))
412 {
413 if (scm_is_false (rest))
414 arity = FIXED_ARITY (nreq);
415 else
416 arity = REST_ARITY (nreq, SCM_BOOL_T);
417 }
418 else if (scm_is_true (alt))
419 arity = FULL_ARITY (nreq, rest, nopt, kw, minits,
420 SCM_MEMOIZED_ARGS (memoize (alt, env)));
421 else
422 arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F);
b7742c6b 423
c438cd71
LC		 424 return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
425 SCM_BOOL_F /* docstring */);
dc3e203e 426 }
b7742c6b 427
dc3e203e
AW		 428 case SCM_EXPANDED_LET:
429 {
430 SCM vars, exps, body, inits, new_env;
431
432 vars = REF (exp, LET, GENSYMS);
433 exps = REF (exp, LET, VALS);
434 body = REF (exp, LET, BODY);
435
436 inits = SCM_EOL;
437 new_env = env;
438 for (; scm_is_pair (vars); vars = CDR (vars), exps = CDR (exps))
439 {
440 new_env = scm_cons (CAR (vars), new_env);
441 inits = scm_cons (memoize (CAR (exps), env), inits);
442 }
b7742c6b 443
dc3e203e
AW		 444 return MAKMEMO_LET (scm_reverse_x (inits, SCM_UNDEFINED),
445 memoize (body, new_env));
446 }
b7742c6b 447
dc3e203e
AW		 448 case SCM_EXPANDED_LETREC:
449 {
826373a2
AW		 450 SCM vars, exps, body, undefs, new_env;
451 int i, nvars, in_order_p;
dc3e203e 452
f238862e
AW		 453 vars = REF (exp, LETREC, GENSYMS);
454 exps = REF (exp, LETREC, VALS);
455 body = REF (exp, LETREC, BODY);
826373a2 456 in_order_p = scm_is_true (REF (exp, LETREC, IN_ORDER_P));
dc3e203e 457 nvars = i = scm_ilength (vars);
826373a2 458 undefs = SCM_EOL;
dc3e203e
AW		 459 new_env = env;
460
826373a2 461 for (; scm_is_pair (vars); vars = CDR (vars))
dc3e203e
AW		 462 {
463 new_env = scm_cons (CAR (vars), new_env);
464 undefs = scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED), undefs);
dc3e203e 465 }
b7742c6b 466
826373a2
AW		 467 if (in_order_p)
468 {
6fc3eae4 469 SCM body_exps = SCM_EOL, seq;
826373a2
AW		 470 for (; scm_is_pair (exps); exps = CDR (exps), i--)
471 body_exps = scm_cons (MAKMEMO_LEX_SET (i-1,
472 memoize (CAR (exps), new_env)),
473 body_exps);
6fc3eae4
AW		 474
475 seq = memoize (body, new_env);
476 for (; scm_is_pair (body_exps); body_exps = CDR (body_exps))
477 seq = MAKMEMO_SEQ (CAR (body_exps), seq);
478
479 return MAKMEMO_LET (undefs, seq);
826373a2
AW		 480 }
481 else
482 {
6fc3eae4 483 SCM sets = SCM_EOL, inits = SCM_EOL, set_seq;
826373a2
AW		 484 for (; scm_is_pair (exps); exps = CDR (exps), i--)
485 {
486 sets = scm_cons (MAKMEMO_LEX_SET ((i-1) + nvars,
487 MAKMEMO_LEX_REF (i-1)),
488 sets);
489 inits = scm_cons (memoize (CAR (exps), new_env), inits);
490 }
491 inits = scm_reverse_x (inits, SCM_UNDEFINED);
6fc3eae4
AW		 492
493 sets = scm_reverse_x (sets, SCM_UNDEFINED);
494 if (scm_is_null (sets))
495 return memoize (body, env);
496
497 for (set_seq = CAR (sets), sets = CDR (sets); scm_is_pair (sets);
498 sets = CDR (sets))
499 set_seq = MAKMEMO_SEQ (CAR (sets), set_seq);
500
501 return MAKMEMO_LET (undefs,
502 MAKMEMO_SEQ (MAKMEMO_LET (inits, set_seq),
503 memoize (body, new_env)));
826373a2 504 }
dc3e203e 505 }
b7742c6b 506
dc3e203e
AW		 507 case SCM_EXPANDED_DYNLET:
508 return MAKMEMO_WITH_FLUIDS (memoize_exps (REF (exp, DYNLET, FLUIDS), env),
509 memoize_exps (REF (exp, DYNLET, VALS), env),
510 memoize (REF (exp, DYNLET, BODY), env));
b7742c6b 511
b7742c6b 512 default:
dc3e203e 513 abort ();
b7742c6b
AW		 514 }
515}
516
517
518\f
519
520SCM_DEFINE (scm_memoize_expression, "memoize-expression", 1, 0, 0,
521 (SCM exp),
522 "Memoize the expression @var{exp}.")
523#define FUNC_NAME s_scm_memoize_expression
524{
a310a1d1 525 SCM_ASSERT_TYPE (SCM_EXPANDED_P (exp), exp, 1, FUNC_NAME, "expanded");
b7742c6b
AW		 526 return memoize (exp, scm_current_module ());
527}
528#undef FUNC_NAME
529
2cd72a84 530
b7742c6b
AW		 531\f
532
2cd72a84
AW		 533#define SCM_MAKE_MEMOIZER(STR, MEMOIZER, N) \
534 (scm_cell (scm_tc16_memoizer, \
b2b33168 535 SCM_UNPACK (scm_c_make_gsubr (STR, N, 0, 0, MEMOIZER))))
2cd72a84
AW		 536#define SCM_DEFINE_MEMOIZER(STR, MEMOIZER, N) \
537SCM_SNARF_INIT(scm_c_define (STR, SCM_MAKE_MEMOIZER (STR, MEMOIZER, N)))
538
2cd72a84 539static SCM m_dynamic_wind (SCM pre, SCM exp, SCM post);
2cd72a84 540
2cd72a84 541SCM_DEFINE_MEMOIZER ("@dynamic-wind", m_dynamic_wind, 3);
2cd72a84
AW		 542
543
544\f
545
2cd72a84
AW		 546static SCM m_dynamic_wind (SCM in, SCM expr, SCM out)
547#define FUNC_NAME "memoize-dynwind"
548{
549 SCM_VALIDATE_MEMOIZED (1, in);
550 SCM_VALIDATE_MEMOIZED (2, expr);
551 SCM_VALIDATE_MEMOIZED (3, out);
552 return MAKMEMO_DYNWIND (in, expr, out);
553}
554#undef FUNC_NAME
555
2cd72a84
AW		 556
557\f
b7742c6b
AW		 558
559SCM_SYMBOL (sym_placeholder, "_");
560
561static SCM unmemoize (SCM expr);
562
563static SCM
564unmemoize_exprs (SCM exprs)
565{
566 SCM ret, tail;
567 if (scm_is_null (exprs))
568 return SCM_EOL;
569 ret = scm_list_1 (unmemoize (CAR (exprs)));
570 tail = ret;
571 for (exprs = CDR (exprs); !scm_is_null (exprs); exprs = CDR (exprs))
572 {
573 SCM_SETCDR (tail, scm_list_1 (unmemoize (CAR (exprs))));
574 tail = CDR (tail);
575 }
576 return ret;
577}
578
579static SCM
580unmemoize_bindings (SCM inits)
581{
582 SCM ret, tail;
583 if (scm_is_null (inits))
584 return SCM_EOL;
585 ret = scm_list_1 (scm_list_2 (sym_placeholder, unmemoize (CAR (inits))));
586 tail = ret;
587 for (inits = CDR (inits); !scm_is_null (inits); inits = CDR (inits))
588 {
589 SCM_SETCDR (tail, scm_list_1 (scm_list_2 (sym_placeholder,
590 unmemoize (CAR (inits)))));
591 tail = CDR (tail);
592 }
593 return ret;
594}
595
596static SCM
597unmemoize_lexical (SCM n)
598{
599 char buf[16];
600 buf[15] = 0;
601 snprintf (buf, 15, "<%u>", scm_to_uint32 (n));
25d50a05 602 return scm_from_utf8_symbol (buf);
b7742c6b
AW		 603}
604
605static SCM
606unmemoize (const SCM expr)
607{
608 SCM args;
609
610 if (!SCM_MEMOIZED_P (expr))
611 abort ();
612
613 args = SCM_MEMOIZED_ARGS (expr);
614 switch (SCM_MEMOIZED_TAG (expr))
615 {
616 case SCM_M_APPLY:
39caffe7
AW		 617 return scm_cons (scm_from_latin1_symbol ("apply"),
618 unmemoize_exprs (args));
6fc3eae4
AW		 619 case SCM_M_SEQ:
620 return scm_list_3 (scm_sym_begin, unmemoize (CAR (args)),
621 unmemoize (CDR (args)));
b7742c6b 622 case SCM_M_CALL:
9331f91c 623 return scm_cons (unmemoize (CAR (args)), unmemoize_exprs (CDDR (args)));
b7742c6b 624 case SCM_M_CONT:
bc056057
AW		 625 return scm_list_2 (scm_from_latin1_symbol
626 ("call-with-current_continuation"),
627 unmemoize (args));
b7742c6b 628 case SCM_M_CALL_WITH_VALUES:
0fcc39a0 629 return scm_list_3 (scm_from_latin1_symbol ("call-with-values"),
b7742c6b
AW		 630 unmemoize (CAR (args)), unmemoize (CDR (args)));
631 case SCM_M_DEFINE:
632 return scm_list_3 (scm_sym_define, CAR (args), unmemoize (CDR (args)));
d69531e2
AW		 633 case SCM_M_DYNWIND:
634 return scm_list_4 (scm_sym_at_dynamic_wind,
635 unmemoize (CAR (args)),
636 unmemoize (CADR (args)),
637 unmemoize (CDDR (args)));
bb0229b5
AW		 638 case SCM_M_WITH_FLUIDS:
639 {
640 SCM binds = SCM_EOL, fluids, vals;
641 for (fluids = CAR (args), vals = CADR (args); scm_is_pair (fluids);
642 fluids = CDR (fluids), vals = CDR (vals))
643 binds = scm_cons (scm_list_2 (unmemoize (CAR (fluids)),
644 unmemoize (CAR (vals))),
645 binds);
646 return scm_list_3 (scm_sym_with_fluids,
647 scm_reverse_x (binds, SCM_UNDEFINED),
648 unmemoize (CDDR (args)));
649 }
b7742c6b
AW		 650 case SCM_M_IF:
651 return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)),
652 unmemoize (scm_cadr (args)), unmemoize (scm_cddr (args)));
653 case SCM_M_LAMBDA:
c438cd71
LC		 654 {
655 SCM body = CAR (args), spec = CDDR (args);
656
657 if (scm_is_null (CDR (spec)))
658 return scm_list_3 (scm_sym_lambda,
659 scm_make_list (CAR (spec), sym_placeholder),
660 unmemoize (CAR (args)));
661 else if (scm_is_null (SCM_CDDR (spec)))
662 {
663 SCM formals = scm_make_list (CAR (spec), sym_placeholder);
664 return scm_list_3 (scm_sym_lambda,
665 scm_is_true (CADR (spec))
666 ? scm_cons_star (sym_placeholder, formals)
667 : formals,
668 unmemoize (CAR (args)));
669 }
670 else
671 {
672 SCM alt, tail;
673
674 alt = CADDR (CDDDR (spec));
675 if (scm_is_true (alt))
676 tail = CDR (unmemoize (alt));
677 else
678 tail = SCM_EOL;
679
680 return scm_cons
681 (sym_case_lambda_star,
682 scm_cons (scm_list_2 (scm_list_5 (CAR (spec),
683 CADR (spec),
684 CADDR (spec),
685 CADDDR (spec),
686 unmemoize_exprs (CADR (CDDDR (spec)))),
687 unmemoize (body)),
688 tail));
689 }
690 }
b7742c6b
AW		 691 case SCM_M_LET:
692 return scm_list_3 (scm_sym_let,
693 unmemoize_bindings (CAR (args)),
694 unmemoize (CDR (args)));
695 case SCM_M_QUOTE:
696 return scm_list_2 (scm_sym_quote, args);
697 case SCM_M_LEXICAL_REF:
698 return unmemoize_lexical (args);
699 case SCM_M_LEXICAL_SET:
700 return scm_list_3 (scm_sym_set_x, unmemoize_lexical (CAR (args)),
701 unmemoize (CDR (args)));
702 case SCM_M_TOPLEVEL_REF:
703 return args;
704 case SCM_M_TOPLEVEL_SET:
705 return scm_list_3 (scm_sym_set_x, CAR (args), unmemoize (CDR (args)));
706 case SCM_M_MODULE_REF:
c08899ff
AW		 707 return SCM_VARIABLEP (args) ? args
708 : scm_list_3 (scm_is_true (CDDR (args)) ? scm_sym_at : scm_sym_atat,
709 scm_i_finite_list_copy (CAR (args)),
710 CADR (args));
b7742c6b
AW		 711 case SCM_M_MODULE_SET:
712 return scm_list_3 (scm_sym_set_x,
c08899ff
AW		 713 SCM_VARIABLEP (CDR (args)) ? CDR (args)
714 : scm_list_3 (scm_is_true (CDDDR (args))
715 ? scm_sym_at : scm_sym_atat,
716 scm_i_finite_list_copy (CADR (args)),
717 CADDR (args)),
b7742c6b 718 unmemoize (CAR (args)));
1773bc7d
AW		 719 case SCM_M_CALL_WITH_PROMPT:
720 return scm_list_4 (scm_from_latin1_symbol ("call-with-prompt"),
747022e4
AW		 721 unmemoize (CAR (args)),
722 unmemoize (CADR (args)),
723 unmemoize (CDDR (args)));
b7742c6b
AW		 724 default:
725 abort ();
726 }
727}
728
2cd72a84
AW		 729
730\f
731
b7742c6b
AW		 732SCM_DEFINE (scm_memoized_p, "memoized?", 1, 0, 0,
733 (SCM obj),
734 "Return @code{#t} if @var{obj} is memoized.")
735#define FUNC_NAME s_scm_memoized_p
736{
737 return scm_from_bool (SCM_MEMOIZED_P (obj));
738}
739#undef FUNC_NAME
740
741SCM_DEFINE (scm_unmemoize_expression, "unmemoize-expression", 1, 0, 0,
742 (SCM m),
743 "Unmemoize the memoized expression @var{m}.")
744#define FUNC_NAME s_scm_unmemoize_expression
745{
746 SCM_VALIDATE_MEMOIZED (1, m);
747 return unmemoize (m);
748}
749#undef FUNC_NAME
750
3149a5b6
AW		 751SCM_DEFINE (scm_memoized_expression_typecode, "memoized-expression-typecode", 1, 0, 0,
752 (SCM m),
753 "Return the typecode from the memoized expression @var{m}.")
754#define FUNC_NAME s_scm_memoized_expression_typecode
755{
756 SCM_VALIDATE_MEMOIZED (1, m);
b7ecadca
LC		 757
758 /* The tag is a 16-bit integer so it fits in an inum. */
759 return SCM_I_MAKINUM (SCM_MEMOIZED_TAG (m));
3149a5b6
AW		 760}
761#undef FUNC_NAME
762
763SCM_DEFINE (scm_memoized_expression_data, "memoized-expression-data", 1, 0, 0,
764 (SCM m),
765 "Return the data from the memoized expression @var{m}.")
766#define FUNC_NAME s_scm_memoized_expression_data
767{
768 SCM_VALIDATE_MEMOIZED (1, m);
769 return SCM_MEMOIZED_ARGS (m);
770}
771#undef FUNC_NAME
772
773SCM_DEFINE (scm_memoized_typecode, "memoized-typecode", 1, 0, 0,
774 (SCM sym),
775 "Return the memoized typecode corresponding to the symbol @var{sym}.")
776#define FUNC_NAME s_scm_memoized_typecode
777{
778 int i;
779
780 SCM_VALIDATE_SYMBOL (1, sym);
781
782 for (i = 0; i < sizeof(memoized_tags)/sizeof(const char*); i++)
783 if (strcmp (scm_i_symbol_chars (sym), memoized_tags[i]) == 0)
784 return scm_from_int32 (i);
785
786 return SCM_BOOL_F;
787}
788#undef FUNC_NAME
789
790SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
791static void error_unbound_variable (SCM symbol) SCM_NORETURN;
792static void error_unbound_variable (SCM symbol)
793{
794 scm_error (scm_unbound_variable_key, NULL, "Unbound variable: ~S",
795 scm_list_1 (symbol), SCM_BOOL_F);
796}
797
798SCM_DEFINE (scm_memoize_variable_access_x, "memoize-variable-access!", 2, 0, 0,
799 (SCM m, SCM mod),
800 "Look up and cache the variable that @var{m} will access, returning the variable.")
7230aaf9 801#define FUNC_NAME s_scm_memoize_variable_access_x
3149a5b6
AW		 802{
803 SCM mx;
804 SCM_VALIDATE_MEMOIZED (1, m);
805 mx = SCM_MEMOIZED_ARGS (m);
806 switch (SCM_MEMOIZED_TAG (m))
807 {
808 case SCM_M_TOPLEVEL_REF:
809 if (SCM_VARIABLEP (mx))
810 return mx;
811 else
812 {
813 SCM var = scm_module_variable (mod, mx);
814 if (scm_is_false (var) || scm_is_false (scm_variable_bound_p (var)))
815 error_unbound_variable (mx);
816 SCM_SET_SMOB_OBJECT (m, var);
817 return var;
818 }
819
820 case SCM_M_TOPLEVEL_SET:
821 {
822 SCM var = CAR (mx);
823 if (SCM_VARIABLEP (var))
824 return var;
825 else
826 {
827 var = scm_module_variable (mod, var);
828 if (scm_is_false (var))
829 error_unbound_variable (CAR (mx));
830 SCM_SETCAR (mx, var);
831 return var;
832 }
833 }
834
835 case SCM_M_MODULE_REF:
836 if (SCM_VARIABLEP (mx))
837 return mx;
838 else
839 {
840 SCM var;
841 mod = scm_resolve_module (CAR (mx));
842 if (scm_is_true (CDDR (mx)))
843 mod = scm_module_public_interface (mod);
844 var = scm_module_lookup (mod, CADR (mx));
845 if (scm_is_false (scm_variable_bound_p (var)))
846 error_unbound_variable (CADR (mx));
847 SCM_SET_SMOB_OBJECT (m, var);
848 return var;
849 }
850
851 case SCM_M_MODULE_SET:
852 /* FIXME: not quite threadsafe */
853 if (SCM_VARIABLEP (CDR (mx)))
854 return CDR (mx);
855 else
856 {
857 SCM var;
858 mod = scm_resolve_module (CADR (mx));
859 if (scm_is_true (CDDDR (mx)))
860 mod = scm_module_public_interface (mod);
861 var = scm_module_lookup (mod, CADDR (mx));
862 SCM_SETCDR (mx, var);
863 return var;
864 }
865
866 default:
867 scm_wrong_type_arg (FUNC_NAME, 1, m);
868 return SCM_BOOL_F;
869 }
870}
871#undef FUNC_NAME
872
b7742c6b
AW		 873
874\f
875
876void
877scm_init_memoize ()
878{
879 scm_tc16_memoized = scm_make_smob_type ("%memoized", 0);
b7742c6b
AW		 880 scm_set_smob_print (scm_tc16_memoized, scm_print_memoized);
881
2cd72a84
AW		 882 scm_tc16_memoizer = scm_make_smob_type ("memoizer", 0);
883
b7742c6b 884#include "libguile/memoize.x"
4f692ace 885
4a655e50 886 list_of_guile = scm_list_1 (scm_from_latin1_symbol ("guile"));
b7742c6b
AW		 887}
888
889/*
890 Local Variables:
891 c-file-style: "gnu"
892 End:
893*/
Unnamed repository; edit this file 'description' to name the repository.