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, 2015
   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, args) \
 143   MAKMEMO (SCM_M_CALL, scm_cons (proc, 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), 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), args);
 476         else if (nargs == 0
 477                  && scm_is_eq (name, scm_from_latin1_symbol ("unwind")))
 478           return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), 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), 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), 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                                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                                args);
 499       }
 500
 501     case SCM_EXPANDED_SEQ:
 502       return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env),
 503                           memoize (REF (exp, SEQ, TAIL), env));
 504
 505     case SCM_EXPANDED_LAMBDA:
 506       /* The body will be a lambda-case. */
 507       {
 508         SCM meta, body, proc, new_env;
 509
 510         meta = REF (exp, LAMBDA, META);
 511         body = REF (exp, LAMBDA, BODY);
 512         new_env = push_flat_link (capture_env (env));
 513         proc = memoize (body, new_env);
 514         SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta);
 515
 516         return maybe_makmemo_capture_module (capture_flat_env (proc, new_env),
 517                                              env);
 518       }
 519
 520     case SCM_EXPANDED_LAMBDA_CASE:
 521       {
 522         SCM req, rest, opt, kw, inits, vars, body, alt;
 523         SCM unbound, arity, rib, new_env;
 524         int nreq, nopt, ninits;
 525
 526         req = REF (exp, LAMBDA_CASE, REQ);
 527         rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST)));
 528         opt = REF (exp, LAMBDA_CASE, OPT);
 529         kw = REF (exp, LAMBDA_CASE, KW);
 530         inits = REF (exp, LAMBDA_CASE, INITS);
 531         vars = REF (exp, LAMBDA_CASE, GENSYMS);
 532         body = REF (exp, LAMBDA_CASE, BODY);
 533         alt = REF (exp, LAMBDA_CASE, ALTERNATE);
 534
 535         nreq = scm_ilength (req);
 536         nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0;
 537         ninits = scm_ilength (inits);
 538         /* This relies on assignment conversion turning inits into a
 539            sequence of CONST expressions whose values are a unique
 540            "unbound" token.  */
 541         unbound = ninits ? REF (CAR (inits), CONST, EXP) : SCM_BOOL_F;
 542         rib = scm_vector (vars);
 543         new_env = push_nested_link (rib, env);
 544
 545         if (scm_is_true (kw))
 546           {
 547             /* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */
 548             SCM aok = CAR (kw), indices = SCM_EOL;
 549             for (kw = CDR (kw); scm_is_pair (kw); kw = CDR (kw))
 550               {
 551                 SCM k;
 552                 int idx;
 553
 554                 k = CAR (CAR (kw));
 555                 idx = lookup_rib (CADDR (CAR (kw)), rib);
 556                 indices = scm_acons (k, SCM_I_MAKINUM (idx), indices);
 557               }
 558             kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED));
 559           }
 560
 561         if (scm_is_false (alt) && scm_is_false (kw) && scm_is_false (opt))
 562           {
 563             if (scm_is_false (rest))
 564               arity = FIXED_ARITY (nreq);
 565             else
 566               arity = REST_ARITY (nreq, SCM_BOOL_T);
 567           }
 568         else if (scm_is_true (alt))
 569           arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
 570                               SCM_MEMOIZED_ARGS (memoize (alt, env)));
 571         else
 572           arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
 573                               SCM_BOOL_F);
 574
 575         return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
 576                                SCM_EOL /* meta, filled in later */);
 577       }
 578
 579     case SCM_EXPANDED_LET:
 580       {
 581         SCM vars, exps, body, varsv, inits, new_env;
 582         int i;
 583
 584         vars = REF (exp, LET, GENSYMS);
 585         exps = REF (exp, LET, VALS);
 586         body = REF (exp, LET, BODY);
 587
 588         varsv = scm_vector (vars);
 589         inits = scm_c_make_vector (VECTOR_LENGTH (varsv),
 590                                    SCM_BOOL_F);
 591         new_env = push_nested_link (varsv, capture_env (env));
 592         for (i = 0; scm_is_pair (exps); exps = CDR (exps), i++)
 593           VECTOR_SET (inits, i, memoize (CAR (exps), env));
 594
 595         return maybe_makmemo_capture_module
 596           (MAKMEMO_LET (inits, memoize (body, new_env)), env);
 597       }
 598
 599     default:
 600       abort ();
 601     }
 602 }
 603
 604
 605 \f
 606
 607 SCM_DEFINE (scm_memoize_expression, "memoize-expression", 1, 0, 0,
 608             (SCM exp),
 609             "Memoize the expression @var{exp}.")
 610 #define FUNC_NAME s_scm_memoize_expression
 611 {
 612   SCM_ASSERT_TYPE (SCM_EXPANDED_P (exp), exp, 1, FUNC_NAME, "expanded");
 613   return memoize (scm_convert_assignment (exp), SCM_BOOL_F);
 614 }
 615 #undef FUNC_NAME
 616
 617
 618 \f
 619
 620 SCM_SYMBOL (sym_placeholder, "_");
 621
 622 static SCM unmemoize (SCM expr);
 623
 624 static SCM
 625 unmemoize_exprs (SCM exprs)
 626 {
 627   SCM ret, tail;
 628   if (scm_is_null (exprs))
 629     return SCM_EOL;
 630   ret = scm_list_1 (unmemoize (CAR (exprs)));
 631   tail = ret;
 632   for (exprs = CDR (exprs); !scm_is_null (exprs); exprs = CDR (exprs))
 633     {
 634       SCM_SETCDR (tail, scm_list_1 (unmemoize (CAR (exprs))));
 635       tail = CDR (tail);
 636     }
 637   return ret;
 638 }
 639
 640 static SCM
 641 unmemoize_bindings (SCM inits)
 642 {
 643   SCM ret = SCM_EOL;
 644   int n = scm_c_vector_length (inits);
 645
 646   while (n--)
 647     ret = scm_cons (unmemoize (scm_c_vector_ref (inits, n)), ret);
 648
 649   return ret;
 650 }
 651
 652 static SCM
 653 unmemoize_lexical (SCM n)
 654 {
 655   char buf[32];
 656   buf[31] = 0;
 657   snprintf (buf, 31, "<%u,%u>", scm_to_uint32 (CAR (n)),
 658             scm_to_uint32 (CDR (n)));
 659   return scm_from_utf8_symbol (buf);
 660 }
 661
 662 static SCM
 663 unmemoize (const SCM expr)
 664 {
 665   SCM args;
 666
 667   args = SCM_MEMOIZED_ARGS (expr);
 668   switch (SCM_MEMOIZED_TAG (expr))
 669     {
 670     case SCM_M_APPLY:
 671       return scm_cons (scm_from_latin1_symbol ("apply"),
 672                        unmemoize_exprs (args));
 673     case SCM_M_SEQ:
 674       return scm_list_3 (scm_sym_begin, unmemoize (CAR (args)),
 675                          unmemoize (CDR (args)));
 676     case SCM_M_CALL:
 677       return unmemoize_exprs (args);
 678     case SCM_M_CONT:
 679       return scm_list_2 (scm_from_latin1_symbol
 680                          ("call-with-current_continuation"),
 681                          unmemoize (args));
 682     case SCM_M_CALL_WITH_VALUES:
 683       return scm_list_3 (scm_from_latin1_symbol ("call-with-values"),
 684                          unmemoize (CAR (args)), unmemoize (CDR (args)));
 685     case SCM_M_CAPTURE_MODULE:
 686       return scm_list_2 (scm_from_latin1_symbol ("capture-module"),
 687                          unmemoize (args));
 688     case SCM_M_IF:
 689       return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)),
 690                          unmemoize (scm_cadr (args)), unmemoize (scm_cddr (args)));
 691     case SCM_M_LAMBDA:
 692       {
 693         SCM body = CAR (args), spec = CDDR (args);
 694
 695         if (scm_is_null (CDR (spec)))
 696           return scm_list_3 (scm_sym_lambda,
 697                              scm_make_list (CAR (spec), sym_placeholder),
 698                              unmemoize (CAR (args)));
 699         else if (scm_is_null (SCM_CDDR (spec)))
 700           {
 701             SCM formals = scm_make_list (CAR (spec), sym_placeholder);
 702             return scm_list_3 (scm_sym_lambda,
 703                                scm_is_true (CADR (spec))
 704                                ? scm_cons_star (sym_placeholder, formals)
 705                                : formals,
 706                                unmemoize (CAR (args)));
 707           }
 708         else
 709           {
 710             SCM alt, tail;
 711
 712             alt = CADDDR (CDDDR (spec));
 713             if (scm_is_true (alt))
 714               tail = CDR (unmemoize (alt));
 715             else
 716               tail = SCM_EOL;
 717
 718             return scm_cons
 719               (sym_case_lambda_star,
 720                scm_cons (scm_list_2 (scm_list_5 (CAR (spec),
 721                                                  CADR (spec),
 722                                                  CADDR (spec),
 723                                                  CADDDR (spec),
 724                                                  CADR (CDDDR (spec))),
 725                                      unmemoize (body)),
 726                          tail));
 727           }
 728       }
 729     case SCM_M_CAPTURE_ENV:
 730       return scm_list_3 (scm_from_latin1_symbol ("capture-env"),
 731                          CAR (args),
 732                          unmemoize (CDR (args)));
 733     case SCM_M_LET:
 734       return scm_list_3 (scm_sym_let,
 735                          unmemoize_bindings (CAR (args)),
 736                          unmemoize (CDR (args)));
 737     case SCM_M_QUOTE:
 738       return scm_list_2 (scm_sym_quote, args);
 739     case SCM_M_LEXICAL_REF:
 740       return unmemoize_lexical (args);
 741     case SCM_M_LEXICAL_SET:
 742       return scm_list_3 (scm_sym_set_x, unmemoize_lexical (CAR (args)),
 743                          unmemoize (CDR (args)));
 744     case SCM_M_BOX_REF:
 745       return scm_list_2 (scm_from_latin1_symbol ("variable-ref"),
 746                          unmemoize (args));
 747     case SCM_M_BOX_SET:
 748       return scm_list_3 (scm_from_latin1_symbol ("variable-set!"),
 749                          unmemoize (CAR (args)),
 750                          unmemoize (CDR (args)));
 751     case SCM_M_RESOLVE:
 752       if (SCM_VARIABLEP (args))
 753         return args;
 754       else if (scm_is_symbol (CDR (args)))
 755         return CDR (args);
 756       else
 757         return scm_list_3
 758           (scm_is_true (CDDDR (args)) ? scm_sym_at : scm_sym_atat,
 759            scm_i_finite_list_copy (CADR (args)),
 760            CADDR (args));
 761     case SCM_M_CALL_WITH_PROMPT:
 762       return scm_list_4 (scm_from_latin1_symbol ("call-with-prompt"),
 763                          unmemoize (CAR (args)),
 764                          unmemoize (CADR (args)),
 765                          unmemoize (CDDR (args)));
 766     default:
 767       abort ();
 768     }
 769 }
 770
 771
 772 \f
 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   return unmemoize (m);
 780 }
 781 #undef FUNC_NAME
 782
 783 SCM_DEFINE (scm_memoized_typecode, "memoized-typecode", 1, 0, 0,
 784             (SCM sym),
 785             "Return the memoized typecode corresponding to the symbol @var{sym}.")
 786 #define FUNC_NAME s_scm_memoized_typecode
 787 {
 788   int i;
 789
 790   SCM_VALIDATE_SYMBOL (1, sym);
 791
 792   for (i = 0; i < sizeof(memoized_tags)/sizeof(const char*); i++)
 793     if (strcmp (scm_i_symbol_chars (sym), memoized_tags[i]) == 0)
 794       return scm_from_int32 (i);
 795
 796   return SCM_BOOL_F;
 797 }
 798 #undef FUNC_NAME
 799
 800 SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
 801 static void error_unbound_variable (SCM symbol) SCM_NORETURN;
 802 static void error_unbound_variable (SCM symbol)
 803 {
 804   scm_error (scm_unbound_variable_key, NULL, "Unbound variable: ~S",
 805              scm_list_1 (symbol), SCM_BOOL_F);
 806 }
 807
 808 SCM_DEFINE (scm_sys_resolve_variable, "%resolve-variable", 2, 0, 0,
 809             (SCM loc, SCM mod),
 810             "Look up and return the variable for @var{loc}.")
 811 #define FUNC_NAME s_scm_sys_resolve_variable
 812 {
 813   int mode;
 814
 815   if (scm_is_false (mod))
 816     mod = scm_the_root_module ();
 817
 818   mode = scm_to_int (scm_car (loc));
 819   loc = scm_cdr (loc);
 820
 821   switch (mode)
 822     {
 823     case SCM_EXPANDED_TOPLEVEL_REF:
 824     case SCM_EXPANDED_TOPLEVEL_SET:
 825       {
 826         SCM var = scm_module_variable (mod, loc);
 827         if (scm_is_false (var)
 828             || (mode == SCM_EXPANDED_TOPLEVEL_REF
 829                 && scm_is_false (scm_variable_bound_p (var))))
 830           error_unbound_variable (loc);
 831         return var;
 832       }
 833
 834     case SCM_EXPANDED_TOPLEVEL_DEFINE:
 835       {
 836         return scm_module_ensure_local_variable (mod, loc);
 837       }
 838
 839     case SCM_EXPANDED_MODULE_REF:
 840     case SCM_EXPANDED_MODULE_SET:
 841       {
 842         SCM var;
 843         mod = scm_resolve_module (scm_car (loc));
 844         if (scm_is_true (scm_cddr (loc)))
 845           mod = scm_module_public_interface (mod);
 846         var = scm_module_lookup (mod, scm_cadr (loc));
 847         if (mode == SCM_EXPANDED_MODULE_SET
 848             && scm_is_false (scm_variable_bound_p (var)))
 849           error_unbound_variable (scm_cadr (loc));
 850         return var;
 851       }
 852
 853     default:
 854       scm_wrong_type_arg (FUNC_NAME, 1, loc);
 855       return SCM_BOOL_F;
 856     }
 857 }
 858 #undef FUNC_NAME
 859
 860
 861 \f
 862
 863 void
 864 scm_init_memoize ()
 865 {
 866 #include "libguile/memoize.x"
 867
 868   wind = scm_c_make_gsubr ("wind", 2, 0, 0, do_wind);
 869   unwind = scm_c_make_gsubr ("unwind", 0, 0, 0, do_unwind);
 870   push_fluid = scm_c_make_gsubr ("push-fluid", 2, 0, 0, do_push_fluid);
 871   pop_fluid = scm_c_make_gsubr ("pop-fluid", 0, 0, 0, do_pop_fluid);
 872
 873   list_of_guile = scm_list_1 (scm_from_latin1_symbol ("guile"));
 874 }
 875
 876 /*
 877   Local Variables:
 878   c-file-style: "gnu"
 879   End:
 880 */