X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=4acbaaeb99205bff01ce03160d825f0241fee3bb;hb=500fae719e1d6e138aff44a711941baab63bd405;hp=3358df958f132c064ad224ec009695fd450fe6df;hpb=2b0710d31c3fa1e5448ec842504d5276842e394f;p=sbcl.git

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 3358df9..4acbaae 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -40,12 +40,6 @@
         (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
@@ -54,7 +48,7 @@
 ;;; Methods are not reinitializable.
 
 (define-condition metaobject-initialization-violation
-    (reference-condition simple-condition)
+    (reference-condition simple-error)
   ())
 
 (macrolet ((def (name args control)
@@ -184,19 +178,6 @@
   (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))
 
@@ -486,6 +467,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 ~
@@ -516,6 +509,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)
@@ -804,16 +808,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)
@@ -951,18 +956,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)))
@@ -999,17 +1006,26 @@
          (default '(default)))
     (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
+                            (eq default (probe-cache cache %wrappers default)))
                    (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))
@@ -1519,49 +1535,56 @@
   (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) (new-value class)
   (let ((classoid (%wrapper-classoid (class-wrapper class))))
-    (setf (classoid-name classoid) new-value))
+    (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)