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