diff options
Diffstat (limited to 'libguile/memoize.c')
-rw-r--r-- | libguile/memoize.c | 604 |
1 files changed, 274 insertions, 330 deletions
diff --git a/libguile/memoize.c b/libguile/memoize.c index dfbeea781..5c7129feb 100644 --- a/libguile/memoize.c +++ b/libguile/memoize.c @@ -54,22 +54,65 @@ #define CDDDR(x) SCM_CDDDR(x) #define CADDDR(x) SCM_CADDDR(x) +#define VECTOR_REF(v, i) (SCM_SIMPLE_VECTOR_REF (v, i)) +#define VECTOR_SET(v, i, x) (SCM_SIMPLE_VECTOR_SET (v, i, x)) +#define VECTOR_LENGTH(v) (SCM_SIMPLE_VECTOR_LENGTH (v)) SCM_SYMBOL (sym_case_lambda_star, "case-lambda*"); +/* Primitives not exposed to general Scheme. */ +static SCM wind; +static SCM unwind; +static SCM push_fluid; +static SCM pop_fluid; + +static SCM +do_wind (SCM in, SCM out) +{ + scm_dynstack_push_dynwind (&SCM_I_CURRENT_THREAD->dynstack, in, out); + return SCM_UNSPECIFIED; +} + +static SCM +do_unwind (void) +{ + scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack); + return SCM_UNSPECIFIED; +} + +static SCM +do_push_fluid (SCM fluid, SCM val) +{ + scm_i_thread *thread = SCM_I_CURRENT_THREAD; + scm_dynstack_push_fluid (&thread->dynstack, fluid, val, + thread->dynamic_state); + return SCM_UNSPECIFIED; +} + +static SCM +do_pop_fluid (void) +{ + scm_i_thread *thread = SCM_I_CURRENT_THREAD; + scm_dynstack_unwind_fluid (&thread->dynstack, thread->dynamic_state); + return SCM_UNSPECIFIED; +} + + + + /* {Evaluator memoized expressions} */ scm_t_bits scm_tc16_memoized; #define MAKMEMO(n, args) \ - (scm_cell (scm_tc16_memoized | ((n) << 16), SCM_UNPACK (args))) + (scm_cons (SCM_I_MAKINUM (n), args)) -#define MAKMEMO_BEGIN(exps) \ - MAKMEMO (SCM_M_BEGIN, exps) +#define MAKMEMO_SEQ(head,tail) \ + MAKMEMO (SCM_M_SEQ, scm_cons (head, tail)) #define MAKMEMO_IF(test, then, else_) \ MAKMEMO (SCM_M_IF, scm_cons (test, scm_cons (then, else_))) #define FIXED_ARITY(nreq) \ @@ -79,19 +122,17 @@ scm_t_bits scm_tc16_memoized; #define FULL_ARITY(nreq, rest, nopt, kw, inits, alt) \ scm_list_n (SCM_I_MAKINUM (nreq), rest, SCM_I_MAKINUM (nopt), kw, inits, \ alt, SCM_UNDEFINED) -#define MAKMEMO_LAMBDA(body, arity, docstring) \ +#define MAKMEMO_LAMBDA(body, arity, meta) \ MAKMEMO (SCM_M_LAMBDA, \ - scm_cons (body, scm_cons (docstring, arity))) + scm_cons (body, scm_cons (meta, arity))) #define MAKMEMO_LET(inits, body) \ MAKMEMO (SCM_M_LET, scm_cons (inits, body)) #define MAKMEMO_QUOTE(exp) \ MAKMEMO (SCM_M_QUOTE, exp) #define MAKMEMO_DEFINE(var, val) \ MAKMEMO (SCM_M_DEFINE, scm_cons (var, val)) -#define MAKMEMO_DYNWIND(in, expr, out) \ - MAKMEMO (SCM_M_DYNWIND, scm_cons (in, scm_cons (expr, out))) -#define MAKMEMO_WITH_FLUIDS(fluids, vals, expr) \ - MAKMEMO (SCM_M_WITH_FLUIDS, scm_cons (fluids, scm_cons (vals, expr))) +#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) \ @@ -100,10 +141,10 @@ scm_t_bits scm_tc16_memoized; MAKMEMO (SCM_M_CALL_WITH_VALUES, scm_cons (prod, cons)) #define MAKMEMO_CALL(proc, nargs, args) \ MAKMEMO (SCM_M_CALL, scm_cons (proc, scm_cons (SCM_I_MAKINUM (nargs), args))) -#define MAKMEMO_LEX_REF(n) \ - MAKMEMO (SCM_M_LEXICAL_REF, SCM_I_MAKINUM (n)) -#define MAKMEMO_LEX_SET(n, val) \ - MAKMEMO (SCM_M_LEXICAL_SET, scm_cons (SCM_I_MAKINUM (n), val)) +#define MAKMEMO_LEX_REF(pos) \ + MAKMEMO (SCM_M_LEXICAL_REF, pos) +#define MAKMEMO_LEX_SET(pos, val) \ + MAKMEMO (SCM_M_LEXICAL_SET, scm_cons (pos, val)) #define MAKMEMO_TOP_REF(var) \ MAKMEMO (SCM_M_TOPLEVEL_REF, var) #define MAKMEMO_TOP_SET(var, val) \ @@ -112,28 +153,22 @@ scm_t_bits scm_tc16_memoized; MAKMEMO (SCM_M_MODULE_REF, scm_cons (mod, scm_cons (var, public))) #define MAKMEMO_MOD_SET(val, mod, var, public) \ MAKMEMO (SCM_M_MODULE_SET, scm_cons (val, scm_cons (mod, scm_cons (var, public)))) -#define MAKMEMO_PROMPT(tag, exp, handler) \ - MAKMEMO (SCM_M_PROMPT, scm_cons (tag, scm_cons (exp, handler))) +#define MAKMEMO_CALL_WITH_PROMPT(tag, thunk, handler) \ + MAKMEMO (SCM_M_CALL_WITH_PROMPT, scm_cons (tag, scm_cons (thunk, handler))) -/* Primitives for the evaluator */ -scm_t_bits scm_tc16_memoizer; -#define SCM_MEMOIZER_P(x) (SCM_SMOB_PREDICATE (scm_tc16_memoizer, (x))) -#define SCM_MEMOIZER(M) (SCM_SMOB_OBJECT_1 (M)) - /* This table must agree with the list of M_ constants in memoize.h */ static const char *const memoized_tags[] = { - "begin", + "seq", "if", "lambda", "let", "quote", "define", - "dynwind", - "with-fluids", + "capture-module", "apply", "call/cc", "call-with-values", @@ -144,33 +179,52 @@ static const char *const memoized_tags[] = "toplevel-set!", "module-ref", "module-set!", - "prompt", + "call-with-prompt", }; + + + + static int -scm_print_memoized (SCM memoized, SCM port, scm_print_state *pstate) +try_lookup_rib (SCM x, SCM rib) { - scm_puts ("#<memoized ", port); - scm_write (scm_unmemoize_expression (memoized), port); - scm_puts (">", port); - return 1; + int idx = 0; + for (; idx < VECTOR_LENGTH (rib); idx++) + if (scm_is_eq (x, VECTOR_REF (rib, idx))) + return idx; /* bound */ + return -1; } +static int +lookup_rib (SCM x, SCM rib) +{ + int idx = try_lookup_rib (x, rib); + if (idx < 0) + abort (); + return idx; +} - - +static SCM +make_pos (int depth, int width) +{ + return scm_cons (SCM_I_MAKINUM (depth), SCM_I_MAKINUM (width)); +} -static int +static SCM lookup (SCM x, SCM env) { - int i = 0; - for (; scm_is_pair (env); env = CDR (env), i++) - if (scm_is_eq (x, CAR (env))) - return i; /* bound */ + int d = 0; + for (; scm_is_pair (env); env = CDR (env), d++) + { + int w = try_lookup_rib (x, CAR (env)); + if (w < 0) + continue; + return make_pos (d, w); + } abort (); } - /* Abbreviate SCM_EXPANDED_REF. Copied because I'm not sure about symbol pasting */ #define REF(x,type,field) \ (scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field))) @@ -189,6 +243,22 @@ memoize_exps (SCM exps, SCM env) } 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) { if (!SCM_EXPANDED_P (exp)) @@ -204,7 +274,9 @@ 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); @@ -228,11 +300,15 @@ memoize (SCM exp, SCM env) 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), @@ -243,38 +319,75 @@ memoize (SCM exp, SCM env) memoize (REF (exp, CONDITIONAL, CONSEQUENT), env), memoize (REF (exp, CONDITIONAL, ALTERNATE), env)); - case SCM_EXPANDED_APPLICATION: + case SCM_EXPANDED_CALL: { SCM proc, args; - proc = REF (exp, APPLICATION, PROC); - args = memoize_exps (REF (exp, APPLICATION, ARGS), env); + proc = REF (exp, CALL, PROC); + args = memoize_exps (REF (exp, CALL, ARGS), env); - if (SCM_EXPANDED_TYPE (proc) == SCM_EXPANDED_TOPLEVEL_REF) - { - SCM var = scm_module_variable (scm_current_module (), - REF (proc, TOPLEVEL_REF, NAME)); - if (SCM_VARIABLEP (var)) - { - SCM val = SCM_VARIABLE_REF (var); - if (SCM_MEMOIZER_P (val)) - return scm_apply (SCM_SMOB_OBJECT_1 (val), args, SCM_EOL); - } - } - /* otherwise we all fall down here */ return MAKMEMO_CALL (memoize (proc, env), scm_ilength (args), args); } - case SCM_EXPANDED_SEQUENCE: - return MAKMEMO_BEGIN (memoize_exps (REF (exp, SEQUENCE, EXPS), env)); + case SCM_EXPANDED_PRIMCALL: + { + SCM name, args; + int nargs; + + name = REF (exp, PRIMCALL, NAME); + args = memoize_exps (REF (exp, PRIMCALL, ARGS), env); + nargs = scm_ilength (args); + + if (nargs == 3 + && scm_is_eq (name, scm_from_latin1_symbol ("call-with-prompt"))) + return MAKMEMO_CALL_WITH_PROMPT (CAR (args), + CADR (args), + CADDR (args)); + else if (nargs == 2 + && scm_is_eq (name, scm_from_latin1_symbol ("apply"))) + return MAKMEMO_APPLY (CAR (args), CADR (args)); + else if (nargs == 1 + && scm_is_eq (name, + scm_from_latin1_symbol + ("call-with-current-continuation"))) + return MAKMEMO_CONT (CAR (args)); + else if (nargs == 2 + && scm_is_eq (name, + scm_from_latin1_symbol ("call-with-values"))) + return MAKMEMO_CALL_WITH_VALUES (CAR (args), CADR (args)); + else if (nargs == 2 + && scm_is_eq (name, scm_from_latin1_symbol ("wind"))) + return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), 2, args); + else if (nargs == 0 + && scm_is_eq (name, scm_from_latin1_symbol ("unwind"))) + return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), 0, SCM_EOL); + else if (nargs == 2 + && scm_is_eq (name, scm_from_latin1_symbol ("push-fluid"))) + return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), 2, args); + else if (nargs == 0 + && 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 (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), + nargs, + args); + } + + case SCM_EXPANDED_SEQ: + return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env), + memoize (REF (exp, SEQ, TAIL), env)); case SCM_EXPANDED_LAMBDA: /* The body will be a lambda-case or #f. */ { - SCM meta, docstring, body, proc; + SCM meta, body, proc; meta = REF (exp, LAMBDA, META); - docstring = scm_assoc_ref (meta, scm_sym_documentation); body = REF (exp, LAMBDA, BODY); if (scm_is_false (body)) @@ -292,24 +405,21 @@ memoize (SCM exp, SCM env) MAKMEMO_QUOTE (SCM_EOL), MAKMEMO_QUOTE (SCM_BOOL_F))), FIXED_ARITY (0), - SCM_BOOL_F /* docstring */); + meta); else - proc = memoize (body, env); - - if (scm_is_string (docstring)) - { - SCM args = SCM_MEMOIZED_ARGS (proc); - SCM_SETCAR (SCM_CDR (args), docstring); - } + { + 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: { SCM req, rest, opt, kw, inits, vars, body, alt; - SCM walk, minits, arity, new_env; - int nreq, nopt, ntotal; + SCM walk, minits, arity, rib, new_env; + int nreq, nopt; req = REF (exp, LAMBDA_CASE, REQ); rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST))); @@ -322,38 +432,16 @@ memoize (SCM exp, SCM env) nreq = scm_ilength (req); nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0; - ntotal = scm_ilength (vars); /* The vars are the gensyms, according to the divine plan. But we need to memoize the inits within their appropriate environment, complicating things. */ - new_env = env; - for (walk = req; scm_is_pair (walk); - walk = CDR (walk), vars = CDR (vars)) - new_env = scm_cons (CAR (vars), new_env); + rib = scm_vector (vars); + new_env = scm_cons (rib, env); minits = SCM_EOL; - for (walk = opt; scm_is_pair (walk); - walk = CDR (walk), vars = CDR (vars), inits = CDR (inits)) - { - minits = scm_cons (memoize (CAR (inits), new_env), minits); - new_env = scm_cons (CAR (vars), new_env); - } - - if (scm_is_true (rest)) - { - new_env = scm_cons (CAR (vars), new_env); - vars = CDR (vars); - } - - for (; scm_is_pair (inits); vars = CDR (vars), inits = CDR (inits)) - { - minits = scm_cons (memoize (CAR (inits), new_env), minits); - new_env = scm_cons (CAR (vars), new_env); - } - if (!scm_is_null (vars)) - abort (); - + for (walk = inits; scm_is_pair (walk); walk = CDR (walk)) + minits = scm_cons (memoize (CAR (walk), new_env), minits); minits = scm_reverse_x (minits, SCM_UNDEFINED); if (scm_is_true (kw)) @@ -366,7 +454,7 @@ memoize (SCM exp, SCM env) int idx; k = CAR (CAR (kw)); - idx = ntotal - 1 - lookup (CADDR (CAR (kw)), new_env); + idx = lookup_rib (CADDR (CAR (kw)), rib); indices = scm_acons (k, SCM_I_MAKINUM (idx), indices); } kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED)); @@ -386,82 +474,87 @@ memoize (SCM exp, SCM env) arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F); return MAKMEMO_LAMBDA (memoize (body, new_env), arity, - SCM_BOOL_F /* docstring */); + SCM_BOOL_F /* meta, filled in later */); } case SCM_EXPANDED_LET: { - SCM vars, exps, body, inits, new_env; + SCM vars, exps, body, varsv, inits, new_env; + int i; vars = REF (exp, LET, GENSYMS); exps = REF (exp, LET, VALS); body = REF (exp, LET, BODY); - inits = SCM_EOL; - new_env = env; - for (; scm_is_pair (vars); vars = CDR (vars), exps = CDR (exps)) - { - new_env = scm_cons (CAR (vars), new_env); - inits = scm_cons (memoize (CAR (exps), env), inits); - } - - return MAKMEMO_LET (scm_reverse_x (inits, SCM_UNDEFINED), - memoize (body, new_env)); + varsv = scm_vector (vars); + inits = scm_c_make_vector (VECTOR_LENGTH (varsv), + SCM_BOOL_F); + 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 maybe_makmemo_capture_module + (MAKMEMO_LET (inits, memoize (body, new_env)), env); } case SCM_EXPANDED_LETREC: { - SCM vars, exps, body, undefs, new_env; + SCM vars, varsv, exps, expsv, body, undefs, new_env; int i, nvars, in_order_p; vars = REF (exp, LETREC, GENSYMS); exps = REF (exp, LETREC, VALS); body = REF (exp, LETREC, BODY); in_order_p = scm_is_true (REF (exp, LETREC, IN_ORDER_P)); - nvars = i = scm_ilength (vars); - undefs = SCM_EOL; - new_env = env; - for (; scm_is_pair (vars); vars = CDR (vars)) - { - new_env = scm_cons (CAR (vars), new_env); - undefs = scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED), undefs); - } + varsv = scm_vector (vars); + nvars = VECTOR_LENGTH (varsv); + expsv = scm_vector (exps); + + undefs = scm_c_make_vector (nvars, MAKMEMO_QUOTE (SCM_UNDEFINED)); + new_env = scm_cons (varsv, capture_env (env)); if (in_order_p) { - SCM body_exps = SCM_EOL; - for (; scm_is_pair (exps); exps = CDR (exps), i--) - body_exps = scm_cons (MAKMEMO_LEX_SET (i-1, - memoize (CAR (exps), new_env)), - body_exps); - body_exps = scm_cons (memoize (body, new_env), body_exps); - body_exps = scm_reverse_x (body_exps, SCM_UNDEFINED); - return MAKMEMO_LET (undefs, MAKMEMO_BEGIN (body_exps)); + SCM body_exps = memoize (body, new_env); + for (i = nvars - 1; i >= 0; i--) + { + SCM init = memoize (VECTOR_REF (expsv, i), new_env); + body_exps = MAKMEMO_SEQ (MAKMEMO_LEX_SET (make_pos (0, i), init), + body_exps); + } + return maybe_makmemo_capture_module + (MAKMEMO_LET (undefs, body_exps), env); } else { - SCM sets = SCM_EOL, inits = SCM_EOL; - for (; scm_is_pair (exps); exps = CDR (exps), i--) + SCM sets = SCM_BOOL_F, inits = scm_c_make_vector (nvars, SCM_BOOL_F); + for (i = nvars - 1; i >= 0; i--) { - sets = scm_cons (MAKMEMO_LEX_SET ((i-1) + nvars, - MAKMEMO_LEX_REF (i-1)), - sets); - inits = scm_cons (memoize (CAR (exps), new_env), inits); + SCM init, set; + + init = memoize (VECTOR_REF (expsv, i), new_env); + VECTOR_SET (inits, i, init); + + set = MAKMEMO_LEX_SET (make_pos (1, i), + MAKMEMO_LEX_REF (make_pos (0, i))); + if (scm_is_false (sets)) + sets = set; + else + sets = MAKMEMO_SEQ (set, sets); } - inits = scm_reverse_x (inits, SCM_UNDEFINED); - return MAKMEMO_LET - (undefs, - MAKMEMO_BEGIN (scm_list_2 (MAKMEMO_LET (inits, MAKMEMO_BEGIN (sets)), - memoize (body, new_env)))); + + if (scm_is_false (sets)) + return memoize (body, env); + + return maybe_makmemo_capture_module + (MAKMEMO_LET (undefs, + MAKMEMO_SEQ (MAKMEMO_LET (inits, sets), + memoize (body, new_env))), + env); } } - case SCM_EXPANDED_DYNLET: - return MAKMEMO_WITH_FLUIDS (memoize_exps (REF (exp, DYNLET, FLUIDS), env), - memoize_exps (REF (exp, DYNLET, VALS), env), - memoize (REF (exp, DYNLET, BODY), env)); - default: abort (); } @@ -476,109 +569,7 @@ SCM_DEFINE (scm_memoize_expression, "memoize-expression", 1, 0, 0, #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 ()); -} -#undef FUNC_NAME - - - - -#define SCM_MAKE_MEMOIZER(STR, MEMOIZER, N) \ - (scm_cell (scm_tc16_memoizer, \ - SCM_UNPACK (scm_c_make_gsubr (STR, N, 0, 0, MEMOIZER)))) -#define SCM_DEFINE_MEMOIZER(STR, MEMOIZER, N) \ -SCM_SNARF_INIT(scm_c_define (STR, SCM_MAKE_MEMOIZER (STR, MEMOIZER, N))) - -#define SCM_MAKE_REST_MEMOIZER(STR, MEMOIZER, N) \ - (scm_cell (scm_tc16_memoizer, \ - SCM_UNPACK ((scm_c_make_gsubr (STR, N, 0, 1, MEMOIZER))))) -#define SCM_DEFINE_REST_MEMOIZER(STR, MEMOIZER, N) \ -SCM_SNARF_INIT(scm_c_define (STR, SCM_MAKE_REST_MEMOIZER (STR, MEMOIZER, N))) - -static SCM m_apply (SCM proc, SCM arg, SCM rest); -static SCM m_call_cc (SCM proc); -static SCM m_call_values (SCM prod, SCM cons); -static SCM m_dynamic_wind (SCM pre, SCM exp, SCM post); -static SCM m_prompt (SCM tag, SCM exp, SCM handler); - -SCM_DEFINE_REST_MEMOIZER ("@apply", m_apply, 2); -SCM_DEFINE_MEMOIZER ("@call-with-current-continuation", m_call_cc, 1); -SCM_DEFINE_MEMOIZER ("@call-with-values", m_call_values, 2); -SCM_DEFINE_MEMOIZER ("@dynamic-wind", m_dynamic_wind, 3); -SCM_DEFINE_MEMOIZER ("@prompt", m_prompt, 3); - - - - -static SCM m_apply (SCM proc, SCM arg, SCM rest) -#define FUNC_NAME "@apply" -{ - long len; - - SCM_VALIDATE_MEMOIZED (1, proc); - SCM_VALIDATE_MEMOIZED (2, arg); - len = scm_ilength (rest); - if (len < 0) - abort (); - else if (len == 0) - return MAKMEMO_APPLY (proc, arg); - else - { - SCM tail; - - rest = scm_reverse (rest); - tail = scm_car (rest); - rest = scm_cdr (rest); - len--; - - while (scm_is_pair (rest)) - { - tail = MAKMEMO_CALL (MAKMEMO_MOD_REF (scm_list_1 (scm_from_latin1_symbol ("guile")), - scm_from_latin1_symbol ("cons"), - SCM_BOOL_F), - 2, - scm_list_2 (scm_car (rest), tail)); - rest = scm_cdr (rest); - } - return MAKMEMO_APPLY (proc, tail); - } -} -#undef FUNC_NAME - -static SCM m_call_cc (SCM proc) -#define FUNC_NAME "@call-with-current-continuation" -{ - SCM_VALIDATE_MEMOIZED (1, proc); - return MAKMEMO_CONT (proc); -} -#undef FUNC_NAME - -static SCM m_call_values (SCM prod, SCM cons) -#define FUNC_NAME "@call-with-values" -{ - SCM_VALIDATE_MEMOIZED (1, prod); - SCM_VALIDATE_MEMOIZED (2, cons); - return MAKMEMO_CALL_WITH_VALUES (prod, cons); -} -#undef FUNC_NAME - -static SCM m_dynamic_wind (SCM in, SCM expr, SCM out) -#define FUNC_NAME "memoize-dynwind" -{ - SCM_VALIDATE_MEMOIZED (1, in); - SCM_VALIDATE_MEMOIZED (2, expr); - SCM_VALIDATE_MEMOIZED (3, out); - return MAKMEMO_DYNWIND (in, expr, out); -} -#undef FUNC_NAME - -static SCM m_prompt (SCM tag, SCM exp, SCM handler) -#define FUNC_NAME "@prompt" -{ - SCM_VALIDATE_MEMOIZED (1, tag); - SCM_VALIDATE_MEMOIZED (2, exp); - SCM_VALIDATE_MEMOIZED (3, handler); - return MAKMEMO_PROMPT (tag, exp, handler); + return memoize (exp, SCM_BOOL_F); } #undef FUNC_NAME @@ -608,27 +599,23 @@ unmemoize_exprs (SCM exprs) static SCM unmemoize_bindings (SCM inits) { - SCM ret, tail; - if (scm_is_null (inits)) - return SCM_EOL; - ret = scm_list_1 (scm_list_2 (sym_placeholder, unmemoize (CAR (inits)))); - tail = ret; - for (inits = CDR (inits); !scm_is_null (inits); inits = CDR (inits)) - { - SCM_SETCDR (tail, scm_list_1 (scm_list_2 (sym_placeholder, - unmemoize (CAR (inits))))); - tail = CDR (tail); - } + SCM ret = SCM_EOL; + int n = scm_c_vector_length (inits); + + while (n--) + ret = scm_cons (unmemoize (scm_c_vector_ref (inits, n)), ret); + return ret; } static SCM unmemoize_lexical (SCM n) { - char buf[16]; - buf[15] = 0; - snprintf (buf, 15, "<%u>", scm_to_uint32 (n)); - return scm_from_locale_symbol (buf); + char buf[32]; + buf[31] = 0; + snprintf (buf, 31, "<%u,%u>", scm_to_uint32 (CAR (n)), + scm_to_uint32 (CDR (n))); + return scm_from_utf8_symbol (buf); } static SCM @@ -636,42 +623,29 @@ unmemoize (const SCM expr) { SCM args; - if (!SCM_MEMOIZED_P (expr)) - abort (); - args = SCM_MEMOIZED_ARGS (expr); switch (SCM_MEMOIZED_TAG (expr)) { case SCM_M_APPLY: - return scm_cons (scm_sym_atapply, unmemoize_exprs (args)); - case SCM_M_BEGIN: - return scm_cons (scm_sym_begin, unmemoize_exprs (args)); + return scm_cons (scm_from_latin1_symbol ("apply"), + unmemoize_exprs (args)); + case SCM_M_SEQ: + return scm_list_3 (scm_sym_begin, unmemoize (CAR (args)), + unmemoize (CDR (args))); case SCM_M_CALL: return scm_cons (unmemoize (CAR (args)), unmemoize_exprs (CDDR (args))); case SCM_M_CONT: - return scm_list_2 (scm_sym_atcall_cc, unmemoize (args)); + return scm_list_2 (scm_from_latin1_symbol + ("call-with-current_continuation"), + unmemoize (args)); case SCM_M_CALL_WITH_VALUES: - return scm_list_3 (scm_sym_at_call_with_values, + return scm_list_3 (scm_from_latin1_symbol ("call-with-values"), 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_DYNWIND: - return scm_list_4 (scm_sym_at_dynamic_wind, - unmemoize (CAR (args)), - unmemoize (CADR (args)), - unmemoize (CDDR (args))); - case SCM_M_WITH_FLUIDS: - { - SCM binds = SCM_EOL, fluids, vals; - for (fluids = CAR (args), vals = CADR (args); scm_is_pair (fluids); - fluids = CDR (fluids), vals = CDR (vals)) - binds = scm_cons (scm_list_2 (unmemoize (CAR (fluids)), - unmemoize (CAR (vals))), - binds); - return scm_list_3 (scm_sym_with_fluids, - scm_reverse_x (binds, SCM_UNDEFINED), - unmemoize (CDDR (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))); @@ -741,8 +715,8 @@ unmemoize (const SCM expr) scm_i_finite_list_copy (CADR (args)), CADDR (args)), unmemoize (CAR (args))); - case SCM_M_PROMPT: - return scm_list_4 (scm_sym_at_prompt, + case SCM_M_CALL_WITH_PROMPT: + return scm_list_4 (scm_from_latin1_symbol ("call-with-prompt"), unmemoize (CAR (args)), unmemoize (CADR (args)), unmemoize (CDDR (args))); @@ -754,47 +728,15 @@ unmemoize (const SCM expr) -SCM_DEFINE (scm_memoized_p, "memoized?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is memoized.") -#define FUNC_NAME s_scm_memoized_p -{ - return scm_from_bool (SCM_MEMOIZED_P (obj)); -} -#undef FUNC_NAME - SCM_DEFINE (scm_unmemoize_expression, "unmemoize-expression", 1, 0, 0, (SCM m), "Unmemoize the memoized expression @var{m}.") #define FUNC_NAME s_scm_unmemoize_expression { - SCM_VALIDATE_MEMOIZED (1, m); return unmemoize (m); } #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); - - /* The tag is a 16-bit integer so it fits in an inum. */ - return SCM_I_MAKINUM (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}.") @@ -825,9 +767,11 @@ SCM_DEFINE (scm_memoize_variable_access_x, "memoize-variable-access!", 2, 0, 0, "Look up and cache the variable that @var{m} will access, returning the variable.") #define FUNC_NAME s_scm_memoize_variable_access_x { - SCM mx; - SCM_VALIDATE_MEMOIZED (1, m); - mx = SCM_MEMOIZED_ARGS (m); + 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: @@ -838,7 +782,7 @@ SCM_DEFINE (scm_memoize_variable_access_x, "memoize-variable-access!", 2, 0, 0, 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); + SCM_SETCDR (m, var); return var; } @@ -869,7 +813,7 @@ SCM_DEFINE (scm_memoize_variable_access_x, "memoize-variable-access!", 2, 0, 0, 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); + SCM_SETCDR (m, var); return var; } @@ -901,13 +845,13 @@ SCM_DEFINE (scm_memoize_variable_access_x, "memoize-variable-access!", 2, 0, 0, void scm_init_memoize () { - scm_tc16_memoized = scm_make_smob_type ("%memoized", 0); - scm_set_smob_print (scm_tc16_memoized, scm_print_memoized); - - scm_tc16_memoizer = scm_make_smob_type ("memoizer", 0); - #include "libguile/memoize.x" + wind = scm_c_make_gsubr ("wind", 2, 0, 0, do_wind); + unwind = scm_c_make_gsubr ("unwind", 0, 0, 0, do_unwind); + push_fluid = scm_c_make_gsubr ("push-fluid", 2, 0, 0, do_push_fluid); + pop_fluid = scm_c_make_gsubr ("pop-fluid", 0, 0, 0, do_pop_fluid); + list_of_guile = scm_list_1 (scm_from_latin1_symbol ("guile")); } |