Fix defmethod arglists leaking into make-method-lambda.

[sbcl.git] / src / pcl / boot.lisp

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 7e58e0a..2e558ff 100644 (file)
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -171,25 +171,33 @@ bootstrapping.
           (let ((car-option (car option)))
             (case car-option
               (declare
-               (when (and
-                      (consp (cadr option))
-                      (member (first (cadr option))
-                              ;; FIXME: this list is slightly weird.
-                              ;; ANSI (on the DEFGENERIC page) in one
-                              ;; place allows only OPTIMIZE; in
-                              ;; another place gives this list of
-                              ;; disallowed declaration specifiers.
-                              ;; This seems to be the only place where
-                              ;; the FUNCTION declaration is
-                              ;; mentioned; TYPE seems to be missing.
-                              ;; Very strange.  -- CSR, 2002-10-21
-                              '(declaration ftype function
-                                inline notinline special)))
-                 (error 'simple-program-error
-                        :format-control "The declaration specifier ~S ~
+               (dolist (spec (cdr option))
+                 (unless (consp spec)
+                   (error 'simple-program-error
+                          :format-control "~@<Invalid declaration specifier in ~
+                                           DEFGENERIC: ~S~:@>"
+                          :format-arguments (list spec)))
+                 (when (member (first spec)
+                               ;; FIXME: this list is slightly weird.
+                               ;; ANSI (on the DEFGENERIC page) in one
+                               ;; place allows only OPTIMIZE; in
+                               ;; another place gives this list of
+                               ;; disallowed declaration specifiers.
+                               ;; This seems to be the only place where
+                               ;; the FUNCTION declaration is
+                               ;; mentioned; TYPE seems to be missing.
+                               ;; Very strange.  -- CSR, 2002-10-21
+                               '(declaration ftype function
+                                 inline notinline special))
+                   (error 'simple-program-error
+                          :format-control "The declaration specifier ~S ~
                                          is not allowed inside DEFGENERIC."
-                        :format-arguments (list (cadr option))))
-               (push (cadr option) (initarg :declarations)))
+                          :format-arguments (list spec)))
+                 (if (or (eq 'optimize (first spec))
+                         (info :declaration :recognized (first spec)))
+                     (push spec (initarg :declarations))
+                     (warn "Ignoring unrecognized declaration in DEFGENERIC: ~S"
+                           spec))))
               (:method-combination
                (when (initarg car-option)
                  (duplicate-option car-option))
@@ -239,8 +247,8 @@ bootstrapping.
            (compile-or-load-defgeneric ',fun-name))
          (load-defgeneric ',fun-name ',lambda-list
                           (sb-c:source-location) ,@initargs)
-        ,@(mapcar #'expand-method-definition methods)
-        (fdefinition ',fun-name)))))
+         ,@(mapcar #'expand-method-definition methods)
+         (fdefinition ',fun-name)))))
 
 (defun compile-or-load-defgeneric (fun-name)
   (proclaim-as-fun-name fun-name)
@@ -310,8 +318,8 @@ bootstrapping.
       ;; belong here!
       (aver (not morep)))))
 \f
-(defmacro defmethod (&rest args)
-  (multiple-value-bind (name qualifiers lambda-list body)
+(defmacro defmethod (name &rest args)
+  (multiple-value-bind (qualifiers lambda-list body)
       (parse-defmethod args)
     `(progn
       ;; KLUDGE: this double expansion is quite a monumental
@@ -580,8 +588,13 @@ bootstrapping.
     ;; if there is are no non-standard prior MAKE-METHOD-LAMBDA methods -- or
     ;; unless they're fantastically unintrusive.
     (let* ((method-name *method-name*)
+           (method-lambda-list *method-lambda-list*)
+           ;; Macroexpansion caused by code-walking may call make-method-lambda and
+           ;; end up with wrong values
+           (*method-name* nil)
+           (*method-lambda-list* nil)
            (generic-function-name (when method-name (car method-name)))
-           (specialized-lambda-list (or *method-lambda-list*
+           (specialized-lambda-list (or method-lambda-list
                                         (ecase (car method-lambda)
                                           (lambda (second method-lambda))
                                           (named-lambda (third method-lambda)))))
@@ -1304,9 +1317,8 @@ bootstrapping.
                                       applyp))
      &body body
      &environment env)
-  (let* ((all-params (append args (when rest-arg (list rest-arg))))
-         (rebindings (when (or setq-p call-next-method-p)
-                       (mapcar (lambda (x) (list x x)) all-params))))
+  (let* ((rebindings (when (or setq-p call-next-method-p)
+                       (mapcar (lambda (x) (list x x)) parameters-setqd))))
     (if (not (or call-next-method-p setq-p closurep next-method-p-p applyp))
         `(locally
              ,@body)
@@ -1329,7 +1341,6 @@ bootstrapping.
                          (declare (optimize (sb-c:insert-step-conditions 0)))
                          (not (null ,next-method-call))))))
            (let ,rebindings
-             ,@(when rebindings `((declare (ignorable ,@all-params))))
              ,@body)))))
 
 ;;; CMUCL comment (Gerd Moellmann):
@@ -2193,12 +2204,14 @@ bootstrapping.
            (finalize-inheritance ,gf-class)))
      (remf ,all-keys :generic-function-class)
      (remf ,all-keys :environment)
-     (let ((combin (getf ,all-keys :method-combination '.shes-not-there.)))
-       (unless (eq combin '.shes-not-there.)
-         (setf (getf ,all-keys :method-combination)
-               (find-method-combination (class-prototype ,gf-class)
-                                        (car combin)
-                                        (cdr combin)))))
+     (let ((combin (getf ,all-keys :method-combination)))
+       (etypecase combin
+         (cons
+          (setf (getf ,all-keys :method-combination)
+                (find-method-combination (class-prototype ,gf-class)
+                                         (car combin)
+                                         (cdr combin))))
+         ((or null method-combination))))
     (let ((method-class (getf ,all-keys :method-class '.shes-not-there.)))
       (unless (eq method-class '.shes-not-there.)
         (setf (getf ,all-keys :method-class)
@@ -2604,14 +2617,13 @@ bootstrapping.
 ;;; is really implemented.
 (defun parse-defmethod (cdr-of-form)
   (declare (list cdr-of-form))
-  (let ((name (pop cdr-of-form))
-        (qualifiers ())
+  (let ((qualifiers ())
         (spec-ll ()))
     (loop (if (and (car cdr-of-form) (atom (car cdr-of-form)))
               (push (pop cdr-of-form) qualifiers)
               (return (setq qualifiers (nreverse qualifiers)))))
     (setq spec-ll (pop cdr-of-form))
-    (values name qualifiers spec-ll cdr-of-form)))
+    (values qualifiers spec-ll cdr-of-form)))
 
 (defun parse-specializers (generic-function specializers)
   (declare (list specializers))