0.8.0.24:

[sbcl.git] / src / code / condition.lisp

diff --git a/src/code/condition.lisp b/src/code/condition.lisp
index 5feeb73..d76500f 100644 (file)
--- a/src/code/condition.lisp
+++ b/src/code/condition.lisp
@@ -72,7 +72,9 @@
   ;; allocation of this slot, or NIL until defaulted
   (allocation nil :type (member :instance :class nil))
   ;; If ALLOCATION is :CLASS, this is a cons whose car holds the value.
-  (cell nil :type (or cons null)))
+  (cell nil :type (or cons null))
+  ;; slot documentation
+  (documentation nil :type (or string null)))
 
 ;;; KLUDGE: It's not clear to me why CONDITION-CLASS has itself listed
 ;;; in its CPL, while other classes derived from CONDITION-CLASS don't
@@ -324,9 +326,10 @@
 ;;; ANSI-compliant, fixing it would also be good.:-)
 (defun compute-effective-slots (class)
   (collect ((res (copy-list (condition-classoid-slots class))))
-    (dolist (sclass (condition-classoid-cpl class))
+    (dolist (sclass (cdr (condition-classoid-cpl class)))
       (dolist (sslot (condition-classoid-slots sclass))
-       (let ((found (find (condition-slot-name sslot) (res))))
+       (let ((found (find (condition-slot-name sslot) (res)
+                           :key #'condition-slot-name)))
          (cond (found
                 (setf (condition-slot-initargs found)
                       (union (condition-slot-initargs found)
@@ -427,6 +430,7 @@
               (slot-name (first spec))
               (allocation :instance)
               (initform-p nil)
+              documentation
               initform)
          (collect ((initargs)
                    (readers)
@@ -450,6 +454,13 @@
                  (:initarg (initargs arg))
                  (:allocation
                   (setq allocation arg))
+                 (:documentation
+                  (when documentation
+                    (error "more than one :DOCUMENTATION in ~S" spec))
+                  (unless (stringp arg)
+                    (error "slot :DOCUMENTATION argument is not a string: ~S"
+                           arg))
+                  (setq documentation arg))
                  (:type)
                  (t
                   (error "unknown slot option:~%  ~S" (first options))))))
@@ -462,6 +473,7 @@
                     :readers ',(readers)
                     :writers ',(writers)
                     :initform-p ',initform-p
+                    :documentation ',documentation
                     :initform
                     ,(if (constantp initform)
                          `',(eval initform)
@@ -660,6 +672,15 @@
 ;;;; setup of CONDITION machinery, only because that makes it easier to
 ;;;; get cold init to work.
 
+(define-condition values-type-error (type-error)
+  ()
+  (:report
+   (lambda (condition stream)
+     (format stream
+            "~@<The values set ~2I~:_[~{~S~^ ~}] ~I~_is not of type ~2I~_~S.~:>"
+            (type-error-datum condition)
+            (type-error-expected-type condition)))))
+
 ;;; KLUDGE: a condition for floating point errors when we can't or
 ;;; won't figure out what type they are. (In FreeBSD and OpenBSD we
 ;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably
@@ -767,8 +788,7 @@
               (reader-error-format-arguments condition)
               (reader-impossible-number-error-error condition))))))
 
-;;; should this inherit from error?  good question
-(define-condition timeout (error) ())
+(define-condition sb!ext::timeout (serious-condition) ())
 
 
 \f