#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);
"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
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;
}
}
}
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;
}
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);
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, "=>");
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");
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)
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)
(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)
(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*)))
(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"
(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
(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)
;;;; 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
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
(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)
HCoop / bpt / guile.git / commitdiff