X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=f61386ebd82d77dabc8e3b95651f5d7aa76d037a;hb=ebc0f0ebf9efd39519ab86ba28c33abdb25443e0;hp=8db6b37c62831236b4eb0a6a27308c7321e13e55;hpb=92c8db80e039f60623e53a0b9355cf0a9ec49f3d;p=sbcl.git

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 8db6b37..f61386e 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))
@@ -53,11 +53,30 @@
 ;;;
 ;;; Methods are not reinitializable.
 
-(defmethod reinitialize-instance ((method standard-method) &rest initargs)
-  (declare (ignore initargs))
-  (error "An attempt was made to reinitialize the method ~S.~%~
-          Method objects cannot be reinitialized."
-         method))
+(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-arguments (list ',name)
+                  :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.")
+  ;; 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))
@@ -163,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))
@@ -229,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"
@@ -257,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)))
 ||#
 
@@ -456,10 +474,10 @@
                        :argument-precedence-order argument-precedence-order))
         (lambda-list-p (set-arg-info gf :lambda-list lambda-list))
         (t (set-arg-info gf)))
-      (when (and (arg-info-valid-p (gf-arg-info gf))
-                 (not (null args))
-                 (or lambda-list-p (cddr args)))
-        (update-dfun gf)))))
+      (when (arg-info-valid-p (gf-arg-info gf))
+        (update-dfun gf))
+      (map-dependents gf (lambda (dependent)
+                           (apply #'update-dependent gf dependent args))))))
 
 (declaim (special *lazy-dfun-compute-p*))
 
@@ -468,6 +486,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 ~
@@ -498,6 +528,17 @@
         (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)
@@ -534,7 +575,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)
@@ -548,10 +589,14 @@
                         :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)))
 
 (defun real-remove-method (generic-function method)
-  (when  (eq generic-function (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))
@@ -564,7 +609,11 @@
       (update-ctors 'remove-method
                     :generic-function generic-function
                     :method method)
-      (update-dfun generic-function)))
+      (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)
@@ -697,8 +746,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)
@@ -909,7 +958,7 @@
                      (eq (pop specls) *the-class-t*))
                  (every #'classp specls))
         (cond ((and (eq (class-name (car specls)) 'std-class)
-                    (eq (class-name (cadr specls)) 'std-object)
+                    (eq (class-name (cadr specls)) 'standard-object)
                     (eq (class-name (caddr specls))
                         'standard-effective-slot-definition))
                (set-standard-svuc-method type method))
@@ -925,19 +974,19 @@
                (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-std-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))))))
+  (unless (invalid-wrapper-p (class-wrapper (specializer-class spec)))
+    (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)))
@@ -994,19 +1043,16 @@
       cache)))
 
 (defmacro class-test (arg class)
-  (cond ((eq class *the-class-t*)
-         t)
-        ((eq class *the-class-slot-object*)
-         `(not (typep (classoid-of ,arg)
-                      'built-in-classoid)))
-        ((eq class *the-class-std-object*)
-         `(or (std-instance-p ,arg) (fsc-instance-p ,arg)))
-        ((eq class *the-class-standard-object*)
-         `(std-instance-p ,arg))
-        ((eq class *the-class-funcallable-standard-object*)
-         `(fsc-instance-p ,arg))
-        (t
-         `(typep ,arg ',(class-name class)))))
+  (cond
+    ((eq class *the-class-t*) t)
+    ((eq class *the-class-slot-object*)
+     `(not (typep (classoid-of ,arg) 'built-in-classoid)))
+    ((eq class *the-class-standard-object*)
+     `(or (std-instance-p ,arg) (fsc-instance-p ,arg)))
+    ((eq class *the-class-funcallable-standard-object*)
+     `(fsc-instance-p ,arg))
+    (t
+     `(typep ,arg ',(class-name class)))))
 
 (defmacro class-eq-test (arg class)
   `(eq (class-of ,arg) ',class))
@@ -1497,49 +1543,60 @@
   (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
+    (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 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)
+         (set-dfun gf dfun cache info) ; lest the cache be freed twice
+         (update-dfun gf dfun cache info))))))
 
-(defmethod (setf class-name) :before (new-value (class class))
-  (let ((classoid (find-classoid (class-name class))))
-    (setf (classoid-name classoid) new-value)))
+(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)
+  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)