X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=657e665cfbdb533ce082031a1f08ea59710fad40;hb=49095724dfe553133b0e85e68497245b02536619;hp=4122b7b36e450fbe14cbd86376b882361658a943;hpb=ef793f0d484ac3a527e945a62c93f904d73049a6;p=sbcl.git

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 4122b7b..657e665 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -23,29 +23,13 @@
 
 (in-package "SB-PCL")
 
-
 ;;; methods
 ;;;
 ;;; Methods themselves are simple inanimate objects. Most properties of
 ;;; methods are immutable, methods cannot be reinitialized. The following
 ;;; properties of methods can be changed:
 ;;;   METHOD-GENERIC-FUNCTION
-;;;   METHOD-FUNCTION       ??
-
-(defmethod method-function ((method standard-method))
-  (or (slot-value method 'function)
-      (let ((fmf (slot-value method 'fast-function)))
-        (unless fmf ; The :BEFORE SHARED-INITIALIZE method prevents this.
-          (error "~S doesn't seem to have a METHOD-FUNCTION." method))
-        (setf (slot-value method 'function)
-              (method-function-from-fast-function fmf)))))
-
-(defmethod accessor-method-class ((method standard-accessor-method))
-  (car (slot-value method 'specializers)))
-
-(defmethod accessor-method-class ((method standard-writer-method))
-  (cadr (slot-value method 'specializers)))
-
+
 ;;; initialization
 ;;;
 ;;; Error checking is done in before methods. Because of the simplicity of
@@ -53,152 +37,124 @@
 ;;;
 ;;; Methods are not reinitializable.
 
-(define-condition metaobject-initialization-violation 
-    (reference-condition simple-condition)
-  ())  
+(define-condition metaobject-initialization-violation
+    (reference-condition simple-error)
+  ())
 
 (macrolet ((def (name args control)
                `(defmethod ,name ,args
                  (declare (ignore initargs))
                  (error 'metaobject-initialization-violation
-                  :format-control ,(format nil "~@<~A~@:>" control )
+                  :format-control ,(format nil "~@<~A~@:>" control)
                   :format-arguments (list ',name)
-                  :references (list '(:amop :initialization "Method"))))))
+                  :references (list '(:amop :initialization method))))))
   (def reinitialize-instance ((method method) &rest initargs)
     "Method objects cannot be redefined by ~S.")
   (def change-class ((method method) new &rest initargs)
     "Method objects cannot be redefined by ~S.")
-  ;; FIXME: NEW being a subclass of METHOD.
-  (def update-instance-for-redefined-class ((method method) added discarded 
+  ;; NEW being a subclass of method is dealt with in the general
+  ;; method of CHANGE-CLASS
+  (def update-instance-for-redefined-class ((method method) added discarded
                                             plist &rest initargs)
     "No behaviour specified for ~S on method objects.")
   (def update-instance-for-different-class (old (new method) &rest initargs)
     "No behaviour specified for ~S on method objects.")
   (def update-instance-for-different-class ((old method) new &rest initargs)
     "No behaviour specified for ~S on method objects."))
-  
-(defmethod legal-documentation-p ((object standard-method) x)
-  (if (or (null x) (stringp x))
-      t
-      "a string or NULL"))
-
-(defmethod legal-lambda-list-p ((object standard-method) x)
-  (declare (ignore x))
-  t)
-
-(defmethod legal-method-function-p ((object standard-method) x)
-  (if (functionp x)
-      t
-      "a function"))
-
-(defmethod legal-qualifiers-p ((object standard-method) x)
+
+(define-condition invalid-method-initarg (simple-program-error)
+  ((method :initarg :method :reader invalid-method-initarg-method))
+  (:report
+   (lambda (c s)
+     (format s "~@<In initialization of ~S:~2I~_~?~@:>"
+             (invalid-method-initarg-method c)
+             (simple-condition-format-control c)
+             (simple-condition-format-arguments c)))))
+
+(defun invalid-method-initarg (method format-control &rest args)
+  (error 'invalid-method-initarg :method method
+         :format-control format-control :format-arguments args))
+
+(defun check-documentation (method doc)
+  (unless (or (null doc) (stringp doc))
+    (invalid-method-initarg method "~@<~S of ~S is neither ~S nor a ~S.~@:>"
+                            :documentation doc 'null 'string)))
+(defun check-lambda-list (method ll)
+  nil)
+
+(defun check-method-function (method fun)
+  (unless (functionp fun)
+    (invalid-method-initarg method "~@<~S of ~S is not a ~S.~@:>"
+                            :function fun 'function)))
+
+(defun check-qualifiers (method qualifiers)
   (flet ((improper-list ()
-           (return-from legal-qualifiers-p "Is not a proper list.")))
-    (dolist-carefully (q x improper-list)
-      (let ((ok (legal-qualifier-p object q)))
-        (unless (eq ok t)
-          (return-from legal-qualifiers-p
-            (format nil "Contains ~S which ~A" q ok)))))
-    t))
-
-(defmethod legal-qualifier-p ((object standard-method) x)
-  (if (and x (atom x))
-      t
-      "is not a non-null atom"))
-
-(defmethod legal-slot-name-p ((object standard-method) x)
-  (cond ((not (symbolp x)) "is not a symbol")
-        (t t)))
-
-(defmethod legal-specializers-p ((object standard-method) x)
+           (invalid-method-initarg method
+                                   "~@<~S of ~S is an improper list.~@:>"
+                                   :qualifiers qualifiers)))
+    (dolist-carefully (q qualifiers improper-list)
+      (unless (and q (atom q))
+        (invalid-method-initarg method
+                                "~@<~S, in ~S ~S, is not a non-~S atom.~@:>"
+                                q :qualifiers qualifiers 'null)))))
+
+(defun check-slot-name (method name)
+  (unless (symbolp name)
+    (invalid-method-initarg "~@<~S of ~S is not a ~S.~@:>"
+                            :slot-name name 'symbol)))
+
+(defun check-specializers (method specializers)
   (flet ((improper-list ()
-           (return-from legal-specializers-p "Is not a proper list.")))
-    (dolist-carefully (s x improper-list)
-      (let ((ok (legal-specializer-p object s)))
-        (unless (eq ok t)
-          (return-from legal-specializers-p
-            (format nil "Contains ~S which ~A" s ok)))))
-    t))
-
-(defvar *allow-experimental-specializers-p* nil)
-
-(defmethod legal-specializer-p ((object standard-method) x)
-  (if (if *allow-experimental-specializers-p*
-          (specializerp x)
-          (or (classp x)
-              (eql-specializer-p x)))
-      t
-      "is neither a class object nor an EQL specializer"))
-
-(defmethod shared-initialize :before ((method standard-method)
-                                      slot-names
-                                      &key qualifiers
-                                           lambda-list
-                                           specializers
-                                           function
-                                           fast-function
-                                           documentation)
+           (invalid-method-initarg method
+                                   "~@<~S of ~S is an improper list.~@:>"
+                                   :specializers specializers)))
+    (dolist-carefully (s specializers improper-list)
+      (unless (specializerp s)
+        (invalid-method-initarg method
+                                "~@<~S, in ~S ~S, is not a ~S.~@:>"
+                                s :specializers specializers 'specializer)))
+    ;; KLUDGE: ANSI says that it's not valid to have methods
+    ;; specializing on classes which are "not defined", leaving
+    ;; unclear what the definedness of a class is; AMOP suggests that
+    ;; forward-referenced-classes, since they have proper names and
+    ;; all, are at least worthy of some level of definition.  We allow
+    ;; methods specialized on forward-referenced-classes, but it's
+    ;; non-portable and potentially dubious, so
+    (let ((frcs (remove-if-not #'forward-referenced-class-p specializers)))
+      (unless (null frcs)
+        (style-warn "~@<Defining a method using ~
+                     ~V[~;~1{~S~}~;~1{~S and ~S~}~:;~{~#[~;and ~]~S~^, ~}~] ~
+                     as ~2:*~V[~;a specializer~:;specializers~].~@:>"
+                    (length frcs) frcs)))))
+
+(defmethod shared-initialize :before
+    ((method standard-method) slot-names &key
+     qualifiers lambda-list specializers function documentation)
   (declare (ignore slot-names))
-  (flet ((lose (initarg value string)
-           (error "when initializing the method ~S:~%~
-                   The ~S initialization argument was: ~S.~%~
-                   which ~A."
-                  method initarg value string)))
-    (let ((check-qualifiers    (legal-qualifiers-p method qualifiers))
-          (check-lambda-list   (legal-lambda-list-p method lambda-list))
-          (check-specializers  (legal-specializers-p method specializers))
-          (check-fun (legal-method-function-p method
-                                              (or function
-                                                  fast-function)))
-          (check-documentation (legal-documentation-p method documentation)))
-      (unless (eq check-qualifiers t)
-        (lose :qualifiers qualifiers check-qualifiers))
-      (unless (eq check-lambda-list t)
-        (lose :lambda-list lambda-list check-lambda-list))
-      (unless (eq check-specializers t)
-        (lose :specializers specializers check-specializers))
-      (unless (eq check-fun t)
-        (lose :function function check-fun))
-      (unless (eq check-documentation t)
-        (lose :documentation documentation check-documentation)))))
-
-(defmethod shared-initialize :before ((method standard-accessor-method)
-                                      slot-names
-                                      &key slot-name slot-definition)
+  ;; FIXME: it's not clear to me (CSR, 2006-08-09) why methods get
+  ;; this extra paranoia and nothing else does; either everything
+  ;; should be aggressively checking initargs, or nothing much should.
+  ;; In either case, it would probably be better to have :type
+  ;; declarations in slots, which would then give a suitable type
+  ;; error (if we implement type-checking for slots...) rather than
+  ;; this hand-crafted thing.
+  (check-qualifiers method qualifiers)
+  (check-lambda-list method lambda-list)
+  (check-specializers method specializers)
+  (check-method-function method function)
+  (check-documentation method documentation))
+
+(defmethod shared-initialize :before
+    ((method standard-accessor-method) slot-names &key
+     slot-name slot-definition)
   (declare (ignore slot-names))
   (unless slot-definition
-    (let ((legalp (legal-slot-name-p method slot-name)))
-      ;; FIXME: nasty convention; should be renamed to ILLEGAL-SLOT-NAME-P and
-      ;; ILLEGALP, and the convention redone to be less twisty
-      (unless (eq legalp t)
-        (error "The value of the :SLOT-NAME initarg ~A." legalp)))))
+    (check-slot-name method slot-name)))
 
 (defmethod shared-initialize :after ((method standard-method) slot-names
-                                     &rest initargs
-                                     &key qualifiers method-spec plist)
-  (declare (ignore slot-names method-spec plist))
-  (initialize-method-function initargs nil method)
-  (setf (plist-value method 'qualifiers) qualifiers)
-  #+ignore
-  (setf (slot-value method 'closure-generator)
-        (method-function-closure-generator (slot-value method 'function))))
-
-(defmethod shared-initialize :after ((method standard-accessor-method)
-                                     slot-names
-                                     &key)
-  (declare (ignore slot-names))
-  (with-slots (slot-name slot-definition)
-    method
-    (unless slot-definition
-      (let ((class (accessor-method-class method)))
-        (when (slot-class-p class)
-          (setq slot-definition (find slot-name (class-direct-slots class)
-                                      :key #'slot-definition-name)))))
-    (when (and slot-definition (null slot-name))
-      (setq slot-name (slot-definition-name slot-definition)))))
-
-(defmethod method-qualifiers ((method standard-method))
-  (plist-value method 'qualifiers))
+                                     &rest initargs &key ((method-cell method-cell)))
+  (declare (ignore slot-names method-cell))
+  (initialize-method-function initargs method))
 
 (defvar *the-class-generic-function*
   (find-class 'generic-function))
@@ -247,64 +203,40 @@
              (initarg-error :method-combination
                             method-combination
                             "a method combination object")))
-          ((slot-boundp generic-function 'method-combination))
+          ((slot-boundp generic-function '%method-combination))
           (t
            (initarg-error :method-combination
                           "not supplied"
                           "a method combination object")))))
-
-#||
-(defmethod reinitialize-instance ((generic-function standard-generic-function)
-                                  &rest initargs
-                                  &key name
-                                       lambda-list
-                                       argument-precedence-order
-                                       declarations
-                                       documentation
-                                       method-class
-                                       method-combination)
-  (declare (ignore documentation declarations argument-precedence-order
-                   lambda-list name method-class method-combination))
-  (macrolet ((add-initarg (check name slot-name)
-               `(unless ,check
-                  (push (slot-value generic-function ,slot-name) initargs)
-                  (push ,name initargs))))
-;   (add-initarg name :name 'name)
-;   (add-initarg lambda-list :lambda-list 'lambda-list)
-;   (add-initarg argument-precedence-order
-;                :argument-precedence-order
-;                'argument-precedence-order)
-;   (add-initarg declarations :declarations 'declarations)
-;   (add-initarg documentation :documentation 'documentation)
-;   (add-initarg method-class :method-class 'method-class)
-;   (add-initarg method-combination :method-combination 'method-combination)
-    (apply #'call-next-method generic-function initargs)))
-||#
 
-;;; These two are scheduled for demolition.
-(defun real-add-named-method (generic-function-name
-                              qualifiers
-                              specializers
-                              lambda-list
-                              &rest other-initargs)
+(defun find-generic-function (name &optional (errorp t))
+  (let ((fun (and (fboundp name) (fdefinition name))))
+    (cond
+      ((and fun (typep fun 'generic-function)) fun)
+      (errorp (error "No generic function named ~S." name))
+      (t nil))))
+
+(defun real-add-named-method (generic-function-name qualifiers
+                              specializers lambda-list &rest other-initargs)
   (unless (and (fboundp generic-function-name)
                (typep (fdefinition generic-function-name) 'generic-function))
-    (style-warn "implicitly creating new generic function ~S"
-                generic-function-name))
-  ;; XXX What about changing the class of the generic function if
-  ;; there is one? Whose job is that, anyway? Do we need something
-  ;; kind of like CLASS-FOR-REDEFINITION?
-  (let* ((generic-function
-           (ensure-generic-function generic-function-name))
-         (specs (parse-specializers specializers))
-         (proto (method-prototype-for-gf generic-function-name))
-         (new (apply #'make-instance (class-of proto)
-                                     :qualifiers qualifiers
-                                     :specializers specs
-                                     :lambda-list lambda-list
-                                     other-initargs)))
-    (add-method generic-function new)
-    new))
+    (warn 'implicit-generic-function-warning :name generic-function-name))
+  (let* ((existing-gf (find-generic-function generic-function-name nil))
+         (generic-function
+          (if existing-gf
+              (ensure-generic-function
+               generic-function-name
+               :generic-function-class (class-of existing-gf))
+              (ensure-generic-function generic-function-name)))
+         (proto (method-prototype-for-gf generic-function-name)))
+    ;; FIXME: Destructive modification of &REST list.
+    (setf (getf (getf other-initargs 'plist) :name)
+          (make-method-spec generic-function qualifiers specializers))
+    (let ((new (apply #'make-instance (class-of proto)
+                      :qualifiers qualifiers :specializers specializers
+                      :lambda-list lambda-list other-initargs)))
+      (add-method generic-function new)
+      new)))
 
 (define-condition find-method-length-mismatch
     (reference-condition simple-error)
@@ -353,11 +285,14 @@
   ;; function, or an error is signaled."
   ;;
   ;; This error checking is done by REAL-GET-METHOD.
-  (real-get-method generic-function
-                   qualifiers
-                   (parse-specializers specializers)
-                   errorp
-                   t))
+  (real-get-method
+   generic-function qualifiers
+   ;; ANSI for FIND-METHOD seems to imply that in fact specializers
+   ;; should always be passed in parsed form instead of being parsed
+   ;; at this point.  Since there's no ANSI-blessed way of getting an
+   ;; EQL specializer, that seems unnecessarily painful, so we are
+   ;; nice to our users.  -- CSR, 2007-06-01
+   (parse-specializers generic-function specializers) errorp t))
 
 ;;; Compute various information about a generic-function's arglist by looking
 ;;; at the argument lists of the methods. The hair for trying not to use
@@ -486,6 +421,18 @@
   (loop (when (null methods) (return gf))
         (real-add-method gf (pop methods) methods)))
 
+(define-condition new-value-specialization (reference-condition error)
+  ((%method :initarg :method :reader new-value-specialization-method))
+  (:report
+   (lambda (c s)
+     (format s "~@<Cannot add method ~S to ~S, as it specializes the ~
+                new-value argument.~@:>"
+             (new-value-specialization-method c)
+             #'(setf slot-value-using-class))))
+  (:default-initargs :references
+      (list '(:sbcl :node "Metaobject Protocol")
+            '(:amop :generic-function (setf slot-value-using-class)))))
+
 (defun real-add-method (generic-function method &optional skip-dfun-update-p)
   (when (method-generic-function method)
     (error "~@<The method ~S is already part of the generic ~
@@ -501,97 +448,120 @@
                     (= a-nopt b-nopt)
                     (eq (or a-keyp a-restp)
                         (or b-keyp b-restp)))))))
-      (let* ((name (generic-function-name generic-function))
-             (qualifiers (method-qualifiers method))
-             (specializers (method-specializers method))
-             (existing (get-method generic-function
-                                   qualifiers
-                                   specializers
-                                   nil)))
-
-        ;; If there is already a method like this one then we must get
-        ;; rid of it before proceeding.  Note that we call the generic
-        ;; function REMOVE-METHOD to remove it rather than doing it in
-        ;; some internal way.
-        (when (and existing (similar-lambda-lists-p existing method))
-          (remove-method generic-function existing))
-
-        (setf (method-generic-function method) generic-function)
-        (pushnew method (generic-function-methods generic-function))
-        (dolist (specializer specializers)
-          (add-direct-method specializer method))
-
-        ;; KLUDGE: SET-ARG-INFO contains the error-detecting logic for
-        ;; detecting attempts to add methods with incongruent lambda
-        ;; lists.  However, according to Gerd Moellmann on cmucl-imp,
-        ;; it also depends on the new method already having been added
-        ;; to the generic function.  Therefore, we need to remove it
-        ;; again on error:
-        (let ((remove-again-p t))
-          (unwind-protect
-               (progn
-                 (set-arg-info generic-function :new-method method)
-                 (setq remove-again-p nil))
-            (when remove-again-p
-              (remove-method generic-function method))))
-
-        ;; KLUDGE II: ANSI saith that it is not an error to add a
-        ;; method with invalid qualifiers to a generic function of the
-        ;; wrong kind; it's only an error at generic function
-        ;; invocation time; I dunno what the rationale was, and it
-        ;; sucks.  Nevertheless, it's probably a programmer error, so
-        ;; let's warn anyway. -- CSR, 2003-08-20
-        (let ((mc (generic-function-method-combination generic-functioN)))
-          (cond
-            ((eq mc *standard-method-combination*)
-             (when (and qualifiers
-                        (or (cdr qualifiers)
-                            (not (memq (car qualifiers)
-                                       '(:around :before :after)))))
-               (warn "~@<Invalid qualifiers for standard method combination ~
-                      in method ~S:~2I~_~S.~@:>"
-                     method qualifiers)))
-            ((short-method-combination-p mc)
-             (let ((mc-name (method-combination-type mc)))
-               (when (or (null qualifiers)
-                         (cdr qualifiers)
-                         (and (neq (car qualifiers) :around)
-                              (neq (car qualifiers) mc-name)))
-                 (warn "~@<Invalid qualifiers for ~S method combination ~
-                        in method ~S:~2I~_~S.~@:>"
-                       mc-name method qualifiers))))))
-
-        (unless skip-dfun-update-p
-          (update-ctors 'add-method
-                        :generic-function generic-function
-                        :method method)
-          (update-dfun generic-function))
-        (map-dependents generic-function
-                        (lambda (dep)
-                          (update-dependent generic-function
-                                            dep 'add-method method)))
-        generic-function)))
+    (let ((lock (gf-lock generic-function)))
+      ;; HANDLER-CASE takes care of releasing the lock and enabling
+      ;; interrupts before going forth with the error.
+      (handler-case
+          ;; System lock because interrupts need to be disabled as
+          ;; well: it would be bad to unwind and leave the gf in an
+          ;; inconsistent state.
+          (sb-thread::with-recursive-system-spinlock (lock)
+            (let* ((qualifiers (method-qualifiers method))
+                   (specializers (method-specializers method))
+                   (existing (get-method generic-function
+                                         qualifiers
+                                         specializers
+                                         nil)))
+
+              ;; If there is already a method like this one then we must get
+              ;; rid of it before proceeding.  Note that we call the generic
+              ;; function REMOVE-METHOD to remove it rather than doing it in
+              ;; some internal way.
+              (when (and existing (similar-lambda-lists-p existing method))
+                (remove-method generic-function existing))
+
+              ;; KLUDGE: We have a special case here, as we disallow
+              ;; specializations of the NEW-VALUE argument to (SETF
+              ;; SLOT-VALUE-USING-CLASS).  GET-ACCESSOR-METHOD-FUNCTION is
+              ;; the optimizing function here: it precomputes the effective
+              ;; method, assuming that there is no dispatch to be done on
+              ;; the new-value argument.
+              (when (and (eq generic-function #'(setf slot-value-using-class))
+                         (not (eq *the-class-t* (first specializers))))
+                (error 'new-value-specialization :method  method))
+
+              (setf (method-generic-function method) generic-function)
+              (pushnew method (generic-function-methods generic-function))
+              (dolist (specializer specializers)
+                (add-direct-method specializer method))
+
+              ;; KLUDGE: SET-ARG-INFO contains the error-detecting logic for
+              ;; detecting attempts to add methods with incongruent lambda
+              ;; lists.  However, according to Gerd Moellmann on cmucl-imp,
+              ;; it also depends on the new method already having been added
+              ;; to the generic function.  Therefore, we need to remove it
+              ;; again on error:
+              (let ((remove-again-p t))
+                (unwind-protect
+                     (progn
+                       (set-arg-info generic-function :new-method method)
+                       (setq remove-again-p nil))
+                  (when remove-again-p
+                    (remove-method generic-function method))))
+
+              ;; KLUDGE II: ANSI saith that it is not an error to add a
+              ;; method with invalid qualifiers to a generic function of the
+              ;; wrong kind; it's only an error at generic function
+              ;; invocation time; I dunno what the rationale was, and it
+              ;; sucks.  Nevertheless, it's probably a programmer error, so
+              ;; let's warn anyway. -- CSR, 2003-08-20
+              (let ((mc (generic-function-method-combination generic-functioN)))
+                (cond
+                  ((eq mc *standard-method-combination*)
+                   (when (and qualifiers
+                              (or (cdr qualifiers)
+                                  (not (memq (car qualifiers)
+                                             '(:around :before :after)))))
+                     (warn "~@<Invalid qualifiers for standard method ~
+                            combination in method ~S:~2I~_~S.~@:>"
+                           method qualifiers)))
+                  ((short-method-combination-p mc)
+                   (let ((mc-name (method-combination-type-name mc)))
+                     (when (or (null qualifiers)
+                               (cdr qualifiers)
+                               (and (neq (car qualifiers) :around)
+                                    (neq (car qualifiers) mc-name)))
+                       (warn "~@<Invalid qualifiers for ~S method combination ~
+                              in method ~S:~2I~_~S.~@:>"
+                             mc-name method qualifiers))))))
+
+              (unless skip-dfun-update-p
+                (update-ctors 'add-method
+                              :generic-function generic-function
+                              :method method)
+                (update-dfun generic-function))
+              (map-dependents generic-function
+                              (lambda (dep)
+                                (update-dependent generic-function
+                                                  dep 'add-method method)))))
+        (serious-condition (c)
+          (error c)))))
+  generic-function)
 
 (defun real-remove-method (generic-function method)
-  (when  (eq generic-function (method-generic-function method))
-    (let* ((name (generic-function-name generic-function))
-           (specializers (method-specializers method))
-           (methods (generic-function-methods generic-function))
-           (new-methods (remove method methods)))
-      (setf (method-generic-function method) nil)
-      (setf (generic-function-methods generic-function) new-methods)
-      (dolist (specializer (method-specializers method))
-        (remove-direct-method specializer method))
-      (set-arg-info generic-function)
-      (update-ctors 'remove-method
-                    :generic-function generic-function
-                    :method method)
-      (update-dfun generic-function)
-      (map-dependents generic-function
-                      (lambda (dep)
-                        (update-dependent generic-function
-                                          dep 'remove-method method)))
-      generic-function)))
+  (when (eq generic-function (method-generic-function method))
+    (let ((lock (gf-lock generic-function)))
+      ;; System lock because interrupts need to be disabled as well:
+      ;; it would be bad to unwind and leave the gf in an inconsistent
+      ;; state.
+      (sb-thread::with-recursive-system-spinlock (lock)
+        (let* ((specializers (method-specializers method))
+               (methods (generic-function-methods generic-function))
+               (new-methods (remove method methods)))
+          (setf (method-generic-function method) nil
+                (generic-function-methods generic-function) new-methods)
+          (dolist (specializer (method-specializers method))
+            (remove-direct-method specializer method))
+          (set-arg-info generic-function)
+          (update-ctors 'remove-method
+                        :generic-function generic-function
+                        :method method)
+          (update-dfun generic-function)
+          (map-dependents generic-function
+                          (lambda (dep)
+                            (update-dependent generic-function
+                                              dep 'remove-method method)))))))
+  generic-function)
 
 (defun compute-applicable-methods-function (generic-function arguments)
   (values (compute-applicable-methods-using-types
@@ -650,7 +620,7 @@
    ))
 
 (defmethod same-specializer-p ((specl1 specializer) (specl2 specializer))
-  nil)
+  (eql specl1 specl2))
 
 (defmethod same-specializer-p ((specl1 class) (specl2 class))
   (eq specl1 specl2))
@@ -669,14 +639,9 @@
 (defmethod specializer-class ((specializer eql-specializer))
   (class-of (slot-value specializer 'object)))
 
-(defvar *in-gf-arg-info-p* nil)
-(setf (gdefinition 'arg-info-reader)
-      (let ((mf (initialize-method-function
-                 (make-internal-reader-method-function
-                  'standard-generic-function 'arg-info)
-                 t)))
-        (lambda (&rest args) (funcall mf args nil))))
-
+(defun specializer-class-or-nil (specializer)
+  (and (standard-specializer-p specializer)
+       (specializer-class specializer)))
 
 (defun error-need-at-least-n-args (function n)
   (error 'simple-program-error
@@ -723,9 +688,7 @@
 (defun value-for-caching (gf classes)
   (let ((methods (compute-applicable-methods-using-types
                    gf (mapcar #'class-eq-type classes))))
-    (method-function-get (or (method-fast-function (car methods))
-                             (method-function (car methods)))
-                         :constant-value)))
+    (method-plist-value (car methods) :constant-value)))
 
 (defun default-secondary-dispatch-function (generic-function)
   (lambda (&rest args)
@@ -804,16 +767,17 @@
     (setf (gf-info-simple-accessor-type arg-info)
           (let* ((methods (generic-function-methods gf))
                  (class (and methods (class-of (car methods))))
-                 (type (and class
-                            (cond ((eq class
-                                       *the-class-standard-reader-method*)
-                                   'reader)
-                                  ((eq class
-                                       *the-class-standard-writer-method*)
-                                   'writer)
-                                  ((eq class
-                                       *the-class-standard-boundp-method*)
-                                   'boundp)))))
+                 (type
+                  (and class
+                       (cond ((or (eq class *the-class-standard-reader-method*)
+                                  (eq class *the-class-global-reader-method*))
+                              'reader)
+                             ((or (eq class *the-class-standard-writer-method*)
+                                  (eq class *the-class-global-writer-method*))
+                              'writer)
+                             ((or (eq class *the-class-standard-boundp-method*)
+                                  (eq class *the-class-global-boundp-method*))
+                              'boundp)))))
             (when (and (gf-info-c-a-m-emf-std-p arg-info)
                        type
                        (dolist (method (cdr methods) t)
@@ -874,13 +838,13 @@
   (unless *new-class*
     (update-std-or-str-methods gf type))
   (when (and (standard-svuc-method type) (structure-svuc-method type))
-    (flet ((update-class (class)
+    (flet ((update-accessor-info (class)
              (when (class-finalized-p class)
                (dolist (slotd (class-slots class))
                  (compute-slot-accessor-info slotd type gf)))))
       (if *new-class*
-          (update-class *new-class*)
-          (map-all-classes #'update-class 'slot-object)))))
+          (update-accessor-info *new-class*)
+          (map-all-classes #'update-accessor-info 'slot-object)))))
 
 (defvar *standard-slot-value-using-class-method* nil)
 (defvar *standard-setf-slot-value-using-class-method* nil)
@@ -951,18 +915,20 @@
                (set-structure-svuc-method type method)))))))
 
 (defun mec-all-classes-internal (spec precompute-p)
-  (cons (specializer-class spec)
-        (and (classp spec)
-             precompute-p
-             (not (or (eq spec *the-class-t*)
-                      (eq spec *the-class-slot-object*)
-                      (eq spec *the-class-standard-object*)
-                      (eq spec *the-class-structure-object*)))
-             (let ((sc (class-direct-subclasses spec)))
-               (when sc
-                 (mapcan (lambda (class)
-                           (mec-all-classes-internal class precompute-p))
-                         sc))))))
+  (let ((wrapper (class-wrapper (specializer-class spec))))
+    (unless (or (not wrapper) (invalid-wrapper-p wrapper))
+      (cons (specializer-class spec)
+            (and (classp spec)
+                 precompute-p
+                 (not (or (eq spec *the-class-t*)
+                          (eq spec *the-class-slot-object*)
+                          (eq spec *the-class-standard-object*)
+                          (eq spec *the-class-structure-object*)))
+                 (let ((sc (class-direct-subclasses spec)))
+                   (when sc
+                     (mapcan (lambda (class)
+                               (mec-all-classes-internal class precompute-p))
+                             sc))))))))
 
 (defun mec-all-classes (spec precompute-p)
   (let ((classes (mec-all-classes-internal spec precompute-p)))
@@ -995,21 +961,28 @@
          (nkeys (arg-info-nkeys arg-info))
          (metatypes (arg-info-metatypes arg-info))
          (wrappers (unless (eq nkeys 1) (make-list nkeys)))
-         (precompute-p (gf-precompute-dfun-and-emf-p arg-info))
-         (default '(default)))
+         (precompute-p (gf-precompute-dfun-and-emf-p arg-info)))
     (flet ((add-class-list (classes)
              (when (or (null new-class) (memq new-class classes))
-               (let ((wrappers (get-wrappers-from-classes
-                                nkeys wrappers classes metatypes)))
-                 (when (and wrappers
-                            (eq default (probe-cache cache wrappers default)))
+               (let ((%wrappers (get-wrappers-from-classes
+                                 nkeys wrappers classes metatypes)))
+                 (when (and %wrappers (not (probe-cache cache %wrappers)))
                    (let ((value (cond ((eq valuep t)
                                        (sdfun-for-caching generic-function
                                                           classes))
                                       ((eq valuep :constant-value)
                                        (value-for-caching generic-function
                                                           classes)))))
-                     (setq cache (fill-cache cache wrappers value))))))))
+                     ;; need to get them again, as finalization might
+                     ;; have happened in between, which would
+                     ;; invalidate wrappers.
+                     (let ((wrappers (get-wrappers-from-classes
+                                      nkeys wrappers classes metatypes)))
+                       (when (if (atom wrappers)
+                                 (not (invalid-wrapper-p wrappers))
+                                 (every (complement #'invalid-wrapper-p)
+                                        wrappers))
+                         (setq cache (fill-cache cache wrappers value))))))))))
       (if classes-list
           (mapc #'add-class-list classes-list)
           (dolist (method (generic-function-methods generic-function))
@@ -1282,7 +1255,8 @@
   (if (atom form)
       (default-test-converter form)
       (case (car form)
-        ((invoke-effective-method-function invoke-fast-method-call)
+        ((invoke-effective-method-function invoke-fast-method-call
+          invoke-effective-narrow-method-function)
          '.call.)
         (methods
          '.methods.)
@@ -1375,20 +1349,20 @@
     (let* ((name (generic-function-name generic-function))
            (arg-info (gf-arg-info generic-function))
            (metatypes (arg-info-metatypes arg-info))
+           (nargs (length metatypes))
            (applyp (arg-info-applyp arg-info))
-           (fmc-arg-info (cons (length metatypes) applyp))
+           (fmc-arg-info (cons nargs applyp))
            (arglist (if function-p
-                        (make-dfun-lambda-list metatypes applyp)
-                        (make-fast-method-call-lambda-list metatypes applyp))))
+                        (make-dfun-lambda-list nargs applyp)
+                        (make-fast-method-call-lambda-list nargs applyp))))
       (multiple-value-bind (cfunction constants)
           (get-fun1 `(lambda
                       ,arglist
                       ,@(unless function-p
-                          `((declare (ignore .pv-cell.
-                                             .next-method-call.))))
+                          `((declare (ignore .pv. .next-method-call.))))
                       (locally (declare #.*optimize-speed*)
                                (let ((emf ,net))
-                                 ,(make-emf-call metatypes applyp 'emf))))
+                                 ,(make-emf-call nargs applyp 'emf))))
                     #'net-test-converter
                     #'net-code-converter
                     (lambda (form)
@@ -1519,61 +1493,70 @@
   (declare (ignore class))
   (function-funcall (slot-definition-boundp-function slotd) object))
 
+(defun special-case-for-compute-discriminating-function-p (gf)
+  (or (eq gf #'slot-value-using-class)
+      (eq gf #'(setf slot-value-using-class))
+      (eq gf #'slot-boundp-using-class)))
+
 (defmethod compute-discriminating-function ((gf standard-generic-function))
-  (with-slots (dfun-state arg-info) gf
+  (let ((dfun-state (slot-value gf 'dfun-state)))
+    (when (special-case-for-compute-discriminating-function-p gf)
+      ;; if we have a special case for
+      ;; COMPUTE-DISCRIMINATING-FUNCTION, then (at least for the
+      ;; special cases implemented as of 2006-05-09) any information
+      ;; in the cache is misplaced.
+      (aver (null dfun-state)))
     (typecase dfun-state
-      (null (let ((name (generic-function-name gf)))
-              (when (eq name 'compute-applicable-methods)
-                (update-all-c-a-m-gf-info gf))
-              (cond ((eq name 'slot-value-using-class)
-                     (update-slot-value-gf-info gf 'reader)
-                     #'slot-value-using-class-dfun)
-                    ((equal name '(setf slot-value-using-class))
-                     (update-slot-value-gf-info gf 'writer)
-                     #'setf-slot-value-using-class-dfun)
-                    ((eq name 'slot-boundp-using-class)
-                     (update-slot-value-gf-info gf 'boundp)
-                     #'slot-boundp-using-class-dfun)
-                    ((gf-precompute-dfun-and-emf-p arg-info)
-                     (make-final-dfun gf))
-                    (t
-                     (make-initial-dfun gf)))))
+      (null
+       (when (eq gf #'compute-applicable-methods)
+         (update-all-c-a-m-gf-info gf))
+       (cond
+         ((eq gf #'slot-value-using-class)
+          (update-slot-value-gf-info gf 'reader)
+          #'slot-value-using-class-dfun)
+         ((eq gf #'(setf slot-value-using-class))
+          (update-slot-value-gf-info gf 'writer)
+          #'setf-slot-value-using-class-dfun)
+         ((eq gf #'slot-boundp-using-class)
+          (update-slot-value-gf-info gf 'boundp)
+          #'slot-boundp-using-class-dfun)
+         ((gf-precompute-dfun-and-emf-p (slot-value gf 'arg-info))
+          (make-final-dfun gf))
+         (t
+          (make-initial-dfun gf))))
       (function dfun-state)
       (cons (car dfun-state)))))
 
 (defmethod update-gf-dfun ((class std-class) gf)
   (let ((*new-class* class)
-        #|| (name (generic-function-name gf)) ||#
         (arg-info (gf-arg-info gf)))
-    (cond #||
-          ((eq name 'slot-value-using-class)
-           (update-slot-value-gf-info gf 'reader))
-          ((equal name '(setf slot-value-using-class))
-           (update-slot-value-gf-info gf 'writer))
-          ((eq name 'slot-boundp-using-class)
-           (update-slot-value-gf-info gf 'boundp))
-          ||#
-          ((gf-precompute-dfun-and-emf-p arg-info)
-           (multiple-value-bind (dfun cache info)
-               (make-final-dfun-internal gf)
-             (set-dfun gf dfun cache info) ; lest the cache be freed twice
-             (update-dfun gf dfun cache info))))))
+    (cond
+      ((special-case-for-compute-discriminating-function-p gf))
+      ((gf-precompute-dfun-and-emf-p arg-info)
+       (multiple-value-bind (dfun cache info)
+           (make-final-dfun-internal gf)
+         (update-dfun gf dfun cache info))))))
 
-(defun (setf class-name) (new-value class)
-  (let ((classoid (%wrapper-classoid (class-wrapper class))))
-    (setf (classoid-name classoid) new-value))
-  (reinitialize-instance class :name new-value))
-
-(defun (setf generic-function-name) (new-value generic-function)
-  (reinitialize-instance generic-function :name new-value))
+(defmethod (setf class-name) (new-value class)
+  (let ((classoid (wrapper-classoid (class-wrapper class))))
+    (if (and new-value (symbolp new-value))
+        (setf (classoid-name classoid) new-value)
+        (setf (classoid-name classoid) nil)))
+  (reinitialize-instance class :name new-value)
+  new-value)
+
+(defmethod (setf generic-function-name) (new-value generic-function)
+  (reinitialize-instance generic-function :name new-value)
+  new-value)
 
-(defmethod function-keywords ((method standard-method))
-  (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
+(defmethod function-keyword-parameters ((method standard-method))
+  (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p
+                        keywords keyword-parameters)
       (analyze-lambda-list (if (consp method)
                                (early-method-lambda-list method)
                                (method-lambda-list method)))
-    (declare (ignore nreq nopt keysp restp))
-    (values keywords allow-other-keys-p)))
+    (declare (ignore nreq nopt keysp restp keywords))
+    (values keyword-parameters allow-other-keys-p)))
 
 (defun method-ll->generic-function-ll (ll)
   (multiple-value-bind
@@ -1585,67 +1568,59 @@
                      (eq s '&allow-other-keys)))
                ll)))
 
-;;; This is based on the rules of method lambda list congruency defined in
-;;; the spec. The lambda list it constructs is the pretty union of the
-;;; lambda lists of all the methods. It doesn't take method applicability
-;;; into account at all yet.
+;;; This is based on the rules of method lambda list congruency
+;;; defined in the spec. The lambda list it constructs is the pretty
+;;; union of the lambda lists of the generic function and of all its
+;;; methods.  It doesn't take method applicability into account at all
+;;; yet.
+
+;;; (Notice that we ignore &AUX variables as they're not part of the
+;;; "public interface" of a function.)
+
 (defmethod generic-function-pretty-arglist
            ((generic-function standard-generic-function))
-  (let ((methods (generic-function-methods generic-function)))
-    (if methods
-      (let ((arglist ()))
-        ;; arglist is constructed from the GF's methods - maybe with
-        ;; keys and rest stuff added
-        (multiple-value-bind (required optional rest key allow-other-keys)
-            (method-pretty-arglist (car methods))
-          (dolist (m (cdr methods))
-            (multiple-value-bind (method-key-keywords
-                                  method-allow-other-keys
-                                  method-key)
-                (function-keywords m)
-              ;; we've modified function-keywords to return what we want as
-              ;;  the third value, no other change here.
-              (declare (ignore method-key-keywords))
-              (setq key (union key method-key))
-              (setq allow-other-keys (or allow-other-keys
-                                         method-allow-other-keys))))
-          (when allow-other-keys
-            (setq arglist '(&allow-other-keys)))
-          (when key
-            (setq arglist (nconc (list '&key) key arglist)))
-          (when rest
-            (setq arglist (nconc (list '&rest rest) arglist)))
-          (when optional
-            (setq arglist (nconc (list '&optional) optional arglist)))
-          (nconc required arglist)))
-      ;; otherwise we take the lambda-list from the GF directly, with no
-      ;; other 'keys' added ...
-      (let ((lambda-list (generic-function-lambda-list generic-function)))
-        lambda-list))))
-
-(defmethod method-pretty-arglist ((method standard-method))
-  (let ((required ())
-        (optional ())
-        (rest nil)
-        (key ())
-        (allow-other-keys nil)
-        (state 'required)
-        (arglist (method-lambda-list method)))
-    (dolist (arg arglist)
-      (cond ((eq arg '&optional)         (setq state 'optional))
-            ((eq arg '&rest)             (setq state 'rest))
-            ((eq arg '&key)              (setq state 'key))
-            ((eq arg '&allow-other-keys) (setq allow-other-keys t))
-            ((memq arg lambda-list-keywords))
-            (t
-             (ecase state
-               (required (push arg required))
-               (optional (push arg optional))
-               (key      (push arg key))
-               (rest     (setq rest arg))))))
-    (values (nreverse required)
-            (nreverse optional)
-            rest
-            (nreverse key)
-            allow-other-keys)))
-
+  (let ((gf-lambda-list (generic-function-lambda-list generic-function))
+        (methods (generic-function-methods generic-function)))
+    (if (null methods)
+        gf-lambda-list
+        (multiple-value-bind (gf.required gf.optional gf.rest gf.keys gf.allowp)
+            (%split-arglist gf-lambda-list)
+          ;; Possibly extend the keyword parameters of the gf by
+          ;; additional key parameters of its methods:
+          (let ((methods.keys nil) (methods.allowp nil))
+            (dolist (m methods)
+              (multiple-value-bind (m.keyparams m.allow-other-keys)
+                  (function-keyword-parameters m)
+                (setq methods.keys (union methods.keys m.keyparams :key #'maybe-car))
+                (setq methods.allowp (or methods.allowp m.allow-other-keys))))
+            (let ((arglist '()))
+              (when (or gf.allowp methods.allowp)
+                (push '&allow-other-keys arglist))
+              (when (or gf.keys methods.keys)
+                ;; We make sure that the keys of the gf appear before
+                ;; those of its methods, since they're probably more
+                ;; generally appliable.
+                (setq arglist (nconc (list '&key) gf.keys
+                                     (nset-difference methods.keys gf.keys)
+                                     arglist)))
+              (when gf.rest
+                (setq arglist (nconc (list '&rest gf.rest) arglist)))
+              (when gf.optional
+                (setq arglist (nconc (list '&optional) gf.optional arglist)))
+              (nconc gf.required arglist)))))))
+
+(defun maybe-car (thing)
+  (if (listp thing)
+      (car thing)
+      thing))
+
+
+(defun %split-arglist (lambda-list)
+  ;; This function serves to shrink the number of returned values of
+  ;; PARSE-LAMBDA-LIST to something handier.
+  (multiple-value-bind (required optional restp rest keyp keys allowp
+                        auxp aux morep more-context more-count)
+      (parse-lambda-list lambda-list)
+    (declare (ignore restp keyp auxp aux morep))
+    (declare (ignore more-context more-count))
+    (values required optional rest keys allowp)))
\ No newline at end of file