1 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
2 * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014
3 * Free Software Foundation, Inc.
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.
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.
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
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"
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)
57 #define VECTOR_REF(v, i) (SCM_SIMPLE_VECTOR_REF (v, i))
58 #define VECTOR_SET(v, i, x) (SCM_SIMPLE_VECTOR_SET (v, i, x))
59 #define VECTOR_LENGTH(v) (SCM_SIMPLE_VECTOR_LENGTH (v))
61 SCM_SYMBOL (sym_case_lambda_star
, "case-lambda*");
66 /* Primitives not exposed to general Scheme. */
69 static SCM push_fluid
;
73 do_wind (SCM in
, SCM out
)
75 scm_dynstack_push_dynwind (&SCM_I_CURRENT_THREAD
->dynstack
, in
, out
);
76 return SCM_UNSPECIFIED
;
82 scm_dynstack_pop (&SCM_I_CURRENT_THREAD
->dynstack
);
83 return SCM_UNSPECIFIED
;
87 do_push_fluid (SCM fluid
, SCM val
)
89 scm_i_thread
*thread
= SCM_I_CURRENT_THREAD
;
90 scm_dynstack_push_fluid (&thread
->dynstack
, fluid
, val
,
91 thread
->dynamic_state
);
92 return SCM_UNSPECIFIED
;
98 scm_i_thread
*thread
= SCM_I_CURRENT_THREAD
;
99 scm_dynstack_unwind_fluid (&thread
->dynstack
, thread
->dynamic_state
);
100 return SCM_UNSPECIFIED
;
106 /* {Evaluator memoized expressions}
109 scm_t_bits scm_tc16_memoized
;
111 #define MAKMEMO(n, args) \
112 (scm_cons (SCM_I_MAKINUM (n), args))
114 #define MAKMEMO_SEQ(head,tail) \
115 MAKMEMO (SCM_M_SEQ, scm_cons (head, tail))
116 #define MAKMEMO_IF(test, then, else_) \
117 MAKMEMO (SCM_M_IF, scm_cons (test, scm_cons (then, else_)))
118 #define FIXED_ARITY(nreq) \
119 scm_list_1 (SCM_I_MAKINUM (nreq))
120 #define REST_ARITY(nreq, rest) \
121 scm_list_2 (SCM_I_MAKINUM (nreq), rest)
122 #define FULL_ARITY(nreq, rest, nopt, kw, ninits, unbound, alt) \
123 scm_list_n (SCM_I_MAKINUM (nreq), rest, SCM_I_MAKINUM (nopt), kw, \
124 SCM_I_MAKINUM (ninits), unbound, alt, SCM_UNDEFINED)
125 #define MAKMEMO_LAMBDA(body, arity, meta) \
126 MAKMEMO (SCM_M_LAMBDA, \
127 scm_cons (body, scm_cons (meta, arity)))
128 #define MAKMEMO_CAPTURE_ENV(vars, body) \
129 MAKMEMO (SCM_M_CAPTURE_ENV, scm_cons (vars, body))
130 #define MAKMEMO_LET(inits, body) \
131 MAKMEMO (SCM_M_LET, scm_cons (inits, body))
132 #define MAKMEMO_QUOTE(exp) \
133 MAKMEMO (SCM_M_QUOTE, exp)
134 #define MAKMEMO_CAPTURE_MODULE(exp) \
135 MAKMEMO (SCM_M_CAPTURE_MODULE, exp)
136 #define MAKMEMO_APPLY(proc, args)\
137 MAKMEMO (SCM_M_APPLY, scm_list_2 (proc, args))
138 #define MAKMEMO_CONT(proc) \
139 MAKMEMO (SCM_M_CONT, proc)
140 #define MAKMEMO_CALL_WITH_VALUES(prod, cons) \
141 MAKMEMO (SCM_M_CALL_WITH_VALUES, scm_cons (prod, cons))
142 #define MAKMEMO_CALL(proc, nargs, args) \
143 MAKMEMO (SCM_M_CALL, scm_cons (proc, scm_cons (SCM_I_MAKINUM (nargs), args)))
144 #define MAKMEMO_LEX_REF(pos) \
145 MAKMEMO (SCM_M_LEXICAL_REF, pos)
146 #define MAKMEMO_LEX_SET(pos, val) \
147 MAKMEMO (SCM_M_LEXICAL_SET, scm_cons (pos, val))
148 #define MAKMEMO_BOX_REF(box) \
149 MAKMEMO (SCM_M_BOX_REF, box)
150 #define MAKMEMO_BOX_SET(box, val) \
151 MAKMEMO (SCM_M_BOX_SET, scm_cons (box, val))
152 #define MAKMEMO_TOP_BOX(mode, var) \
153 MAKMEMO (SCM_M_RESOLVE, scm_cons (SCM_I_MAKINUM (mode), var))
154 #define MAKMEMO_MOD_BOX(mode, mod, var, public) \
155 MAKMEMO (SCM_M_RESOLVE, \
156 scm_cons (SCM_I_MAKINUM (mode), \
157 scm_cons (mod, scm_cons (var, public))))
158 #define MAKMEMO_CALL_WITH_PROMPT(tag, thunk, handler) \
159 MAKMEMO (SCM_M_CALL_WITH_PROMPT, scm_cons (tag, scm_cons (thunk, handler)))
164 /* This table must agree with the list of M_ constants in memoize.h */
165 static const char *const memoized_tags
[] =
190 /* Memoization-time environments mirror the structure of eval-time
191 environments. Each link in the chain at memoization-time corresponds
192 to a link at eval-time.
194 env := module | (link, env)
196 link := flat-link . nested-link
197 flat-link := (#t . ((var . pos) ...))
198 nested-link := (#f . #(var ...))
200 A module of #f indicates that the current module has not yet been
201 captured. Memoizing a capture-module expression will capture the
204 Flat environments copy the values for a set of free variables into a
205 flat environment, via the capture-env expression. During memoization
206 a flat link collects the values of free variables, along with their
207 resolved outer locations. We are able to copy values because the
208 incoming expression has already been assignment-converted. Flat
209 environments prevent closures from hanging on to too much memory.
211 Nested environments have a rib of "let" bindings, and link to an
216 try_lookup_rib (SCM x
, SCM rib
)
219 for (; idx
< VECTOR_LENGTH (rib
); idx
++)
220 if (scm_is_eq (x
, VECTOR_REF (rib
, idx
)))
221 return idx
; /* bound */
226 lookup_rib (SCM x
, SCM rib
)
228 int idx
= try_lookup_rib (x
, rib
);
235 make_pos (int depth
, int width
)
237 return scm_cons (SCM_I_MAKINUM (depth
), SCM_I_MAKINUM (width
));
241 push_nested_link (SCM vars
, SCM env
)
243 return scm_acons (SCM_BOOL_F
, vars
, env
);
247 push_flat_link (SCM env
)
249 return scm_acons (SCM_BOOL_T
, SCM_EOL
, env
);
253 env_link_is_flat (SCM env_link
)
255 return scm_is_true (CAR (env_link
));
259 env_link_vars (SCM env_link
)
261 return CDR (env_link
);
265 env_link_add_flat_var (SCM env_link
, SCM var
, SCM pos
)
267 SCM vars
= env_link_vars (env_link
);
268 if (scm_is_false (scm_assq (var
, vars
)))
269 scm_set_cdr_x (env_link
, scm_acons (var
, pos
, vars
));
273 lookup (SCM x
, SCM env
)
276 for (; scm_is_pair (env
); env
= CDR (env
), d
++)
278 SCM link
= CAR (env
);
279 if (env_link_is_flat (link
))
284 for (vars
= env_link_vars (link
), w
= scm_ilength (vars
) - 1;
286 vars
= CDR (vars
), w
--)
287 if (scm_is_eq (x
, (CAAR (vars
))))
288 return make_pos (d
, w
);
290 env_link_add_flat_var (link
, x
, lookup (x
, CDR (env
)));
291 return make_pos (d
, scm_ilength (env_link_vars (link
)) - 1);
295 int w
= try_lookup_rib (x
, env_link_vars (link
));
298 return make_pos (d
, w
);
305 capture_flat_env (SCM lambda
, SCM env
)
308 SCM vars
, link
, locs
;
311 vars
= env_link_vars (link
);
312 nenv
= scm_ilength (vars
);
313 locs
= scm_c_make_vector (nenv
, SCM_BOOL_F
);
315 for (; scm_is_pair (vars
); vars
= CDR (vars
))
316 scm_c_vector_set_x (locs
, --nenv
, CDAR (vars
));
318 return MAKMEMO_CAPTURE_ENV (locs
, lambda
);
321 /* Abbreviate SCM_EXPANDED_REF. Copied because I'm not sure about symbol pasting */
322 #define REF(x,type,field) \
323 (scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field)))
325 static SCM list_of_guile
= SCM_BOOL_F
;
327 static SCM
memoize (SCM exp
, SCM env
);
330 memoize_exps (SCM exps
, SCM env
)
333 for (ret
= SCM_EOL
; scm_is_pair (exps
); exps
= CDR (exps
))
334 ret
= scm_cons (memoize (CAR (exps
), env
), ret
);
335 return scm_reverse_x (ret
, SCM_UNDEFINED
);
339 capture_env (SCM env
)
341 if (scm_is_false (env
))
347 maybe_makmemo_capture_module (SCM exp
, SCM env
)
349 if (scm_is_false (env
))
350 return MAKMEMO_CAPTURE_MODULE (exp
);
355 memoize (SCM exp
, SCM env
)
357 if (!SCM_EXPANDED_P (exp
))
360 switch (SCM_EXPANDED_TYPE (exp
))
362 case SCM_EXPANDED_VOID
:
363 return MAKMEMO_QUOTE (SCM_UNSPECIFIED
);
365 case SCM_EXPANDED_CONST
:
366 return MAKMEMO_QUOTE (REF (exp
, CONST
, EXP
));
368 case SCM_EXPANDED_PRIMITIVE_REF
:
369 if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
370 return maybe_makmemo_capture_module
371 (MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF
,
372 REF (exp
, PRIMITIVE_REF
, NAME
))),
375 return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF
,
377 REF (exp
, PRIMITIVE_REF
, NAME
),
380 case SCM_EXPANDED_LEXICAL_REF
:
381 return MAKMEMO_LEX_REF (lookup (REF (exp
, LEXICAL_REF
, GENSYM
), env
));
383 case SCM_EXPANDED_LEXICAL_SET
:
384 return MAKMEMO_LEX_SET (lookup (REF (exp
, LEXICAL_SET
, GENSYM
), env
),
385 memoize (REF (exp
, LEXICAL_SET
, EXP
), env
));
387 case SCM_EXPANDED_MODULE_REF
:
388 return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX
389 (SCM_EXPANDED_MODULE_REF
,
390 REF (exp
, MODULE_REF
, MOD
),
391 REF (exp
, MODULE_REF
, NAME
),
392 REF (exp
, MODULE_REF
, PUBLIC
)));
394 case SCM_EXPANDED_MODULE_SET
:
395 return MAKMEMO_BOX_SET (MAKMEMO_MOD_BOX
396 (SCM_EXPANDED_MODULE_SET
,
397 REF (exp
, MODULE_SET
, MOD
),
398 REF (exp
, MODULE_SET
, NAME
),
399 REF (exp
, MODULE_SET
, PUBLIC
)),
400 memoize (REF (exp
, MODULE_SET
, EXP
), env
));
402 case SCM_EXPANDED_TOPLEVEL_REF
:
403 return maybe_makmemo_capture_module
404 (MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF
,
405 REF (exp
, TOPLEVEL_REF
, NAME
))),
408 case SCM_EXPANDED_TOPLEVEL_SET
:
409 return maybe_makmemo_capture_module
410 (MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_SET
,
411 REF (exp
, TOPLEVEL_SET
, NAME
)),
412 memoize (REF (exp
, TOPLEVEL_SET
, EXP
),
416 case SCM_EXPANDED_TOPLEVEL_DEFINE
:
417 return maybe_makmemo_capture_module
418 (MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_DEFINE
,
419 REF (exp
, TOPLEVEL_DEFINE
, NAME
)),
420 memoize (REF (exp
, TOPLEVEL_DEFINE
, EXP
),
424 case SCM_EXPANDED_CONDITIONAL
:
425 return MAKMEMO_IF (memoize (REF (exp
, CONDITIONAL
, TEST
), env
),
426 memoize (REF (exp
, CONDITIONAL
, CONSEQUENT
), env
),
427 memoize (REF (exp
, CONDITIONAL
, ALTERNATE
), env
));
429 case SCM_EXPANDED_CALL
:
433 proc
= REF (exp
, CALL
, PROC
);
434 args
= memoize_exps (REF (exp
, CALL
, ARGS
), env
);
436 return MAKMEMO_CALL (memoize (proc
, env
), scm_ilength (args
), args
);
439 case SCM_EXPANDED_PRIMCALL
:
444 name
= REF (exp
, PRIMCALL
, NAME
);
445 args
= memoize_exps (REF (exp
, PRIMCALL
, ARGS
), env
);
446 nargs
= scm_ilength (args
);
449 && scm_is_eq (name
, scm_from_latin1_symbol ("call-with-prompt")))
450 return MAKMEMO_CALL_WITH_PROMPT (CAR (args
),
454 && scm_is_eq (name
, scm_from_latin1_symbol ("apply")))
455 return MAKMEMO_APPLY (CAR (args
), CADR (args
));
458 scm_from_latin1_symbol
459 ("call-with-current-continuation")))
460 return MAKMEMO_CONT (CAR (args
));
463 scm_from_latin1_symbol ("call-with-values")))
464 return MAKMEMO_CALL_WITH_VALUES (CAR (args
), CADR (args
));
467 scm_from_latin1_symbol ("variable-ref")))
468 return MAKMEMO_BOX_REF (CAR (args
));
471 scm_from_latin1_symbol ("variable-set!")))
472 return MAKMEMO_BOX_SET (CAR (args
), CADR (args
));
474 && scm_is_eq (name
, scm_from_latin1_symbol ("wind")))
475 return MAKMEMO_CALL (MAKMEMO_QUOTE (wind
), 2, args
);
477 && scm_is_eq (name
, scm_from_latin1_symbol ("unwind")))
478 return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind
), 0, SCM_EOL
);
480 && scm_is_eq (name
, scm_from_latin1_symbol ("push-fluid")))
481 return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid
), 2, args
);
483 && scm_is_eq (name
, scm_from_latin1_symbol ("pop-fluid")))
484 return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid
), 0, SCM_EOL
);
485 else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
486 return MAKMEMO_CALL (maybe_makmemo_capture_module
488 (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF
,
493 return MAKMEMO_CALL (MAKMEMO_BOX_REF
494 (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF
,
502 case SCM_EXPANDED_SEQ
:
503 return MAKMEMO_SEQ (memoize (REF (exp
, SEQ
, HEAD
), env
),
504 memoize (REF (exp
, SEQ
, TAIL
), env
));
506 case SCM_EXPANDED_LAMBDA
:
507 /* The body will be a lambda-case. */
509 SCM meta
, body
, proc
, new_env
;
511 meta
= REF (exp
, LAMBDA
, META
);
512 body
= REF (exp
, LAMBDA
, BODY
);
513 new_env
= push_flat_link (capture_env (env
));
514 proc
= memoize (body
, new_env
);
515 SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc
)), meta
);
517 return maybe_makmemo_capture_module (capture_flat_env (proc
, new_env
),
521 case SCM_EXPANDED_LAMBDA_CASE
:
523 SCM req
, rest
, opt
, kw
, inits
, vars
, body
, alt
;
524 SCM unbound
, arity
, rib
, new_env
;
525 int nreq
, nopt
, ninits
;
527 req
= REF (exp
, LAMBDA_CASE
, REQ
);
528 rest
= scm_not (scm_not (REF (exp
, LAMBDA_CASE
, REST
)));
529 opt
= REF (exp
, LAMBDA_CASE
, OPT
);
530 kw
= REF (exp
, LAMBDA_CASE
, KW
);
531 inits
= REF (exp
, LAMBDA_CASE
, INITS
);
532 vars
= REF (exp
, LAMBDA_CASE
, GENSYMS
);
533 body
= REF (exp
, LAMBDA_CASE
, BODY
);
534 alt
= REF (exp
, LAMBDA_CASE
, ALTERNATE
);
536 nreq
= scm_ilength (req
);
537 nopt
= scm_is_pair (opt
) ? scm_ilength (opt
) : 0;
538 ninits
= scm_ilength (inits
);
539 /* This relies on assignment conversion turning inits into a
540 sequence of CONST expressions whose values are a unique
542 unbound
= ninits
? REF (CAR (inits
), CONST
, EXP
) : SCM_BOOL_F
;
543 rib
= scm_vector (vars
);
544 new_env
= push_nested_link (rib
, env
);
546 if (scm_is_true (kw
))
548 /* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */
549 SCM aok
= CAR (kw
), indices
= SCM_EOL
;
550 for (kw
= CDR (kw
); scm_is_pair (kw
); kw
= CDR (kw
))
556 idx
= lookup_rib (CADDR (CAR (kw
)), rib
);
557 indices
= scm_acons (k
, SCM_I_MAKINUM (idx
), indices
);
559 kw
= scm_cons (aok
, scm_reverse_x (indices
, SCM_UNDEFINED
));
562 if (scm_is_false (alt
) && scm_is_false (kw
) && scm_is_false (opt
))
564 if (scm_is_false (rest
))
565 arity
= FIXED_ARITY (nreq
);
567 arity
= REST_ARITY (nreq
, SCM_BOOL_T
);
569 else if (scm_is_true (alt
))
570 arity
= FULL_ARITY (nreq
, rest
, nopt
, kw
, ninits
, unbound
,
571 SCM_MEMOIZED_ARGS (memoize (alt
, env
)));
573 arity
= FULL_ARITY (nreq
, rest
, nopt
, kw
, ninits
, unbound
,
576 return MAKMEMO_LAMBDA (memoize (body
, new_env
), arity
,
577 SCM_EOL
/* meta, filled in later */);
580 case SCM_EXPANDED_LET
:
582 SCM vars
, exps
, body
, varsv
, inits
, new_env
;
585 vars
= REF (exp
, LET
, GENSYMS
);
586 exps
= REF (exp
, LET
, VALS
);
587 body
= REF (exp
, LET
, BODY
);
589 varsv
= scm_vector (vars
);
590 inits
= scm_c_make_vector (VECTOR_LENGTH (varsv
),
592 new_env
= push_nested_link (varsv
, capture_env (env
));
593 for (i
= 0; scm_is_pair (exps
); exps
= CDR (exps
), i
++)
594 VECTOR_SET (inits
, i
, memoize (CAR (exps
), env
));
596 return maybe_makmemo_capture_module
597 (MAKMEMO_LET (inits
, memoize (body
, new_env
)), env
);
608 SCM_DEFINE (scm_memoize_expression
, "memoize-expression", 1, 0, 0,
610 "Memoize the expression @var{exp}.")
611 #define FUNC_NAME s_scm_memoize_expression
613 SCM_ASSERT_TYPE (SCM_EXPANDED_P (exp
), exp
, 1, FUNC_NAME
, "expanded");
614 return memoize (scm_convert_assignment (exp
), SCM_BOOL_F
);
621 SCM_SYMBOL (sym_placeholder
, "_");
623 static SCM
unmemoize (SCM expr
);
626 unmemoize_exprs (SCM exprs
)
629 if (scm_is_null (exprs
))
631 ret
= scm_list_1 (unmemoize (CAR (exprs
)));
633 for (exprs
= CDR (exprs
); !scm_is_null (exprs
); exprs
= CDR (exprs
))
635 SCM_SETCDR (tail
, scm_list_1 (unmemoize (CAR (exprs
))));
642 unmemoize_bindings (SCM inits
)
645 int n
= scm_c_vector_length (inits
);
648 ret
= scm_cons (unmemoize (scm_c_vector_ref (inits
, n
)), ret
);
654 unmemoize_lexical (SCM n
)
658 snprintf (buf
, 31, "<%u,%u>", scm_to_uint32 (CAR (n
)),
659 scm_to_uint32 (CDR (n
)));
660 return scm_from_utf8_symbol (buf
);
664 unmemoize (const SCM expr
)
668 args
= SCM_MEMOIZED_ARGS (expr
);
669 switch (SCM_MEMOIZED_TAG (expr
))
672 return scm_cons (scm_from_latin1_symbol ("apply"),
673 unmemoize_exprs (args
));
675 return scm_list_3 (scm_sym_begin
, unmemoize (CAR (args
)),
676 unmemoize (CDR (args
)));
678 return scm_cons (unmemoize (CAR (args
)), unmemoize_exprs (CDDR (args
)));
680 return scm_list_2 (scm_from_latin1_symbol
681 ("call-with-current_continuation"),
683 case SCM_M_CALL_WITH_VALUES
:
684 return scm_list_3 (scm_from_latin1_symbol ("call-with-values"),
685 unmemoize (CAR (args
)), unmemoize (CDR (args
)));
686 case SCM_M_CAPTURE_MODULE
:
687 return scm_list_2 (scm_from_latin1_symbol ("capture-module"),
690 return scm_list_4 (scm_sym_if
, unmemoize (scm_car (args
)),
691 unmemoize (scm_cadr (args
)), unmemoize (scm_cddr (args
)));
694 SCM body
= CAR (args
), spec
= CDDR (args
);
696 if (scm_is_null (CDR (spec
)))
697 return scm_list_3 (scm_sym_lambda
,
698 scm_make_list (CAR (spec
), sym_placeholder
),
699 unmemoize (CAR (args
)));
700 else if (scm_is_null (SCM_CDDR (spec
)))
702 SCM formals
= scm_make_list (CAR (spec
), sym_placeholder
);
703 return scm_list_3 (scm_sym_lambda
,
704 scm_is_true (CADR (spec
))
705 ? scm_cons_star (sym_placeholder
, formals
)
707 unmemoize (CAR (args
)));
713 alt
= CADDDR (CDDDR (spec
));
714 if (scm_is_true (alt
))
715 tail
= CDR (unmemoize (alt
));
720 (sym_case_lambda_star
,
721 scm_cons (scm_list_2 (scm_list_5 (CAR (spec
),
725 CADR (CDDDR (spec
))),
730 case SCM_M_CAPTURE_ENV
:
731 return scm_list_3 (scm_from_latin1_symbol ("capture-env"),
733 unmemoize (CDR (args
)));
735 return scm_list_3 (scm_sym_let
,
736 unmemoize_bindings (CAR (args
)),
737 unmemoize (CDR (args
)));
739 return scm_list_2 (scm_sym_quote
, args
);
740 case SCM_M_LEXICAL_REF
:
741 return unmemoize_lexical (args
);
742 case SCM_M_LEXICAL_SET
:
743 return scm_list_3 (scm_sym_set_x
, unmemoize_lexical (CAR (args
)),
744 unmemoize (CDR (args
)));
746 return scm_list_2 (scm_from_latin1_symbol ("variable-ref"),
749 return scm_list_3 (scm_from_latin1_symbol ("variable-set!"),
750 unmemoize (CAR (args
)),
751 unmemoize (CDR (args
)));
753 if (SCM_VARIABLEP (args
))
755 else if (scm_is_symbol (CDR (args
)))
759 (scm_is_true (CDDDR (args
)) ? scm_sym_at
: scm_sym_atat
,
760 scm_i_finite_list_copy (CADR (args
)),
762 case SCM_M_CALL_WITH_PROMPT
:
763 return scm_list_4 (scm_from_latin1_symbol ("call-with-prompt"),
764 unmemoize (CAR (args
)),
765 unmemoize (CADR (args
)),
766 unmemoize (CDDR (args
)));
775 SCM_DEFINE (scm_unmemoize_expression
, "unmemoize-expression", 1, 0, 0,
777 "Unmemoize the memoized expression @var{m}.")
778 #define FUNC_NAME s_scm_unmemoize_expression
780 return unmemoize (m
);
784 SCM_DEFINE (scm_memoized_typecode
, "memoized-typecode", 1, 0, 0,
786 "Return the memoized typecode corresponding to the symbol @var{sym}.")
787 #define FUNC_NAME s_scm_memoized_typecode
791 SCM_VALIDATE_SYMBOL (1, sym
);
793 for (i
= 0; i
< sizeof(memoized_tags
)/sizeof(const char*); i
++)
794 if (strcmp (scm_i_symbol_chars (sym
), memoized_tags
[i
]) == 0)
795 return scm_from_int32 (i
);
801 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
802 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
803 static void error_unbound_variable (SCM symbol
)
805 scm_error (scm_unbound_variable_key
, NULL
, "Unbound variable: ~S",
806 scm_list_1 (symbol
), SCM_BOOL_F
);
809 SCM_DEFINE (scm_sys_resolve_variable
, "%resolve-variable", 2, 0, 0,
811 "Look up and return the variable for @var{loc}.")
812 #define FUNC_NAME s_scm_sys_resolve_variable
816 if (scm_is_false (mod
))
817 mod
= scm_the_root_module ();
819 mode
= scm_to_int (scm_car (loc
));
824 case SCM_EXPANDED_TOPLEVEL_REF
:
825 case SCM_EXPANDED_TOPLEVEL_SET
:
827 SCM var
= scm_module_variable (mod
, loc
);
828 if (scm_is_false (var
)
829 || (mode
== SCM_EXPANDED_TOPLEVEL_REF
830 && scm_is_false (scm_variable_bound_p (var
))))
831 error_unbound_variable (loc
);
835 case SCM_EXPANDED_TOPLEVEL_DEFINE
:
837 return scm_module_ensure_local_variable (mod
, loc
);
840 case SCM_EXPANDED_MODULE_REF
:
841 case SCM_EXPANDED_MODULE_SET
:
844 mod
= scm_resolve_module (scm_car (loc
));
845 if (scm_is_true (scm_cddr (loc
)))
846 mod
= scm_module_public_interface (mod
);
847 var
= scm_module_lookup (mod
, scm_cadr (loc
));
848 if (mode
== SCM_EXPANDED_MODULE_SET
849 && scm_is_false (scm_variable_bound_p (var
)))
850 error_unbound_variable (scm_cadr (loc
));
855 scm_wrong_type_arg (FUNC_NAME
, 1, loc
);
867 #include "libguile/memoize.x"
869 wind
= scm_c_make_gsubr ("wind", 2, 0, 0, do_wind
);
870 unwind
= scm_c_make_gsubr ("unwind", 0, 0, 0, do_unwind
);
871 push_fluid
= scm_c_make_gsubr ("push-fluid", 2, 0, 0, do_push_fluid
);
872 pop_fluid
= scm_c_make_gsubr ("pop-fluid", 0, 0, 0, do_pop_fluid
);
874 list_of_guile
= scm_list_1 (scm_from_latin1_symbol ("guile"));