mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 14:21:10 +02:00
Code Activity

primitive support for lambda*

Browse source 
* libguile/memoize.c (scm_m_lambda_star): Define lambda* in the
  pre-psyntax env, and make it memoize lambda* expressions.

* libguile/eval.c (BOOT_CLOSURE_PARSE_FULL): New helper.
  (error_invalid_keyword, error_unrecognized_keyword): New helpers.
  (prepare_boot_closure_env_for_apply): Flesh out application of boot
  closures with "full" arity.
  (prepare_boot_closure_env_for_eval): Punt to
  prepare_boot_closure_env_for_eval for the full-arity case.

* module/ice-9/eval.scm (make-fixed-closure): Rename from `closure', and
  just handle fixed arities, where there is no rest argument..
  (make-general-closure): New helper, a procedure, that returns a
  closure that can take rest, optional, and keyword arguments.
  (eval): Adapt to call make-fixed-closure or make-general-closure as
  appropriate.

* test-suite/tests/optargs.test ("lambda* inits"): Test the memoizer as
  well.
This commit is contained in:
Andy Wingo 2010-05-13 17:15:10 +02:00
parent 9658182d5f
commit d8a071fc4e
4 changed files with 472 additions and 31 deletions
Download patch file Download diff file Expand all files Collapse all files

149
libguile/eval.c
View file

@ -114,8 +114,16 @@ static scm_t_bits scm_tc16_boot_closure;
#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)))
#define BOOT_CLOSURE_PARSE_FULL(x,body,nargs,rest,nopt,kw,inits,alt) \
do { SCM mx = BOOT_CLOSURE_CODE (x); \
body = CAR (mx); mx = CDR (mx); \
nreq = SCM_I_INUM (CAR (mx)); mx = CDR (mx); \
rest = CAR (mx); mx = CDR (mx); \
nopt = SCM_I_INUM (CAR (mx)); mx = CDR (mx); \
kw = CAR (mx); mx = CDR (mx); \
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);
@ -139,6 +147,21 @@ static void error_used_before_defined (void)
"Variable used before given a value", SCM_EOL, SCM_BOOL_F);
}
static void error_invalid_keyword (SCM proc)
{
scm_error_scm (scm_from_locale_symbol ("keyword-argument-error"), proc,
scm_from_locale_string ("Invalid keyword"), SCM_EOL,
SCM_BOOL_F);
}
static void error_unrecognized_keyword (SCM proc)
{
scm_error_scm (scm_from_locale_symbol ("keyword-argument-error"), proc,
scm_from_locale_string ("Unrecognized keyword"), SCM_EOL,
SCM_BOOL_F);
}
/* the environment:
(VAL ... . MOD)
If MOD is #f, it means the environment was captured before modules were
@ -900,7 +923,119 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args)
env = scm_cons (args, env);
}
else
abort ();
{
int i, argc, nreq, nopt;
SCM body, rest, kw, inits, alt;
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 ();
else
scm_wrong_num_args (proc);
}
if (scm_is_false (kw) && argc > nreq + nopt && scm_is_false (rest))
{
if (scm_is_true (alt))
abort ();
else
scm_wrong_num_args (proc);
}
for (i = 0; i < nreq; i++, args = CDR (args))
env = scm_cons (CAR (args), env);
if (scm_is_false (kw))
{
/* Optional args (possibly), but no keyword args. */
for (; i < argc && i < nreq + nopt;
i++, args = CDR (args))
{
env = scm_cons (CAR (args), env);
inits = CDR (inits);
}
for (; i < nreq + nopt; i++, inits = CDR (inits))
env = scm_cons (eval (CAR (inits), env), env);
if (scm_is_true (rest))
env = scm_cons (args, env);
}
else
{
SCM aok;
aok = CAR (kw);
kw = CDR (kw);
/* Keyword args. As before, but stop at the first keyword. */
for (; i < argc && i < nreq + nopt && !scm_is_keyword (CAR (args));
i++, args = CDR (args), inits = CDR (inits))
env = scm_cons (CAR (args), env);
for (; i < nreq + nopt; i++, inits = CDR (inits))
env = scm_cons (eval (CAR (inits), env), env);
if (scm_is_true (rest))
{
env = scm_cons (args, env);
i++;
}
/* Now fill in env with unbound values, limn the rest of the args for
keywords, and fill in unbound values with their inits. */
{
int imax = i - 1;
int kw_start_idx = i;
SCM walk, k, v;
for (walk = kw; scm_is_pair (walk); walk = CDR (walk))
if (SCM_I_INUM (CDAR (walk)) > imax)
imax = SCM_I_INUM (CDAR (walk));
for (; i <= imax; i++)
env = scm_cons (SCM_UNDEFINED, env);
if (scm_is_pair (args) && scm_is_pair (CDR (args)))
for (; scm_is_pair (args) && scm_is_pair (CDR (args));
args = CDR (args))
{
k = CAR (args); v = CADR (args);
if (!scm_is_keyword (k))
{
if (scm_is_true (rest))
continue;
else
break;
}
for (walk = kw; scm_is_pair (walk); walk = CDR (walk))
if (scm_is_eq (k, CAAR (walk)))
{
/* Well... ok, list-set! isn't the nicest interface, but
hey. */
int iset = imax - SCM_I_INUM (CDAR (walk));
scm_list_set_x (env, SCM_I_MAKINUM (iset), v);
args = CDR (args);
break;
}
if (scm_is_null (walk) && scm_is_false (aok))
error_unrecognized_keyword (proc);
}
if (scm_is_pair (args) && scm_is_false (rest))
error_invalid_keyword (proc);
/* Now fill in unbound values, evaluating init expressions in their
appropriate environment. */
for (i = imax - kw_start_idx; scm_is_pair (inits); i--, inits = CDR (inits))
{
SCM tail = scm_list_tail (env, SCM_I_MAKINUM (i));
if (SCM_UNBNDP (CAR (tail)))
SCM_SETCAR (tail, eval (CAR (inits), CDR (tail)));
}
}
}
}
return env;
}
@ -935,7 +1070,13 @@ prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
}
}
else
abort ();
{
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);
}
return new_env;
}

171
libguile/memoize.c
View file

@ -272,6 +272,7 @@ static SCM scm_m_with_fluids (SCM xorig, SCM env);
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_let (SCM xorig, SCM env);
static SCM scm_m_letrec (SCM xorig, SCM env);
static SCM scm_m_letstar (SCM xorig, SCM env);
@ -429,6 +430,7 @@ SCM_SYNTAX (s_cond, "cond", scm_m_cond);
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_GLOBAL_SYMBOL (scm_sym_apply, "apply");
SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
@ -454,6 +456,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_or, "or");
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_eval, "eval");
SCM_SYMBOL (sym_load, "load");
@ -461,6 +464,11 @@ SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, "quasiquote");
SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
SCM_KEYWORD (kw_allow_other_keys, "allow-other-keys");
SCM_KEYWORD (kw_optional, "optional");
SCM_KEYWORD (kw_key, "key");
SCM_KEYWORD (kw_rest, "rest");
static SCM
scm_m_at (SCM expr, SCM env SCM_UNUSED)
@ -732,6 +740,169 @@ scm_m_lambda (SCM expr, SCM env SCM_UNUSED)
return MAKMEMO_LAMBDA (body, FIXED_ARITY (nreq));
}
static SCM
scm_m_lambda_star (SCM expr, SCM env)
{
SCM req, opt, kw, allow_other_keys, rest, formals, body;
SCM inits, kw_indices;
int nreq, nopt;
const long length = scm_ilength (expr);
ASSERT_SYNTAX (length >= 1, s_bad_expression, expr);
ASSERT_SYNTAX (length >= 3, s_missing_expression, expr);
formals = CADR (expr);
body = CDDR (expr);
nreq = nopt = 0;
req = opt = kw = SCM_EOL;
rest = allow_other_keys = SCM_BOOL_F;
while (scm_is_pair (formals) && scm_is_symbol (CAR (formals)))
{
nreq++;
req = scm_cons (CAR (formals), req);
formals = scm_cdr (formals);
}
if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_optional))
{
formals = CDR (formals);
while (scm_is_pair (formals)
&& (scm_is_symbol (CAR (formals)) || scm_is_pair (CAR (formals))))
{
nopt++;
opt = scm_cons (CAR (formals), opt);
formals = scm_cdr (formals);
}
}
if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_key))
{
formals = CDR (formals);
while (scm_is_pair (formals)
&& (scm_is_symbol (CAR (formals)) || scm_is_pair (CAR (formals))))
{
kw = scm_cons (CAR (formals), kw);
formals = scm_cdr (formals);
}
}
if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_allow_other_keys))
{
formals = CDR (formals);
allow_other_keys = SCM_BOOL_T;
}
if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_rest))
{
if (scm_ilength (formals) != 2)
syntax_error (s_bad_formals, CADR (expr), expr);
else
rest = CADR (formals);
}
else if (scm_is_symbol (formals))
rest = formals;
else if (!scm_is_null (formals))
syntax_error (s_bad_formals, CADR (expr), expr);
else
rest = SCM_BOOL_F;
/* Now, iterate through them a second time, building up an expansion-time
environment, checking, expanding and canonicalizing the opt/kw init forms,
and eventually memoizing the body as well. Note that the rest argument, if
any, is expanded before keyword args, thus necessitating the second
pass.
Also note that the specific environment during expansion of init
expressions here needs to coincide with the environment when psyntax
expands. A lot of effort for something that is only used in the bootstrap
memoizer, you say? Yes. Yes it is.
*/
inits = SCM_EOL;
/* nreq is already set, and req is already reversed: simply extend. */
env = memoize_env_extend (env, req);
/* Build up opt inits and env */
opt = scm_reverse_x (opt, SCM_EOL);
while (scm_is_pair (opt))
{
SCM x = CAR (opt);
if (scm_is_symbol (x))
inits = scm_cons (MAKMEMO_QUOTE (SCM_BOOL_F), inits);
else if (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)))
inits = scm_cons (memoize (CADR (x), env), inits);
else
syntax_error (s_bad_formals, CADR (expr), expr);
env = scm_cons (scm_is_symbol (x) ? x : CAR (x), env);
opt = CDR (opt);
}
/* Process rest before keyword args */
if (scm_is_true (rest))
env = scm_cons (rest, env);
/* Build up kw inits, env, and kw-indices alist */
if (scm_is_null (kw))
kw_indices = SCM_BOOL_F;
else
{
int idx = nreq + nopt + (scm_is_true (rest) ? 1 : 0);
kw_indices = SCM_EOL;
kw = scm_reverse_x (kw, SCM_EOL);
while (scm_is_pair (kw))
{
SCM x, sym, k, init;
x = CAR (kw);
if (scm_is_symbol (x))
{
sym = x;
init = SCM_BOOL_F;
k = scm_symbol_to_keyword (sym);
}
else if (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)))
{
sym = CAR (x);
init = CADR (x);
k = scm_symbol_to_keyword (sym);
}
else if (scm_ilength (x) == 3 && scm_is_symbol (CAR (x))
&& scm_is_keyword (CADDR (x)))
{
sym = CAR (x);
init = CADR (x);
k = CADDR (x);
}
else
syntax_error (s_bad_formals, CADR (expr), expr);
kw_indices = scm_acons (k, SCM_I_MAKINUM (idx++), kw_indices);
inits = scm_cons (memoize (init, env), inits);
env = scm_cons (sym, env);
kw = CDR (kw);
}
kw_indices = scm_cons (allow_other_keys,
scm_reverse_x (kw_indices, SCM_UNDEFINED));
}
/* We should check for no duplicates, but given that psyntax does this
already, we can punt on it here... */
inits = scm_reverse_x (inits, SCM_UNDEFINED);
body = memoize_sequence (body, env);
if (scm_is_false (kw_indices) && scm_is_false (rest) && !nopt)
return MAKMEMO_LAMBDA (body, FIXED_ARITY (nreq));
if (scm_is_false (kw_indices) && !nopt)
return MAKMEMO_LAMBDA (body, REST_ARITY (nreq, SCM_BOOL_T));
else
return MAKMEMO_LAMBDA (body, FULL_ARITY (nreq, rest, nopt, kw_indices, inits,
SCM_BOOL_F));
}
/* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
static void
check_bindings (const SCM bindings, const SCM expr)

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

@ -55,7 +55,8 @@
(and (current-module) the-root-module)
env)))))
(define-syntax make-closure
;; Fast case for procedures with fixed arities.
(define-syntax make-fixed-closure
(lambda (x)
(define *max-static-argument-count* 8)
(define (make-formals n)
@ -66,22 +67,17 @@
(string (integer->char (+ (char->integer #\a) i))))))
(iota n)))
(syntax-case x ()
((_ eval nreq rest? body env) (not (identifier? #'env))
((_ eval nreq body env) (not (identifier? #'env))
#'(let ((e env))
(make-closure eval nreq rest? body e)))
((_ eval nreq rest? body env)
(make-fixed-closure eval nreq body e)))
((_ eval nreq body env)
#`(case nreq
#,@(map (lambda (nreq)
(let ((formals (make-formals nreq)))
#`((#,nreq)
(if rest?
(lambda (#,@formals . rest)
(eval body
(cons* rest #,@(reverse formals)
env)))
(lambda (#,@formals)
(eval body
(cons* #,@(reverse formals) env)))))))
(lambda (#,@formals)
(eval body
(cons* #,@(reverse formals) env))))))
(iota *max-static-argument-count*))
(else
#,(let ((formals (make-formals *max-static-argument-count*)))
@ -91,13 +87,11 @@
(args more))
(if (zero? nreq)
(eval body
(if rest?
(cons args new-env)
(if (not (null? args))
(scm-error 'wrong-number-of-args
"eval" "Wrong number of arguments"
'() #f)
new-env)))
(if (null? args)
new-env
(scm-error 'wrong-number-of-args
"eval" "Wrong number of arguments"
'() #f)))
(if (null? args)
(scm-error 'wrong-number-of-args
"eval" "Wrong number of arguments"
@ -218,6 +212,114 @@
(define primitive-eval
(let ()
;; We pre-generate procedures with fixed arities, up to some number of
;; arguments; see make-fixed-closure above.
;; A unique marker for unbound keywords.
(define unbound-arg (list 'unbound-arg))
;; Procedures with rest, optional, or keyword arguments.
(define (make-general-closure env body nreq rest? nopt kw inits alt)
(lambda args
(let lp ((env env)
(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)
(lp (cons (car args) env)
(1- nreq)
(cdr args)))
;; Move on to optional arguments.
(if (not kw)
;; Without keywords, bind optionals from arguments.
(let lp ((env env)
(nopt nopt)
(args args)
(inits inits))
(if (zero? nopt)
(if rest?
(eval body (cons args env))
(if (null? args)
(eval body env)
(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))
(lp (cons (car args) env)
(1- nopt) (cdr args) (cdr inits)))))
;; With keywords, we stop binding optionals at the first
;; keyword.
(let lp ((env env)
(nopt* nopt)
(args args)
(inits inits))
(if (> nopt* 0)
(if (or (null? args) (keyword? (car args)))
(lp (cons (eval (car inits) env) env)
(1- nopt*) args (cdr inits))
(lp (cons (car args) env)
(1- nopt*) (cdr args) (cdr inits)))
;; Finished with optionals.
(let* ((aok (car kw))
(kw (cdr kw))
(kw-base (+ nopt nreq (if rest? 1 0)))
(imax (let lp ((imax (1- kw-base)) (kw kw))
(if (null? kw)
imax
(lp (max (cdar kw) imax)
(cdr kw)))))
;; Fill in kwargs with "undefined" vals.
(env (let lp ((i kw-base)
;; Also, here we bind the rest
;; arg, if any.
(env (if rest? (cons args env) env)))
(if (<= i imax)
(lp (1+ i) (cons unbound-arg env))
env))))
;; Now scan args for keywords.
(let lp ((args args))
(if (and (pair? args) (pair? (cdr args))
(keyword? (car args)))
(let ((kw-pair (assq (car args) kw))
(v (cadr args)))
(if kw-pair
;; Found a known keyword; set its value.
(list-set! env (- imax (cdr kw-pair)) v)
;; Unknown keyword.
(if (not aok)
(scm-error 'keyword-argument-error
"eval" "Unrecognized keyword"
'() #f)))
(lp (cddr args)))
(if (pair? args)
(if rest?
;; Be lenient parsing rest args.
(lp (cdr args))
(scm-error 'keyword-argument-error
"eval" "Invalid keyword"
'() #f))
;; Finished parsing keywords. Fill in
;; uninitialized kwargs by evalling init
;; expressions in their appropriate
;; environment.
(let lp ((i (- imax kw-base))
(inits inits))
(if (pair? inits)
(let ((tail (list-tail env i)))
(if (eq? (car tail) unbound-arg)
(set-car! tail
(eval (car inits)
(cdr tail))))
(lp (1- i) (cdr inits)))
;; Finally, eval the body.
(eval body env))))))))))))))
;; The "engine". EXP is a memoized expression.
(define (eval exp env)
(memoized-expression-case exp
@ -256,9 +358,13 @@
(cons (eval (car inits) env) new-env)))))
(('lambda (body nreq . tail))
(make-closure eval nreq (and (pair? tail) (car tail))
body (capture-env env)))
(if (null? tail)
(make-fixed-closure eval nreq body (capture-env env))
(if (null? (cdr tail))
(make-general-closure (capture-env env) body nreq (car tail)
0 #f '() #f)
(apply make-general-closure (capture-env env) body nreq tail))))
(('begin (first . rest))
(let lp ((first first) (rest rest))
(if (null? rest)

33
test-suite/tests/optargs.test
View file

@ -1,7 +1,7 @@
;;;; optargs.test --- test suite for optional arg processing -*- scheme -*-
;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001
;;;;
;;;; Copyright (C) 2001, 2006, 2009 Free Software Foundation, Inc.
;;;; Copyright (C) 2001, 2006, 2009, 2010 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -45,11 +45,34 @@
exc (compile 'exp #:to 'value
#:env (current-module)))))))
(define-syntax c&m&e
(syntax-rules (pass-if pass-if-exception)
((_ (pass-if test-name exp))
(begin (pass-if (string-append test-name " (eval)")
(primitive-eval 'exp))
(pass-if (string-append test-name " (memoized eval)")
(primitive-eval (memoize-expression 'exp)))
(pass-if (string-append test-name " (compile)")
(compile 'exp #:to 'value #:env (current-module)))))
((_ (pass-if-exception test-name exc exp))
(begin (pass-if-exception (string-append test-name " (eval)")
exc (primitive-eval 'exp))
(pass-if-exception (string-append test-name " (memoized eval)")
exc (primitive-eval (memoize-expression 'exp)))
(pass-if-exception (string-append test-name " (compile)")
exc (compile 'exp #:to 'value
#:env (current-module)))))))
(define-syntax with-test-prefix/c&e
(syntax-rules ()
((_ section-name exp ...)
(with-test-prefix section-name (c&e exp) ...))))
(define-syntax with-test-prefix/c&m&e
(syntax-rules ()
((_ section-name exp ...)
(with-test-prefix section-name (c&m&e exp) ...))))
(with-test-prefix/c&e "optional argument processing"
(pass-if "local defines work with optional arguments"
(eval '(begin
@ -174,12 +197,12 @@
(equal? (f 1 2 3 #:x 'x #:z 'z)
'(x #f z (1 2 3 #:x x #:z z))))))
(with-test-prefix/c&e "lambda* inits"
(with-test-prefix/c&m&e "lambda* inits"
(pass-if "can bind lexicals within inits"
(begin
(define* (qux #:optional a
#:key (b (or a 13) #:a))
b)
(define qux
(lambda* (#:optional a #:key (b (or a 13) #:a))
b))
#t))
(pass-if "testing qux"
(and (equal? (qux) 13)