libguile/memoize.c

   1 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
   2  *   2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013
   3  *   Free Software Foundation, Inc.
   4  *
   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
  27 #include "libguile/__scm.h"
  28 #include "libguile/_scm.h"
  29 #include "libguile/continuations.h"
  30 #include "libguile/eq.h"
  31 #include "libguile/expand.h"
  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
  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)
  55 #define CADDDR(x) SCM_CADDDR(x)
  56
  57
  58 SCM_SYMBOL (sym_case_lambda_star, "case-lambda*");
  59
  60 \f
  61
  62
  63 /* {Evaluator memoized expressions}
  64  */
  65
  66 scm_t_bits scm_tc16_memoized;
  67
  68 #define MAKMEMO(n, args)                                                \
  69   (scm_cell (scm_tc16_memoized | ((n) << 16), SCM_UNPACK (args)))
  70
  71 #define MAKMEMO_SEQ(head,tail) \
  72   MAKMEMO (SCM_M_SEQ, scm_cons (head, tail))
  73 #define MAKMEMO_IF(test, then, else_) \
  74   MAKMEMO (SCM_M_IF, scm_cons (test, scm_cons (then, else_)))
  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)
  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)
  82 #define MAKMEMO_LAMBDA(body, arity, docstring)                  \
  83   MAKMEMO (SCM_M_LAMBDA,                                        \
  84            scm_cons (body, scm_cons (docstring, arity)))
  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))
  91 #define MAKMEMO_DYNWIND(in, expr, out) \
  92   MAKMEMO (SCM_M_DYNWIND, scm_cons (in, scm_cons (expr, out)))
  93 #define MAKMEMO_WITH_FLUIDS(fluids, vals, expr) \
  94   MAKMEMO (SCM_M_WITH_FLUIDS, scm_cons (fluids, scm_cons (vals, expr)))
  95 #define MAKMEMO_APPLY(proc, args)\
  96   MAKMEMO (SCM_M_APPLY, scm_list_2 (proc, args))
  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))
 101 #define MAKMEMO_CALL(proc, nargs, args) \
 102   MAKMEMO (SCM_M_CALL, scm_cons (proc, scm_cons (SCM_I_MAKINUM (nargs), args)))
 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))))
 115 #define MAKMEMO_PROMPT(tag, exp, handler) \
 116   MAKMEMO (SCM_M_PROMPT, scm_cons (tag, scm_cons (exp, handler)))
 117
 118
 119 /* Primitives for the evaluator */
 120 scm_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
 124 \f
 125
 126 /* This table must agree with the list of M_ constants in memoize.h */
 127 static const char *const memoized_tags[] =
 128 {
 129   "seq",
 130   "if",
 131   "lambda",
 132   "let",
 133   "quote",
 134   "define",
 135   "dynwind",
 136   "with-fluids",
 137   "apply",
 138   "call/cc",
 139   "call-with-values",
 140   "call",
 141   "lexical-ref",
 142   "lexical-set!",
 143   "toplevel-ref",
 144   "toplevel-set!",
 145   "module-ref",
 146   "module-set!",
 147   "prompt",
 148 };
 149
 150 static int
 151 scm_print_memoized (SCM memoized, SCM port, scm_print_state *pstate)
 152 {
 153   scm_puts_unlocked ("#<memoized ", port);
 154   scm_write (scm_unmemoize_expression (memoized), port);
 155   scm_puts_unlocked (">", port);
 156   return 1;
 157 }
 158
 159
 160 \f
 161
 162
 163 static int
 164 lookup (SCM x, SCM env)
 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 */
 170   abort ();
 171 }
 172
 173
 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)))
 177
 178 static SCM list_of_guile = SCM_BOOL_F;
 179
 180 static SCM memoize (SCM exp, SCM env);
 181
 182 static SCM
 183 memoize_exps (SCM exps, SCM env)
 184 {
 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);
 189 }
 190
 191 static SCM
 192 memoize (SCM exp, SCM env)
 193 {
 194   if (!SCM_EXPANDED_P (exp))
 195     abort ();
 196
 197   switch (SCM_EXPANDED_TYPE (exp))
 198     {
 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));
 204
 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
 246     case SCM_EXPANDED_CALL:
 247       {
 248         SCM proc, args;
 249
 250         proc = REF (exp, CALL, PROC);
 251         args = memoize_exps (REF (exp, CALL, ARGS), env);
 252
 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       }
 267
 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
 282     case SCM_EXPANDED_SEQ:
 283       return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env),
 284                           memoize (REF (exp, SEQ, TAIL), env));
 285
 286     case SCM_EXPANDED_LAMBDA:
 287       /* The body will be a lambda-case. */
 288       {
 289         SCM meta, docstring, proc;
 290
 291         meta = REF (exp, LAMBDA, META);
 292         docstring = scm_assoc_ref (meta, scm_sym_documentation);
 293
 294         proc = memoize (REF (exp, LAMBDA, BODY), env);
 295         if (scm_is_string (docstring))
 296           {
 297             SCM args = SCM_MEMOIZED_ARGS (proc);
 298             SCM_SETCAR (SCM_CDR (args), docstring);
 299           }
 300
 301         return proc;
 302       }
 303
 304     case SCM_EXPANDED_LAMBDA_CASE:
 305       {
 306         SCM req, rest, opt, kw, inits, vars, body, alt;
 307         SCM walk, minits, arity, new_env;
 308         int nreq, nopt, ntotal;
 309
 310         req = REF (exp, LAMBDA_CASE, REQ);
 311         rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST)));
 312         opt = REF (exp, LAMBDA_CASE, OPT);
 313         kw = REF (exp, LAMBDA_CASE, KW);
 314         inits = REF (exp, LAMBDA_CASE, INITS);
 315         vars = REF (exp, LAMBDA_CASE, GENSYMS);
 316         body = REF (exp, LAMBDA_CASE, BODY);
 317         alt = REF (exp, LAMBDA_CASE, ALTERNATE);
 318
 319         nreq = scm_ilength (req);
 320         nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0;
 321         ntotal = scm_ilength (vars);
 322
 323         /* The vars are the gensyms, according to the divine plan. But we need
 324            to memoize the inits within their appropriate environment,
 325            complicating things. */
 326         new_env = env;
 327         for (walk = req; scm_is_pair (walk);
 328              walk = CDR (walk), vars = CDR (vars))
 329           new_env = scm_cons (CAR (vars), new_env);
 330
 331         minits = SCM_EOL;
 332         for (walk = opt; scm_is_pair (walk);
 333              walk = CDR (walk), vars = CDR (vars), inits = CDR (inits))
 334           {
 335             minits = scm_cons (memoize (CAR (inits), new_env), minits);
 336             new_env = scm_cons (CAR (vars), new_env);
 337           }
 338
 339         if (scm_is_true (rest))
 340           {
 341             new_env = scm_cons (CAR (vars), new_env);
 342             vars = CDR (vars);
 343           }
 344
 345         for (; scm_is_pair (inits); vars = CDR (vars), inits = CDR (inits))
 346           {
 347             minits = scm_cons (memoize (CAR (inits), new_env), minits);
 348             new_env = scm_cons (CAR (vars), new_env);
 349           }
 350         if (!scm_is_null (vars))
 351           abort ();
 352
 353         minits = scm_reverse_x (minits, SCM_UNDEFINED);
 354
 355         if (scm_is_true (kw))
 356           {
 357             /* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */
 358             SCM aok = CAR (kw), indices = SCM_EOL;
 359             for (kw = CDR (kw); scm_is_pair (kw); kw = CDR (kw))
 360               {
 361                 SCM k;
 362                 int idx;
 363
 364                 k = CAR (CAR (kw));
 365                 idx = ntotal - 1 - lookup (CADDR (CAR (kw)), new_env);
 366                 indices = scm_acons (k, SCM_I_MAKINUM (idx), indices);
 367               }
 368             kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED));
 369           }
 370
 371         if (scm_is_false (alt) && scm_is_false (kw) && scm_is_false (opt))
 372           {
 373             if (scm_is_false (rest))
 374               arity = FIXED_ARITY (nreq);
 375             else
 376               arity = REST_ARITY (nreq, SCM_BOOL_T);
 377           }
 378         else if (scm_is_true (alt))
 379           arity = FULL_ARITY (nreq, rest, nopt, kw, minits,
 380                               SCM_MEMOIZED_ARGS (memoize (alt, env)));
 381         else
 382           arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F);
 383
 384         return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
 385                                SCM_BOOL_F /* docstring */);
 386       }
 387
 388     case SCM_EXPANDED_LET:
 389       {
 390         SCM vars, exps, body, inits, new_env;
 391
 392         vars = REF (exp, LET, GENSYMS);
 393         exps = REF (exp, LET, VALS);
 394         body = REF (exp, LET, BODY);
 395
 396         inits = SCM_EOL;
 397         new_env = env;
 398         for (; scm_is_pair (vars); vars = CDR (vars), exps = CDR (exps))
 399           {
 400             new_env = scm_cons (CAR (vars), new_env);
 401             inits = scm_cons (memoize (CAR (exps), env), inits);
 402           }
 403
 404         return MAKMEMO_LET (scm_reverse_x (inits, SCM_UNDEFINED),
 405                             memoize (body, new_env));
 406       }
 407
 408     case SCM_EXPANDED_LETREC:
 409       {
 410         SCM vars, exps, body, undefs, new_env;
 411         int i, nvars, in_order_p;
 412
 413         vars = REF (exp, LETREC, GENSYMS);
 414         exps = REF (exp, LETREC, VALS);
 415         body = REF (exp, LETREC, BODY);
 416         in_order_p = scm_is_true (REF (exp, LETREC, IN_ORDER_P));
 417         nvars = i = scm_ilength (vars);
 418         undefs = SCM_EOL;
 419         new_env = env;
 420
 421         for (; scm_is_pair (vars); vars = CDR (vars))
 422           {
 423             new_env = scm_cons (CAR (vars), new_env);
 424             undefs = scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED), undefs);
 425           }
 426
 427         if (in_order_p)
 428           {
 429             SCM body_exps = SCM_EOL, seq;
 430             for (; scm_is_pair (exps); exps = CDR (exps), i--)
 431               body_exps = scm_cons (MAKMEMO_LEX_SET (i-1,
 432                                                      memoize (CAR (exps), new_env)),
 433                                     body_exps);
 434
 435             seq = memoize (body, new_env);
 436             for (; scm_is_pair (body_exps); body_exps = CDR (body_exps))
 437               seq = MAKMEMO_SEQ (CAR (body_exps), seq);
 438
 439             return MAKMEMO_LET (undefs, seq);
 440           }
 441         else
 442           {
 443             SCM sets = SCM_EOL, inits = SCM_EOL, set_seq;
 444             for (; scm_is_pair (exps); exps = CDR (exps), i--)
 445               {
 446                 sets = scm_cons (MAKMEMO_LEX_SET ((i-1) + nvars,
 447                                                   MAKMEMO_LEX_REF (i-1)),
 448                                  sets);
 449                 inits = scm_cons (memoize (CAR (exps), new_env), inits);
 450               }
 451             inits = scm_reverse_x (inits, SCM_UNDEFINED);
 452
 453             sets = scm_reverse_x (sets, SCM_UNDEFINED);
 454             if (scm_is_null (sets))
 455               return memoize (body, env);
 456
 457             for (set_seq = CAR (sets), sets = CDR (sets); scm_is_pair (sets);
 458                  sets = CDR (sets))
 459               set_seq = MAKMEMO_SEQ (CAR (sets), set_seq);
 460
 461             return MAKMEMO_LET (undefs,
 462                                 MAKMEMO_SEQ (MAKMEMO_LET (inits, set_seq),
 463                                              memoize (body, new_env)));
 464           }
 465       }
 466
 467     case SCM_EXPANDED_DYNLET:
 468       return MAKMEMO_WITH_FLUIDS (memoize_exps (REF (exp, DYNLET, FLUIDS), env),
 469                                   memoize_exps (REF (exp, DYNLET, VALS), env),
 470                                   memoize (REF (exp, DYNLET, BODY), env));
 471
 472     default:
 473       abort ();
 474     }
 475 }
 476
 477
 478 \f
 479
 480 SCM_DEFINE (scm_memoize_expression, "memoize-expression", 1, 0, 0,
 481             (SCM exp),
 482             "Memoize the expression @var{exp}.")
 483 #define FUNC_NAME s_scm_memoize_expression
 484 {
 485   SCM_ASSERT_TYPE (SCM_EXPANDED_P (exp), exp, 1, FUNC_NAME, "expanded");
 486   return memoize (exp, scm_current_module ());
 487 }
 488 #undef FUNC_NAME
 489
 490
 491 \f
 492
 493 #define SCM_MAKE_MEMOIZER(STR, MEMOIZER, N)                             \
 494   (scm_cell (scm_tc16_memoizer,                                         \
 495              SCM_UNPACK (scm_c_make_gsubr (STR, N, 0, 0, MEMOIZER))))
 496 #define SCM_DEFINE_MEMOIZER(STR, MEMOIZER, N)                           \
 497 SCM_SNARF_INIT(scm_c_define (STR, SCM_MAKE_MEMOIZER (STR, MEMOIZER, N)))
 498
 499 #define SCM_MAKE_REST_MEMOIZER(STR, MEMOIZER, N)                        \
 500   (scm_cell (scm_tc16_memoizer,                                         \
 501              SCM_UNPACK ((scm_c_make_gsubr (STR, N, 0, 1, MEMOIZER)))))
 502 #define SCM_DEFINE_REST_MEMOIZER(STR, MEMOIZER, N)                      \
 503 SCM_SNARF_INIT(scm_c_define (STR, SCM_MAKE_REST_MEMOIZER (STR, MEMOIZER, N)))
 504
 505 static SCM m_apply (SCM proc, SCM arg, SCM rest);
 506 static SCM m_call_cc (SCM proc);
 507 static SCM m_call_values (SCM prod, SCM cons);
 508 static SCM m_dynamic_wind (SCM pre, SCM exp, SCM post);
 509 static SCM m_prompt (SCM tag, SCM exp, SCM handler);
 510
 511 SCM_DEFINE_REST_MEMOIZER ("@apply", m_apply, 2);
 512 SCM_DEFINE_MEMOIZER ("@call-with-current-continuation", m_call_cc, 1);
 513 SCM_DEFINE_MEMOIZER ("@call-with-values", m_call_values, 2);
 514 SCM_DEFINE_MEMOIZER ("@dynamic-wind", m_dynamic_wind, 3);
 515 SCM_DEFINE_MEMOIZER ("@prompt", m_prompt, 3);
 516
 517
 518 \f
 519
 520 static SCM m_apply (SCM proc, SCM arg, SCM rest)
 521 #define FUNC_NAME "@apply"
 522 {
 523   long len;
 524
 525   SCM_VALIDATE_MEMOIZED (1, proc);
 526   SCM_VALIDATE_MEMOIZED (2, arg);
 527   len = scm_ilength (rest);
 528   if (len < 0)
 529     abort ();
 530   else if (len == 0)
 531     return MAKMEMO_APPLY (proc, arg);
 532   else
 533     {
 534       SCM tail;
 535
 536       rest = scm_reverse (rest);
 537       tail = scm_car (rest);
 538       rest = scm_cdr (rest);
 539       len--;
 540
 541       while (scm_is_pair (rest))
 542         {
 543           tail = MAKMEMO_CALL (MAKMEMO_MOD_REF (scm_list_1 (scm_from_latin1_symbol ("guile")),
 544                                                 scm_from_latin1_symbol ("cons"),
 545                                                 SCM_BOOL_F),
 546                                2,
 547                                scm_list_2 (scm_car (rest), tail));
 548           rest = scm_cdr (rest);
 549         }
 550       return MAKMEMO_APPLY (proc, tail);
 551     }
 552 }
 553 #undef FUNC_NAME
 554
 555 static SCM m_call_cc (SCM proc)
 556 #define FUNC_NAME "@call-with-current-continuation"
 557 {
 558   SCM_VALIDATE_MEMOIZED (1, proc);
 559   return MAKMEMO_CONT (proc);
 560 }
 561 #undef FUNC_NAME
 562
 563 static SCM m_call_values (SCM prod, SCM cons)
 564 #define FUNC_NAME "@call-with-values"
 565 {
 566   SCM_VALIDATE_MEMOIZED (1, prod);
 567   SCM_VALIDATE_MEMOIZED (2, cons);
 568   return MAKMEMO_CALL_WITH_VALUES (prod, cons);
 569 }
 570 #undef FUNC_NAME
 571
 572 static SCM m_dynamic_wind (SCM in, SCM expr, SCM out)
 573 #define FUNC_NAME "memoize-dynwind"
 574 {
 575   SCM_VALIDATE_MEMOIZED (1, in);
 576   SCM_VALIDATE_MEMOIZED (2, expr);
 577   SCM_VALIDATE_MEMOIZED (3, out);
 578   return MAKMEMO_DYNWIND (in, expr, out);
 579 }
 580 #undef FUNC_NAME
 581
 582 static SCM m_prompt (SCM tag, SCM exp, SCM handler)
 583 #define FUNC_NAME "@prompt"
 584 {
 585   SCM_VALIDATE_MEMOIZED (1, tag);
 586   SCM_VALIDATE_MEMOIZED (2, exp);
 587   SCM_VALIDATE_MEMOIZED (3, handler);
 588   return MAKMEMO_PROMPT (tag, exp, handler);
 589 }
 590 #undef FUNC_NAME
 591
 592
 593 \f
 594
 595 SCM_SYMBOL (sym_placeholder, "_");
 596
 597 static SCM unmemoize (SCM expr);
 598
 599 static SCM
 600 unmemoize_exprs (SCM exprs)
 601 {
 602   SCM ret, tail;
 603   if (scm_is_null (exprs))
 604     return SCM_EOL;
 605   ret = scm_list_1 (unmemoize (CAR (exprs)));
 606   tail = ret;
 607   for (exprs = CDR (exprs); !scm_is_null (exprs); exprs = CDR (exprs))
 608     {
 609       SCM_SETCDR (tail, scm_list_1 (unmemoize (CAR (exprs))));
 610       tail = CDR (tail);
 611     }
 612   return ret;
 613 }
 614
 615 static SCM
 616 unmemoize_bindings (SCM inits)
 617 {
 618   SCM ret, tail;
 619   if (scm_is_null (inits))
 620     return SCM_EOL;
 621   ret = scm_list_1 (scm_list_2 (sym_placeholder, unmemoize (CAR (inits))));
 622   tail = ret;
 623   for (inits = CDR (inits); !scm_is_null (inits); inits = CDR (inits))
 624     {
 625       SCM_SETCDR (tail, scm_list_1 (scm_list_2 (sym_placeholder,
 626                                                 unmemoize (CAR (inits)))));
 627       tail = CDR (tail);
 628     }
 629   return ret;
 630 }
 631
 632 static SCM
 633 unmemoize_lexical (SCM n)
 634 {
 635   char buf[16];
 636   buf[15] = 0;
 637   snprintf (buf, 15, "<%u>", scm_to_uint32 (n));
 638   return scm_from_utf8_symbol (buf);
 639 }
 640
 641 static SCM
 642 unmemoize (const SCM expr)
 643 {
 644   SCM args;
 645
 646   if (!SCM_MEMOIZED_P (expr))
 647     abort ();
 648
 649   args = SCM_MEMOIZED_ARGS (expr);
 650   switch (SCM_MEMOIZED_TAG (expr))
 651     {
 652     case SCM_M_APPLY:
 653       return scm_cons (scm_sym_atapply, unmemoize_exprs (args));
 654     case SCM_M_SEQ:
 655       return scm_list_3 (scm_sym_begin, unmemoize (CAR (args)),
 656                          unmemoize (CDR (args)));
 657     case SCM_M_CALL:
 658       return scm_cons (unmemoize (CAR (args)), unmemoize_exprs (CDDR (args)));
 659     case SCM_M_CONT:
 660       return scm_list_2 (scm_sym_atcall_cc, unmemoize (args));
 661     case SCM_M_CALL_WITH_VALUES:
 662       return scm_list_3 (scm_sym_at_call_with_values,
 663                          unmemoize (CAR (args)), unmemoize (CDR (args)));
 664     case SCM_M_DEFINE:
 665       return scm_list_3 (scm_sym_define, CAR (args), unmemoize (CDR (args)));
 666     case SCM_M_DYNWIND:
 667       return scm_list_4 (scm_sym_at_dynamic_wind,
 668                          unmemoize (CAR (args)),
 669                          unmemoize (CADR (args)),
 670                          unmemoize (CDDR (args)));
 671     case SCM_M_WITH_FLUIDS:
 672       {
 673         SCM binds = SCM_EOL, fluids, vals;
 674         for (fluids = CAR (args), vals = CADR (args); scm_is_pair (fluids);
 675              fluids = CDR (fluids), vals = CDR (vals))
 676           binds = scm_cons (scm_list_2 (unmemoize (CAR (fluids)),
 677                                         unmemoize (CAR (vals))),
 678                             binds);
 679         return scm_list_3 (scm_sym_with_fluids,
 680                            scm_reverse_x (binds, SCM_UNDEFINED),
 681                            unmemoize (CDDR (args)));
 682       }
 683     case SCM_M_IF:
 684       return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)),
 685                          unmemoize (scm_cadr (args)), unmemoize (scm_cddr (args)));
 686     case SCM_M_LAMBDA:
 687       {
 688         SCM body = CAR (args), spec = CDDR (args);
 689
 690         if (scm_is_null (CDR (spec)))
 691           return scm_list_3 (scm_sym_lambda,
 692                              scm_make_list (CAR (spec), sym_placeholder),
 693                              unmemoize (CAR (args)));
 694         else if (scm_is_null (SCM_CDDR (spec)))
 695           {
 696             SCM formals = scm_make_list (CAR (spec), sym_placeholder);
 697             return scm_list_3 (scm_sym_lambda,
 698                                scm_is_true (CADR (spec))
 699                                ? scm_cons_star (sym_placeholder, formals)
 700                                : formals,
 701                                unmemoize (CAR (args)));
 702           }
 703         else
 704           {
 705             SCM alt, tail;
 706
 707             alt = CADDR (CDDDR (spec));
 708             if (scm_is_true (alt))
 709               tail = CDR (unmemoize (alt));
 710             else
 711               tail = SCM_EOL;
 712
 713             return scm_cons
 714               (sym_case_lambda_star,
 715                scm_cons (scm_list_2 (scm_list_5 (CAR (spec),
 716                                                  CADR (spec),
 717                                                  CADDR (spec),
 718                                                  CADDDR (spec),
 719                                                  unmemoize_exprs (CADR (CDDDR (spec)))),
 720                                      unmemoize (body)),
 721                          tail));
 722           }
 723       }
 724     case SCM_M_LET:
 725       return scm_list_3 (scm_sym_let,
 726                          unmemoize_bindings (CAR (args)),
 727                          unmemoize (CDR (args)));
 728     case SCM_M_QUOTE:
 729       return scm_list_2 (scm_sym_quote, args);
 730     case SCM_M_LEXICAL_REF:
 731       return unmemoize_lexical (args);
 732     case SCM_M_LEXICAL_SET:
 733       return scm_list_3 (scm_sym_set_x, unmemoize_lexical (CAR (args)),
 734                          unmemoize (CDR (args)));
 735     case SCM_M_TOPLEVEL_REF:
 736       return args;
 737     case SCM_M_TOPLEVEL_SET:
 738       return scm_list_3 (scm_sym_set_x, CAR (args), unmemoize (CDR (args)));
 739     case SCM_M_MODULE_REF:
 740       return SCM_VARIABLEP (args) ? args
 741         : scm_list_3 (scm_is_true (CDDR (args)) ? scm_sym_at : scm_sym_atat,
 742                       scm_i_finite_list_copy (CAR (args)),
 743                       CADR (args));
 744     case SCM_M_MODULE_SET:
 745       return scm_list_3 (scm_sym_set_x,
 746                          SCM_VARIABLEP (CDR (args)) ? CDR (args)
 747                          : scm_list_3 (scm_is_true (CDDDR (args))
 748                                        ? scm_sym_at : scm_sym_atat,
 749                                        scm_i_finite_list_copy (CADR (args)),
 750                                        CADDR (args)),
 751                          unmemoize (CAR (args)));
 752     case SCM_M_PROMPT:
 753       return scm_list_4 (scm_sym_at_prompt,
 754                          unmemoize (CAR (args)),
 755                          unmemoize (CADR (args)),
 756                          unmemoize (CDDR (args)));
 757     default:
 758       abort ();
 759     }
 760 }
 761
 762
 763 \f
 764
 765 SCM_DEFINE (scm_memoized_p, "memoized?", 1, 0, 0,
 766             (SCM obj),
 767             "Return @code{#t} if @var{obj} is memoized.")
 768 #define FUNC_NAME s_scm_memoized_p
 769 {
 770   return scm_from_bool (SCM_MEMOIZED_P (obj));
 771 }
 772 #undef FUNC_NAME
 773
 774 SCM_DEFINE (scm_unmemoize_expression, "unmemoize-expression", 1, 0, 0,
 775             (SCM m),
 776             "Unmemoize the memoized expression @var{m}.")
 777 #define FUNC_NAME s_scm_unmemoize_expression
 778 {
 779   SCM_VALIDATE_MEMOIZED (1, m);
 780   return unmemoize (m);
 781 }
 782 #undef FUNC_NAME
 783
 784 SCM_DEFINE (scm_memoized_expression_typecode, "memoized-expression-typecode", 1, 0, 0,
 785             (SCM m),
 786             "Return the typecode from the memoized expression @var{m}.")
 787 #define FUNC_NAME s_scm_memoized_expression_typecode
 788 {
 789   SCM_VALIDATE_MEMOIZED (1, m);
 790
 791   /* The tag is a 16-bit integer so it fits in an inum.  */
 792   return SCM_I_MAKINUM (SCM_MEMOIZED_TAG (m));
 793 }
 794 #undef FUNC_NAME
 795
 796 SCM_DEFINE (scm_memoized_expression_data, "memoized-expression-data", 1, 0, 0,
 797             (SCM m),
 798             "Return the data from the memoized expression @var{m}.")
 799 #define FUNC_NAME s_scm_memoized_expression_data
 800 {
 801   SCM_VALIDATE_MEMOIZED (1, m);
 802   return SCM_MEMOIZED_ARGS (m);
 803 }
 804 #undef FUNC_NAME
 805
 806 SCM_DEFINE (scm_memoized_typecode, "memoized-typecode", 1, 0, 0,
 807             (SCM sym),
 808             "Return the memoized typecode corresponding to the symbol @var{sym}.")
 809 #define FUNC_NAME s_scm_memoized_typecode
 810 {
 811   int i;
 812
 813   SCM_VALIDATE_SYMBOL (1, sym);
 814
 815   for (i = 0; i < sizeof(memoized_tags)/sizeof(const char*); i++)
 816     if (strcmp (scm_i_symbol_chars (sym), memoized_tags[i]) == 0)
 817       return scm_from_int32 (i);
 818
 819   return SCM_BOOL_F;
 820 }
 821 #undef FUNC_NAME
 822
 823 SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
 824 static void error_unbound_variable (SCM symbol) SCM_NORETURN;
 825 static void error_unbound_variable (SCM symbol)
 826 {
 827   scm_error (scm_unbound_variable_key, NULL, "Unbound variable: ~S",
 828              scm_list_1 (symbol), SCM_BOOL_F);
 829 }
 830
 831 SCM_DEFINE (scm_memoize_variable_access_x, "memoize-variable-access!", 2, 0, 0,
 832             (SCM m, SCM mod),
 833             "Look up and cache the variable that @var{m} will access, returning the variable.")
 834 #define FUNC_NAME s_scm_memoize_variable_access_x
 835 {
 836   SCM mx;
 837   SCM_VALIDATE_MEMOIZED (1, m);
 838   mx = SCM_MEMOIZED_ARGS (m);
 839   switch (SCM_MEMOIZED_TAG (m))
 840     {
 841     case SCM_M_TOPLEVEL_REF:
 842       if (SCM_VARIABLEP (mx))
 843         return mx;
 844       else
 845         {
 846           SCM var = scm_module_variable (mod, mx);
 847           if (scm_is_false (var) || scm_is_false (scm_variable_bound_p (var)))
 848             error_unbound_variable (mx);
 849           SCM_SET_SMOB_OBJECT (m, var);
 850           return var;
 851         }
 852
 853     case SCM_M_TOPLEVEL_SET:
 854       {
 855         SCM var = CAR (mx);
 856         if (SCM_VARIABLEP (var))
 857           return var;
 858         else
 859           {
 860             var = scm_module_variable (mod, var);
 861             if (scm_is_false (var))
 862               error_unbound_variable (CAR (mx));
 863             SCM_SETCAR (mx, var);
 864             return var;
 865           }
 866       }
 867
 868     case SCM_M_MODULE_REF:
 869       if (SCM_VARIABLEP (mx))
 870         return mx;
 871       else
 872         {
 873           SCM var;
 874           mod = scm_resolve_module (CAR (mx));
 875           if (scm_is_true (CDDR (mx)))
 876             mod = scm_module_public_interface (mod);
 877           var = scm_module_lookup (mod, CADR (mx));
 878           if (scm_is_false (scm_variable_bound_p (var)))
 879             error_unbound_variable (CADR (mx));
 880           SCM_SET_SMOB_OBJECT (m, var);
 881           return var;
 882         }
 883
 884     case SCM_M_MODULE_SET:
 885       /* FIXME: not quite threadsafe */
 886       if (SCM_VARIABLEP (CDR (mx)))
 887         return CDR (mx);
 888       else
 889         {
 890           SCM var;
 891           mod = scm_resolve_module (CADR (mx));
 892           if (scm_is_true (CDDDR (mx)))
 893             mod = scm_module_public_interface (mod);
 894           var = scm_module_lookup (mod, CADDR (mx));
 895           SCM_SETCDR (mx, var);
 896           return var;
 897         }
 898
 899     default:
 900       scm_wrong_type_arg (FUNC_NAME, 1, m);
 901       return SCM_BOOL_F;
 902     }
 903 }
 904 #undef FUNC_NAME
 905
 906
 907 \f
 908
 909 void
 910 scm_init_memoize ()
 911 {
 912   scm_tc16_memoized = scm_make_smob_type ("%memoized", 0);
 913   scm_set_smob_print (scm_tc16_memoized, scm_print_memoized);
 914
 915   scm_tc16_memoizer = scm_make_smob_type ("memoizer", 0);
 916
 917 #include "libguile/memoize.x"
 918
 919   list_of_guile = scm_list_1 (scm_from_latin1_symbol ("guile"));
 920 }
 921
 922 /*
 923   Local Variables:
 924   c-file-style: "gnu"
 925   End:
 926 */