X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=849e499390873103dd2e119a7edbd3d84cbdc2e5;hb=355e6c09a8f7f528a838f7a50b99ad77811b51a2;hp=76a784f18fcc7d08fdd934bd518d014317002217;hpb=832f3b5652ae1b4a8888829cd4a1b391a8ca9952;p=sbcl.git

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 76a784f..849e499 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -209,36 +209,14 @@
            (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 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
@@ -248,11 +226,13 @@
                (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))
+  (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)))
          (specs (parse-specializers specializers))
          (proto (method-prototype-for-gf generic-function-name))
          (new (apply #'make-instance (class-of proto)
@@ -844,13 +824,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)
@@ -1263,7 +1243,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.)
@@ -1365,8 +1346,7 @@
           (get-fun1 `(lambda
                       ,arglist
                       ,@(unless function-p
-                          `((declare (ignore .pv-cell.
-                                             .next-method-call.))))
+                          `((declare (ignore .pv-cell. .next-method-call.))))
                       (locally (declare #.*optimize-speed*)
                                (let ((emf ,net))
                                  ,(make-emf-call metatypes applyp 'emf))))
@@ -1546,7 +1526,7 @@
          (update-dfun gf dfun cache info))))))
 
 (defmethod (setf class-name) (new-value class)
-  (let ((classoid (%wrapper-classoid (class-wrapper 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)))