mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 03:30:27 +02:00
change to format of memoization lambda expressions
* libguile/memoize.c (scm_m_lambda, memoize_named_let) (scm_memoize_lambda, unmemoize) * libguile/eval.c (eval, prepare_boot_closure_env_for_apply) (prepare_boot_closure_env_for_eval, boot_closure_apply): * module/ice-9/eval.scm (primitive-eval): Change the format for memoized lambda expressions, so as to allow, in the future, case-lambda* to be supported by the evaluator.
This commit is contained in:
Andy Wingo
parent
cc00f44743
commit
8f9c5b589d
3 changed files with 119 additions and 80 deletions
144
libguile/eval.c
144
libguile/eval.c
|
|
@ -106,10 +106,19 @@ static scm_t_bits scm_tc16_boot_closure;
|
|||
#define BOOT_CLOSURE_P(obj) SCM_TYP16_PREDICATE (scm_tc16_boot_closure, (obj))
|
||||
#define BOOT_CLOSURE_CODE(x) SCM_SMOB_OBJECT (x)
|
||||
#define BOOT_CLOSURE_ENV(x) SCM_SMOB_OBJECT_2 (x)
|
||||
#define BOOT_CLOSURE_NUM_REQUIRED_ARGS(x) SCM_I_INUM (CAR (BOOT_CLOSURE_CODE (x)))
|
||||
#define BOOT_CLOSURE_HAS_REST_ARGS(x) scm_is_true (CADR (BOOT_CLOSURE_CODE (x)))
|
||||
#define BOOT_CLOSURE_BODY(x) CDDR (BOOT_CLOSURE_CODE (x))
|
||||
|
||||
#define BOOT_CLOSURE_BODY(x) CAR (BOOT_CLOSURE_CODE (x))
|
||||
#define BOOT_CLOSURE_NUM_REQUIRED_ARGS(x) SCM_I_INUM (CADR (BOOT_CLOSURE_CODE (x)))
|
||||
#define BOOT_CLOSURE_IS_FIXED(x) scm_is_null (CDDR (BOOT_CLOSURE_CODE (x)))
|
||||
/* NB: One may only call the following accessors if the closure is not FIXED. */
|
||||
#define BOOT_CLOSURE_HAS_REST_ARGS(x) scm_is_true (CADDR (BOOT_CLOSURE_CODE (x)))
|
||||
#define BOOT_CLOSURE_IS_REST(x) scm_is_null (CDDDR (BOOT_CLOSURE_CODE (x)))
|
||||
/* NB: One may only call the following accessors if the closure is not REST. */
|
||||
#define BOOT_CLOSURE_IS_FULL(x) (1)
|
||||
#define BOOT_CLOSURE_OPT(x) CAR (CDDDR (BOOT_CLOSURE_CODE (x)))
|
||||
#define BOOT_CLOSURE_ALT(x) CADR (CDDDR (BOOT_CLOSURE_CODE (x)))
|
||||
static SCM prepare_boot_closure_env_for_apply (SCM proc, SCM args);
|
||||
static SCM prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
|
||||
SCM exps, SCM env);
|
||||
|
||||
|
||||
#define CAR(x) SCM_CAR(x)
|
||||
|
|
@ -238,25 +247,8 @@ eval (SCM x, SCM env)
|
|||
* ARGS is the list of arguments. */
|
||||
if (BOOT_CLOSURE_P (proc))
|
||||
{
|
||||
int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
|
||||
SCM new_env = BOOT_CLOSURE_ENV (proc);
|
||||
if (BOOT_CLOSURE_HAS_REST_ARGS (proc))
|
||||
{
|
||||
if (SCM_UNLIKELY (scm_ilength (args) < nreq))
|
||||
scm_wrong_num_args (proc);
|
||||
for (; nreq; nreq--, args = CDR (args))
|
||||
new_env = scm_cons (CAR (args), new_env);
|
||||
new_env = scm_cons (args, new_env);
|
||||
}
|
||||
else
|
||||
{
|
||||
if (SCM_UNLIKELY (scm_ilength (args) != nreq))
|
||||
scm_wrong_num_args (proc);
|
||||
for (; scm_is_pair (args); args = CDR (args))
|
||||
new_env = scm_cons (CAR (args), new_env);
|
||||
}
|
||||
x = BOOT_CLOSURE_BODY (proc);
|
||||
env = new_env;
|
||||
env = prepare_boot_closure_env_for_apply (proc, args);
|
||||
goto loop;
|
||||
}
|
||||
else
|
||||
|
|
@ -270,31 +262,8 @@ eval (SCM x, SCM env)
|
|||
|
||||
if (BOOT_CLOSURE_P (proc))
|
||||
{
|
||||
int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
|
||||
SCM new_env = BOOT_CLOSURE_ENV (proc);
|
||||
if (BOOT_CLOSURE_HAS_REST_ARGS (proc))
|
||||
{
|
||||
if (SCM_UNLIKELY (argc < nreq))
|
||||
scm_wrong_num_args (proc);
|
||||
for (; nreq; nreq--, mx = CDR (mx))
|
||||
new_env = scm_cons (eval (CAR (mx), env), new_env);
|
||||
{
|
||||
SCM rest = SCM_EOL;
|
||||
for (; scm_is_pair (mx); mx = CDR (mx))
|
||||
rest = scm_cons (eval (CAR (mx), env), rest);
|
||||
new_env = scm_cons (scm_reverse (rest),
|
||||
new_env);
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
for (; scm_is_pair (mx); mx = CDR (mx), nreq--)
|
||||
new_env = scm_cons (eval (CAR (mx), env), new_env);
|
||||
if (SCM_UNLIKELY (nreq != 0))
|
||||
scm_wrong_num_args (proc);
|
||||
}
|
||||
x = BOOT_CLOSURE_BODY (proc);
|
||||
env = new_env;
|
||||
env = prepare_boot_closure_env_for_eval (proc, argc, mx, env);
|
||||
goto loop;
|
||||
}
|
||||
else
|
||||
|
|
@ -908,28 +877,73 @@ scm_apply (SCM proc, SCM arg1, SCM args)
|
|||
return scm_vm_apply (scm_the_vm (), proc, args);
|
||||
}
|
||||
|
||||
static SCM
|
||||
prepare_boot_closure_env_for_apply (SCM proc, SCM args)
|
||||
{
|
||||
int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
|
||||
SCM env = BOOT_CLOSURE_ENV (proc);
|
||||
if (BOOT_CLOSURE_IS_FIXED (proc)
|
||||
|| (BOOT_CLOSURE_IS_REST (proc)
|
||||
&& !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
|
||||
{
|
||||
if (SCM_UNLIKELY (scm_ilength (args) != nreq))
|
||||
scm_wrong_num_args (proc);
|
||||
for (; scm_is_pair (args); args = CDR (args))
|
||||
env = scm_cons (CAR (args), env);
|
||||
}
|
||||
else if (BOOT_CLOSURE_IS_REST (proc))
|
||||
{
|
||||
if (SCM_UNLIKELY (scm_ilength (args) < nreq))
|
||||
scm_wrong_num_args (proc);
|
||||
for (; nreq; nreq--, args = CDR (args))
|
||||
env = scm_cons (CAR (args), env);
|
||||
env = scm_cons (args, env);
|
||||
}
|
||||
else
|
||||
abort ();
|
||||
|
||||
return env;
|
||||
}
|
||||
|
||||
static SCM
|
||||
prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
|
||||
SCM exps, SCM env)
|
||||
{
|
||||
int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
|
||||
SCM new_env = BOOT_CLOSURE_ENV (proc);
|
||||
if (BOOT_CLOSURE_IS_FIXED (proc)
|
||||
|| (BOOT_CLOSURE_IS_REST (proc)
|
||||
&& !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
|
||||
{
|
||||
for (; scm_is_pair (exps); exps = CDR (exps), nreq--)
|
||||
new_env = scm_cons (eval (CAR (exps), env), new_env);
|
||||
if (SCM_UNLIKELY (nreq != 0))
|
||||
scm_wrong_num_args (proc);
|
||||
}
|
||||
else if (BOOT_CLOSURE_IS_REST (proc))
|
||||
{
|
||||
if (SCM_UNLIKELY (argc < nreq))
|
||||
scm_wrong_num_args (proc);
|
||||
for (; nreq; nreq--, exps = CDR (exps))
|
||||
new_env = scm_cons (eval (CAR (exps), env), new_env);
|
||||
{
|
||||
SCM rest = SCM_EOL;
|
||||
for (; scm_is_pair (exps); exps = CDR (exps))
|
||||
rest = scm_cons (eval (CAR (exps), env), rest);
|
||||
new_env = scm_cons (scm_reverse (rest),
|
||||
new_env);
|
||||
}
|
||||
}
|
||||
else
|
||||
abort ();
|
||||
return new_env;
|
||||
}
|
||||
|
||||
static SCM
|
||||
boot_closure_apply (SCM closure, SCM args)
|
||||
{
|
||||
int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure);
|
||||
SCM new_env = BOOT_CLOSURE_ENV (closure);
|
||||
if (BOOT_CLOSURE_HAS_REST_ARGS (closure))
|
||||
{
|
||||
if (SCM_UNLIKELY (scm_ilength (args) < nreq))
|
||||
scm_wrong_num_args (closure);
|
||||
for (; nreq; nreq--, args = CDR (args))
|
||||
new_env = scm_cons (CAR (args), new_env);
|
||||
new_env = scm_cons (args, new_env);
|
||||
}
|
||||
else
|
||||
{
|
||||
if (SCM_UNLIKELY (scm_ilength (args) != nreq))
|
||||
scm_wrong_num_args (closure);
|
||||
for (; scm_is_pair (args); args = CDR (args))
|
||||
new_env = scm_cons (CAR (args), new_env);
|
||||
}
|
||||
return eval (BOOT_CLOSURE_BODY (closure), new_env);
|
||||
return eval (BOOT_CLOSURE_BODY (closure),
|
||||
prepare_boot_closure_env_for_apply (closure, args));
|
||||
}
|
||||
|
||||
static int
|
||||
|
|
@ -941,7 +955,7 @@ boot_closure_print (SCM closure, SCM port, scm_print_state *pstate)
|
|||
scm_putc (' ', port);
|
||||
args = scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure)),
|
||||
scm_from_locale_symbol ("_"));
|
||||
if (BOOT_CLOSURE_HAS_REST_ARGS (closure))
|
||||
if (!BOOT_CLOSURE_IS_FIXED (closure) && BOOT_CLOSURE_HAS_REST_ARGS (closure))
|
||||
args = scm_cons_star (scm_from_locale_symbol ("_"), args);
|
||||
scm_display (args, port);
|
||||
scm_putc ('>', port);
|
||||
|
|
|
|||
|
|
@ -179,8 +179,15 @@ scm_t_bits scm_tc16_memoized;
|
|||
MAKMEMO (SCM_M_BEGIN, exps)
|
||||
#define MAKMEMO_IF(test, then, else_) \
|
||||
MAKMEMO (SCM_M_IF, scm_cons (test, scm_cons (then, else_)))
|
||||
#define MAKMEMO_LAMBDA(nreq, rest, body) \
|
||||
MAKMEMO (SCM_M_LAMBDA, scm_cons (SCM_I_MAKINUM (nreq), scm_cons (rest, body)))
|
||||
#define FIXED_ARITY(nreq) \
|
||||
scm_list_1 (SCM_I_MAKINUM (nreq))
|
||||
#define REST_ARITY(nreq, rest) \
|
||||
scm_list_2 (SCM_I_MAKINUM (nreq), rest)
|
||||
/* opts := #f | (aok? (pos? kw init) ...) */
|
||||
#define FULL_ARITY(nreq, rest, opts, alt) \
|
||||
scm_list_4 (SCM_I_MAKINUM (nreq), rest, opts, alt)
|
||||
#define MAKMEMO_LAMBDA(body, arity) \
|
||||
MAKMEMO (SCM_M_LAMBDA, (scm_cons (body, arity)))
|
||||
#define MAKMEMO_LET(inits, body) \
|
||||
MAKMEMO (SCM_M_LET, scm_cons (inits, body))
|
||||
#define MAKMEMO_QUOTE(exp) \
|
||||
|
|
@ -676,6 +683,7 @@ scm_m_lambda (SCM expr, SCM env SCM_UNUSED)
|
|||
SCM formals;
|
||||
SCM formals_idx;
|
||||
SCM formal_vars = SCM_EOL;
|
||||
SCM body;
|
||||
int nreq = 0;
|
||||
|
||||
const SCM cdr_expr = CDR (expr);
|
||||
|
|
@ -715,9 +723,13 @@ scm_m_lambda (SCM expr, SCM env SCM_UNUSED)
|
|||
s_bad_formal, formals_idx, expr);
|
||||
if (scm_is_symbol (formals_idx))
|
||||
formal_vars = scm_cons (formals_idx, formal_vars);
|
||||
return MAKMEMO_LAMBDA (nreq, scm_symbol_p (formals_idx),
|
||||
memoize_sequence (CDDR (expr),
|
||||
memoize_env_extend (env, formal_vars)));
|
||||
|
||||
body = memoize_sequence (CDDR (expr), memoize_env_extend (env, formal_vars));
|
||||
|
||||
if (scm_is_symbol (formals_idx))
|
||||
return MAKMEMO_LAMBDA (body, REST_ARITY (nreq, SCM_BOOL_T));
|
||||
else
|
||||
return MAKMEMO_LAMBDA (body, FIXED_ARITY (nreq));
|
||||
}
|
||||
|
||||
/* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
|
||||
|
|
@ -796,10 +808,10 @@ memoize_named_let (const SCM expr, SCM env)
|
|||
MAKMEMO_BEGIN
|
||||
(scm_list_2 (MAKMEMO_LEX_SET
|
||||
(0,
|
||||
MAKMEMO_LAMBDA
|
||||
(nreq, SCM_BOOL_F,
|
||||
memoize_sequence (CDDDR (expr),
|
||||
memoize_env_extend (env, rvariables)))),
|
||||
MAKMEMO_LAMBDA (memoize_sequence
|
||||
(CDDDR (expr),
|
||||
memoize_env_extend (env, rvariables)),
|
||||
FIXED_ARITY (nreq))),
|
||||
MAKMEMO_CALL (MAKMEMO_LEX_REF (0),
|
||||
nreq,
|
||||
memoize_exprs (inits, env)))));
|
||||
|
|
@ -1118,7 +1130,7 @@ SCM_DEFINE (scm_memoize_lambda, "memoize-lambda", 3, 0, 0,
|
|||
{
|
||||
SCM_VALIDATE_BOOL (2, rest);
|
||||
SCM_VALIDATE_MEMOIZED (3, body);
|
||||
return MAKMEMO_LAMBDA (scm_to_uint16 (nreq), rest, body);
|
||||
return MAKMEMO_LAMBDA (body, REST_ARITY (scm_to_uint16 (nreq), rest));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
@ -1323,9 +1335,21 @@ unmemoize (const SCM expr)
|
|||
return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)),
|
||||
unmemoize (scm_cadr (args)), unmemoize (scm_cddr (args)));
|
||||
case SCM_M_LAMBDA:
|
||||
return scm_list_3 (scm_sym_lambda,
|
||||
scm_make_list (CAR (args), sym_placeholder),
|
||||
unmemoize (CDDR (args)));
|
||||
if (scm_is_null (CDDR (args)))
|
||||
return scm_list_3 (scm_sym_lambda,
|
||||
scm_make_list (CADR (args), sym_placeholder),
|
||||
unmemoize (CAR (args)));
|
||||
else if (scm_is_null (CDDDR (args)))
|
||||
{
|
||||
SCM formals = scm_make_list (CADR (args), sym_placeholder);
|
||||
return scm_list_3 (scm_sym_lambda,
|
||||
scm_is_true (CADDR (args))
|
||||
? scm_cons_star (sym_placeholder, formals)
|
||||
: formals,
|
||||
unmemoize (CAR (args)));
|
||||
}
|
||||
else
|
||||
abort ();
|
||||
case SCM_M_LET:
|
||||
return scm_list_3 (scm_sym_let,
|
||||
unmemoize_bindings (CAR (args)),
|
||||
|
|
|
|||
|
|
@ -255,8 +255,9 @@
|
|||
(lp (cdr inits)
|
||||
(cons (eval (car inits) env) new-env)))))
|
||||
|
||||
(('lambda (nreq rest? . body))
|
||||
(make-closure eval nreq rest? body (capture-env env)))
|
||||
(('lambda (body nreq . tail))
|
||||
(make-closure eval nreq (and (pair? tail) (car tail))
|
||||
body (capture-env env)))
|
||||
|
||||
(('begin (first . rest))
|
||||
(let lp ((first first) (rest rest))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue