HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
abort-to-prompt* instead of @abort
[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))))
747022e4
AW		 115#define MAKMEMO_PROMPT(tag, exp, handler) \
116 MAKMEMO (SCM_M_PROMPT, scm_cons (tag, scm_cons (exp, 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!",
747022e4 147 "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 {
270 SCM proc, args;
271
272 if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
273 proc = MAKMEMO_TOP_REF (REF (exp, PRIMCALL, NAME));
274 else
275 proc = MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMCALL, NAME),
276 SCM_BOOL_F);
277 args = memoize_exps (REF (exp, PRIMCALL, ARGS), env);
278
279 return MAKMEMO_CALL (proc, scm_ilength (args), args);
280 }
281
6fc3eae4
AW		 282 case SCM_EXPANDED_SEQ:
283 return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env),
284 memoize (REF (exp, SEQ, TAIL), env));
b7742c6b 285
dc3e203e 286 case SCM_EXPANDED_LAMBDA:
19113f1c 287 /* The body will be a lambda-case or #f. */
c438cd71 288 {
19113f1c 289 SCM meta, docstring, body, proc;
c438cd71
LC		 290
291 meta = REF (exp, LAMBDA, META);
292 docstring = scm_assoc_ref (meta, scm_sym_documentation);
293
19113f1c
AW		 294 body = REF (exp, LAMBDA, BODY);
295 if (scm_is_false (body))
296 /* Give a body to case-lambda with no clauses. */
297 proc = MAKMEMO_LAMBDA
298 (MAKMEMO_CALL
299 (MAKMEMO_MOD_REF (list_of_guile,
300 scm_from_latin1_symbol ("throw"),
301 SCM_BOOL_F),
302 5,
303 scm_list_5 (MAKMEMO_QUOTE (scm_args_number_key),
304 MAKMEMO_QUOTE (SCM_BOOL_F),
305 MAKMEMO_QUOTE (scm_from_latin1_string
306 ("Wrong number of arguments")),
307 MAKMEMO_QUOTE (SCM_EOL),
308 MAKMEMO_QUOTE (SCM_BOOL_F))),
309 FIXED_ARITY (0),
310 SCM_BOOL_F /* docstring */);
311 else
312 proc = memoize (body, env);
313
c438cd71
LC		 314 if (scm_is_string (docstring))
315 {
316 SCM args = SCM_MEMOIZED_ARGS (proc);
317 SCM_SETCAR (SCM_CDR (args), docstring);
318 }
319
320 return proc;
321 }
b7742c6b 322
dc3e203e
AW		 323 case SCM_EXPANDED_LAMBDA_CASE:
324 {
325 SCM req, rest, opt, kw, inits, vars, body, alt;
326 SCM walk, minits, arity, new_env;
632ddbf0 327 int nreq, nopt, ntotal;
dc3e203e
AW		 328
329 req = REF (exp, LAMBDA_CASE, REQ);
d61d6686 330 rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST)));
dc3e203e
AW		 331 opt = REF (exp, LAMBDA_CASE, OPT);
332 kw = REF (exp, LAMBDA_CASE, KW);
333 inits = REF (exp, LAMBDA_CASE, INITS);
334 vars = REF (exp, LAMBDA_CASE, GENSYMS);
335 body = REF (exp, LAMBDA_CASE, BODY);
336 alt = REF (exp, LAMBDA_CASE, ALTERNATE);
337
338 nreq = scm_ilength (req);
339 nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0;
632ddbf0 340 ntotal = scm_ilength (vars);
dc3e203e
AW		 341
342 /* The vars are the gensyms, according to the divine plan. But we need
343 to memoize the inits within their appropriate environment,
344 complicating things. */
345 new_env = env;
346 for (walk = req; scm_is_pair (walk);
347 walk = CDR (walk), vars = CDR (vars))
348 new_env = scm_cons (CAR (vars), new_env);
349
350 minits = SCM_EOL;
351 for (walk = opt; scm_is_pair (walk);
352 walk = CDR (walk), vars = CDR (vars), inits = CDR (inits))
353 {
354 minits = scm_cons (memoize (CAR (inits), new_env), minits);
355 new_env = scm_cons (CAR (vars), new_env);
356 }
b7742c6b 357
dc3e203e
AW		 358 if (scm_is_true (rest))
359 {
360 new_env = scm_cons (CAR (vars), new_env);
361 vars = CDR (vars);
362 }
b7742c6b 363
dc3e203e
AW		 364 for (; scm_is_pair (inits); vars = CDR (vars), inits = CDR (inits))
365 {
366 minits = scm_cons (memoize (CAR (inits), new_env), minits);
367 new_env = scm_cons (CAR (vars), new_env);
368 }
369 if (!scm_is_null (vars))
370 abort ();
b7742c6b 371
dc3e203e 372 minits = scm_reverse_x (minits, SCM_UNDEFINED);
b7742c6b 373
632ddbf0
AW		 374 if (scm_is_true (kw))
375 {
376 /* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */
377 SCM aok = CAR (kw), indices = SCM_EOL;
378 for (kw = CDR (kw); scm_is_pair (kw); kw = CDR (kw))
379 {
380 SCM k;
381 int idx;
382
383 k = CAR (CAR (kw));
384 idx = ntotal - 1 - lookup (CADDR (CAR (kw)), new_env);
385 indices = scm_acons (k, SCM_I_MAKINUM (idx), indices);
386 }
387 kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED));
388 }
389
dc3e203e
AW		 390 if (scm_is_false (alt) && scm_is_false (kw) && scm_is_false (opt))
391 {
392 if (scm_is_false (rest))
393 arity = FIXED_ARITY (nreq);
394 else
395 arity = REST_ARITY (nreq, SCM_BOOL_T);
396 }
397 else if (scm_is_true (alt))
398 arity = FULL_ARITY (nreq, rest, nopt, kw, minits,
399 SCM_MEMOIZED_ARGS (memoize (alt, env)));
400 else
401 arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F);
b7742c6b 402
c438cd71
LC		 403 return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
404 SCM_BOOL_F /* docstring */);
dc3e203e 405 }
b7742c6b 406
dc3e203e
AW		 407 case SCM_EXPANDED_LET:
408 {
409 SCM vars, exps, body, inits, new_env;
410
411 vars = REF (exp, LET, GENSYMS);
412 exps = REF (exp, LET, VALS);
413 body = REF (exp, LET, BODY);
414
415 inits = SCM_EOL;
416 new_env = env;
417 for (; scm_is_pair (vars); vars = CDR (vars), exps = CDR (exps))
418 {
419 new_env = scm_cons (CAR (vars), new_env);
420 inits = scm_cons (memoize (CAR (exps), env), inits);
421 }
b7742c6b 422
dc3e203e
AW		 423 return MAKMEMO_LET (scm_reverse_x (inits, SCM_UNDEFINED),
424 memoize (body, new_env));
425 }
b7742c6b 426
dc3e203e
AW		 427 case SCM_EXPANDED_LETREC:
428 {
826373a2
AW		 429 SCM vars, exps, body, undefs, new_env;
430 int i, nvars, in_order_p;
dc3e203e 431
f238862e
AW		 432 vars = REF (exp, LETREC, GENSYMS);
433 exps = REF (exp, LETREC, VALS);
434 body = REF (exp, LETREC, BODY);
826373a2 435 in_order_p = scm_is_true (REF (exp, LETREC, IN_ORDER_P));
dc3e203e 436 nvars = i = scm_ilength (vars);
826373a2 437 undefs = SCM_EOL;
dc3e203e
AW		 438 new_env = env;
439
826373a2 440 for (; scm_is_pair (vars); vars = CDR (vars))
dc3e203e
AW		 441 {
442 new_env = scm_cons (CAR (vars), new_env);
443 undefs = scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED), undefs);
dc3e203e 444 }
b7742c6b 445
826373a2
AW		 446 if (in_order_p)
447 {
6fc3eae4 448 SCM body_exps = SCM_EOL, seq;
826373a2
AW		 449 for (; scm_is_pair (exps); exps = CDR (exps), i--)
450 body_exps = scm_cons (MAKMEMO_LEX_SET (i-1,
451 memoize (CAR (exps), new_env)),
452 body_exps);
6fc3eae4
AW		 453
454 seq = memoize (body, new_env);
455 for (; scm_is_pair (body_exps); body_exps = CDR (body_exps))
456 seq = MAKMEMO_SEQ (CAR (body_exps), seq);
457
458 return MAKMEMO_LET (undefs, seq);
826373a2
AW		 459 }
460 else
461 {
6fc3eae4 462 SCM sets = SCM_EOL, inits = SCM_EOL, set_seq;
826373a2
AW		 463 for (; scm_is_pair (exps); exps = CDR (exps), i--)
464 {
465 sets = scm_cons (MAKMEMO_LEX_SET ((i-1) + nvars,
466 MAKMEMO_LEX_REF (i-1)),
467 sets);
468 inits = scm_cons (memoize (CAR (exps), new_env), inits);
469 }
470 inits = scm_reverse_x (inits, SCM_UNDEFINED);
6fc3eae4
AW		 471
472 sets = scm_reverse_x (sets, SCM_UNDEFINED);
473 if (scm_is_null (sets))
474 return memoize (body, env);
475
476 for (set_seq = CAR (sets), sets = CDR (sets); scm_is_pair (sets);
477 sets = CDR (sets))
478 set_seq = MAKMEMO_SEQ (CAR (sets), set_seq);
479
480 return MAKMEMO_LET (undefs,
481 MAKMEMO_SEQ (MAKMEMO_LET (inits, set_seq),
482 memoize (body, new_env)));
826373a2 483 }
dc3e203e 484 }
b7742c6b 485
dc3e203e
AW		 486 case SCM_EXPANDED_DYNLET:
487 return MAKMEMO_WITH_FLUIDS (memoize_exps (REF (exp, DYNLET, FLUIDS), env),
488 memoize_exps (REF (exp, DYNLET, VALS), env),
489 memoize (REF (exp, DYNLET, BODY), env));
b7742c6b 490
b7742c6b 491 default:
dc3e203e 492 abort ();
b7742c6b
AW		 493 }
494}
495
496
497\f
498
499SCM_DEFINE (scm_memoize_expression, "memoize-expression", 1, 0, 0,
500 (SCM exp),
501 "Memoize the expression @var{exp}.")
502#define FUNC_NAME s_scm_memoize_expression
503{
a310a1d1 504 SCM_ASSERT_TYPE (SCM_EXPANDED_P (exp), exp, 1, FUNC_NAME, "expanded");
b7742c6b
AW		 505 return memoize (exp, scm_current_module ());
506}
507#undef FUNC_NAME
508
2cd72a84 509
b7742c6b
AW		 510\f
511
2cd72a84
AW		 512#define SCM_MAKE_MEMOIZER(STR, MEMOIZER, N) \
513 (scm_cell (scm_tc16_memoizer, \
b2b33168 514 SCM_UNPACK (scm_c_make_gsubr (STR, N, 0, 0, MEMOIZER))))
2cd72a84
AW		 515#define SCM_DEFINE_MEMOIZER(STR, MEMOIZER, N) \
516SCM_SNARF_INIT(scm_c_define (STR, SCM_MAKE_MEMOIZER (STR, MEMOIZER, N)))
517
efa360af
AW		 518#define SCM_MAKE_REST_MEMOIZER(STR, MEMOIZER, N) \
519 (scm_cell (scm_tc16_memoizer, \
b2b33168 520 SCM_UNPACK ((scm_c_make_gsubr (STR, N, 0, 1, MEMOIZER)))))
efa360af
AW		 521#define SCM_DEFINE_REST_MEMOIZER(STR, MEMOIZER, N) \
522SCM_SNARF_INIT(scm_c_define (STR, SCM_MAKE_REST_MEMOIZER (STR, MEMOIZER, N)))
523
524static SCM m_apply (SCM proc, SCM arg, SCM rest);
2cd72a84
AW		 525static SCM m_call_cc (SCM proc);
526static SCM m_call_values (SCM prod, SCM cons);
527static SCM m_dynamic_wind (SCM pre, SCM exp, SCM post);
528static SCM m_prompt (SCM tag, SCM exp, SCM handler);
529
efa360af 530SCM_DEFINE_REST_MEMOIZER ("@apply", m_apply, 2);
2cd72a84
AW		 531SCM_DEFINE_MEMOIZER ("@call-with-current-continuation", m_call_cc, 1);
532SCM_DEFINE_MEMOIZER ("@call-with-values", m_call_values, 2);
533SCM_DEFINE_MEMOIZER ("@dynamic-wind", m_dynamic_wind, 3);
534SCM_DEFINE_MEMOIZER ("@prompt", m_prompt, 3);
535
536
537\f
538
efa360af 539static SCM m_apply (SCM proc, SCM arg, SCM rest)
2cd72a84
AW		 540#define FUNC_NAME "@apply"
541{
efa360af
AW		 542 long len;
543
2cd72a84 544 SCM_VALIDATE_MEMOIZED (1, proc);
efa360af
AW		 545 SCM_VALIDATE_MEMOIZED (2, arg);
546 len = scm_ilength (rest);
547 if (len < 0)
548 abort ();
549 else if (len == 0)
550 return MAKMEMO_APPLY (proc, arg);
551 else
552 {
553 SCM tail;
554
555 rest = scm_reverse (rest);
556 tail = scm_car (rest);
557 rest = scm_cdr (rest);
558 len--;
559
560 while (scm_is_pair (rest))
561 {
4a655e50
AW		 562 tail = MAKMEMO_CALL (MAKMEMO_MOD_REF (scm_list_1 (scm_from_latin1_symbol ("guile")),
563 scm_from_latin1_symbol ("cons"),
efa360af
AW		 564 SCM_BOOL_F),
565 2,
566 scm_list_2 (scm_car (rest), tail));
567 rest = scm_cdr (rest);
568 }
569 return MAKMEMO_APPLY (proc, tail);
570 }
2cd72a84
AW		 571}
572#undef FUNC_NAME
573
574static SCM m_call_cc (SCM proc)
575#define FUNC_NAME "@call-with-current-continuation"
576{
577 SCM_VALIDATE_MEMOIZED (1, proc);
578 return MAKMEMO_CONT (proc);
579}
580#undef FUNC_NAME
581
582static SCM m_call_values (SCM prod, SCM cons)
583#define FUNC_NAME "@call-with-values"
584{
585 SCM_VALIDATE_MEMOIZED (1, prod);
586 SCM_VALIDATE_MEMOIZED (2, cons);
587 return MAKMEMO_CALL_WITH_VALUES (prod, cons);
588}
589#undef FUNC_NAME
590
591static SCM m_dynamic_wind (SCM in, SCM expr, SCM out)
592#define FUNC_NAME "memoize-dynwind"
593{
594 SCM_VALIDATE_MEMOIZED (1, in);
595 SCM_VALIDATE_MEMOIZED (2, expr);
596 SCM_VALIDATE_MEMOIZED (3, out);
597 return MAKMEMO_DYNWIND (in, expr, out);
598}
599#undef FUNC_NAME
600
601static SCM m_prompt (SCM tag, SCM exp, SCM handler)
602#define FUNC_NAME "@prompt"
603{
604 SCM_VALIDATE_MEMOIZED (1, tag);
605 SCM_VALIDATE_MEMOIZED (2, exp);
606 SCM_VALIDATE_MEMOIZED (3, handler);
607 return MAKMEMO_PROMPT (tag, exp, handler);
608}
609#undef FUNC_NAME
610
2cd72a84
AW		 611
612\f
b7742c6b
AW		 613
614SCM_SYMBOL (sym_placeholder, "_");
615
616static SCM unmemoize (SCM expr);
617
618static SCM
619unmemoize_exprs (SCM exprs)
620{
621 SCM ret, tail;
622 if (scm_is_null (exprs))
623 return SCM_EOL;
624 ret = scm_list_1 (unmemoize (CAR (exprs)));
625 tail = ret;
626 for (exprs = CDR (exprs); !scm_is_null (exprs); exprs = CDR (exprs))
627 {
628 SCM_SETCDR (tail, scm_list_1 (unmemoize (CAR (exprs))));
629 tail = CDR (tail);
630 }
631 return ret;
632}
633
634static SCM
635unmemoize_bindings (SCM inits)
636{
637 SCM ret, tail;
638 if (scm_is_null (inits))
639 return SCM_EOL;
640 ret = scm_list_1 (scm_list_2 (sym_placeholder, unmemoize (CAR (inits))));
641 tail = ret;
642 for (inits = CDR (inits); !scm_is_null (inits); inits = CDR (inits))
643 {
644 SCM_SETCDR (tail, scm_list_1 (scm_list_2 (sym_placeholder,
645 unmemoize (CAR (inits)))));
646 tail = CDR (tail);
647 }
648 return ret;
649}
650
651static SCM
652unmemoize_lexical (SCM n)
653{
654 char buf[16];
655 buf[15] = 0;
656 snprintf (buf, 15, "<%u>", scm_to_uint32 (n));
25d50a05 657 return scm_from_utf8_symbol (buf);
b7742c6b
AW		 658}
659
660static SCM
661unmemoize (const SCM expr)
662{
663 SCM args;
664
665 if (!SCM_MEMOIZED_P (expr))
666 abort ();
667
668 args = SCM_MEMOIZED_ARGS (expr);
669 switch (SCM_MEMOIZED_TAG (expr))
670 {
671 case SCM_M_APPLY:
672 return scm_cons (scm_sym_atapply, unmemoize_exprs (args));
6fc3eae4
AW		 673 case SCM_M_SEQ:
674 return scm_list_3 (scm_sym_begin, unmemoize (CAR (args)),
675 unmemoize (CDR (args)));
b7742c6b 676 case SCM_M_CALL:
9331f91c 677 return scm_cons (unmemoize (CAR (args)), unmemoize_exprs (CDDR (args)));
b7742c6b
AW		 678 case SCM_M_CONT:
679 return scm_list_2 (scm_sym_atcall_cc, unmemoize (args));
680 case SCM_M_CALL_WITH_VALUES:
681 return scm_list_3 (scm_sym_at_call_with_values,
682 unmemoize (CAR (args)), unmemoize (CDR (args)));
683 case SCM_M_DEFINE:
684 return scm_list_3 (scm_sym_define, CAR (args), unmemoize (CDR (args)));
d69531e2
AW		 685 case SCM_M_DYNWIND:
686 return scm_list_4 (scm_sym_at_dynamic_wind,
687 unmemoize (CAR (args)),
688 unmemoize (CADR (args)),
689 unmemoize (CDDR (args)));
bb0229b5
AW		 690 case SCM_M_WITH_FLUIDS:
691 {
692 SCM binds = SCM_EOL, fluids, vals;
693 for (fluids = CAR (args), vals = CADR (args); scm_is_pair (fluids);
694 fluids = CDR (fluids), vals = CDR (vals))
695 binds = scm_cons (scm_list_2 (unmemoize (CAR (fluids)),
696 unmemoize (CAR (vals))),
697 binds);
698 return scm_list_3 (scm_sym_with_fluids,
699 scm_reverse_x (binds, SCM_UNDEFINED),
700 unmemoize (CDDR (args)));
701 }
b7742c6b
AW		 702 case SCM_M_IF:
703 return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)),
704 unmemoize (scm_cadr (args)), unmemoize (scm_cddr (args)));
705 case SCM_M_LAMBDA:
c438cd71
LC		 706 {
707 SCM body = CAR (args), spec = CDDR (args);
708
709 if (scm_is_null (CDR (spec)))
710 return scm_list_3 (scm_sym_lambda,
711 scm_make_list (CAR (spec), sym_placeholder),
712 unmemoize (CAR (args)));
713 else if (scm_is_null (SCM_CDDR (spec)))
714 {
715 SCM formals = scm_make_list (CAR (spec), sym_placeholder);
716 return scm_list_3 (scm_sym_lambda,
717 scm_is_true (CADR (spec))
718 ? scm_cons_star (sym_placeholder, formals)
719 : formals,
720 unmemoize (CAR (args)));
721 }
722 else
723 {
724 SCM alt, tail;
725
726 alt = CADDR (CDDDR (spec));
727 if (scm_is_true (alt))
728 tail = CDR (unmemoize (alt));
729 else
730 tail = SCM_EOL;
731
732 return scm_cons
733 (sym_case_lambda_star,
734 scm_cons (scm_list_2 (scm_list_5 (CAR (spec),
735 CADR (spec),
736 CADDR (spec),
737 CADDDR (spec),
738 unmemoize_exprs (CADR (CDDDR (spec)))),
739 unmemoize (body)),
740 tail));
741 }
742 }
b7742c6b
AW		 743 case SCM_M_LET:
744 return scm_list_3 (scm_sym_let,
745 unmemoize_bindings (CAR (args)),
746 unmemoize (CDR (args)));
747 case SCM_M_QUOTE:
748 return scm_list_2 (scm_sym_quote, args);
749 case SCM_M_LEXICAL_REF:
750 return unmemoize_lexical (args);
751 case SCM_M_LEXICAL_SET:
752 return scm_list_3 (scm_sym_set_x, unmemoize_lexical (CAR (args)),
753 unmemoize (CDR (args)));
754 case SCM_M_TOPLEVEL_REF:
755 return args;
756 case SCM_M_TOPLEVEL_SET:
757 return scm_list_3 (scm_sym_set_x, CAR (args), unmemoize (CDR (args)));
758 case SCM_M_MODULE_REF:
c08899ff
AW		 759 return SCM_VARIABLEP (args) ? args
760 : scm_list_3 (scm_is_true (CDDR (args)) ? scm_sym_at : scm_sym_atat,
761 scm_i_finite_list_copy (CAR (args)),
762 CADR (args));
b7742c6b
AW		 763 case SCM_M_MODULE_SET:
764 return scm_list_3 (scm_sym_set_x,
c08899ff
AW		 765 SCM_VARIABLEP (CDR (args)) ? CDR (args)
766 : scm_list_3 (scm_is_true (CDDDR (args))
767 ? scm_sym_at : scm_sym_atat,
768 scm_i_finite_list_copy (CADR (args)),
769 CADDR (args)),
b7742c6b 770 unmemoize (CAR (args)));
747022e4
AW		 771 case SCM_M_PROMPT:
772 return scm_list_4 (scm_sym_at_prompt,
773 unmemoize (CAR (args)),
774 unmemoize (CADR (args)),
775 unmemoize (CDDR (args)));
b7742c6b
AW		 776 default:
777 abort ();
778 }
779}
780
2cd72a84
AW		 781
782\f
783
b7742c6b
AW		 784SCM_DEFINE (scm_memoized_p, "memoized?", 1, 0, 0,
785 (SCM obj),
786 "Return @code{#t} if @var{obj} is memoized.")
787#define FUNC_NAME s_scm_memoized_p
788{
789 return scm_from_bool (SCM_MEMOIZED_P (obj));
790}
791#undef FUNC_NAME
792
793SCM_DEFINE (scm_unmemoize_expression, "unmemoize-expression", 1, 0, 0,
794 (SCM m),
795 "Unmemoize the memoized expression @var{m}.")
796#define FUNC_NAME s_scm_unmemoize_expression
797{
798 SCM_VALIDATE_MEMOIZED (1, m);
799 return unmemoize (m);
800}
801#undef FUNC_NAME
802
3149a5b6
AW		 803SCM_DEFINE (scm_memoized_expression_typecode, "memoized-expression-typecode", 1, 0, 0,
804 (SCM m),
805 "Return the typecode from the memoized expression @var{m}.")
806#define FUNC_NAME s_scm_memoized_expression_typecode
807{
808 SCM_VALIDATE_MEMOIZED (1, m);
b7ecadca
LC		 809
810 /* The tag is a 16-bit integer so it fits in an inum. */
811 return SCM_I_MAKINUM (SCM_MEMOIZED_TAG (m));
3149a5b6
AW		 812}
813#undef FUNC_NAME
814
815SCM_DEFINE (scm_memoized_expression_data, "memoized-expression-data", 1, 0, 0,
816 (SCM m),
817 "Return the data from the memoized expression @var{m}.")
818#define FUNC_NAME s_scm_memoized_expression_data
819{
820 SCM_VALIDATE_MEMOIZED (1, m);
821 return SCM_MEMOIZED_ARGS (m);
822}
823#undef FUNC_NAME
824
825SCM_DEFINE (scm_memoized_typecode, "memoized-typecode", 1, 0, 0,
826 (SCM sym),
827 "Return the memoized typecode corresponding to the symbol @var{sym}.")
828#define FUNC_NAME s_scm_memoized_typecode
829{
830 int i;
831
832 SCM_VALIDATE_SYMBOL (1, sym);
833
834 for (i = 0; i < sizeof(memoized_tags)/sizeof(const char*); i++)
835 if (strcmp (scm_i_symbol_chars (sym), memoized_tags[i]) == 0)
836 return scm_from_int32 (i);
837
838 return SCM_BOOL_F;
839}
840#undef FUNC_NAME
841
842SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
843static void error_unbound_variable (SCM symbol) SCM_NORETURN;
844static void error_unbound_variable (SCM symbol)
845{
846 scm_error (scm_unbound_variable_key, NULL, "Unbound variable: ~S",
847 scm_list_1 (symbol), SCM_BOOL_F);
848}
849
850SCM_DEFINE (scm_memoize_variable_access_x, "memoize-variable-access!", 2, 0, 0,
851 (SCM m, SCM mod),
852 "Look up and cache the variable that @var{m} will access, returning the variable.")
7230aaf9 853#define FUNC_NAME s_scm_memoize_variable_access_x
3149a5b6
AW		 854{
855 SCM mx;
856 SCM_VALIDATE_MEMOIZED (1, m);
857 mx = SCM_MEMOIZED_ARGS (m);
858 switch (SCM_MEMOIZED_TAG (m))
859 {
860 case SCM_M_TOPLEVEL_REF:
861 if (SCM_VARIABLEP (mx))
862 return mx;
863 else
864 {
865 SCM var = scm_module_variable (mod, mx);
866 if (scm_is_false (var) || scm_is_false (scm_variable_bound_p (var)))
867 error_unbound_variable (mx);
868 SCM_SET_SMOB_OBJECT (m, var);
869 return var;
870 }
871
872 case SCM_M_TOPLEVEL_SET:
873 {
874 SCM var = CAR (mx);
875 if (SCM_VARIABLEP (var))
876 return var;
877 else
878 {
879 var = scm_module_variable (mod, var);
880 if (scm_is_false (var))
881 error_unbound_variable (CAR (mx));
882 SCM_SETCAR (mx, var);
883 return var;
884 }
885 }
886
887 case SCM_M_MODULE_REF:
888 if (SCM_VARIABLEP (mx))
889 return mx;
890 else
891 {
892 SCM var;
893 mod = scm_resolve_module (CAR (mx));
894 if (scm_is_true (CDDR (mx)))
895 mod = scm_module_public_interface (mod);
896 var = scm_module_lookup (mod, CADR (mx));
897 if (scm_is_false (scm_variable_bound_p (var)))
898 error_unbound_variable (CADR (mx));
899 SCM_SET_SMOB_OBJECT (m, var);
900 return var;
901 }
902
903 case SCM_M_MODULE_SET:
904 /* FIXME: not quite threadsafe */
905 if (SCM_VARIABLEP (CDR (mx)))
906 return CDR (mx);
907 else
908 {
909 SCM var;
910 mod = scm_resolve_module (CADR (mx));
911 if (scm_is_true (CDDDR (mx)))
912 mod = scm_module_public_interface (mod);
913 var = scm_module_lookup (mod, CADDR (mx));
914 SCM_SETCDR (mx, var);
915 return var;
916 }
917
918 default:
919 scm_wrong_type_arg (FUNC_NAME, 1, m);
920 return SCM_BOOL_F;
921 }
922}
923#undef FUNC_NAME
924
b7742c6b
AW		 925
926\f
927
928void
929scm_init_memoize ()
930{
931 scm_tc16_memoized = scm_make_smob_type ("%memoized", 0);
b7742c6b
AW		 932 scm_set_smob_print (scm_tc16_memoized, scm_print_memoized);
933
2cd72a84
AW		 934 scm_tc16_memoizer = scm_make_smob_type ("memoizer", 0);
935
b7742c6b 936#include "libguile/memoize.x"
4f692ace 937
4a655e50 938 list_of_guile = scm_list_1 (scm_from_latin1_symbol ("guile"));
b7742c6b
AW		 939}
940
941/*
942 Local Variables:
943 c-file-style: "gnu"
944 End:
945*/
Unnamed repository; edit this file 'description' to name the repository.