X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Fmethods.lisp;h=63b1bcd34fdcbb2f2f71de5149abb3a730fe3767;hb=22aec7852f4861e5dab28cc0d619c24b62590dad;hp=8d0f176410967f77193f7f6e4e5e5e05e7263874;hpb=4cb22853031c89db0da148d16c60d917102a57ed;p=sbcl.git

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 8d0f176..63b1bcd 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -89,10 +89,7 @@
       "is not a non-null atom"))
 
 (defmethod legal-slot-name-p ((object standard-method) x)
-  (cond ((not (symbolp x)) "is not a symbol and so cannot be bound")
-	((keywordp x)      "is a keyword and so cannot be bound")
-	((memq x '(t nil)) "cannot be bound")
-	((constantp x)     "is a constant and so cannot be bound")
+  (cond ((not (symbolp x)) "is not a symbol")
 	(t t)))
 
 (defmethod legal-specializers-p ((object standard-method) x)
@@ -515,12 +512,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 +525,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
@@ -821,6 +817,9 @@
 (defvar *standard-slot-value-using-class-method* nil)
 (defvar *standard-setf-slot-value-using-class-method* nil)
 (defvar *standard-slot-boundp-using-class-method* nil)
+(defvar *condition-slot-value-using-class-method* nil)
+(defvar *condition-setf-slot-value-using-class-method* nil)
+(defvar *condition-slot-boundp-using-class-method* nil)
 (defvar *structure-slot-value-using-class-method* nil)
 (defvar *structure-setf-slot-value-using-class-method* nil)
 (defvar *structure-slot-boundp-using-class-method* nil)
@@ -837,6 +836,18 @@
     (writer (setq *standard-setf-slot-value-using-class-method* method))
     (boundp (setq *standard-slot-boundp-using-class-method* method))))
 
+(defun condition-svuc-method (type)
+  (case type
+    (reader *condition-slot-value-using-class-method*)
+    (writer *condition-setf-slot-value-using-class-method*)
+    (boundp *condition-slot-boundp-using-class-method*)))
+
+(defun set-condition-svuc-method (type method)
+  (case type
+    (reader (setq *condition-slot-value-using-class-method* method))
+    (writer (setq *condition-setf-slot-value-using-class-method* method))
+    (boundp (setq *condition-slot-boundp-using-class-method* method))))
+
 (defun structure-svuc-method (type)
   (case type
     (reader *structure-slot-value-using-class-method*)
@@ -855,17 +866,18 @@
       (when (and (or (not (eq type 'writer))
 		     (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)
+	(cond ((and (eq (class-name (car specls)) 'std-class)
+		    (eq (class-name (cadr specls)) 'std-object)
 		    (eq (class-name (caddr specls))
 			'standard-effective-slot-definition))
 	       (set-standard-svuc-method type method))
-	      ((and (eq (class-name (car specls))
-			'structure-class)
-		    (eq (class-name (cadr specls))
-			'structure-object)
+	      ((and (eq (class-name (car specls)) 'condition-class)
+		    (eq (class-name (cadr specls)) 'condition)
+		    (eq (class-name (caddr specls))
+			'condition-effective-slot-definition))
+	       (set-condition-svuc-method type method))
+	      ((and (eq (class-name (car specls)) 'structure-class)
+		    (eq (class-name (cadr specls)) 'structure-object)
 		    (eq (class-name (caddr specls))
 			'structure-effective-slot-definition))
 	       (set-structure-svuc-method type method)))))))
@@ -1183,15 +1195,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))))