0.pre8.82:

        Fixed bugs caught by Paul Dietz' test suite:
        * CONVERT-MORE-CALL failed on ((LAMBDA (&KEY) 1)
          :ALLOW-OTHER-KEYS T) (fixed by Gerd Moellmann);
        * &WHOLE and &REST arguments in a macro lambda list may be
          patterns.

diff --git a/BUGS b/BUGS
index 3389897..efd3641 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -1315,6 +1315,10 @@ WORKAROUND:
   (When this is fixed, the ROOM entries in tests/smoke.impure.lisp
   should be uncommented.)
 
+248: "reporting errors in type specifier syntax"
+  (TYPEP 1 '(SYMBOL NIL)) says something about "unknown type
+  specifier".
+
 DEFUNCT CATEGORIES OF BUGS
   IR1-#:
     These labels were used for bugs related to the old IR1 interpreter.

diff --git a/NEWS b/NEWS
index db164bb..4ba4e2f 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1658,9 +1658,9 @@ changes in sbcl-0.8.0 relative to sbcl-0.7.14
   * bug fix: INTERACTIVE-STREAM-P now works on streams associated with
     Unix file descriptors, instead of blowing up. (thanks to Antonio
     Martinez)
-  * Experimental native threads support, on x86 Linux.  This is not 
+  * Experimental native threads support, on x86 Linux.  This is not
     compiled in by default: you need to add :SB-THREAD to the target
-    features.  See the "Beyond ANSI" chapter of the manual for 
+    features.  See the "Beyond ANSI" chapter of the manual for
     details.
   * sb-aclrepl module improvements: an integrated inspector, added
     repl features, and a bug fix to :trace command.
@@ -1677,6 +1677,9 @@ changes in sbcl-0.8.0 relative to sbcl-0.7.14
        causes an error;
     ** condition slots are now initialized once each, not multiple
        times;  (thanks to Gerd Moellmann)
+    ** CONVERT-MORE-CALL failed on a lambda list (&KEY);  (thanks to
+       Gerd Moellmann)
+    ** &WHOLE and &REST arguments in macro lambda lists are patterns;
 
 planned incompatible changes in 0.8.x:
   * (not done yet, but planned:) When the profiling interface settles

diff --git a/build-order.lisp-expr b/build-order.lisp-expr
index ed002e7..c31fc9b 100644 (file)
--- a/build-order.lisp-expr
+++ b/build-order.lisp-expr
@@ -96,9 +96,9 @@
  ("src/compiler/target/parms")
  ("src/code/early-array") ; needs "early-vm" numbers
 
+ ("src/code/early-extensions") ; on host for COLLECT, SYMBOLICATE, etc.
  ("src/code/parse-body")       ; on host for PARSE-BODY
  ("src/code/parse-defmacro")   ; on host for PARSE-DEFMACRO
- ("src/code/early-extensions") ; on host for COLLECT, SYMBOLICATE, etc.
  ("src/compiler/deftype")      ; on host for SB!XC:DEFTYPE
  ("src/compiler/defconstant")
  ("src/code/early-alieneval")  ; for vars needed both at build and run time

diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp
index d6a13e3..edd9323 100644 (file)
--- a/src/code/parse-defmacro.lisp
+++ b/src/code/parse-defmacro.lisp
@@ -77,8 +77,8 @@
         ;; considering at this point in the code. PATH-0 is the root of the
         ;; lambda list, which is the initial value of PATH.
         (path-0 (if toplevel
-                  `(cdr ,arg-list-name)
-                  arg-list-name))
+                     `(cdr ,arg-list-name)
+                     arg-list-name))
         (path path-0) ; (will change below)
         (now-processing :required)
         (maximum 0)
@@ -92,117 +92,126 @@
                           (reversed-result nil))
                          ((atom in-pdll)
                           (nreverse (if in-pdll
-                                      (list* in-pdll '&rest reversed-result)
-                                      reversed-result)))
+                                         (list* in-pdll '&rest reversed-result)
+                                         reversed-result)))
                        (push (car in-pdll) reversed-result)))
         rest-name restp allow-other-keys-p env-arg-used)
     (when (member '&whole (rest lambda-list))
       (error "&WHOLE may only appear first in ~S lambda-list." error-kind))
     (do ((rest-of-args lambda-list (cdr rest-of-args)))
        ((null rest-of-args))
-      (let ((var (car rest-of-args)))
-       (cond ((eq var '&whole)
-              (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
-                     (setq rest-of-args (cdr rest-of-args))
-                     (push-let-binding (car rest-of-args) arg-list-name nil))
-                    (t
-                     (defmacro-error "&WHOLE" error-kind name))))
-             ((eq var '&environment)
-              (cond (env-illegal
-                     (error "&ENVIRONMENT is not valid with ~S." error-kind))
-                    ((not toplevel)
-                     (error "&ENVIRONMENT is only valid at top level of ~
-                             lambda-list.")))
-              (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
-                     (setq rest-of-args (cdr rest-of-args))
-                     (push-let-binding (car rest-of-args) env-arg-name nil)
-                     (setq env-arg-used t))
-                    (t
-                     (defmacro-error "&ENVIRONMENT" error-kind name))))
-             ((or (eq var '&rest)
-                  (eq var '&body))
-              (cond (restp
-                     (defmacro-error (symbol-name var) error-kind name))
-                    ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
-                     (setq rest-of-args (cdr rest-of-args))
-                     (setq restp t)
-                     (push-let-binding (car rest-of-args) path nil))
-                    (t
-                     (defmacro-error (symbol-name var) error-kind name))))
-             ((eq var '&optional)
-              (setq now-processing :optionals))
-             ((eq var '&key)
-              (setq now-processing :keywords)
-              (setq rest-name (gensym "KEYWORDS-"))
-              (push rest-name *ignorable-vars*)
-              (setq restp t)
-              (push-let-binding rest-name path t))
-             ((eq var '&allow-other-keys)
-              (setq allow-other-keys-p t))
-             ((eq var '&aux)
-              (setq now-processing :auxs))
-             ((listp var)
-              (case now-processing
-                ((:required)
-                 (when restp
-                   (defmacro-error "required argument after &REST/&BODY" error-kind name))  
-                 (let ((sub-list-name (gensym "SUBLIST-")))
-                   (push-sub-list-binding sub-list-name `(car ,path) var
-                                          name error-kind error-fun)
-                   (parse-defmacro-lambda-list var sub-list-name name
-                                               error-kind error-fun))
-                 (setq path `(cdr ,path)
-                       minimum (1+ minimum)
-                       maximum (1+ maximum)))
-                ((:optionals)
-                 (destructuring-bind (varname &optional initform supplied-p)
-                     var
-                   (push-optional-binding varname initform supplied-p
-                                          `(not (null ,path)) `(car ,path)
-                                          name error-kind error-fun))
-                 (setq path `(cdr ,path)
-                       maximum (1+ maximum)))
-                ((:keywords)
-                 (let* ((keyword-given (consp (car var)))
-                        (variable (if keyword-given
-                                      (cadar var)
-                                      (car var)))
-                        (keyword (if keyword-given
-                                     (caar var)
-                                     (keywordicate variable)))
-                        (supplied-p (caddr var)))
-                   (push-optional-binding variable (cadr var) supplied-p
-                                          `(keyword-supplied-p ',keyword
-                                            ,rest-name)
-                                          `(lookup-keyword ',keyword
-                                            ,rest-name)
-                                          name error-kind error-fun)
-                   (push keyword keys)))
-                ((:auxs)
-                 (push-let-binding (car var) (cadr var) nil))))
-             ((symbolp var)
-              (case now-processing
-                ((:required)
-                 (when restp
-                   (defmacro-error "required argument after &REST/&BODY" error-kind name))
-                 (push-let-binding var `(car ,path) nil)
-                 (setq minimum (1+ minimum)
-                       maximum (1+ maximum)
-                       path `(cdr ,path)))
-                ((:optionals)
-                 (push-let-binding var `(car ,path) nil `(not (null ,path)))
-                 (setq path `(cdr ,path)
-                       maximum (1+ maximum)))
-                ((:keywords)
-                 (let ((key (keywordicate var)))
-                   (push-let-binding var
-                                     `(lookup-keyword ,key ,rest-name)
-                                     nil)
-                   (push key keys)))
-                ((:auxs)
-                 (push-let-binding var nil nil))))
-             (t
-              (error "non-symbol in lambda-list: ~S" var)))))
+      (macrolet ((process-sublist (var sublist-name path)
+                   (once-only ((var var))
+                     `(if (consp ,var)
+                          (let ((sub-list-name (gensym ,sublist-name)))
+                            (push-sub-list-binding sub-list-name ,path ,var
+                                                   name error-kind error-fun)
+                            (parse-defmacro-lambda-list ,var sub-list-name name
+                                                        error-kind error-fun))
+                          (push-let-binding ,var ,path nil)))))
+        (let ((var (car rest-of-args)))
+          (typecase var
+            (list
+             (case now-processing
+               ((:required)
+                (when restp
+                  (defmacro-error "required argument after &REST/&BODY"
+                      error-kind name))
+                (process-sublist var "SUBLIST-" `(car ,path))
+                (setq path `(cdr ,path)
+                      minimum (1+ minimum)
+                      maximum (1+ maximum)))
+               ((:optionals)
+                (destructuring-bind (varname &optional initform supplied-p)
+                    var
+                  (push-optional-binding varname initform supplied-p
+                                         `(not (null ,path)) `(car ,path)
+                                         name error-kind error-fun))
+                (setq path `(cdr ,path)
+                      maximum (1+ maximum)))
+               ((:keywords)
+                (let* ((keyword-given (consp (car var)))
+                       (variable (if keyword-given
+                                     (cadar var)
+                                     (car var)))
+                       (keyword (if keyword-given
+                                    (caar var)
+                                    (keywordicate variable)))
+                       (supplied-p (caddr var)))
+                  (push-optional-binding variable (cadr var) supplied-p
+                                         `(keyword-supplied-p ',keyword
+                                                              ,rest-name)
+                                         `(lookup-keyword ',keyword
+                                                          ,rest-name)
+                                         name error-kind error-fun)
+                  (push keyword keys)))
+               ((:auxs)
+                (push-let-binding (car var) (cadr var) nil))))
+            ((and symbol (not (eql nil)))
+             (case var
+               (&whole
+                (cond ((cdr rest-of-args)
+                       (setq rest-of-args (cdr rest-of-args))
+                       (process-sublist (car rest-of-args)
+                                        "WHOLE-LIST-" arg-list-name))
+                      (t
+                       (defmacro-error "&WHOLE" error-kind name))))
+               (&environment
+                (cond (env-illegal
+                       (error "&ENVIRONMENT is not valid with ~S." error-kind))
+                      ((not toplevel)
+                       (error "&ENVIRONMENT is only valid at top level of ~
+                             lambda-list.")))
+                (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
+                       (setq rest-of-args (cdr rest-of-args))
+                       (push-let-binding (car rest-of-args) env-arg-name nil)
+                       (setq env-arg-used t))
+                      (t
+                       (defmacro-error "&ENVIRONMENT" error-kind name))))
+               ((&rest &body)
+                (cond ((and (not restp) (cdr rest-of-args))
+                       (setq rest-of-args (cdr rest-of-args))
+                       (setq restp t)
+                       (process-sublist (car rest-of-args) "REST-LIST-" path))
+                      (t
+                       (defmacro-error (symbol-name var) error-kind name))))
+               (&optional
+                (setq now-processing :optionals))
+               (&key
+                (setq now-processing :keywords)
+                (setq rest-name (gensym "KEYWORDS-"))
+                (push rest-name *ignorable-vars*)
+                (setq restp t)
+                (push-let-binding rest-name path t))
+               (&allow-other-keys
+                (setq allow-other-keys-p t))
+               (&aux
+                (setq now-processing :auxs))
+               ;; FIXME: Other lambda list keywords.
+               (t
+                (case now-processing
+                  ((:required)
+                   (when restp
+                     (defmacro-error "required argument after &REST/&BODY"
+                         error-kind name))
+                   (push-let-binding var `(car ,path) nil)
+                   (setq minimum (1+ minimum)
+                         maximum (1+ maximum)
+                         path `(cdr ,path)))
+                  ((:optionals)
+                   (push-let-binding var `(car ,path) nil `(not (null ,path)))
+                   (setq path `(cdr ,path)
+                         maximum (1+ maximum)))
+                  ((:keywords)
+                   (let ((key (keywordicate var)))
+                     (push-let-binding var
+                                       `(lookup-keyword ,key ,rest-name)
+                                       nil)
+                     (push key keys)))
+                  ((:auxs)
+                   (push-let-binding var nil nil))))))
+            (t
+             (error "non-symbol in lambda-list: ~S" var))))))
     (let (;; common subexpression, suitable for passing to functions
          ;; which expect a MAXIMUM argument regardless of whether
          ;; there actually is a maximum number of arguments

diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index ae4ad08..4f59a87 100644 (file)
--- a/src/compiler/locall.lisp
+++ b/src/compiler/locall.lisp
@@ -637,7 +637,7 @@
       (collect ((call-args))
        (do ((var arglist (cdr var))
             (temp temps (cdr temp)))
-           (())
+           ((null var))
          (let ((info (lambda-var-arg-info (car var))))
            (if info
                (ecase (arg-info-kind info)

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 8154102..fb5d3e4 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -337,3 +337,7 @@
 (assert (equal (funcall (eval '(lambda (x &optional (y (pop x))) (list x y)))
                         '(1 2))
                '((2) 1)))
+
+;;; Bug reported by Paul Dietz on cmucl-imp and fixed by Gerd
+;;; Moellmann: CONVERT-MORE-CALL failed on the following call
+(assert (eq (eval '((lambda (&key) 'u) :allow-other-keys nil)) 'u))

diff --git a/version.lisp-expr b/version.lisp-expr
index 636210d..ac7c4c8 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre8.81"
+"0.pre8.82"