X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=2b84a1856bbe75bbc4ea6c197393751ad0617082;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=6337b611b68f8bba06b61d99f4b147b962af1ab6;hpb=2912f5f6c2acb2da3b9fcc0f5afd1ca89782a9f8;p=sbcl.git

diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index 6337b61..2b84a18 100644
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -209,11 +209,11 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 			 (funcallable-standard-instance-access object location)
 			 (standard-instance-access object location))))
 	  (when (eq +slot-unbound+ value)
-	    (error "~@<slot ~s of class ~s is unbound in object ~s~@:>"
+	    (error "~@<slot ~S of class ~S is unbound in object ~S~@:>"
 		   slot-name class object))
 	  value)
-	(error "~@<cannot get standard value of slot ~s of class ~s ~
-                in object ~s~@:>"
+	(error "~@<cannot get standard value of slot ~S of class ~S ~
+                in object ~S~@:>"
 	       slot-name class object))))
 
 (defun standard-slot-value/gf (gf slot-name)
@@ -769,11 +769,14 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 ;;; considered as state transitions.
 (defvar *lazy-dfun-compute-p* t)
 (defvar *early-p* nil)
-(defvar *max-emf-precomputation-methods* 10)
+
+(declaim (type (or null unsigned-byte) *max-emf-precomputation-methods*))
+(defvar *max-emf-precomputation-methods* nil)
 
 (defun finalize-specializers (gf)
   (let ((methods (generic-function-methods gf)))
-    (when (<= (length methods) *max-emf-precomputation-methods*)
+    (when (or (null *max-emf-precomputation-methods*)
+	      (<= (length methods) *max-emf-precomputation-methods*))
       (let ((all-finalized t))
 	(dolist (method methods all-finalized)
 	  (dolist (specializer (method-specializers method))
@@ -1212,15 +1215,22 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 ;;; function GF which reads/writes instances of class CLASS.
 ;;; TYPE is one of the symbols READER or WRITER.
 (defun find-standard-class-accessor-method (gf class type)
-  (dolist (method (standard-slot-value/gf gf 'methods))
-    (let ((specializers (standard-slot-value/method method 'specializers))
-	  (qualifiers (plist-value method 'qualifiers)))
-      (when (and (null qualifiers)
-		 (eq (ecase type
-		       (reader (car specializers))
-		       (writer (cadr specializers)))
-		     class))
-	(return method)))))
+  (let ((cpl (standard-slot-value/class class 'class-precedence-list))
+	(found-specializer *the-class-t*)
+	(found-method nil))
+    (dolist (method (standard-slot-value/gf gf 'methods) found-method)
+      (let ((specializers (standard-slot-value/method method 'specializers))
+	    (qualifiers (plist-value method 'qualifiers)))
+	(when (and (null qualifiers)
+		   (let ((subcpl (member (ecase type
+					   (reader (car specializers))
+					   (writer (cadr specializers)))
+					 cpl)))
+		     (and subcpl (member found-specializer subcpl))))
+	  (setf found-specializer (ecase type
+				    (reader (car specializers))
+				    (writer (cadr specializers))))
+	  (setf found-method method))))))
 
 (defun accessor-values (gf arg-info classes methods)
   (declare (ignore gf))
@@ -1491,7 +1501,20 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 
 (defun cpl-or-nil (class)
   (if (eq *boot-state* 'complete)
-      (when (class-finalized-p class)
+      ;; KLUDGE: why not use (slot-boundp class
+      ;; 'class-precedence-list)?  Well, unfortunately, CPL-OR-NIL is
+      ;; used within COMPUTE-APPLICABLE-METHODS, including for
+      ;; SLOT-BOUNDP-USING-CLASS... and the available mechanism for
+      ;; breaking such nasty cycles in effective method computation
+      ;; only works for readers and writers, not boundps.  It might
+      ;; not be too hard to make it work for BOUNDP accessors, but in
+      ;; the meantime we use an extra slot for exactly the result of
+      ;; the SLOT-BOUNDP that we want.  (We cannot use
+      ;; CLASS-FINALIZED-P, because in the process of class
+      ;; finalization we need to use the CPL which has been computed
+      ;; to cache effective methods for slot accessors.) -- CSR,
+      ;; 2004-09-19.
+      (when (cpl-available-p class)
         (class-precedence-list class))
       (early-class-precedence-list class)))