From a33185e14640963e7f74d32aa1be81690e788c0e Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Thu, 20 May 2004 22:56:38 +0000
Subject: [PATCH] 0.8.10.42:          Fixed bug reported by Thomas Burdick
 (sbcl-devel 2004-05-09),          which causes an AVER to
 fail from identical :READER and :WRITER          names in
 DEFCLASS slot definitions:          ... Moved error
 checking from FIND-METHOD to REAL-GET-METHOD so            
     that internals bypassing FIND-METHOD can benefit from
 it.          ... Added regression test.

---
 NEWS                   |    3 +++
 src/pcl/methods.lisp   |   67 ++++++++++++++++++++++++++++--------------------
 tests/clos.impure.lisp |    8 ++++++
 version.lisp-expr      |    2 +-
 4 files changed, 51 insertions(+), 29 deletions(-)

diff --git a/NEWS b/NEWS
index 323e4a1..b063d62 100644
--- a/NEWS
+++ b/NEWS
@@ -2403,6 +2403,9 @@ changes in sbcl-0.8.11 relative to sbcl-0.8.10:
     SB-EXT:INHIBIT-WARNINGS OPTIMIZE quality.  See the manual for
     documentation on this feature.  The SB-EXT:INHIBIT-WARNINGS
     quality should be considered deprecated.
+  * fixed bug: DEFCLASS slot definitions with identical :READER and
+    :WRITER names now signal a reasonable error. (reported by Thomas
+    Burdick)
   * fixed bug: CLOSE :ABORT T on appending stream no longer causes
     file deletion.
   * fixed bug: Invalid slot specification errors now print correctly. 
diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index db593a5..8cd94fa 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -289,37 +289,48 @@
     new))
 
 (defun real-get-method (generic-function qualifiers specializers
-					 &optional (errorp t))
-  (let* ((lspec (length specializers))
-	 (hit 
-	  (dolist (method (generic-function-methods generic-function))
-	    (let ((mspecializers (method-specializers method)))
-	      (aver (= lspec (length mspecializers)))
-	      (when (and (equal qualifiers (method-qualifiers method))
-			 (every #'same-specializer-p specializers
-				(method-specializers method)))
-		(return method))))))
-    (cond (hit hit)
-	  ((null errorp) nil)
-	  (t
-	   (error "~@<There is no method on ~S with ~
-                   ~:[no qualifiers~;~:*qualifiers ~S~] ~
-                   and specializers ~S.~@:>"
-		  generic-function qualifiers specializers)))))
+			&optional (errorp t) 
+			always-check-specializers)
+  (let ((lspec (length specializers))
+	(methods (generic-function-methods generic-function)))
+    (when (or methods always-check-specializers)
+      (let ((nreq (length (arg-info-metatypes (gf-arg-info generic-function)))))
+	;; Since we internally bypass FIND-METHOD by using GET-METHOD
+	;; instead we need to to this here or users may get hit by a
+	;; failed AVER instead of a sensible error message.
+	(when (/= lspec nreq)
+	  (error "~@<The generic function ~S takes ~D required argument~:P; ~
+                 was asked to find a method with specializers ~S~@:>"
+		 generic-function nreq specializers))))
+    (let ((hit 
+	   (dolist (method methods)
+	     (let ((mspecializers (method-specializers method)))
+	       (aver (= lspec (length mspecializers)))
+	       (when (and (equal qualifiers (method-qualifiers method))
+			  (every #'same-specializer-p specializers
+				 (method-specializers method)))
+		 (return method))))))
+      (cond (hit hit)
+	    ((null errorp) nil)
+	    (t
+	     (error "~@<There is no method on ~S with ~
+                    ~:[no qualifiers~;~:*qualifiers ~S~] ~
+                    and specializers ~S.~@:>"
+		    generic-function qualifiers specializers))))))
 
 (defmethod find-method ((generic-function standard-generic-function)
 			qualifiers specializers &optional (errorp t))
-  (let ((nreq (length (arg-info-metatypes (gf-arg-info generic-function)))))
-    ;; ANSI: "The specializers argument contains the parameter
-    ;; specializers for the method. It must correspond in length to
-    ;; the number of required arguments of the generic function, or an
-    ;; error is signaled."
-    (when (/= (length specializers) nreq)
-      (error "~@<The generic function ~S takes ~D required argument~:P; ~
-              was asked to find a method with specializers ~S~@:>"
-	     generic-function nreq specializers))
-    (real-get-method generic-function qualifiers
-		     (parse-specializers specializers) errorp)))
+  ;; ANSI about FIND-METHOD: "The specializers argument contains the
+  ;; parameter specializers for the method. It must correspond in
+  ;; length to the number of required arguments of the generic
+  ;; function, or an error is signaled."
+  ;;
+  ;; This error checking is done by REAL-GET-METHOD.
+  (real-get-method generic-function 
+		   qualifiers
+		   (parse-specializers specializers) 
+		   errorp 
+		   t))
 
 ;;; Compute various information about a generic-function's arglist by looking
 ;;; at the argument lists of the methods. The hair for trying not to use
diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 7ef3e46..ccdfeca 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -784,5 +784,13 @@
 (assert (eq (find-class 'one-more-to-obsolete) 
 	    (make-instances-obsolete (find-class 'one-more-to-obsolete))))
 
+;;; Sensible error instead of a BUG. Reported by Thomas Burdick.
+(multiple-value-bind (value err)
+    (ignore-errors
+      (defclass slot-def-with-duplicate-accessors ()
+	((slot :writer get-slot :reader get-slot))))
+  (assert (typep err 'error))
+  (assert (not (typep err 'sb-int:bug))))
+
 ;;;; success
 (sb-ext:quit :unix-status 104)
diff --git a/version.lisp-expr b/version.lisp-expr
index 95de0ce..a2ee4d0 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.10.41"
+"0.8.10.42"
-- 
1.7.10.4