X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=3fb6cd242a830c8cfcac7e23706c7676e5c74622;hb=3a0f3612dc2bbf3e4e8e7395bcbbf8cd1791b963;hp=9b8487f43174002777914260f19b53123bd3b0c9;hpb=1ffd970d36b42c9d3448d412eb9bd91c55914643;p=sbcl.git

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 9b8487f..3fb6cd2 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -33,11 +33,11 @@
 ;;;   METHOD-FUNCTION       ??
 
 (defmethod method-function ((method standard-method))
-  (or (slot-value method 'function)
+  (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)
+        (setf (slot-value method '%function)
               (method-function-from-fast-function fmf)))))
 
 (defmethod accessor-method-class ((method standard-accessor-method))
@@ -63,7 +63,7 @@
                  (error 'metaobject-initialization-violation
                   :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)
@@ -182,21 +182,20 @@
   (setf (plist-value method 'qualifiers) qualifiers)
   #+ignore
   (setf (slot-value method 'closure-generator)
-        (method-function-closure-generator (slot-value method 'function))))
+        (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
+  (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)
+          (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)))))
+    (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))
@@ -248,7 +247,7 @@
              (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"
@@ -276,9 +275,9 @@
 ;                :argument-precedence-order
 ;                'argument-precedence-order)
 ;   (add-initarg declarations :declarations 'declarations)
-;   (add-initarg documentation :documentation 'documentation)
+;   (add-initarg documentation :documentation '%documentation)
 ;   (add-initarg method-class :method-class 'method-class)
-;   (add-initarg method-combination :method-combination 'method-combination)
+;   (add-initarg method-combination :method-combination '%method-combination)
     (apply #'call-next-method generic-function initargs)))
 ||#
 
@@ -553,7 +552,7 @@
                       in method ~S:~2I~_~S.~@:>"
                      method qualifiers)))
             ((short-method-combination-p mc)
-             (let ((mc-name (method-combination-type mc)))
+             (let ((mc-name (method-combination-type-name mc)))
                (when (or (null qualifiers)
                          (cdr qualifiers)
                          (and (neq (car qualifiers) :around)
@@ -724,8 +723,8 @@
 (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)))
+    (method-function-get (or (safe-method-fast-function (car methods))
+                             (safe-method-function (car methods)))
                          :constant-value)))
 
 (defun default-secondary-dispatch-function (generic-function)
@@ -1560,13 +1559,15 @@
              (set-dfun gf dfun cache info) ; lest the cache be freed twice
              (update-dfun gf dfun cache info))))))
 
-(defun (setf class-name) (new-value class)
+(defmethod (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))
+  (reinitialize-instance class :name new-value)
+  new-value)
 
-(defun (setf generic-function-name) (new-value generic-function)
-  (reinitialize-instance generic-function :name 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)