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_cell (scm_tc16_memoized | ((n) << 16), SCM_UNPACK (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, docstring)                  \
 126   MAKMEMO (SCM_M_LAMBDA,                                        \
 127            scm_cons (body, scm_cons (docstring, 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_APPLY(proc, args)\
 135   MAKMEMO (SCM_M_APPLY, scm_list_2 (proc, args))
 136 #define MAKMEMO_CONT(proc) \
 137   MAKMEMO (SCM_M_CONT, proc)
 138 #define MAKMEMO_CALL_WITH_VALUES(prod, cons) \
 139   MAKMEMO (SCM_M_CALL_WITH_VALUES, scm_cons (prod, cons))
 140 #define MAKMEMO_CALL(proc, nargs, args) \
 141   MAKMEMO (SCM_M_CALL, scm_cons (proc, scm_cons (SCM_I_MAKINUM (nargs), args)))
 142 #define MAKMEMO_LEX_REF(pos) \
 143   MAKMEMO (SCM_M_LEXICAL_REF, pos)
 144 #define MAKMEMO_LEX_SET(pos, val)                                      \
 145   MAKMEMO (SCM_M_LEXICAL_SET, scm_cons (pos, val))
 146 #define MAKMEMO_TOP_REF(var) \
 147   MAKMEMO (SCM_M_TOPLEVEL_REF, var)
 148 #define MAKMEMO_TOP_SET(var, val) \
 149   MAKMEMO (SCM_M_TOPLEVEL_SET, scm_cons (var, val))
 150 #define MAKMEMO_MOD_REF(mod, var, public) \
 151   MAKMEMO (SCM_M_MODULE_REF, scm_cons (mod, scm_cons (var, public)))
 152 #define MAKMEMO_MOD_SET(val, mod, var, public) \
 153   MAKMEMO (SCM_M_MODULE_SET, scm_cons (val, scm_cons (mod, scm_cons (var, public))))
 154 #define MAKMEMO_CALL_WITH_PROMPT(tag, thunk, handler) \
 155   MAKMEMO (SCM_M_CALL_WITH_PROMPT, scm_cons (tag, scm_cons (thunk, handler)))
 156
 157
 158 \f
 159
 160 /* This table must agree with the list of M_ constants in memoize.h */
 161 static const char *const memoized_tags[] =
 162 {
 163   "seq",
 164   "if",
 165   "lambda",
 166   "let",
 167   "quote",
 168   "define",
 169   "apply",
 170   "call/cc",
 171   "call-with-values",
 172   "call",
 173   "lexical-ref",
 174   "lexical-set!",
 175   "toplevel-ref",
 176   "toplevel-set!",
 177   "module-ref",
 178   "module-set!",
 179   "call-with-prompt",
 180 };
 181
 182 static int
 183 scm_print_memoized (SCM memoized, SCM port, scm_print_state *pstate)
 184 {
 185   scm_puts_unlocked ("#<memoized ", port);
 186   scm_write (scm_unmemoize_expression (memoized), port);
 187   scm_puts_unlocked (">", port);
 188   return 1;
 189 }
 190
 191
 192 \f
 193
 194
 195 static int
 196 try_lookup_rib (SCM x, SCM rib)
 197 {
 198   int idx = 0;
 199   for (; idx < VECTOR_LENGTH (rib); idx++)
 200     if (scm_is_eq (x, VECTOR_REF (rib, idx)))
 201       return idx; /* bound */
 202   return -1;
 203 }
 204
 205 static int
 206 lookup_rib (SCM x, SCM rib)
 207 {
 208   int idx = try_lookup_rib (x, rib);
 209   if (idx < 0)
 210     abort ();
 211   return idx;
 212 }
 213
 214 static SCM
 215 make_pos (int depth, int width)
 216 {
 217   return scm_cons (SCM_I_MAKINUM (depth), SCM_I_MAKINUM (width));
 218 }
 219
 220 static SCM
 221 lookup (SCM x, SCM env)
 222 {
 223   int d = 0;
 224   for (; scm_is_pair (env); env = CDR (env), d++)
 225     {
 226       int w = try_lookup_rib (x, CAR (env));
 227       if (w < 0)
 228         continue;
 229       return make_pos (d, w);
 230     }
 231   abort ();
 232 }
 233
 234 /* Abbreviate SCM_EXPANDED_REF. Copied because I'm not sure about symbol pasting */
 235 #define REF(x,type,field) \
 236   (scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field)))
 237
 238 static SCM list_of_guile = SCM_BOOL_F;
 239
 240 static SCM memoize (SCM exp, SCM env);
 241
 242 static SCM
 243 memoize_exps (SCM exps, SCM env)
 244 {
 245   SCM ret;
 246   for (ret = SCM_EOL; scm_is_pair (exps); exps = CDR (exps))
 247     ret = scm_cons (memoize (CAR (exps), env), ret);
 248   return scm_reverse_x (ret, SCM_UNDEFINED);
 249 }
 250
 251 static SCM
 252 memoize (SCM exp, SCM env)
 253 {
 254   if (!SCM_EXPANDED_P (exp))
 255     abort ();
 256
 257   switch (SCM_EXPANDED_TYPE (exp))
 258     {
 259     case SCM_EXPANDED_VOID:
 260       return MAKMEMO_QUOTE (SCM_UNSPECIFIED);
 261
 262     case SCM_EXPANDED_CONST:
 263       return MAKMEMO_QUOTE (REF (exp, CONST, EXP));
 264
 265     case SCM_EXPANDED_PRIMITIVE_REF:
 266       if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
 267         return MAKMEMO_TOP_REF (REF (exp, PRIMITIVE_REF, NAME));
 268       else
 269         return MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMITIVE_REF, NAME),
 270                                 SCM_BOOL_F);
 271
 272     case SCM_EXPANDED_LEXICAL_REF:
 273       return MAKMEMO_LEX_REF (lookup (REF (exp, LEXICAL_REF, GENSYM), env));
 274
 275     case SCM_EXPANDED_LEXICAL_SET:
 276       return MAKMEMO_LEX_SET (lookup (REF (exp, LEXICAL_SET, GENSYM), env),
 277                               memoize (REF (exp, LEXICAL_SET, EXP), env));
 278
 279     case SCM_EXPANDED_MODULE_REF:
 280       return MAKMEMO_MOD_REF (REF (exp, MODULE_REF, MOD),
 281                               REF (exp, MODULE_REF, NAME),
 282                               REF (exp, MODULE_REF, PUBLIC));
 283
 284     case SCM_EXPANDED_MODULE_SET:
 285       return MAKMEMO_MOD_SET (memoize (REF (exp, MODULE_SET, EXP), env),
 286                               REF (exp, MODULE_SET, MOD),
 287                               REF (exp, MODULE_SET, NAME),
 288                               REF (exp, MODULE_SET, PUBLIC));
 289
 290     case SCM_EXPANDED_TOPLEVEL_REF:
 291       return MAKMEMO_TOP_REF (REF (exp, TOPLEVEL_REF, NAME));
 292
 293     case SCM_EXPANDED_TOPLEVEL_SET:
 294       return MAKMEMO_TOP_SET (REF (exp, TOPLEVEL_SET, NAME),
 295                               memoize (REF (exp, TOPLEVEL_SET, EXP), env));
 296
 297     case SCM_EXPANDED_TOPLEVEL_DEFINE:
 298       return MAKMEMO_DEFINE (REF (exp, TOPLEVEL_DEFINE, NAME),
 299                              memoize (REF (exp, TOPLEVEL_DEFINE, EXP), env));
 300
 301     case SCM_EXPANDED_CONDITIONAL:
 302       return MAKMEMO_IF (memoize (REF (exp, CONDITIONAL, TEST), env),
 303                          memoize (REF (exp, CONDITIONAL, CONSEQUENT), env),
 304                          memoize (REF (exp, CONDITIONAL, ALTERNATE), env));
 305
 306     case SCM_EXPANDED_CALL:
 307       {
 308         SCM proc, args;
 309
 310         proc = REF (exp, CALL, PROC);
 311         args = memoize_exps (REF (exp, CALL, ARGS), env);
 312
 313         return MAKMEMO_CALL (memoize (proc, env), scm_ilength (args), args);
 314       }
 315
 316     case SCM_EXPANDED_PRIMCALL:
 317       {
 318         SCM name, args;
 319         int nargs;
 320
 321         name = REF (exp, PRIMCALL, NAME);
 322         args = memoize_exps (REF (exp, PRIMCALL, ARGS), env);
 323         nargs = scm_ilength (args);
 324
 325         if (nargs == 3
 326             && scm_is_eq (name, scm_from_latin1_symbol ("call-with-prompt")))
 327           return MAKMEMO_CALL_WITH_PROMPT (CAR (args),
 328                                            CADR (args),
 329                                            CADDR (args));
 330         else if (nargs == 2
 331                  && scm_is_eq (name, scm_from_latin1_symbol ("apply")))
 332           return MAKMEMO_APPLY (CAR (args), CADR (args));
 333         else if (nargs == 1
 334                  && scm_is_eq (name,
 335                                scm_from_latin1_symbol
 336                                ("call-with-current-continuation")))
 337           return MAKMEMO_CONT (CAR (args));
 338         else if (nargs == 2
 339                  && scm_is_eq (name,
 340                                scm_from_latin1_symbol ("call-with-values")))
 341           return MAKMEMO_CALL_WITH_VALUES (CAR (args), CADR (args));
 342         else if (nargs == 2
 343                  && scm_is_eq (name, scm_from_latin1_symbol ("wind")))
 344           return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), 2, args);
 345         else if (nargs == 0
 346                  && scm_is_eq (name, scm_from_latin1_symbol ("unwind")))
 347           return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), 0, SCM_EOL);
 348         else if (nargs == 2
 349                  && scm_is_eq (name, scm_from_latin1_symbol ("push-fluid")))
 350           return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), 2, args);
 351         else if (nargs == 0
 352                  && scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid")))
 353           return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), 0, SCM_EOL);
 354         else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
 355           return MAKMEMO_CALL (MAKMEMO_TOP_REF (name), nargs, args);
 356         else
 357           return MAKMEMO_CALL (MAKMEMO_MOD_REF (list_of_guile, name,
 358                                                 SCM_BOOL_F),
 359                                nargs,
 360                                args);
 361       }
 362
 363     case SCM_EXPANDED_SEQ:
 364       return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env),
 365                           memoize (REF (exp, SEQ, TAIL), env));
 366
 367     case SCM_EXPANDED_LAMBDA:
 368       /* The body will be a lambda-case or #f. */
 369       {
 370         SCM meta, docstring, body, proc;
 371
 372         meta = REF (exp, LAMBDA, META);
 373         docstring = scm_assoc_ref (meta, scm_sym_documentation);
 374
 375         body = REF (exp, LAMBDA, BODY);
 376         if (scm_is_false (body))
 377           /* Give a body to case-lambda with no clauses.  */
 378           proc = MAKMEMO_LAMBDA
 379             (MAKMEMO_CALL
 380              (MAKMEMO_MOD_REF (list_of_guile,
 381                                scm_from_latin1_symbol ("throw"),
 382                                SCM_BOOL_F),
 383               5,
 384               scm_list_5 (MAKMEMO_QUOTE (scm_args_number_key),
 385                           MAKMEMO_QUOTE (SCM_BOOL_F),
 386                           MAKMEMO_QUOTE (scm_from_latin1_string
 387                                          ("Wrong number of arguments")),
 388                           MAKMEMO_QUOTE (SCM_EOL),
 389                           MAKMEMO_QUOTE (SCM_BOOL_F))),
 390              FIXED_ARITY (0),
 391              SCM_BOOL_F /* docstring */);
 392         else
 393           proc = memoize (body, env);
 394
 395         if (scm_is_string (docstring))
 396           {
 397             SCM args = SCM_MEMOIZED_ARGS (proc);
 398             SCM_SETCAR (SCM_CDR (args), docstring);
 399           }
 400
 401         return proc;
 402       }
 403
 404     case SCM_EXPANDED_LAMBDA_CASE:
 405       {
 406         SCM req, rest, opt, kw, inits, vars, body, alt;
 407         SCM walk, minits, arity, rib, new_env;
 408         int nreq, nopt;
 409
 410         req = REF (exp, LAMBDA_CASE, REQ);
 411         rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST)));
 412         opt = REF (exp, LAMBDA_CASE, OPT);
 413         kw = REF (exp, LAMBDA_CASE, KW);
 414         inits = REF (exp, LAMBDA_CASE, INITS);
 415         vars = REF (exp, LAMBDA_CASE, GENSYMS);
 416         body = REF (exp, LAMBDA_CASE, BODY);
 417         alt = REF (exp, LAMBDA_CASE, ALTERNATE);
 418
 419         nreq = scm_ilength (req);
 420         nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0;
 421
 422         /* The vars are the gensyms, according to the divine plan. But we need
 423            to memoize the inits within their appropriate environment,
 424            complicating things. */
 425         rib = scm_vector (vars);
 426         new_env = scm_cons (rib, env);
 427
 428         minits = SCM_EOL;
 429         for (walk = inits; scm_is_pair (walk); walk = CDR (walk))
 430           minits = scm_cons (memoize (CAR (walk), new_env), minits);
 431         minits = scm_reverse_x (minits, SCM_UNDEFINED);
 432
 433         if (scm_is_true (kw))
 434           {
 435             /* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */
 436             SCM aok = CAR (kw), indices = SCM_EOL;
 437             for (kw = CDR (kw); scm_is_pair (kw); kw = CDR (kw))
 438               {
 439                 SCM k;
 440                 int idx;
 441
 442                 k = CAR (CAR (kw));
 443                 idx = lookup_rib (CADDR (CAR (kw)), rib);
 444                 indices = scm_acons (k, SCM_I_MAKINUM (idx), indices);
 445               }
 446             kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED));
 447           }
 448
 449         if (scm_is_false (alt) && scm_is_false (kw) && scm_is_false (opt))
 450           {
 451             if (scm_is_false (rest))
 452               arity = FIXED_ARITY (nreq);
 453             else
 454               arity = REST_ARITY (nreq, SCM_BOOL_T);
 455           }
 456         else if (scm_is_true (alt))
 457           arity = FULL_ARITY (nreq, rest, nopt, kw, minits,
 458                               SCM_MEMOIZED_ARGS (memoize (alt, env)));
 459         else
 460           arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F);
 461
 462         return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
 463                                SCM_BOOL_F /* docstring */);
 464       }
 465
 466     case SCM_EXPANDED_LET:
 467       {
 468         SCM vars, exps, body, varsv, inits, new_env;
 469         int i;
 470
 471         vars = REF (exp, LET, GENSYMS);
 472         exps = REF (exp, LET, VALS);
 473         body = REF (exp, LET, BODY);
 474
 475         varsv = scm_vector (vars);
 476         inits = scm_c_make_vector (VECTOR_LENGTH (varsv),
 477                                    SCM_BOOL_F);
 478         new_env = scm_cons (varsv, env);
 479         for (i = 0; scm_is_pair (exps); exps = CDR (exps), i++)
 480           VECTOR_SET (inits, i, memoize (CAR (exps), env));
 481
 482         return MAKMEMO_LET (inits, memoize (body, new_env));
 483       }
 484
 485     case SCM_EXPANDED_LETREC:
 486       {
 487         SCM vars, varsv, exps, expsv, body, undefs, new_env;
 488         int i, nvars, in_order_p;
 489
 490         vars = REF (exp, LETREC, GENSYMS);
 491         exps = REF (exp, LETREC, VALS);
 492         body = REF (exp, LETREC, BODY);
 493         in_order_p = scm_is_true (REF (exp, LETREC, IN_ORDER_P));
 494
 495         varsv = scm_vector (vars);
 496         nvars = VECTOR_LENGTH (varsv);
 497         expsv = scm_vector (exps);
 498
 499         undefs = scm_c_make_vector (nvars, MAKMEMO_QUOTE (SCM_UNDEFINED));
 500         new_env = scm_cons (varsv, env);
 501
 502         if (in_order_p)
 503           {
 504             SCM body_exps = memoize (body, new_env);
 505             for (i = nvars - 1; i >= 0; i--)
 506               {
 507                 SCM init = memoize (VECTOR_REF (expsv, i), new_env);
 508                 body_exps = MAKMEMO_SEQ (MAKMEMO_LEX_SET (make_pos (0, i), init),
 509                                          body_exps);
 510               }
 511             return MAKMEMO_LET (undefs, body_exps);
 512           }
 513         else
 514           {
 515             SCM sets = SCM_BOOL_F, inits = scm_c_make_vector (nvars, SCM_BOOL_F);
 516             for (i = nvars - 1; i >= 0; i--)
 517               {
 518                 SCM init, set;
 519
 520                 init = memoize (VECTOR_REF (expsv, i), new_env);
 521                 VECTOR_SET (inits, i, init);
 522
 523                 set = MAKMEMO_LEX_SET (make_pos (1, i),
 524                                        MAKMEMO_LEX_REF (make_pos (0, i)));
 525                 if (scm_is_false (sets))
 526                   sets = set;
 527                 else
 528                   sets = MAKMEMO_SEQ (set, sets);
 529               }
 530
 531             if (scm_is_false (sets))
 532               return memoize (body, env);
 533
 534             return MAKMEMO_LET (undefs,
 535                                 MAKMEMO_SEQ (MAKMEMO_LET (inits, sets),
 536                                              memoize (body, new_env)));
 537           }
 538       }
 539
 540     default:
 541       abort ();
 542     }
 543 }
 544
 545
 546 \f
 547
 548 SCM_DEFINE (scm_memoize_expression, "memoize-expression", 1, 0, 0,
 549             (SCM exp),
 550             "Memoize the expression @var{exp}.")
 551 #define FUNC_NAME s_scm_memoize_expression
 552 {
 553   SCM_ASSERT_TYPE (SCM_EXPANDED_P (exp), exp, 1, FUNC_NAME, "expanded");
 554   return memoize (exp, scm_current_module ());
 555 }
 556 #undef FUNC_NAME
 557
 558
 559 \f
 560
 561 SCM_SYMBOL (sym_placeholder, "_");
 562
 563 static SCM unmemoize (SCM expr);
 564
 565 static SCM
 566 unmemoize_exprs (SCM exprs)
 567 {
 568   SCM ret, tail;
 569   if (scm_is_null (exprs))
 570     return SCM_EOL;
 571   ret = scm_list_1 (unmemoize (CAR (exprs)));
 572   tail = ret;
 573   for (exprs = CDR (exprs); !scm_is_null (exprs); exprs = CDR (exprs))
 574     {
 575       SCM_SETCDR (tail, scm_list_1 (unmemoize (CAR (exprs))));
 576       tail = CDR (tail);
 577     }
 578   return ret;
 579 }
 580
 581 static SCM
 582 unmemoize_bindings (SCM inits)
 583 {
 584   SCM ret = SCM_EOL;
 585   int n = scm_c_vector_length (inits);
 586
 587   while (n--)
 588     ret = scm_cons (unmemoize (scm_c_vector_ref (inits, n)), ret);
 589
 590   return ret;
 591 }
 592
 593 static SCM
 594 unmemoize_lexical (SCM n)
 595 {
 596   char buf[32];
 597   buf[31] = 0;
 598   snprintf (buf, 31, "<%u,%u>", scm_to_uint32 (CAR (n)),
 599             scm_to_uint32 (CDR (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 */