mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

add memoized expression accessors to scheme

Browse source 
* libguile/eval.c: Fix a comment.
  (eval): Abstract out the variable memoization into a function,
  scm_memoize_variable_access_x.

* libguile/memoize.c (memoized_tags): Fix a couple names.
  (scm_memoize_variable_access_x): New internal function. Actually it's
  public to Scheme, but we can't do much about that, because the new
  evaluator will need it.
  (scm_memoized_expression_typecode, scm_memoized_expression_data): New
  accessors for memoized code, for Scheme.
  (scm_memoized_typecode): Looks up the typecode for a symbol.
This commit is contained in:
Andy Wingo 2009-11-30 22:21:31 +01:00
parent c7a2a803bd
commit 3149a5b60d
3 changed files with 137 additions and 38 deletions
Download patch file Download diff file Expand all files Collapse all files

47
libguile/eval.c
View file

@ -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;
}

124
libguile/memoize.c
View file

@ -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

4
libguile/memoize.h
View file

@ -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);