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, 2014
   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 #define VECTOR_REF(v, i) (SCM_SIMPLE_VECTOR_REF (v, i))
  58 #define VECTOR_SET(v, i, x) (SCM_SIMPLE_VECTOR_SET (v, i, x))
  59 #define VECTOR_LENGTH(v) (SCM_SIMPLE_VECTOR_LENGTH (v))
  60
  61 SCM_SYMBOL (sym_case_lambda_star, "case-lambda*");
  62
  63 \f
  64
  65
  66 /* Primitives not exposed to general Scheme. */
  67 static SCM wind;
  68 static SCM unwind;
  69 static SCM push_fluid;
  70 static SCM pop_fluid;
  71
  72 static SCM
  73 do_wind (SCM in, SCM out)
  74 {
  75   scm_dynstack_push_dynwind (&SCM_I_CURRENT_THREAD->dynstack, in, out);
  76   return SCM_UNSPECIFIED;
  77 }
  78
  79 static SCM
  80 do_unwind (void)
  81 {
  82   scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
  83   return SCM_UNSPECIFIED;
  84 }
  85
  86 static SCM
  87 do_push_fluid (SCM fluid, SCM val)
  88 {
  89   scm_i_thread *thread = SCM_I_CURRENT_THREAD;
  90   scm_dynstack_push_fluid (&thread->dynstack, fluid, val,
  91                            thread->dynamic_state);
  92   return SCM_UNSPECIFIED;
  93 }
  94
  95 static SCM
  96 do_pop_fluid (void)
  97 {
  98   scm_i_thread *thread = SCM_I_CURRENT_THREAD;
  99   scm_dynstack_unwind_fluid (&thread->dynstack, thread->dynamic_state);
 100   return SCM_UNSPECIFIED;
 101 }
 102
 103
 104 \f
 105
 106 /* {Evaluator memoized expressions}
 107  */
 108
 109 scm_t_bits scm_tc16_memoized;
 110
 111 #define MAKMEMO(n, args)                                                \
 112   (scm_cons (SCM_I_MAKINUM (n), args))
 113
 114 #define MAKMEMO_SEQ(head,tail) \
 115   MAKMEMO (SCM_M_SEQ, scm_cons (head, tail))
 116 #define MAKMEMO_IF(test, then, else_) \
 117   MAKMEMO (SCM_M_IF, scm_cons (test, scm_cons (then, else_)))
 118 #define FIXED_ARITY(nreq) \
 119   scm_list_1 (SCM_I_MAKINUM (nreq))
 120 #define REST_ARITY(nreq, rest) \
 121   scm_list_2 (SCM_I_MAKINUM (nreq), rest)
 122 #define FULL_ARITY(nreq, rest, nopt, kw, ninits, unbound, alt) \
 123   scm_list_n (SCM_I_MAKINUM (nreq), rest, SCM_I_MAKINUM (nopt), kw, \
 124               SCM_I_MAKINUM (ninits), unbound, alt, SCM_UNDEFINED)
 125 #define MAKMEMO_LAMBDA(body, arity, meta)                       \
 126   MAKMEMO (SCM_M_LAMBDA,                                        \
 127            scm_cons (body, scm_cons (meta, arity)))
 128 #define MAKMEMO_CAPTURE_ENV(vars, body)                 \
 129   MAKMEMO (SCM_M_CAPTURE_ENV, scm_cons (vars, body))
 130 #define MAKMEMO_LET(inits, body) \
 131   MAKMEMO (SCM_M_LET, scm_cons (inits, body))
 132 #define MAKMEMO_QUOTE(exp) \
 133   MAKMEMO (SCM_M_QUOTE, exp)
 134 #define MAKMEMO_CAPTURE_MODULE(exp) \
 135   MAKMEMO (SCM_M_CAPTURE_MODULE, exp)
 136 #define MAKMEMO_APPLY(proc, args)\
 137   MAKMEMO (SCM_M_APPLY, scm_list_2 (proc, args))
 138 #define MAKMEMO_CONT(proc) \
 139   MAKMEMO (SCM_M_CONT, proc)
 140 #define MAKMEMO_CALL_WITH_VALUES(prod, cons) \
 141   MAKMEMO (SCM_M_CALL_WITH_VALUES, scm_cons (prod, cons))
 142 #define MAKMEMO_CALL(proc, nargs, args) \
 143   MAKMEMO (SCM_M_CALL, scm_cons (proc, scm_cons (SCM_I_MAKINUM (nargs), args)))
 144 #define MAKMEMO_LEX_REF(pos) \
 145   MAKMEMO (SCM_M_LEXICAL_REF, pos)
 146 #define MAKMEMO_LEX_SET(pos, val)                                      \
 147   MAKMEMO (SCM_M_LEXICAL_SET, scm_cons (pos, val))
 148 #define MAKMEMO_BOX_REF(box) \
 149   MAKMEMO (SCM_M_BOX_REF, box)
 150 #define MAKMEMO_BOX_SET(box, val)                                      \
 151   MAKMEMO (SCM_M_BOX_SET, scm_cons (box, val))
 152 #define MAKMEMO_TOP_BOX(mode, var)               \
 153   MAKMEMO (SCM_M_RESOLVE, scm_cons (SCM_I_MAKINUM (mode), var))
 154 #define MAKMEMO_MOD_BOX(mode, mod, var, public)                         \
 155   MAKMEMO (SCM_M_RESOLVE, \
 156            scm_cons (SCM_I_MAKINUM (mode),                              \
 157                      scm_cons (mod, scm_cons (var, public))))
 158 #define MAKMEMO_CALL_WITH_PROMPT(tag, thunk, handler) \
 159   MAKMEMO (SCM_M_CALL_WITH_PROMPT, scm_cons (tag, scm_cons (thunk, handler)))
 160
 161
 162 \f
 163
 164 /* This table must agree with the list of M_ constants in memoize.h */
 165 static const char *const memoized_tags[] =
 166 {
 167   "seq",
 168   "if",
 169   "lambda",
 170   "capture-env",
 171   "let",
 172   "quote",
 173   "capture-module",
 174   "apply",
 175   "call/cc",
 176   "call-with-values",
 177   "call",
 178   "lexical-ref",
 179   "lexical-set!",
 180   "box-ref",
 181   "box-set!",
 182   "resolve",
 183   "call-with-prompt",
 184 };
 185
 186
 187 \f
 188
 189
 190 /* Memoization-time environments mirror the structure of eval-time
 191    environments.  Each link in the chain at memoization-time corresponds
 192    to a link at eval-time.
 193
 194    env := module | (link, env)
 195    module := #f | #t
 196    link := flat-link . nested-link
 197    flat-link := (#t . ((var . pos) ...))
 198    nested-link := (#f . #(var ...))
 199
 200    A module of #f indicates that the current module has not yet been
 201    captured.  Memoizing a capture-module expression will capture the
 202    module.
 203
 204    Flat environments copy the values for a set of free variables into a
 205    flat environment, via the capture-env expression.  During memoization
 206    a flat link collects the values of free variables, along with their
 207    resolved outer locations.  We are able to copy values because the
 208    incoming expression has already been assignment-converted.  Flat
 209    environments prevent closures from hanging on to too much memory.
 210
 211    Nested environments have a rib of "let" bindings, and link to an
 212    outer environment.
 213 */
 214
 215 static int
 216 try_lookup_rib (SCM x, SCM rib)
 217 {
 218   int idx = 0;
 219   for (; idx < VECTOR_LENGTH (rib); idx++)
 220     if (scm_is_eq (x, VECTOR_REF (rib, idx)))
 221       return idx; /* bound */
 222   return -1;
 223 }
 224
 225 static int
 226 lookup_rib (SCM x, SCM rib)
 227 {
 228   int idx = try_lookup_rib (x, rib);
 229   if (idx < 0)
 230     abort ();
 231   return idx;
 232 }
 233
 234 static SCM
 235 make_pos (int depth, int width)
 236 {
 237   return scm_cons (SCM_I_MAKINUM (depth), SCM_I_MAKINUM (width));
 238 }
 239
 240 static SCM
 241 push_nested_link (SCM vars, SCM env)
 242 {
 243   return scm_acons (SCM_BOOL_F, vars, env);
 244 }
 245
 246 static SCM
 247 push_flat_link (SCM env)
 248 {
 249   return scm_acons (SCM_BOOL_T, SCM_EOL, env);
 250 }
 251
 252 static int
 253 env_link_is_flat (SCM env_link)
 254 {
 255   return scm_is_true (CAR (env_link));
 256 }
 257
 258 static SCM
 259 env_link_vars (SCM env_link)
 260 {
 261   return CDR (env_link);
 262 }
 263
 264 static void
 265 env_link_add_flat_var (SCM env_link, SCM var, SCM pos)
 266 {
 267   SCM vars = env_link_vars (env_link);
 268   if (scm_is_false (scm_assq (var, vars)))
 269     scm_set_cdr_x (env_link, scm_acons (var, pos, vars));
 270 }
 271
 272 static SCM
 273 lookup (SCM x, SCM env)
 274 {
 275   int d = 0;
 276   for (; scm_is_pair (env); env = CDR (env), d++)
 277     {
 278       SCM link = CAR (env);
 279       if (env_link_is_flat (link))
 280         {
 281           int w;
 282           SCM vars;
 283
 284           for (vars = env_link_vars (link), w = scm_ilength (vars) - 1;
 285                scm_is_pair (vars);
 286                vars = CDR (vars), w--)
 287             if (scm_is_eq (x, (CAAR (vars))))
 288               return make_pos (d, w);
 289
 290           env_link_add_flat_var (link, x, lookup (x, CDR (env)));
 291           return make_pos (d, scm_ilength (env_link_vars (link)) - 1);
 292         }
 293       else
 294         {
 295           int w = try_lookup_rib (x, env_link_vars (link));
 296           if (w < 0)
 297             continue;
 298           return make_pos (d, w);
 299         }
 300     }
 301   abort ();
 302 }
 303
 304 static SCM
 305 capture_flat_env (SCM lambda, SCM env)
 306 {
 307   int nenv;
 308   SCM vars, link, locs;
 309
 310   link = CAR (env);
 311   vars = env_link_vars (link);
 312   nenv = scm_ilength (vars);
 313   locs = scm_c_make_vector (nenv, SCM_BOOL_F);
 314
 315   for (; scm_is_pair (vars); vars = CDR (vars))
 316     scm_c_vector_set_x (locs, --nenv, CDAR (vars));
 317
 318   return MAKMEMO_CAPTURE_ENV (locs, lambda);
 319 }
 320
 321 /* Abbreviate SCM_EXPANDED_REF. Copied because I'm not sure about symbol pasting */
 322 #define REF(x,type,field) \
 323   (scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field)))
 324
 325 static SCM list_of_guile = SCM_BOOL_F;
 326
 327 static SCM memoize (SCM exp, SCM env);
 328
 329 static SCM
 330 memoize_exps (SCM exps, SCM env)
 331 {
 332   SCM ret;
 333   for (ret = SCM_EOL; scm_is_pair (exps); exps = CDR (exps))
 334     ret = scm_cons (memoize (CAR (exps), env), ret);
 335   return scm_reverse_x (ret, SCM_UNDEFINED);
 336 }
 337
 338 static SCM
 339 capture_env (SCM env)
 340 {
 341   if (scm_is_false (env))
 342     return SCM_BOOL_T;
 343   return env;
 344 }
 345
 346 static SCM
 347 maybe_makmemo_capture_module (SCM exp, SCM env)
 348 {
 349   if (scm_is_false (env))
 350     return MAKMEMO_CAPTURE_MODULE (exp);
 351   return exp;
 352 }
 353
 354 static SCM
 355 memoize (SCM exp, SCM env)
 356 {
 357   if (!SCM_EXPANDED_P (exp))
 358     abort ();
 359
 360   switch (SCM_EXPANDED_TYPE (exp))
 361     {
 362     case SCM_EXPANDED_VOID:
 363       return MAKMEMO_QUOTE (SCM_UNSPECIFIED);
 364
 365     case SCM_EXPANDED_CONST:
 366       return MAKMEMO_QUOTE (REF (exp, CONST, EXP));
 367
 368     case SCM_EXPANDED_PRIMITIVE_REF:
 369       if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
 370         return maybe_makmemo_capture_module
 371           (MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
 372                                              REF (exp, PRIMITIVE_REF, NAME))),
 373            env);
 374       else
 375         return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF,
 376                                                  list_of_guile,
 377                                                  REF (exp, PRIMITIVE_REF, NAME),
 378                                                  SCM_BOOL_F));
 379
 380     case SCM_EXPANDED_LEXICAL_REF:
 381       return MAKMEMO_LEX_REF (lookup (REF (exp, LEXICAL_REF, GENSYM), env));
 382
 383     case SCM_EXPANDED_LEXICAL_SET:
 384       return MAKMEMO_LEX_SET (lookup (REF (exp, LEXICAL_SET, GENSYM), env),
 385                               memoize (REF (exp, LEXICAL_SET, EXP), env));
 386
 387     case SCM_EXPANDED_MODULE_REF:
 388       return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX
 389                               (SCM_EXPANDED_MODULE_REF,
 390                                REF (exp, MODULE_REF, MOD),
 391                                REF (exp, MODULE_REF, NAME),
 392                                REF (exp, MODULE_REF, PUBLIC)));
 393
 394     case SCM_EXPANDED_MODULE_SET:
 395       return MAKMEMO_BOX_SET (MAKMEMO_MOD_BOX
 396                               (SCM_EXPANDED_MODULE_SET,
 397                                REF (exp, MODULE_SET, MOD),
 398                                REF (exp, MODULE_SET, NAME),
 399                                REF (exp, MODULE_SET, PUBLIC)),
 400                               memoize (REF (exp, MODULE_SET, EXP), env));
 401
 402     case SCM_EXPANDED_TOPLEVEL_REF:
 403       return maybe_makmemo_capture_module
 404         (MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
 405                                            REF (exp, TOPLEVEL_REF, NAME))),
 406          env);
 407
 408     case SCM_EXPANDED_TOPLEVEL_SET:
 409       return maybe_makmemo_capture_module
 410         (MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_SET,
 411                                            REF (exp, TOPLEVEL_SET, NAME)),
 412                           memoize (REF (exp, TOPLEVEL_SET, EXP),
 413                                    capture_env (env))),
 414          env);
 415
 416     case SCM_EXPANDED_TOPLEVEL_DEFINE:
 417       return maybe_makmemo_capture_module
 418         (MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_DEFINE,
 419                                            REF (exp, TOPLEVEL_DEFINE, NAME)),
 420                           memoize (REF (exp, TOPLEVEL_DEFINE, EXP),
 421                                    capture_env (env))),
 422          env);
 423
 424     case SCM_EXPANDED_CONDITIONAL:
 425       return MAKMEMO_IF (memoize (REF (exp, CONDITIONAL, TEST), env),
 426                          memoize (REF (exp, CONDITIONAL, CONSEQUENT), env),
 427                          memoize (REF (exp, CONDITIONAL, ALTERNATE), env));
 428
 429     case SCM_EXPANDED_CALL:
 430       {
 431         SCM proc, args;
 432
 433         proc = REF (exp, CALL, PROC);
 434         args = memoize_exps (REF (exp, CALL, ARGS), env);
 435
 436         return MAKMEMO_CALL (memoize (proc, env), scm_ilength (args), args);
 437       }
 438
 439     case SCM_EXPANDED_PRIMCALL:
 440       {
 441         SCM name, args;
 442         int nargs;
 443
 444         name = REF (exp, PRIMCALL, NAME);
 445         args = memoize_exps (REF (exp, PRIMCALL, ARGS), env);
 446         nargs = scm_ilength (args);
 447
 448         if (nargs == 3
 449             && scm_is_eq (name, scm_from_latin1_symbol ("call-with-prompt")))
 450           return MAKMEMO_CALL_WITH_PROMPT (CAR (args),
 451                                            CADR (args),
 452                                            CADDR (args));
 453         else if (nargs == 2
 454                  && scm_is_eq (name, scm_from_latin1_symbol ("apply")))
 455           return MAKMEMO_APPLY (CAR (args), CADR (args));
 456         else if (nargs == 1
 457                  && scm_is_eq (name,
 458                                scm_from_latin1_symbol
 459                                ("call-with-current-continuation")))
 460           return MAKMEMO_CONT (CAR (args));
 461         else if (nargs == 2
 462                  && scm_is_eq (name,
 463                                scm_from_latin1_symbol ("call-with-values")))
 464           return MAKMEMO_CALL_WITH_VALUES (CAR (args), CADR (args));
 465         else if (nargs == 1
 466                  && scm_is_eq (name,
 467                                scm_from_latin1_symbol ("variable-ref")))
 468           return MAKMEMO_BOX_REF (CAR (args));
 469         else if (nargs == 2
 470                  && scm_is_eq (name,
 471                                scm_from_latin1_symbol ("variable-set!")))
 472           return MAKMEMO_BOX_SET (CAR (args), CADR (args));
 473         else if (nargs == 2
 474                  && scm_is_eq (name, scm_from_latin1_symbol ("wind")))
 475           return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), 2, args);
 476         else if (nargs == 0
 477                  && scm_is_eq (name, scm_from_latin1_symbol ("unwind")))
 478           return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), 0, SCM_EOL);
 479         else if (nargs == 2
 480                  && scm_is_eq (name, scm_from_latin1_symbol ("push-fluid")))
 481           return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), 2, args);
 482         else if (nargs == 0
 483                  && scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid")))
 484           return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), 0, SCM_EOL);
 485         else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
 486           return MAKMEMO_CALL (maybe_makmemo_capture_module
 487                                (MAKMEMO_BOX_REF
 488                                 (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
 489                                                   name)),
 490                                 env),
 491                                nargs, args);
 492         else
 493           return MAKMEMO_CALL (MAKMEMO_BOX_REF
 494                                (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF,
 495                                                  list_of_guile,
 496                                                  name,
 497                                                  SCM_BOOL_F)),
 498                                nargs,
 499                                args);
 500       }
 501
 502     case SCM_EXPANDED_SEQ:
 503       return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env),
 504                           memoize (REF (exp, SEQ, TAIL), env));
 505
 506     case SCM_EXPANDED_LAMBDA:
 507       /* The body will be a lambda-case. */
 508       {
 509         SCM meta, body, proc, new_env;
 510
 511         meta = REF (exp, LAMBDA, META);
 512         body = REF (exp, LAMBDA, BODY);
 513         new_env = push_flat_link (capture_env (env));
 514         proc = memoize (body, new_env);
 515         SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta);
 516
 517         return maybe_makmemo_capture_module (capture_flat_env (proc, new_env),
 518                                              env);
 519       }
 520
 521     case SCM_EXPANDED_LAMBDA_CASE:
 522       {
 523         SCM req, rest, opt, kw, inits, vars, body, alt;
 524         SCM unbound, arity, rib, new_env;
 525         int nreq, nopt, ninits;
 526
 527         req = REF (exp, LAMBDA_CASE, REQ);
 528         rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST)));
 529         opt = REF (exp, LAMBDA_CASE, OPT);
 530         kw = REF (exp, LAMBDA_CASE, KW);
 531         inits = REF (exp, LAMBDA_CASE, INITS);
 532         vars = REF (exp, LAMBDA_CASE, GENSYMS);
 533         body = REF (exp, LAMBDA_CASE, BODY);
 534         alt = REF (exp, LAMBDA_CASE, ALTERNATE);
 535
 536         nreq = scm_ilength (req);
 537         nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0;
 538         ninits = scm_ilength (inits);
 539         /* This relies on assignment conversion turning inits into a
 540            sequence of CONST expressions whose values are a unique
 541            "unbound" token.  */
 542         unbound = ninits ? REF (CAR (inits), CONST, EXP) : SCM_BOOL_F;
 543         rib = scm_vector (vars);
 544         new_env = push_nested_link (rib, env);
 545
 546         if (scm_is_true (kw))
 547           {
 548             /* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */
 549             SCM aok = CAR (kw), indices = SCM_EOL;
 550             for (kw = CDR (kw); scm_is_pair (kw); kw = CDR (kw))
 551               {
 552                 SCM k;
 553                 int idx;
 554
 555                 k = CAR (CAR (kw));
 556                 idx = lookup_rib (CADDR (CAR (kw)), rib);
 557                 indices = scm_acons (k, SCM_I_MAKINUM (idx), indices);
 558               }
 559             kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED));
 560           }
 561
 562         if (scm_is_false (alt) && scm_is_false (kw) && scm_is_false (opt))
 563           {
 564             if (scm_is_false (rest))
 565               arity = FIXED_ARITY (nreq);
 566             else
 567               arity = REST_ARITY (nreq, SCM_BOOL_T);
 568           }
 569         else if (scm_is_true (alt))
 570           arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
 571                               SCM_MEMOIZED_ARGS (memoize (alt, env)));
 572         else
 573           arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
 574                               SCM_BOOL_F);
 575
 576         return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
 577                                SCM_EOL /* meta, filled in later */);
 578       }
 579
 580     case SCM_EXPANDED_LET:
 581       {
 582         SCM vars, exps, body, varsv, inits, new_env;
 583         int i;
 584
 585         vars = REF (exp, LET, GENSYMS);
 586         exps = REF (exp, LET, VALS);
 587         body = REF (exp, LET, BODY);
 588
 589         varsv = scm_vector (vars);
 590         inits = scm_c_make_vector (VECTOR_LENGTH (varsv),
 591                                    SCM_BOOL_F);
 592         new_env = push_nested_link (varsv, capture_env (env));
 593         for (i = 0; scm_is_pair (exps); exps = CDR (exps), i++)
 594           VECTOR_SET (inits, i, memoize (CAR (exps), env));
 595
 596         return maybe_makmemo_capture_module
 597           (MAKMEMO_LET (inits, memoize (body, new_env)), env);
 598       }
 599
 600     default:
 601       abort ();
 602     }
 603 }
 604
 605
 606 \f
 607
 608 SCM_DEFINE (scm_memoize_expression, "memoize-expression", 1, 0, 0,
 609             (SCM exp),
 610             "Memoize the expression @var{exp}.")
 611 #define FUNC_NAME s_scm_memoize_expression
 612 {
 613   SCM_ASSERT_TYPE (SCM_EXPANDED_P (exp), exp, 1, FUNC_NAME, "expanded");
 614   return memoize (scm_convert_assignment (exp), SCM_BOOL_F);
 615 }
 616 #undef FUNC_NAME
 617
 618
 619 \f
 620
 621 SCM_SYMBOL (sym_placeholder, "_");
 622
 623 static SCM unmemoize (SCM expr);
 624
 625 static SCM
 626 unmemoize_exprs (SCM exprs)
 627 {
 628   SCM ret, tail;
 629   if (scm_is_null (exprs))
 630     return SCM_EOL;
 631   ret = scm_list_1 (unmemoize (CAR (exprs)));
 632   tail = ret;
 633   for (exprs = CDR (exprs); !scm_is_null (exprs); exprs = CDR (exprs))
 634     {
 635       SCM_SETCDR (tail, scm_list_1 (unmemoize (CAR (exprs))));
 636       tail = CDR (tail);
 637     }
 638   return ret;
 639 }
 640
 641 static SCM
 642 unmemoize_bindings (SCM inits)
 643 {
 644   SCM ret = SCM_EOL;
 645   int n = scm_c_vector_length (inits);
 646
 647   while (n--)
 648     ret = scm_cons (unmemoize (scm_c_vector_ref (inits, n)), ret);
 649
 650   return ret;
 651 }
 652
 653 static SCM
 654 unmemoize_lexical (SCM n)
 655 {
 656   char buf[32];
 657   buf[31] = 0;
 658   snprintf (buf, 31, "<%u,%u>", scm_to_uint32 (CAR (n)),
 659             scm_to_uint32 (CDR (n)));
 660   return scm_from_utf8_symbol (buf);
 661 }
 662
 663 static SCM
 664 unmemoize (const SCM expr)
 665 {
 666   SCM args;
 667
 668   args = SCM_MEMOIZED_ARGS (expr);
 669   switch (SCM_MEMOIZED_TAG (expr))
 670     {
 671     case SCM_M_APPLY:
 672       return scm_cons (scm_from_latin1_symbol ("apply"),
 673                        unmemoize_exprs (args));
 674     case SCM_M_SEQ:
 675       return scm_list_3 (scm_sym_begin, unmemoize (CAR (args)),
 676                          unmemoize (CDR (args)));
 677     case SCM_M_CALL:
 678       return scm_cons (unmemoize (CAR (args)), unmemoize_exprs (CDDR (args)));
 679     case SCM_M_CONT:
 680       return scm_list_2 (scm_from_latin1_symbol
 681                          ("call-with-current_continuation"),
 682                          unmemoize (args));
 683     case SCM_M_CALL_WITH_VALUES:
 684       return scm_list_3 (scm_from_latin1_symbol ("call-with-values"),
 685                          unmemoize (CAR (args)), unmemoize (CDR (args)));
 686     case SCM_M_CAPTURE_MODULE:
 687       return scm_list_2 (scm_from_latin1_symbol ("capture-module"),
 688                          unmemoize (args));
 689     case SCM_M_IF:
 690       return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)),
 691                          unmemoize (scm_cadr (args)), unmemoize (scm_cddr (args)));
 692     case SCM_M_LAMBDA:
 693       {
 694         SCM body = CAR (args), spec = CDDR (args);
 695
 696         if (scm_is_null (CDR (spec)))
 697           return scm_list_3 (scm_sym_lambda,
 698                              scm_make_list (CAR (spec), sym_placeholder),
 699                              unmemoize (CAR (args)));
 700         else if (scm_is_null (SCM_CDDR (spec)))
 701           {
 702             SCM formals = scm_make_list (CAR (spec), sym_placeholder);
 703             return scm_list_3 (scm_sym_lambda,
 704                                scm_is_true (CADR (spec))
 705                                ? scm_cons_star (sym_placeholder, formals)
 706                                : formals,
 707                                unmemoize (CAR (args)));
 708           }
 709         else
 710           {
 711             SCM alt, tail;
 712
 713             alt = CADDDR (CDDDR (spec));
 714             if (scm_is_true (alt))
 715               tail = CDR (unmemoize (alt));
 716             else
 717               tail = SCM_EOL;
 718
 719             return scm_cons
 720               (sym_case_lambda_star,
 721                scm_cons (scm_list_2 (scm_list_5 (CAR (spec),
 722                                                  CADR (spec),
 723                                                  CADDR (spec),
 724                                                  CADDDR (spec),
 725                                                  CADR (CDDDR (spec))),
 726                                      unmemoize (body)),
 727                          tail));
 728           }
 729       }
 730     case SCM_M_CAPTURE_ENV:
 731       return scm_list_3 (scm_from_latin1_symbol ("capture-env"),
 732                          CAR (args),
 733                          unmemoize (CDR (args)));
 734     case SCM_M_LET:
 735       return scm_list_3 (scm_sym_let,
 736                          unmemoize_bindings (CAR (args)),
 737                          unmemoize (CDR (args)));
 738     case SCM_M_QUOTE:
 739       return scm_list_2 (scm_sym_quote, args);
 740     case SCM_M_LEXICAL_REF:
 741       return unmemoize_lexical (args);
 742     case SCM_M_LEXICAL_SET:
 743       return scm_list_3 (scm_sym_set_x, unmemoize_lexical (CAR (args)),
 744                          unmemoize (CDR (args)));
 745     case SCM_M_BOX_REF:
 746       return scm_list_2 (scm_from_latin1_symbol ("variable-ref"),
 747                          unmemoize (args));
 748     case SCM_M_BOX_SET:
 749       return scm_list_3 (scm_from_latin1_symbol ("variable-set!"),
 750                          unmemoize (CAR (args)),
 751                          unmemoize (CDR (args)));
 752     case SCM_M_RESOLVE:
 753       if (SCM_VARIABLEP (args))
 754         return args;
 755       else if (scm_is_symbol (CDR (args)))
 756         return CDR (args);
 757       else
 758         return scm_list_3
 759           (scm_is_true (CDDDR (args)) ? scm_sym_at : scm_sym_atat,
 760            scm_i_finite_list_copy (CADR (args)),
 761            CADDR (args));
 762     case SCM_M_CALL_WITH_PROMPT:
 763       return scm_list_4 (scm_from_latin1_symbol ("call-with-prompt"),
 764                          unmemoize (CAR (args)),
 765                          unmemoize (CADR (args)),
 766                          unmemoize (CDDR (args)));
 767     default:
 768       abort ();
 769     }
 770 }
 771
 772
 773 \f
 774
 775 SCM_DEFINE (scm_unmemoize_expression, "unmemoize-expression", 1, 0, 0,
 776             (SCM m),
 777             "Unmemoize the memoized expression @var{m}.")
 778 #define FUNC_NAME s_scm_unmemoize_expression
 779 {
 780   return unmemoize (m);
 781 }
 782 #undef FUNC_NAME
 783
 784 SCM_DEFINE (scm_memoized_typecode, "memoized-typecode", 1, 0, 0,
 785             (SCM sym),
 786             "Return the memoized typecode corresponding to the symbol @var{sym}.")
 787 #define FUNC_NAME s_scm_memoized_typecode
 788 {
 789   int i;
 790
 791   SCM_VALIDATE_SYMBOL (1, sym);
 792
 793   for (i = 0; i < sizeof(memoized_tags)/sizeof(const char*); i++)
 794     if (strcmp (scm_i_symbol_chars (sym), memoized_tags[i]) == 0)
 795       return scm_from_int32 (i);
 796
 797   return SCM_BOOL_F;
 798 }
 799 #undef FUNC_NAME
 800
 801 SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
 802 static void error_unbound_variable (SCM symbol) SCM_NORETURN;
 803 static void error_unbound_variable (SCM symbol)
 804 {
 805   scm_error (scm_unbound_variable_key, NULL, "Unbound variable: ~S",
 806              scm_list_1 (symbol), SCM_BOOL_F);
 807 }
 808
 809 SCM_DEFINE (scm_sys_resolve_variable, "%resolve-variable", 2, 0, 0,
 810             (SCM loc, SCM mod),
 811             "Look up and return the variable for @var{loc}.")
 812 #define FUNC_NAME s_scm_sys_resolve_variable
 813 {
 814   int mode;
 815
 816   if (scm_is_false (mod))
 817     mod = scm_the_root_module ();
 818
 819   mode = scm_to_int (scm_car (loc));
 820   loc = scm_cdr (loc);
 821
 822   switch (mode)
 823     {
 824     case SCM_EXPANDED_TOPLEVEL_REF:
 825     case SCM_EXPANDED_TOPLEVEL_SET:
 826       {
 827         SCM var = scm_module_variable (mod, loc);
 828         if (scm_is_false (var)
 829             || (mode == SCM_EXPANDED_TOPLEVEL_REF
 830                 && scm_is_false (scm_variable_bound_p (var))))
 831           error_unbound_variable (loc);
 832         return var;
 833       }
 834
 835     case SCM_EXPANDED_TOPLEVEL_DEFINE:
 836       {
 837         return scm_module_ensure_local_variable (mod, loc);
 838       }
 839
 840     case SCM_EXPANDED_MODULE_REF:
 841     case SCM_EXPANDED_MODULE_SET:
 842       {
 843         SCM var;
 844         mod = scm_resolve_module (scm_car (loc));
 845         if (scm_is_true (scm_cddr (loc)))
 846           mod = scm_module_public_interface (mod);
 847         var = scm_module_lookup (mod, scm_cadr (loc));
 848         if (mode == SCM_EXPANDED_MODULE_SET
 849             && scm_is_false (scm_variable_bound_p (var)))
 850           error_unbound_variable (scm_cadr (loc));
 851         return var;
 852       }
 853
 854     default:
 855       scm_wrong_type_arg (FUNC_NAME, 1, loc);
 856       return SCM_BOOL_F;
 857     }
 858 }
 859 #undef FUNC_NAME
 860
 861
 862 \f
 863
 864 void
 865 scm_init_memoize ()
 866 {
 867 #include "libguile/memoize.x"
 868
 869   wind = scm_c_make_gsubr ("wind", 2, 0, 0, do_wind);
 870   unwind = scm_c_make_gsubr ("unwind", 0, 0, 0, do_unwind);
 871   push_fluid = scm_c_make_gsubr ("push-fluid", 2, 0, 0, do_push_fluid);
 872   pop_fluid = scm_c_make_gsubr ("pop-fluid", 0, 0, 0, do_pop_fluid);
 873
 874   list_of_guile = scm_list_1 (scm_from_latin1_symbol ("guile"));
 875 }
 876
 877 /*
 878   Local Variables:
 879   c-file-style: "gnu"
 880   End:
 881 */