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

evaluator support for case-lambda

Browse source 
* libguile/memoize.c (patch_case_lambda, scm_m_case_lambda)
  (scm_m_case_lambda_star): Add memoizers for case-lambda and
  case-lambda*.
  (unmemoize): Unmemoize lambdas with multiple arities.

* libguile/eval.c (prepare_boot_closure_env_for_apply):
  (prepare_boot_closure_env_for_eval): Adapt to return both body and
  env, so that case-lambda clauses can be selected appropriately.
  (eval, boot_closure_apply): Adapt callers.

* module/ice-9/eval.scm (make-general-closure): Support multiple
  arities.
This commit is contained in:
Andy Wingo 2010-05-13 21:43:35 +02:00
parent d8a071fc4e
commit 7572ee5261
3 changed files with 158 additions and 45 deletions
Download patch file Download diff file Expand all files Collapse all files

66
libguile/eval.c
View file

@ -124,9 +124,11 @@ static scm_t_bits scm_tc16_boot_closure;
inits = CAR (mx); mx = CDR (mx); \
alt = CAR (mx); \
} while (0)
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);
static void prepare_boot_closure_env_for_apply (SCM proc, SCM args,
SCM *out_body, SCM *out_env);
static void prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
SCM exps, SCM *out_body,
SCM *inout_env);
#define CAR(x) SCM_CAR(x)
@ -270,8 +272,7 @@ eval (SCM x, SCM env)
* ARGS is the list of arguments. */
if (BOOT_CLOSURE_P (proc))
{
x = BOOT_CLOSURE_BODY (proc);
env = prepare_boot_closure_env_for_apply (proc, args);
prepare_boot_closure_env_for_apply (proc, args, &x, &env);
goto loop;
}
else
@ -285,8 +286,7 @@ eval (SCM x, SCM env)
if (BOOT_CLOSURE_P (proc))
{
x = BOOT_CLOSURE_BODY (proc);
env = prepare_boot_closure_env_for_eval (proc, argc, mx, env);
prepare_boot_closure_env_for_eval (proc, argc, mx, &x, &env);
goto loop;
}
else
@ -900,8 +900,9 @@ 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)
static void
prepare_boot_closure_env_for_apply (SCM proc, SCM args,
SCM *out_body, SCM *out_env)
{
int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
SCM env = BOOT_CLOSURE_ENV (proc);
@ -913,6 +914,8 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args)
scm_wrong_num_args (proc);
for (; scm_is_pair (args); args = CDR (args))
env = scm_cons (CAR (args), env);
*out_body = BOOT_CLOSURE_BODY (proc);
*out_env = env;
}
else if (BOOT_CLOSURE_IS_REST (proc))
{
@ -921,26 +924,35 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args)
for (; nreq; nreq--, args = CDR (args))
env = scm_cons (CAR (args), env);
env = scm_cons (args, env);
*out_body = BOOT_CLOSURE_BODY (proc);
*out_env = env;
}
else
{
int i, argc, nreq, nopt;
SCM body, rest, kw, inits, alt;
loop:
BOOT_CLOSURE_PARSE_FULL (proc, body, nargs, rest, nopt, kw, inits, alt);
argc = scm_ilength (args);
if (argc < nreq)
{
if (scm_is_true (alt))
abort ();
{
proc = alt;
goto loop;
}
else
scm_wrong_num_args (proc);
}
if (scm_is_false (kw) && argc > nreq + nopt && scm_is_false (rest))
{
if (scm_is_true (alt))
abort ();
{
proc = alt;
goto loop;
}
else
scm_wrong_num_args (proc);
}
@ -1035,14 +1047,15 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args)
}
}
}
}
return env;
*out_body = BOOT_CLOSURE_BODY (proc);
*out_env = env;
}
}
static SCM
static void
prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
SCM exps, SCM env)
SCM exps, SCM *out_body, SCM *inout_env)
{
int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
SCM new_env = BOOT_CLOSURE_ENV (proc);
@ -1051,40 +1064,44 @@ prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
&& !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);
new_env = scm_cons (eval (CAR (exps), *inout_env), new_env);
if (SCM_UNLIKELY (nreq != 0))
scm_wrong_num_args (proc);
*out_body = BOOT_CLOSURE_BODY (proc);
*inout_env = new_env;
}
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);
new_env = scm_cons (eval (CAR (exps), *inout_env), new_env);
{
SCM rest = SCM_EOL;
for (; scm_is_pair (exps); exps = CDR (exps))
rest = scm_cons (eval (CAR (exps), env), rest);
rest = scm_cons (eval (CAR (exps), *inout_env), rest);
new_env = scm_cons (scm_reverse (rest),
new_env);
}
*out_body = BOOT_CLOSURE_BODY (proc);
*inout_env = new_env;
}
else
{
SCM args = SCM_EOL;
for (; scm_is_pair (exps); exps = CDR (exps))
args = scm_cons (eval (CAR (exps), env), args);
scm_reverse_x (args, SCM_UNDEFINED);
new_env = prepare_boot_closure_env_for_apply (proc, args);
args = scm_cons (eval (CAR (exps), *inout_env), args);
args = scm_reverse_x (args, SCM_UNDEFINED);
prepare_boot_closure_env_for_apply (proc, args, out_body, inout_env);
}
return new_env;
}
static SCM
boot_closure_apply (SCM closure, SCM args)
{
return eval (BOOT_CLOSURE_BODY (closure),
prepare_boot_closure_env_for_apply (closure, args));
SCM body, env;
prepare_boot_closure_env_for_apply (closure, args, &body, &env);
return eval (body, env);
}
static int
@ -1098,6 +1115,7 @@ boot_closure_print (SCM closure, SCM port, scm_print_state *pstate)
scm_from_locale_symbol ("_"));
if (!BOOT_CLOSURE_IS_FIXED (closure) && BOOT_CLOSURE_HAS_REST_ARGS (closure))
args = scm_cons_star (scm_from_locale_symbol ("_"), args);
/* FIXME: optionals and rests */
scm_display (args, port);
scm_putc ('>', port);
return 1;

105
libguile/memoize.c
View file

@ -273,6 +273,8 @@ static SCM scm_m_eval_when (SCM xorig, SCM env);
static SCM scm_m_if (SCM xorig, SCM env);
static SCM scm_m_lambda (SCM xorig, SCM env);
static SCM scm_m_lambda_star (SCM xorig, SCM env);
static SCM scm_m_case_lambda (SCM xorig, SCM env);
static SCM scm_m_case_lambda_star (SCM xorig, SCM env);
static SCM scm_m_let (SCM xorig, SCM env);
static SCM scm_m_letrec (SCM xorig, SCM env);
static SCM scm_m_letstar (SCM xorig, SCM env);
@ -431,6 +433,8 @@ SCM_SYNTAX (s_letrec, "letrec", scm_m_letrec);
SCM_SYNTAX (s_letstar, "let*", scm_m_letstar);
SCM_SYNTAX (s_or, "or", scm_m_or);
SCM_SYNTAX (s_lambda_star, "lambda*", scm_m_lambda_star);
SCM_SYNTAX (s_case_lambda, "case-lambda", scm_m_case_lambda);
SCM_SYNTAX (s_case_lambda_star, "case-lambda*", scm_m_case_lambda_star);
SCM_GLOBAL_SYMBOL (scm_sym_apply, "apply");
SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
@ -457,6 +461,8 @@ SCM_GLOBAL_SYMBOL (scm_sym_at_prompt, "@prompt");
SCM_GLOBAL_SYMBOL (scm_sym_quote, "quote");
SCM_GLOBAL_SYMBOL (scm_sym_set_x, "set!");
SCM_SYMBOL (sym_lambda_star, "lambda*");
SCM_SYMBOL (sym_case_lambda, "case-lambda");
SCM_SYMBOL (sym_case_lambda_star, "case-lambda*");
SCM_SYMBOL (sym_eval, "eval");
SCM_SYMBOL (sym_load, "load");
@ -903,6 +909,83 @@ scm_m_lambda_star (SCM expr, SCM env)
SCM_BOOL_F));
}
static SCM
patch_case_lambda (SCM a, SCM b)
{
SCM mx, body, rest, kw_indices, inits;
int nreq, nopt;
mx = SCM_SMOB_OBJECT_1 (a);
body = CAR (mx);
mx = CDR (mx);
if (scm_is_null (CDR (mx)))
{
nreq = scm_to_int16 (CAR (mx));
rest = SCM_BOOL_F;
nopt = 0;
kw_indices = SCM_BOOL_F;
inits = SCM_EOL;
}
else if (scm_is_null (CDDR (mx)))
{
nreq = scm_to_int16 (CAR (mx));
rest = CADR (mx);
nopt = 0;
kw_indices = SCM_BOOL_F;
inits = SCM_EOL;
}
else
{
nreq = scm_to_int16 (CAR (mx));
rest = CADR (mx);
nopt = scm_to_int16 (CADDR (mx));
kw_indices = CADDDR (mx);
inits = CADR (CDDDR (mx));
}
return MAKMEMO_LAMBDA
(body, FULL_ARITY (nreq, rest, nopt, kw_indices, inits, b));
}
static SCM
scm_m_case_lambda (SCM expr, SCM env)
{
SCM ret, clauses;
const long length = scm_ilength (expr);
ASSERT_SYNTAX (length >= 1, s_bad_expression, expr);
ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
clauses = scm_reverse (CDR (expr));
ret = SCM_BOOL_F;
for (; scm_is_pair (clauses); clauses = CDR (clauses))
ret = patch_case_lambda
(scm_m_lambda (scm_cons (scm_sym_lambda, CAR (clauses)), env), ret);
return ret;
}
static SCM
scm_m_case_lambda_star (SCM expr, SCM env)
{
SCM ret, clauses;
const long length = scm_ilength (expr);
ASSERT_SYNTAX (length >= 1, s_bad_expression, expr);
ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
clauses = scm_reverse (CDR (expr));
ret = SCM_BOOL_F;
for (; scm_is_pair (clauses); clauses = CDR (clauses))
ret = patch_case_lambda
(scm_m_lambda_star (scm_cons (sym_lambda_star, CAR (clauses)), env), ret);
return ret;
}
/* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
static void
check_bindings (const SCM bindings, const SCM expr)
@ -1521,19 +1604,23 @@ unmemoize (const SCM expr)
}
else
{
SCM body = CAR (args), spec = CDR (args), alt;
SCM body = CAR (args), spec = CDR (args), alt, tail;
alt = CADDR (CDDDR (spec));
if (scm_is_true (alt))
abort ();
tail = CDR (unmemoize (alt));
else
tail = SCM_EOL;
return scm_list_3 (sym_lambda_star,
scm_list_5 (CAR (spec),
CADR (spec),
CADDR (spec),
CADDDR (spec),
unmemoize_exprs (CADR (CDDDR (spec)))),
unmemoize (body));
return scm_cons
(sym_case_lambda_star,
scm_cons (scm_list_2 (scm_list_5 (CAR (spec),
CADR (spec),
CADDR (spec),
CADDDR (spec),
unmemoize_exprs (CADR (CDDDR (spec)))),
unmemoize (body)),
tail));
}
case SCM_M_LET:
return scm_list_3 (scm_sym_let,

32
module/ice-9/eval.scm
View file

@ -218,20 +218,26 @@
;; A unique marker for unbound keywords.
(define unbound-arg (list 'unbound-arg))
;; Procedures with rest, optional, or keyword arguments.
;; Procedures with rest, optional, or keyword arguments, potentially with
;; multiple arities, as with case-lambda.
(define (make-general-closure env body nreq rest? nopt kw inits alt)
(lambda args
(define alt-proc
(and alt
(apply make-general-closure env (memoized-expression-data alt))))
(lambda %args
(let lp ((env env)
(nreq nreq)
(args args))
(if (> nreq 0)
(nreq* nreq)
(args %args))
(if (> nreq* 0)
;; First, bind required arguments.
(if (null? args)
(scm-error 'wrong-number-of-args
"eval" "Wrong number of arguments"
'() #f)
(if alt
(apply alt-proc %args)
(scm-error 'wrong-number-of-args
"eval" "Wrong number of arguments"
'() #f))
(lp (cons (car args) env)
(1- nreq)
(1- nreq*)
(cdr args)))
;; Move on to optional arguments.
(if (not kw)
@ -245,9 +251,11 @@
(eval body (cons args env))
(if (null? args)
(eval body env)
(scm-error 'wrong-number-of-args
"eval" "Wrong number of arguments"
'() #f)))
(if alt
(apply alt-proc %args)
(scm-error 'wrong-number-of-args
"eval" "Wrong number of arguments"
'() #f))))
(if (null? args)
(lp (cons (eval (car inits) env) env)
(1- nopt) args (cdr inits))