0.7.9.28:

	Fix bug 172 (as per Matthew Danish sbcl-devel 2002-11-01)
		entomotomy: macro-lambda-list-rest-overly-permissive

diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp
index 4ef5bd4..d6a13e3 100644 (file)
--- a/src/code/parse-defmacro.lisp
+++ b/src/code/parse-defmacro.lisp
@@ -121,7 +121,9 @@
                      (defmacro-error "&ENVIRONMENT" error-kind name))))
              ((or (eq var '&rest)
                   (eq var '&body))
-              (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
+              (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))
@@ -140,8 +142,10 @@
              ((eq var '&aux)
               (setq now-processing :auxs))
              ((listp var)
-              (cond ; (since it's too early to use CASE)
-                ((eq now-processing :required)
+              (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)
@@ -150,7 +154,7 @@
                  (setq path `(cdr ,path)
                        minimum (1+ minimum)
                        maximum (1+ maximum)))
-                ((eq now-processing :optionals)
+                ((:optionals)
                  (destructuring-bind (varname &optional initform supplied-p)
                      var
                    (push-optional-binding varname initform supplied-p
@@ -158,7 +162,7 @@
                                           name error-kind error-fun))
                  (setq path `(cdr ,path)
                        maximum (1+ maximum)))
-                ((eq now-processing :keywords)
+                ((:keywords)
                  (let* ((keyword-given (consp (car var)))
                         (variable (if keyword-given
                                       (cadar var)
@@ -169,33 +173,33 @@
                         (supplied-p (caddr var)))
                    (push-optional-binding variable (cadr var) supplied-p
                                           `(keyword-supplied-p ',keyword
-                                                               ,rest-name)
+                                            ,rest-name)
                                           `(lookup-keyword ',keyword
-                                                           ,rest-name)
+                                            ,rest-name)
                                           name error-kind error-fun)
                    (push keyword keys)))
-                ((eq now-processing :auxs)
+                ((:auxs)
                  (push-let-binding (car var) (cadr var) nil))))
              ((symbolp var)
-              (cond ; (too early in bootstrapping to use CASE)
-               ;; FIXME: ^ This "too early in bootstrapping" is no
-               ;; longer an issue in current SBCL bootstrapping.
-                ((eq now-processing :required)
+              (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)))
-                ((eq now-processing :optionals)
+                ((:optionals)
                  (push-let-binding var `(car ,path) nil `(not (null ,path)))
                  (setq path `(cdr ,path)
                        maximum (1+ maximum)))
-                ((eq now-processing :keywords)
+                ((:keywords)
                  (let ((key (keywordicate var)))
                    (push-let-binding var
                                      `(lookup-keyword ,key ,rest-name)
                                      nil)
                    (push key keys)))
-                ((eq now-processing :auxs)
+                ((:auxs)
                  (push-let-binding var nil nil))))
              (t
               (error "non-symbol in lambda-list: ~S" var)))))

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index c583b22..1d5ce41 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -574,6 +574,11 @@ BUG 48c, not yet fixed:
 (defun bug221 (b x)
   (funcall (if b #'bug221f1 #'bug221f2) x))
 \f
+;;; bug 172: macro lambda lists were too permissive until 0.7.9.28
+;;; (fix provided by Matthew Danish) on sbcl-devel
+(assert (null (ignore-errors
+               (defmacro bug172 (&rest rest foo) `(list ,rest ,foo)))))
+\f
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself
 

diff --git a/version.lisp-expr b/version.lisp-expr
index 04df8cb..2cac6a9 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.9.27"
+"0.7.9.28"