0.8.0.8:

[sbcl.git] / src / pcl / methods.lisp

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index dff22ed..63b1bcd 100644 (file)
--- 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)
@@ -820,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)
@@ -836,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*)
@@ -854,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)))))))
@@ -1182,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))))