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