}
#define EVAL1(x, env) (truncate_values (eval ((x), (env))))
-/* the environment:
- (VAL ... . MOD)
- If MOD is #f, it means the environment was captured before modules were
- booted.
- If MOD is the literal value '(), we are evaluating at the top level, and so
- should track changes to the current module. You have to be careful in this
- case, because further lexical contours should capture the current module.
-*/
-#define CAPTURE_ENV(env) \
- (scm_is_null (env) ? scm_current_module () : \
- (scm_is_false (env) ? scm_the_root_module () : env))
-
static SCM
eval (SCM x, SCM env)
{
SCM new_env;
int i;
- new_env = make_env (VECTOR_LENGTH (inits), SCM_UNDEFINED,
- CAPTURE_ENV (env));
+ new_env = make_env (VECTOR_LENGTH (inits), SCM_UNDEFINED, env);
for (i = 0; i < VECTOR_LENGTH (inits); i++)
env_set (new_env, 0, i, EVAL1 (VECTOR_REF (inits, i), env));
env = new_env;
}
case SCM_M_LAMBDA:
- RETURN_BOOT_CLOSURE (mx, CAPTURE_ENV (env));
+ RETURN_BOOT_CLOSURE (mx, env);
case SCM_M_QUOTE:
return mx;
scm_define (CAR (mx), EVAL1 (CDR (mx), env));
return SCM_UNSPECIFIED;
+ case SCM_M_CAPTURE_MODULE:
+ return eval (mx, scm_current_module ());
+
case SCM_M_APPLY:
/* Evaluate the procedure to be applied. */
proc = EVAL1 (CAR (mx), env);
else
{
env = env_tail (env);
- return SCM_VARIABLE_REF
- (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)));
+ return SCM_VARIABLE_REF (scm_memoize_variable_access_x (x, env));
}
case SCM_M_TOPLEVEL_SET:
else
{
env = env_tail (env);
- SCM_VARIABLE_SET
- (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)),
- val);
+ SCM_VARIABLE_SET (scm_memoize_variable_access_x (x, env), val);
return SCM_UNSPECIFIED;
}
}
{
if (!SCM_EXPANDED_P (exp))
exp = scm_call_1 (scm_current_module_transformer (), exp);
- return eval (scm_memoize_expression (exp), SCM_EOL);
+ return eval (scm_memoize_expression (exp), SCM_BOOL_F);
}
static SCM var_primitive_eval;
MAKMEMO (SCM_M_QUOTE, exp)
#define MAKMEMO_DEFINE(var, val) \
MAKMEMO (SCM_M_DEFINE, scm_cons (var, val))
+#define MAKMEMO_CAPTURE_MODULE(exp) \
+ MAKMEMO (SCM_M_CAPTURE_MODULE, exp)
#define MAKMEMO_APPLY(proc, args)\
MAKMEMO (SCM_M_APPLY, scm_list_2 (proc, args))
#define MAKMEMO_CONT(proc) \
"let",
"quote",
"define",
+ "capture-module",
"apply",
"call/cc",
"call-with-values",
return scm_reverse_x (ret, SCM_UNDEFINED);
}
+static SCM
+capture_env (SCM env)
+{
+ if (scm_is_false (env))
+ return SCM_BOOL_T;
+ return env;
+}
+
+static SCM
+maybe_makmemo_capture_module (SCM exp, SCM env)
+{
+ if (scm_is_false (env))
+ return MAKMEMO_CAPTURE_MODULE (exp);
+ return exp;
+}
+
static SCM
memoize (SCM exp, SCM env)
{
case SCM_EXPANDED_PRIMITIVE_REF:
if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
- return MAKMEMO_TOP_REF (REF (exp, PRIMITIVE_REF, NAME));
+ return maybe_makmemo_capture_module
+ (MAKMEMO_TOP_REF (REF (exp, PRIMITIVE_REF, NAME)),
+ env);
else
return MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMITIVE_REF, NAME),
SCM_BOOL_F);
REF (exp, MODULE_SET, PUBLIC));
case SCM_EXPANDED_TOPLEVEL_REF:
- return MAKMEMO_TOP_REF (REF (exp, TOPLEVEL_REF, NAME));
+ return maybe_makmemo_capture_module
+ (MAKMEMO_TOP_REF (REF (exp, TOPLEVEL_REF, NAME)), env);
case SCM_EXPANDED_TOPLEVEL_SET:
- return MAKMEMO_TOP_SET (REF (exp, TOPLEVEL_SET, NAME),
- memoize (REF (exp, TOPLEVEL_SET, EXP), env));
+ return maybe_makmemo_capture_module
+ (MAKMEMO_TOP_SET (REF (exp, TOPLEVEL_SET, NAME),
+ memoize (REF (exp, TOPLEVEL_SET, EXP),
+ capture_env (env))),
+ env);
case SCM_EXPANDED_TOPLEVEL_DEFINE:
return MAKMEMO_DEFINE (REF (exp, TOPLEVEL_DEFINE, NAME),
&& scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), 0, SCM_EOL);
else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
- return MAKMEMO_CALL (MAKMEMO_TOP_REF (name), nargs, args);
+ return MAKMEMO_CALL (maybe_makmemo_capture_module
+ (MAKMEMO_TOP_REF (name), env),
+ nargs, args);
else
return MAKMEMO_CALL (MAKMEMO_MOD_REF (list_of_guile, name,
SCM_BOOL_F),
meta);
else
{
- proc = memoize (body, env);
+ proc = memoize (body, capture_env (env));
SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta);
}
- return proc;
+ return maybe_makmemo_capture_module (proc, env);
}
case SCM_EXPANDED_LAMBDA_CASE:
varsv = scm_vector (vars);
inits = scm_c_make_vector (VECTOR_LENGTH (varsv),
SCM_BOOL_F);
- new_env = scm_cons (varsv, env);
+ new_env = scm_cons (varsv, capture_env (env));
for (i = 0; scm_is_pair (exps); exps = CDR (exps), i++)
VECTOR_SET (inits, i, memoize (CAR (exps), env));
- return MAKMEMO_LET (inits, memoize (body, new_env));
+ return maybe_makmemo_capture_module
+ (MAKMEMO_LET (inits, memoize (body, new_env)), env);
}
case SCM_EXPANDED_LETREC:
expsv = scm_vector (exps);
undefs = scm_c_make_vector (nvars, MAKMEMO_QUOTE (SCM_UNDEFINED));
- new_env = scm_cons (varsv, env);
+ new_env = scm_cons (varsv, capture_env (env));
if (in_order_p)
{
body_exps = MAKMEMO_SEQ (MAKMEMO_LEX_SET (make_pos (0, i), init),
body_exps);
}
- return MAKMEMO_LET (undefs, body_exps);
+ return maybe_makmemo_capture_module
+ (MAKMEMO_LET (undefs, body_exps), env);
}
else
{
if (scm_is_false (sets))
return memoize (body, env);
- return MAKMEMO_LET (undefs,
- MAKMEMO_SEQ (MAKMEMO_LET (inits, sets),
- memoize (body, new_env)));
+ return maybe_makmemo_capture_module
+ (MAKMEMO_LET (undefs,
+ MAKMEMO_SEQ (MAKMEMO_LET (inits, sets),
+ memoize (body, new_env))),
+ env);
}
}
#define FUNC_NAME s_scm_memoize_expression
{
SCM_ASSERT_TYPE (SCM_EXPANDED_P (exp), exp, 1, FUNC_NAME, "expanded");
- return memoize (exp, scm_current_module ());
+ return memoize (exp, SCM_BOOL_F);
}
#undef FUNC_NAME
unmemoize (CAR (args)), unmemoize (CDR (args)));
case SCM_M_DEFINE:
return scm_list_3 (scm_sym_define, CAR (args), unmemoize (CDR (args)));
+ case SCM_M_CAPTURE_MODULE:
+ return scm_list_2 (scm_from_latin1_symbol ("capture-module"),
+ unmemoize (args));
case SCM_M_IF:
return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)),
unmemoize (scm_cadr (args)), unmemoize (scm_cddr (args)));
{
SCM mx = SCM_MEMOIZED_ARGS (m);
+ if (scm_is_false (mod))
+ mod = scm_the_root_module ();
+
switch (SCM_MEMOIZED_TAG (m))
{
case SCM_M_TOPLEVEL_REF:
\f
(eval-when (compile)
- (define-syntax capture-env
- (syntax-rules ()
- ((_ (exp ...))
- (let ((env (exp ...)))
- (capture-env env)))
- ((_ env)
- (if (null? env)
- (current-module)
- (if (not env)
- ;; the and current-module checks that modules are booted,
- ;; and thus the-root-module is defined
- (and (current-module) the-root-module)
- env)))))
-
(define-syntax env-toplevel
(syntax-rules ()
((_ env)
(variable-ref
(if (variable? var-or-sym)
var-or-sym
- (memoize-variable-access! exp
- (capture-env (env-toplevel env))))))
+ (memoize-variable-access! exp (env-toplevel env)))))
(('if (test consequent . alternate))
(if (eval test env)
(('let (inits . body))
(let* ((width (vector-length inits))
- (new-env (make-env width #f (capture-env env))))
+ (new-env (make-env width #f env)))
(let lp ((i 0))
(when (< i width)
(env-set! new-env 0 i (eval (vector-ref inits i) env))
(('lambda (body meta nreq . tail))
(let ((proc
(if (null? tail)
- (make-fixed-closure eval nreq body (capture-env env))
+ (make-fixed-closure eval nreq body env)
(if (null? (cdr tail))
- (make-rest-closure eval nreq body (capture-env env))
- (apply make-general-closure (capture-env env)
- body nreq tail)))))
+ (make-rest-closure eval nreq body env)
+ (apply make-general-closure env body nreq tail)))))
(let lp ((meta meta))
(unless (null? meta)
(set-procedure-property! proc (caar meta) (cdar meta))
(begin
(define! name (eval x env))
(if #f #f)))
-
+
+ (('capture-module x)
+ (eval x (current-module)))
+
(('toplevel-set! (var-or-sym . x))
(variable-set!
(if (variable? var-or-sym)
var-or-sym
- (memoize-variable-access! exp
- (capture-env (env-toplevel env))))
+ (memoize-variable-access! exp (env-toplevel env)))
(eval x env)))
(('call-with-prompt (tag thunk . handler))
(if (macroexpanded? exp)
exp
((module-transformer (current-module)) exp)))
- '()))))
+ #f))))
HCoop / bpt / guile.git / commitdiff