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