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.
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, inits, alt) \
123 scm_list_n (SCM_I_MAKINUM (nreq), rest, SCM_I_MAKINUM (nopt), kw, inits, \
125 #define MAKMEMO_LAMBDA(body, arity, meta) \
126 MAKMEMO (SCM_M_LAMBDA, \
127 scm_cons (body, scm_cons (meta, arity)))
128 #define MAKMEMO_LET(inits, body) \
129 MAKMEMO (SCM_M_LET, scm_cons (inits, body))
130 #define MAKMEMO_QUOTE(exp) \
131 MAKMEMO (SCM_M_QUOTE, exp)
132 #define MAKMEMO_DEFINE(var, val) \
133 MAKMEMO (SCM_M_DEFINE, scm_cons (var, val))
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_TOP_REF(var) \
149 MAKMEMO (SCM_M_TOPLEVEL_REF, var)
150 #define MAKMEMO_TOP_SET(var, val) \
151 MAKMEMO (SCM_M_TOPLEVEL_SET, scm_cons (var, val))
152 #define MAKMEMO_MOD_REF(mod, var, public) \
153 MAKMEMO (SCM_M_MODULE_REF, scm_cons (mod, scm_cons (var, public)))
154 #define MAKMEMO_MOD_SET(val, mod, var, public) \
155 MAKMEMO (SCM_M_MODULE_SET, scm_cons (val, scm_cons (mod, scm_cons (var, public))))
156 #define MAKMEMO_CALL_WITH_PROMPT(tag, thunk, handler) \
157 MAKMEMO (SCM_M_CALL_WITH_PROMPT, scm_cons (tag, scm_cons (thunk, handler)))
162 /* This table must agree with the list of M_ constants in memoize.h */
163 static const char *const memoized_tags
[] =
190 try_lookup_rib (SCM x
, SCM rib
)
193 for (; idx
< VECTOR_LENGTH (rib
); idx
++)
194 if (scm_is_eq (x
, VECTOR_REF (rib
, idx
)))
195 return idx
; /* bound */
200 lookup_rib (SCM x
, SCM rib
)
202 int idx
= try_lookup_rib (x
, rib
);
209 make_pos (int depth
, int width
)
211 return scm_cons (SCM_I_MAKINUM (depth
), SCM_I_MAKINUM (width
));
215 lookup (SCM x
, SCM env
)
218 for (; scm_is_pair (env
); env
= CDR (env
), d
++)
220 int w
= try_lookup_rib (x
, CAR (env
));
223 return make_pos (d
, w
);
228 /* Abbreviate SCM_EXPANDED_REF. Copied because I'm not sure about symbol pasting */
229 #define REF(x,type,field) \
230 (scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field)))
232 static SCM list_of_guile
= SCM_BOOL_F
;
234 static SCM
memoize (SCM exp
, SCM env
);
237 memoize_exps (SCM exps
, SCM env
)
240 for (ret
= SCM_EOL
; scm_is_pair (exps
); exps
= CDR (exps
))
241 ret
= scm_cons (memoize (CAR (exps
), env
), ret
);
242 return scm_reverse_x (ret
, SCM_UNDEFINED
);
246 capture_env (SCM env
)
248 if (scm_is_false (env
))
254 maybe_makmemo_capture_module (SCM exp
, SCM env
)
256 if (scm_is_false (env
))
257 return MAKMEMO_CAPTURE_MODULE (exp
);
262 memoize (SCM exp
, SCM env
)
264 if (!SCM_EXPANDED_P (exp
))
267 switch (SCM_EXPANDED_TYPE (exp
))
269 case SCM_EXPANDED_VOID
:
270 return MAKMEMO_QUOTE (SCM_UNSPECIFIED
);
272 case SCM_EXPANDED_CONST
:
273 return MAKMEMO_QUOTE (REF (exp
, CONST
, EXP
));
275 case SCM_EXPANDED_PRIMITIVE_REF
:
276 if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
277 return maybe_makmemo_capture_module
278 (MAKMEMO_TOP_REF (REF (exp
, PRIMITIVE_REF
, NAME
)),
281 return MAKMEMO_MOD_REF (list_of_guile
, REF (exp
, PRIMITIVE_REF
, NAME
),
284 case SCM_EXPANDED_LEXICAL_REF
:
285 return MAKMEMO_LEX_REF (lookup (REF (exp
, LEXICAL_REF
, GENSYM
), env
));
287 case SCM_EXPANDED_LEXICAL_SET
:
288 return MAKMEMO_LEX_SET (lookup (REF (exp
, LEXICAL_SET
, GENSYM
), env
),
289 memoize (REF (exp
, LEXICAL_SET
, EXP
), env
));
291 case SCM_EXPANDED_MODULE_REF
:
292 return MAKMEMO_MOD_REF (REF (exp
, MODULE_REF
, MOD
),
293 REF (exp
, MODULE_REF
, NAME
),
294 REF (exp
, MODULE_REF
, PUBLIC
));
296 case SCM_EXPANDED_MODULE_SET
:
297 return MAKMEMO_MOD_SET (memoize (REF (exp
, MODULE_SET
, EXP
), env
),
298 REF (exp
, MODULE_SET
, MOD
),
299 REF (exp
, MODULE_SET
, NAME
),
300 REF (exp
, MODULE_SET
, PUBLIC
));
302 case SCM_EXPANDED_TOPLEVEL_REF
:
303 return maybe_makmemo_capture_module
304 (MAKMEMO_TOP_REF (REF (exp
, TOPLEVEL_REF
, NAME
)), env
);
306 case SCM_EXPANDED_TOPLEVEL_SET
:
307 return maybe_makmemo_capture_module
308 (MAKMEMO_TOP_SET (REF (exp
, TOPLEVEL_SET
, NAME
),
309 memoize (REF (exp
, TOPLEVEL_SET
, EXP
),
313 case SCM_EXPANDED_TOPLEVEL_DEFINE
:
314 return MAKMEMO_DEFINE (REF (exp
, TOPLEVEL_DEFINE
, NAME
),
315 memoize (REF (exp
, TOPLEVEL_DEFINE
, EXP
), env
));
317 case SCM_EXPANDED_CONDITIONAL
:
318 return MAKMEMO_IF (memoize (REF (exp
, CONDITIONAL
, TEST
), env
),
319 memoize (REF (exp
, CONDITIONAL
, CONSEQUENT
), env
),
320 memoize (REF (exp
, CONDITIONAL
, ALTERNATE
), env
));
322 case SCM_EXPANDED_CALL
:
326 proc
= REF (exp
, CALL
, PROC
);
327 args
= memoize_exps (REF (exp
, CALL
, ARGS
), env
);
329 return MAKMEMO_CALL (memoize (proc
, env
), scm_ilength (args
), args
);
332 case SCM_EXPANDED_PRIMCALL
:
337 name
= REF (exp
, PRIMCALL
, NAME
);
338 args
= memoize_exps (REF (exp
, PRIMCALL
, ARGS
), env
);
339 nargs
= scm_ilength (args
);
342 && scm_is_eq (name
, scm_from_latin1_symbol ("call-with-prompt")))
343 return MAKMEMO_CALL_WITH_PROMPT (CAR (args
),
347 && scm_is_eq (name
, scm_from_latin1_symbol ("apply")))
348 return MAKMEMO_APPLY (CAR (args
), CADR (args
));
351 scm_from_latin1_symbol
352 ("call-with-current-continuation")))
353 return MAKMEMO_CONT (CAR (args
));
356 scm_from_latin1_symbol ("call-with-values")))
357 return MAKMEMO_CALL_WITH_VALUES (CAR (args
), CADR (args
));
359 && scm_is_eq (name
, scm_from_latin1_symbol ("wind")))
360 return MAKMEMO_CALL (MAKMEMO_QUOTE (wind
), 2, args
);
362 && scm_is_eq (name
, scm_from_latin1_symbol ("unwind")))
363 return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind
), 0, SCM_EOL
);
365 && scm_is_eq (name
, scm_from_latin1_symbol ("push-fluid")))
366 return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid
), 2, args
);
368 && scm_is_eq (name
, scm_from_latin1_symbol ("pop-fluid")))
369 return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid
), 0, SCM_EOL
);
370 else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
371 return MAKMEMO_CALL (maybe_makmemo_capture_module
372 (MAKMEMO_TOP_REF (name
), env
),
375 return MAKMEMO_CALL (MAKMEMO_MOD_REF (list_of_guile
, name
,
381 case SCM_EXPANDED_SEQ
:
382 return MAKMEMO_SEQ (memoize (REF (exp
, SEQ
, HEAD
), env
),
383 memoize (REF (exp
, SEQ
, TAIL
), env
));
385 case SCM_EXPANDED_LAMBDA
:
386 /* The body will be a lambda-case or #f. */
388 SCM meta
, body
, proc
;
390 meta
= REF (exp
, LAMBDA
, META
);
392 body
= REF (exp
, LAMBDA
, BODY
);
393 if (scm_is_false (body
))
394 /* Give a body to case-lambda with no clauses. */
395 proc
= MAKMEMO_LAMBDA
397 (MAKMEMO_MOD_REF (list_of_guile
,
398 scm_from_latin1_symbol ("throw"),
401 scm_list_5 (MAKMEMO_QUOTE (scm_args_number_key
),
402 MAKMEMO_QUOTE (SCM_BOOL_F
),
403 MAKMEMO_QUOTE (scm_from_latin1_string
404 ("Wrong number of arguments")),
405 MAKMEMO_QUOTE (SCM_EOL
),
406 MAKMEMO_QUOTE (SCM_BOOL_F
))),
411 proc
= memoize (body
, capture_env (env
));
412 SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc
)), meta
);
415 return maybe_makmemo_capture_module (proc
, env
);
418 case SCM_EXPANDED_LAMBDA_CASE
:
420 SCM req
, rest
, opt
, kw
, inits
, vars
, body
, alt
;
421 SCM walk
, minits
, arity
, rib
, new_env
;
424 req
= REF (exp
, LAMBDA_CASE
, REQ
);
425 rest
= scm_not (scm_not (REF (exp
, LAMBDA_CASE
, REST
)));
426 opt
= REF (exp
, LAMBDA_CASE
, OPT
);
427 kw
= REF (exp
, LAMBDA_CASE
, KW
);
428 inits
= REF (exp
, LAMBDA_CASE
, INITS
);
429 vars
= REF (exp
, LAMBDA_CASE
, GENSYMS
);
430 body
= REF (exp
, LAMBDA_CASE
, BODY
);
431 alt
= REF (exp
, LAMBDA_CASE
, ALTERNATE
);
433 nreq
= scm_ilength (req
);
434 nopt
= scm_is_pair (opt
) ? scm_ilength (opt
) : 0;
436 /* The vars are the gensyms, according to the divine plan. But we need
437 to memoize the inits within their appropriate environment,
438 complicating things. */
439 rib
= scm_vector (vars
);
440 new_env
= scm_cons (rib
, env
);
443 for (walk
= inits
; scm_is_pair (walk
); walk
= CDR (walk
))
444 minits
= scm_cons (memoize (CAR (walk
), new_env
), minits
);
445 minits
= scm_reverse_x (minits
, SCM_UNDEFINED
);
447 if (scm_is_true (kw
))
449 /* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */
450 SCM aok
= CAR (kw
), indices
= SCM_EOL
;
451 for (kw
= CDR (kw
); scm_is_pair (kw
); kw
= CDR (kw
))
457 idx
= lookup_rib (CADDR (CAR (kw
)), rib
);
458 indices
= scm_acons (k
, SCM_I_MAKINUM (idx
), indices
);
460 kw
= scm_cons (aok
, scm_reverse_x (indices
, SCM_UNDEFINED
));
463 if (scm_is_false (alt
) && scm_is_false (kw
) && scm_is_false (opt
))
465 if (scm_is_false (rest
))
466 arity
= FIXED_ARITY (nreq
);
468 arity
= REST_ARITY (nreq
, SCM_BOOL_T
);
470 else if (scm_is_true (alt
))
471 arity
= FULL_ARITY (nreq
, rest
, nopt
, kw
, minits
,
472 SCM_MEMOIZED_ARGS (memoize (alt
, env
)));
474 arity
= FULL_ARITY (nreq
, rest
, nopt
, kw
, minits
, SCM_BOOL_F
);
476 return MAKMEMO_LAMBDA (memoize (body
, new_env
), arity
,
477 SCM_BOOL_F
/* meta, filled in later */);
480 case SCM_EXPANDED_LET
:
482 SCM vars
, exps
, body
, varsv
, inits
, new_env
;
485 vars
= REF (exp
, LET
, GENSYMS
);
486 exps
= REF (exp
, LET
, VALS
);
487 body
= REF (exp
, LET
, BODY
);
489 varsv
= scm_vector (vars
);
490 inits
= scm_c_make_vector (VECTOR_LENGTH (varsv
),
492 new_env
= scm_cons (varsv
, capture_env (env
));
493 for (i
= 0; scm_is_pair (exps
); exps
= CDR (exps
), i
++)
494 VECTOR_SET (inits
, i
, memoize (CAR (exps
), env
));
496 return maybe_makmemo_capture_module
497 (MAKMEMO_LET (inits
, memoize (body
, new_env
)), env
);
500 case SCM_EXPANDED_LETREC
:
502 SCM vars
, varsv
, exps
, expsv
, body
, undefs
, new_env
;
503 int i
, nvars
, in_order_p
;
505 vars
= REF (exp
, LETREC
, GENSYMS
);
506 exps
= REF (exp
, LETREC
, VALS
);
507 body
= REF (exp
, LETREC
, BODY
);
508 in_order_p
= scm_is_true (REF (exp
, LETREC
, IN_ORDER_P
));
510 varsv
= scm_vector (vars
);
511 nvars
= VECTOR_LENGTH (varsv
);
512 expsv
= scm_vector (exps
);
514 undefs
= scm_c_make_vector (nvars
, MAKMEMO_QUOTE (SCM_UNDEFINED
));
515 new_env
= scm_cons (varsv
, capture_env (env
));
519 SCM body_exps
= memoize (body
, new_env
);
520 for (i
= nvars
- 1; i
>= 0; i
--)
522 SCM init
= memoize (VECTOR_REF (expsv
, i
), new_env
);
523 body_exps
= MAKMEMO_SEQ (MAKMEMO_LEX_SET (make_pos (0, i
), init
),
526 return maybe_makmemo_capture_module
527 (MAKMEMO_LET (undefs
, body_exps
), env
);
531 SCM sets
= SCM_BOOL_F
, inits
= scm_c_make_vector (nvars
, SCM_BOOL_F
);
532 for (i
= nvars
- 1; i
>= 0; i
--)
536 init
= memoize (VECTOR_REF (expsv
, i
), new_env
);
537 VECTOR_SET (inits
, i
, init
);
539 set
= MAKMEMO_LEX_SET (make_pos (1, i
),
540 MAKMEMO_LEX_REF (make_pos (0, i
)));
541 if (scm_is_false (sets
))
544 sets
= MAKMEMO_SEQ (set
, sets
);
547 if (scm_is_false (sets
))
548 return memoize (body
, env
);
550 return maybe_makmemo_capture_module
551 (MAKMEMO_LET (undefs
,
552 MAKMEMO_SEQ (MAKMEMO_LET (inits
, sets
),
553 memoize (body
, new_env
))),
566 SCM_DEFINE (scm_memoize_expression
, "memoize-expression", 1, 0, 0,
568 "Memoize the expression @var{exp}.")
569 #define FUNC_NAME s_scm_memoize_expression
571 SCM_ASSERT_TYPE (SCM_EXPANDED_P (exp
), exp
, 1, FUNC_NAME
, "expanded");
572 return memoize (exp
, SCM_BOOL_F
);
579 SCM_SYMBOL (sym_placeholder
, "_");
581 static SCM
unmemoize (SCM expr
);
584 unmemoize_exprs (SCM exprs
)
587 if (scm_is_null (exprs
))
589 ret
= scm_list_1 (unmemoize (CAR (exprs
)));
591 for (exprs
= CDR (exprs
); !scm_is_null (exprs
); exprs
= CDR (exprs
))
593 SCM_SETCDR (tail
, scm_list_1 (unmemoize (CAR (exprs
))));
600 unmemoize_bindings (SCM inits
)
603 int n
= scm_c_vector_length (inits
);
606 ret
= scm_cons (unmemoize (scm_c_vector_ref (inits
, n
)), ret
);
612 unmemoize_lexical (SCM n
)
616 snprintf (buf
, 31, "<%u,%u>", scm_to_uint32 (CAR (n
)),
617 scm_to_uint32 (CDR (n
)));
618 return scm_from_utf8_symbol (buf
);
622 unmemoize (const SCM expr
)
626 args
= SCM_MEMOIZED_ARGS (expr
);
627 switch (SCM_MEMOIZED_TAG (expr
))
630 return scm_cons (scm_from_latin1_symbol ("apply"),
631 unmemoize_exprs (args
));
633 return scm_list_3 (scm_sym_begin
, unmemoize (CAR (args
)),
634 unmemoize (CDR (args
)));
636 return scm_cons (unmemoize (CAR (args
)), unmemoize_exprs (CDDR (args
)));
638 return scm_list_2 (scm_from_latin1_symbol
639 ("call-with-current_continuation"),
641 case SCM_M_CALL_WITH_VALUES
:
642 return scm_list_3 (scm_from_latin1_symbol ("call-with-values"),
643 unmemoize (CAR (args
)), unmemoize (CDR (args
)));
645 return scm_list_3 (scm_sym_define
, CAR (args
), unmemoize (CDR (args
)));
646 case SCM_M_CAPTURE_MODULE
:
647 return scm_list_2 (scm_from_latin1_symbol ("capture-module"),
650 return scm_list_4 (scm_sym_if
, unmemoize (scm_car (args
)),
651 unmemoize (scm_cadr (args
)), unmemoize (scm_cddr (args
)));
654 SCM body
= CAR (args
), spec
= CDDR (args
);
656 if (scm_is_null (CDR (spec
)))
657 return scm_list_3 (scm_sym_lambda
,
658 scm_make_list (CAR (spec
), sym_placeholder
),
659 unmemoize (CAR (args
)));
660 else if (scm_is_null (SCM_CDDR (spec
)))
662 SCM formals
= scm_make_list (CAR (spec
), sym_placeholder
);
663 return scm_list_3 (scm_sym_lambda
,
664 scm_is_true (CADR (spec
))
665 ? scm_cons_star (sym_placeholder
, formals
)
667 unmemoize (CAR (args
)));
673 alt
= CADDR (CDDDR (spec
));
674 if (scm_is_true (alt
))
675 tail
= CDR (unmemoize (alt
));
680 (sym_case_lambda_star
,
681 scm_cons (scm_list_2 (scm_list_5 (CAR (spec
),
685 unmemoize_exprs (CADR (CDDDR (spec
)))),
691 return scm_list_3 (scm_sym_let
,
692 unmemoize_bindings (CAR (args
)),
693 unmemoize (CDR (args
)));
695 return scm_list_2 (scm_sym_quote
, args
);
696 case SCM_M_LEXICAL_REF
:
697 return unmemoize_lexical (args
);
698 case SCM_M_LEXICAL_SET
:
699 return scm_list_3 (scm_sym_set_x
, unmemoize_lexical (CAR (args
)),
700 unmemoize (CDR (args
)));
701 case SCM_M_TOPLEVEL_REF
:
703 case SCM_M_TOPLEVEL_SET
:
704 return scm_list_3 (scm_sym_set_x
, CAR (args
), unmemoize (CDR (args
)));
705 case SCM_M_MODULE_REF
:
706 return SCM_VARIABLEP (args
) ? args
707 : scm_list_3 (scm_is_true (CDDR (args
)) ? scm_sym_at
: scm_sym_atat
,
708 scm_i_finite_list_copy (CAR (args
)),
710 case SCM_M_MODULE_SET
:
711 return scm_list_3 (scm_sym_set_x
,
712 SCM_VARIABLEP (CDR (args
)) ? CDR (args
)
713 : scm_list_3 (scm_is_true (CDDDR (args
))
714 ? scm_sym_at
: scm_sym_atat
,
715 scm_i_finite_list_copy (CADR (args
)),
717 unmemoize (CAR (args
)));
718 case SCM_M_CALL_WITH_PROMPT
:
719 return scm_list_4 (scm_from_latin1_symbol ("call-with-prompt"),
720 unmemoize (CAR (args
)),
721 unmemoize (CADR (args
)),
722 unmemoize (CDDR (args
)));
731 SCM_DEFINE (scm_unmemoize_expression
, "unmemoize-expression", 1, 0, 0,
733 "Unmemoize the memoized expression @var{m}.")
734 #define FUNC_NAME s_scm_unmemoize_expression
736 return unmemoize (m
);
740 SCM_DEFINE (scm_memoized_typecode
, "memoized-typecode", 1, 0, 0,
742 "Return the memoized typecode corresponding to the symbol @var{sym}.")
743 #define FUNC_NAME s_scm_memoized_typecode
747 SCM_VALIDATE_SYMBOL (1, sym
);
749 for (i
= 0; i
< sizeof(memoized_tags
)/sizeof(const char*); i
++)
750 if (strcmp (scm_i_symbol_chars (sym
), memoized_tags
[i
]) == 0)
751 return scm_from_int32 (i
);
757 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
758 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
759 static void error_unbound_variable (SCM symbol
)
761 scm_error (scm_unbound_variable_key
, NULL
, "Unbound variable: ~S",
762 scm_list_1 (symbol
), SCM_BOOL_F
);
765 SCM_DEFINE (scm_memoize_variable_access_x
, "memoize-variable-access!", 2, 0, 0,
767 "Look up and cache the variable that @var{m} will access, returning the variable.")
768 #define FUNC_NAME s_scm_memoize_variable_access_x
770 SCM mx
= SCM_MEMOIZED_ARGS (m
);
772 if (scm_is_false (mod
))
773 mod
= scm_the_root_module ();
775 switch (SCM_MEMOIZED_TAG (m
))
777 case SCM_M_TOPLEVEL_REF
:
778 if (SCM_VARIABLEP (mx
))
782 SCM var
= scm_module_variable (mod
, mx
);
783 if (scm_is_false (var
) || scm_is_false (scm_variable_bound_p (var
)))
784 error_unbound_variable (mx
);
789 case SCM_M_TOPLEVEL_SET
:
792 if (SCM_VARIABLEP (var
))
796 var
= scm_module_variable (mod
, var
);
797 if (scm_is_false (var
))
798 error_unbound_variable (CAR (mx
));
799 SCM_SETCAR (mx
, var
);
804 case SCM_M_MODULE_REF
:
805 if (SCM_VARIABLEP (mx
))
810 mod
= scm_resolve_module (CAR (mx
));
811 if (scm_is_true (CDDR (mx
)))
812 mod
= scm_module_public_interface (mod
);
813 var
= scm_module_lookup (mod
, CADR (mx
));
814 if (scm_is_false (scm_variable_bound_p (var
)))
815 error_unbound_variable (CADR (mx
));
820 case SCM_M_MODULE_SET
:
821 /* FIXME: not quite threadsafe */
822 if (SCM_VARIABLEP (CDR (mx
)))
827 mod
= scm_resolve_module (CADR (mx
));
828 if (scm_is_true (CDDDR (mx
)))
829 mod
= scm_module_public_interface (mod
);
830 var
= scm_module_lookup (mod
, CADDR (mx
));
831 SCM_SETCDR (mx
, var
);
836 scm_wrong_type_arg (FUNC_NAME
, 1, m
);
848 #include "libguile/memoize.x"
850 wind
= scm_c_make_gsubr ("wind", 2, 0, 0, do_wind
);
851 unwind
= scm_c_make_gsubr ("unwind", 0, 0, 0, do_unwind
);
852 push_fluid
= scm_c_make_gsubr ("push-fluid", 2, 0, 0, do_push_fluid
);
853 pop_fluid
= scm_c_make_gsubr ("pop-fluid", 0, 0, 0, do_pop_fluid
);
855 list_of_guile
= scm_list_1 (scm_from_latin1_symbol ("guile"));