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