libguile/memoize.c

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