X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=849e499390873103dd2e119a7edbd3d84cbdc2e5;hb=4d8b3b1da4d960a6ff768c9e6ee8f99bf270b631;hp=f488ae3cdb94b9379e41e0c3faef7ed1bf98da68;hpb=81c6f85203df993c7e29ac5f75d50c705dbbfd8d;p=sbcl.git

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index f488ae3..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)
@@ -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)))