diff options
Diffstat (limited to 'libguile/memoize.c')
-rw-r--r-- | libguile/memoize.c | 124 |
1 files changed, 122 insertions, 2 deletions
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 + |