[armedbear-cvs] r11797 - trunk/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Wed Apr 29 19:11:46 UTC 2009
Author: ehuelsmann
Date: Wed Apr 29 15:11:44 2009
New Revision: 11797
Log:
Fix the build. Removal of &aux variables rewriting broke it.
Modified:
trunk/abcl/src/org/armedbear/lisp/precompiler.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Wed Apr 29 15:11:44 2009
@@ -553,101 +553,105 @@
(defun maybe-rewrite-lambda (form)
(let* ((lambda-list (cadr form)))
- (multiple-value-bind (body decls doc)
- (parse-body (cddr form))
- (let (state let-bindings new-lambda-list
- (non-constants 0))
- (do* ((vars lambda-list (cdr vars))
- (var (car vars) (car vars)))
- ((endp vars))
- (push (car vars) new-lambda-list)
- (let ((replacement (gensym)))
- (flet ((parse-compound-argument (arg)
- "Returns the values NAME, KEYWORD, INITFORM, INITFORM-P,
+ (if (not (or (memq '&optional lambda-list)
+ (memq '&key lambda-list)))
+ ;; no need to rewrite: no arguments with possible initforms anyway
+ form
+ (multiple-value-bind (body decls doc)
+ (parse-body (cddr form))
+ (let (state let-bindings new-lambda-list
+ (non-constants 0))
+ (do* ((vars lambda-list (cdr vars))
+ (var (car vars) (car vars)))
+ ((or (endp vars) (eq '&aux (car vars))))
+ (push (car vars) new-lambda-list)
+ (let ((replacement (gensym)))
+ (flet ((parse-compound-argument (arg)
+ "Returns the values NAME, KEYWORD, INITFORM, INITFORM-P,
SUPPLIED-P and SUPPLIED-P-P assuming ARG is a compound argument."
- (destructuring-bind
- (name &optional (initform nil initform-supplied-p)
- (supplied-p nil supplied-p-supplied-p))
- (if (listp arg) arg (list arg))
- (if (listp name)
- (values (cadr name) (car name)
- initform initform-supplied-p
- supplied-p supplied-p-supplied-p)
- (values name (make-keyword name)
- initform initform-supplied-p
- supplied-p supplied-p-supplied-p)))))
- (case var
- (&optional (setf state :optional))
- (&key (setf state :key))
- ((&whole &environment &rest &body &allow-other-keys)
- ;; do nothing special
- )
- (t
- (cond
- ((atom var)
- (setf (car new-lambda-list)
- (if (eq state :key)
- (list (list (make-keyword var) replacement))
- replacement))
- (push (list var replacement) let-bindings))
- ((constantp (second var))
- ;; so, we must have a consp-type var we're looking at
- ;; and it has a constantp initform
- (multiple-value-bind
- (name keyword initform initform-supplied-p
- supplied-p supplied-p-supplied-p)
- (parse-compound-argument var)
- (let ((var-form (if (eq state :key)
- (list keyword replacement)
- replacement))
- (supplied-p-replacement (gensym)))
+ (destructuring-bind
+ (name &optional (initform nil initform-supplied-p)
+ (supplied-p nil supplied-p-supplied-p))
+ (if (listp arg) arg (list arg))
+ (if (listp name)
+ (values (cadr name) (car name)
+ initform initform-supplied-p
+ supplied-p supplied-p-supplied-p)
+ (values name (make-keyword name)
+ initform initform-supplied-p
+ supplied-p supplied-p-supplied-p)))))
+ (case var
+ (&optional (setf state :optional))
+ (&key (setf state :key))
+ ((&whole &environment &rest &body &allow-other-keys)
+ ;; do nothing special
+ )
+ (t
+ (cond
+ ((atom var)
(setf (car new-lambda-list)
- (cond
- ((not initform-supplied-p)
- (list var-form))
- ((not supplied-p-supplied-p)
- (list var-form initform))
- (t
- (list var-form initform
- supplied-p-replacement))))
- (push (list name replacement) let-bindings)
- ;; if there was a 'supplied-p' variable, it might
- ;; be used in the declarations. Since those will be
- ;; moved below the LET* block, we need to move the
- ;; supplied-p parameter too.
- (when supplied-p-supplied-p
- (push (list supplied-p supplied-p-replacement)
- let-bindings)))))
- (t
- (incf non-constants)
- ;; this is either a keyword or an optional argument
- ;; with a non-constantp initform
- (multiple-value-bind
- (name keyword initform initform-supplied-p
- supplied-p supplied-p-supplied-p)
- (parse-compound-argument var)
- (declare (ignore initform-supplied-p))
- (let ((var-form (if (eq state :key)
- (list keyword replacement)
- replacement))
- (supplied-p-replacement (gensym)))
- (setf (car new-lambda-list)
- (list var-form nil supplied-p-replacement))
- (push (list name `(if ,supplied-p-replacement
- ,replacement ,initform))
- let-bindings)
- (when supplied-p-supplied-p
- (push (list supplied-p supplied-p-replacement)
- let-bindings)))))))))))
- (if (zerop non-constants)
- ;; there was no reason to rewrite...
- form
- (let ((rv
- `(lambda ,(nreverse new-lambda-list)
- ,@(when doc (list doc))
- (let* ,(nreverse let-bindings)
- , at decls , at body))))
- rv))))))
+ (if (eq state :key)
+ (list (list (make-keyword var) replacement))
+ replacement))
+ (push (list var replacement) let-bindings))
+ ((constantp (second var))
+ ;; so, we must have a consp-type var we're looking at
+ ;; and it has a constantp initform
+ (multiple-value-bind
+ (name keyword initform initform-supplied-p
+ supplied-p supplied-p-supplied-p)
+ (parse-compound-argument var)
+ (let ((var-form (if (eq state :key)
+ (list keyword replacement)
+ replacement))
+ (supplied-p-replacement (gensym)))
+ (setf (car new-lambda-list)
+ (cond
+ ((not initform-supplied-p)
+ (list var-form))
+ ((not supplied-p-supplied-p)
+ (list var-form initform))
+ (t
+ (list var-form initform
+ supplied-p-replacement))))
+ (push (list name replacement) let-bindings)
+ ;; if there was a 'supplied-p' variable, it might
+ ;; be used in the declarations. Since those will be
+ ;; moved below the LET* block, we need to move the
+ ;; supplied-p parameter too.
+ (when supplied-p-supplied-p
+ (push (list supplied-p supplied-p-replacement)
+ let-bindings)))))
+ (t
+ (incf non-constants)
+ ;; this is either a keyword or an optional argument
+ ;; with a non-constantp initform
+ (multiple-value-bind
+ (name keyword initform initform-supplied-p
+ supplied-p supplied-p-supplied-p)
+ (parse-compound-argument var)
+ (declare (ignore initform-supplied-p))
+ (let ((var-form (if (eq state :key)
+ (list keyword replacement)
+ replacement))
+ (supplied-p-replacement (gensym)))
+ (setf (car new-lambda-list)
+ (list var-form nil supplied-p-replacement))
+ (push (list name `(if ,supplied-p-replacement
+ ,replacement ,initform))
+ let-bindings)
+ (when supplied-p-supplied-p
+ (push (list supplied-p supplied-p-replacement)
+ let-bindings)))))))))))
+ (if (zerop non-constants)
+ ;; there was no reason to rewrite...
+ form
+ (let ((rv
+ `(lambda ,(nreverse new-lambda-list)
+ ,@(when doc (list doc))
+ (let* ,(nreverse let-bindings)
+ , at decls , at body))))
+ rv)))))))
(defun precompile-lambda-list (form)
(let (new)
More information about the armedbear-cvs
mailing list