libguile/memoize.c

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