summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/eval.c47
-rw-r--r--libguile/memoize.c124
-rw-r--r--libguile/memoize.h4
3 files changed, 137 insertions, 38 deletions
diff --git a/libguile/eval.c b/libguile/eval.c
index 616410d49..4b8cc0af3 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -120,13 +120,6 @@
SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
-static void error_unbound_variable (SCM symbol) SCM_NORETURN;
-static void error_unbound_variable (SCM symbol)
-{
- scm_error (scm_unbound_variable_key, NULL, "Unbound variable: ~S",
- scm_list_1 (symbol), SCM_BOOL_F);
-}
-
static void error_used_before_defined (void)
{
scm_error (scm_unbound_variable_key, NULL,
@@ -151,7 +144,7 @@ scm_badargsp (SCM formals, SCM args)
static SCM apply (SCM proc, SCM args);
/* the environment:
- ((SYM . VAL) (SYM . VAL) ... . MOD)
+ (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
@@ -347,14 +340,10 @@ eval (SCM x, SCM env)
return SCM_VARIABLE_REF (mx);
else
{
- SCM var;
while (scm_is_pair (env))
env = scm_cdr (env);
- var = scm_module_variable (CAPTURE_ENV (env), mx);
- if (scm_is_false (var) || scm_is_false (scm_variable_bound_p (var)))
- error_unbound_variable (mx);
- SCM_SET_SMOB_OBJECT (x, var);
- return SCM_VARIABLE_REF (var);
+ return SCM_VARIABLE_REF
+ (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)));
}
case SCM_M_TOPLEVEL_SET:
@@ -370,11 +359,9 @@ eval (SCM x, SCM env)
{
while (scm_is_pair (env))
env = scm_cdr (env);
- var = scm_module_variable (CAPTURE_ENV (env), var);
- if (scm_is_false (var) || scm_is_false (scm_variable_bound_p (var)))
- error_unbound_variable (CAR (mx));
- SCM_SETCAR (mx, var);
- SCM_VARIABLE_SET (var, val);
+ SCM_VARIABLE_SET
+ (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)),
+ val);
return SCM_UNSPECIFIED;
}
}
@@ -383,16 +370,8 @@ eval (SCM x, SCM env)
if (SCM_VARIABLEP (mx))
return SCM_VARIABLE_REF (mx);
else
- {
- SCM mod, var;
- mod = scm_resolve_module (CAR (mx));
- if (scm_is_true (CDDR (mx)))
- mod = scm_module_public_interface (mod);
- var = scm_module_lookup (mod, CADR (mx));
- if (scm_is_true (scm_variable_bound_p (var)))
- SCM_SET_SMOB_OBJECT (x, var);
- return scm_variable_ref (var);
- }
+ return SCM_VARIABLE_REF
+ (scm_memoize_variable_access_x (x, SCM_BOOL_F));
case SCM_M_MODULE_SET:
if (SCM_VARIABLEP (CDR (mx)))
@@ -402,13 +381,9 @@ eval (SCM x, SCM env)
}
else
{
- SCM mod, var;
- mod = scm_resolve_module (CADR (mx));
- if (scm_is_true (CDDDR (mx)))
- mod = scm_module_public_interface (mod);
- var = scm_module_lookup (mod, CADDR (mx));
- SCM_SET_SMOB_OBJECT (x, var);
- SCM_VARIABLE_SET (var, eval (CAR (mx), env));
+ SCM_VARIABLE_SET
+ (scm_memoize_variable_access_x (x, SCM_BOOL_F),
+ eval (CAR (mx), env));
return SCM_UNSPECIFIED;
}
diff --git a/libguile/memoize.c b/libguile/memoize.c
index d37a72374..0574e1197 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -236,7 +236,7 @@ static const char *const memoized_tags[] =
"quote",
"define",
"apply",
- "call-with-current-continuation",
+ "call/cc",
"call-with-values",
"call",
"lexical-ref",
@@ -244,7 +244,7 @@ static const char *const memoized_tags[] =
"toplevel-ref",
"toplevel-set!",
"module-ref",
- "module-set",
+ "module-set!",
};
static int
@@ -1121,6 +1121,126 @@ SCM_DEFINE (scm_unmemoize_expression, "unmemoize-expression", 1, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_memoized_expression_typecode, "memoized-expression-typecode", 1, 0, 0,
+ (SCM m),
+ "Return the typecode from the memoized expression @var{m}.")
+#define FUNC_NAME s_scm_memoized_expression_typecode
+{
+ SCM_VALIDATE_MEMOIZED (1, m);
+ return scm_from_uint16 (SCM_MEMOIZED_TAG (m));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_memoized_expression_data, "memoized-expression-data", 1, 0, 0,
+ (SCM m),
+ "Return the data from the memoized expression @var{m}.")
+#define FUNC_NAME s_scm_memoized_expression_data
+{
+ SCM_VALIDATE_MEMOIZED (1, m);
+ return SCM_MEMOIZED_ARGS (m);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_memoized_typecode, "memoized-typecode", 1, 0, 0,
+ (SCM sym),
+ "Return the memoized typecode corresponding to the symbol @var{sym}.")
+#define FUNC_NAME s_scm_memoized_typecode
+{
+ int i;
+
+ SCM_VALIDATE_SYMBOL (1, sym);
+
+ for (i = 0; i < sizeof(memoized_tags)/sizeof(const char*); i++)
+ if (strcmp (scm_i_symbol_chars (sym), memoized_tags[i]) == 0)
+ return scm_from_int32 (i);
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
+static void error_unbound_variable (SCM symbol) SCM_NORETURN;
+static void error_unbound_variable (SCM symbol)
+{
+ scm_error (scm_unbound_variable_key, NULL, "Unbound variable: ~S",
+ scm_list_1 (symbol), SCM_BOOL_F);
+}
+
+SCM_DEFINE (scm_memoize_variable_access_x, "memoize-variable-access!", 2, 0, 0,
+ (SCM m, SCM mod),
+ "Look up and cache the variable that @var{m} will access, returning the variable.")
+#define FUNC_NAME s_scm_memoized_expression_data
+{
+ SCM mx;
+ SCM_VALIDATE_MEMOIZED (1, m);
+ mx = SCM_MEMOIZED_ARGS (m);
+ switch (SCM_MEMOIZED_TAG (m))
+ {
+ case SCM_M_TOPLEVEL_REF:
+ if (SCM_VARIABLEP (mx))
+ return mx;
+ else
+ {
+ SCM var = scm_module_variable (mod, mx);
+ if (scm_is_false (var) || scm_is_false (scm_variable_bound_p (var)))
+ error_unbound_variable (mx);
+ SCM_SET_SMOB_OBJECT (m, var);
+ return var;
+ }
+
+ case SCM_M_TOPLEVEL_SET:
+ {
+ SCM var = CAR (mx);
+ if (SCM_VARIABLEP (var))
+ return var;
+ else
+ {
+ var = scm_module_variable (mod, var);
+ if (scm_is_false (var))
+ error_unbound_variable (CAR (mx));
+ SCM_SETCAR (mx, var);
+ return var;
+ }
+ }
+
+ case SCM_M_MODULE_REF:
+ if (SCM_VARIABLEP (mx))
+ return mx;
+ else
+ {
+ SCM var;
+ mod = scm_resolve_module (CAR (mx));
+ if (scm_is_true (CDDR (mx)))
+ mod = scm_module_public_interface (mod);
+ var = scm_module_lookup (mod, CADR (mx));
+ if (scm_is_false (scm_variable_bound_p (var)))
+ error_unbound_variable (CADR (mx));
+ SCM_SET_SMOB_OBJECT (m, var);
+ return var;
+ }
+
+ case SCM_M_MODULE_SET:
+ /* FIXME: not quite threadsafe */
+ if (SCM_VARIABLEP (CDR (mx)))
+ return CDR (mx);
+ else
+ {
+ SCM var;
+ mod = scm_resolve_module (CADR (mx));
+ if (scm_is_true (CDDDR (mx)))
+ mod = scm_module_public_interface (mod);
+ var = scm_module_lookup (mod, CADDR (mx));
+ SCM_SETCDR (mx, var);
+ return var;
+ }
+
+ default:
+ scm_wrong_type_arg (FUNC_NAME, 1, m);
+ return SCM_BOOL_F;
+ }
+}
+#undef FUNC_NAME
+
diff --git a/libguile/memoize.h b/libguile/memoize.h
index 5a96ef6bf..e033e67f3 100644
--- a/libguile/memoize.h
+++ b/libguile/memoize.h
@@ -92,6 +92,10 @@ enum
SCM_INTERNAL SCM scm_memoize_expression (SCM exp);
SCM_INTERNAL SCM scm_unmemoize_expression (SCM memoized);
+SCM_INTERNAL SCM scm_memoized_expression_typecode (SCM memoized);
+SCM_INTERNAL SCM scm_memoized_expression_data (SCM memoized);
+SCM_INTERNAL SCM scm_memoized_typecode (SCM sym);
+SCM_INTERNAL SCM scm_memoize_variable_access_x (SCM memoized, SCM module);
SCM_API SCM scm_memoized_p (SCM obj);
SCM_INTERNAL void scm_init_memoize (void);