X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=66d873ef404390d428ca08f9fd3af54420f6488c;hb=2c668ec79541ced67b8771dc7f41f6028d1f1c43;hp=5fd798fd5eaf7d37ada9fba124285a83bcf6f521;hpb=dc86450e18fb7b90bf6be7d8df8b8ebcb0d090f9;p=sbcl.git

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 5fd798f..66d873e 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -515,12 +515,11 @@
 	method)))
 
 (defun real-remove-method (generic-function method)
-  ;; Note: Error check prohibited by ANSI spec removed.
   (when  (eq generic-function (method-generic-function method))
-    (let* ((name	 (generic-function-name generic-function))
+    (let* ((name (generic-function-name generic-function))
 	   (specializers (method-specializers method))
-	   (methods      (generic-function-methods generic-function))
-	   (new-methods  (remove method methods)))
+	   (methods (generic-function-methods generic-function))
+	   (new-methods (remove method methods)))
       (setf (method-generic-function method) nil)
       (setf (generic-function-methods generic-function) new-methods)
       (dolist (specializer (method-specializers method))
@@ -529,8 +528,8 @@
       (update-ctors 'remove-method
 		    :generic-function generic-function
 		    :method method)
-      (update-dfun generic-function)
-      generic-function)))
+      (update-dfun generic-function)))
+  generic-function)
 
 (defun compute-applicable-methods-function (generic-function arguments)
   (values (compute-applicable-methods-using-types
@@ -561,8 +560,8 @@
 	(pushnew other-class (class-incompatible-superclass-list class))))))
 
 (defun superclasses-compatible-p (class1 class2)
-  (let ((cpl1 (class-precedence-list class1))
-	(cpl2 (class-precedence-list class2)))
+  (let ((cpl1 (cpl-or-nil class1))
+	(cpl2 (cpl-or-nil class2)))
     (dolist (sc1 cpl1 t)
       (dolist (ic (class-incompatible-superclass-list sc1))
 	(when (memq ic cpl2)
@@ -758,6 +757,22 @@
 			   *standard-method-combination*))
 	      type)))))
 
+
+;;; CMUCL (Gerd's PCL, 2002-04-25) comment:
+;;;
+;;; Return two values.  First value is a function to be stored in
+;;; effective slot definition SLOTD for reading it with
+;;; SLOT-VALUE-USING-CLASS, setting it with (SETF
+;;; SLOT-VALUE-USING-CLASS) or testing it with
+;;; SLOT-BOUNDP-USING-CLASS.  GF is one of these generic functions,
+;;; TYPE is one of the symbols READER, WRITER, BOUNDP.  CLASS is
+;;; SLOTD's class.
+;;;
+;;; Second value is true if the function returned is one of the
+;;; optimized standard functions for the purpose, which are used
+;;; when only standard methods are applicable.
+;;;
+;;; FIXME: Change all these wacky function names to something sane.
 (defun get-accessor-method-function (gf type class slotd)
   (let* ((std-method (standard-svuc-method type))
 	 (str-method (structure-svuc-method type))
@@ -768,27 +783,25 @@
     (values
      (if std-p
 	 (get-optimized-std-accessor-method-function class slotd type)
-	 (get-accessor-from-svuc-method-function
-	  class slotd
-	  (get-secondary-dispatch-function
-	   gf methods types
-	   `((,(car (or (member std-method methods)
-			(member str-method methods)
-			(error "error in get-accessor-method-function")))
-	      ,(get-optimized-std-slot-value-using-class-method-function
-		class slotd type)))
-	   (unless (and (eq type 'writer)
-			(dolist (method methods t)
-			  (unless (eq (car (method-specializers method))
-				      *the-class-t*)
-			    (return nil))))
-	     (let ((wrappers (list (wrapper-of class)
-				   (class-wrapper class)
-				   (wrapper-of slotd))))
-	       (if (eq type 'writer)
-		   (cons (class-wrapper *the-class-t*) wrappers)
-		   wrappers))))
-	  type))
+	 (let* ((optimized-std-fun
+		 (get-optimized-std-slot-value-using-class-method-function
+		  class slotd type))
+		(method-alist
+		 `((,(car (or (member std-method methods)
+			      (member str-method methods)
+			      (bug "error in ~S"
+				   'get-accessor-method-function)))
+		    ,optimized-std-fun)))
+		(wrappers
+		 (let ((wrappers (list (wrapper-of class)
+				       (class-wrapper class)
+				       (wrapper-of slotd))))
+		   (if (eq type 'writer)
+		       (cons (class-wrapper *the-class-t*) wrappers)
+		       wrappers)))
+		(sdfun (get-secondary-dispatch-function 
+			gf methods types method-alist wrappers)))
+	   (get-accessor-from-svuc-method-function class slotd sdfun type)))
      std-p)))
 
 ;;; used by OPTIMIZE-SLOT-VALUE-BY-CLASS-P (vector.lisp)
@@ -1169,15 +1182,19 @@
 
 (defmacro mlookup (key info default &optional eq-p type)
   (unless (or (eq eq-p t) (null eq-p))
-    (error "Invalid eq-p argument"))
+    (bug "Invalid eq-p argument: ~S" eq-p))
   (ecase type
     (:simple
-     `(if (,(if eq-p 'eq 'eql) ,key (car ,info))
+     `(if (locally
+	    (declare (optimize (inhibit-warnings 3)))
+	    (,(if eq-p 'eq 'eql) ,key (car ,info)))
 	  (cdr ,info)
 	  ,default))
     (:assoc
      `(dolist (e ,info ,default)
-	(when (,(if eq-p 'eq 'eql) (car e) ,key)
+	(when (locally
+		(declare (optimize (inhibit-warnings 3)))
+		(,(if eq-p 'eq 'eql) (car e) ,key))
 	  (return (cdr e)))))
     (:hash-table
      `(gethash ,key ,info ,default))))