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