libguile/memoize.c

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