memoize.c 27 KB

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