X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcondition.lisp;h=0b2b49bcd3a9f8dce7efe0f70d6311f0c3b80e2b;hb=b4831dc945c0754b3ba77881e67c8ea4d0a3d905;hp=07393fad2e22bd9b15d666af148b8b41b7a6996a;hpb=f9ef8b045b60ae064c7bd40af599b46707ea4d8a;p=sbcl.git

diff --git a/src/code/condition.lisp b/src/code/condition.lisp
index 07393fa..0b2b49b 100644
--- 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
@@ -206,7 +208,6 @@
       (when (eq (condition-slot-name cslot) name)
 	(return-from condition-reader-function
 		     (car (condition-slot-cell cslot)))))
-
     (let ((val (getf (condition-assigned-slots condition) name
 		     *empty-condition-slot*)))
       (if (eq val *empty-condition-slot*)
@@ -214,17 +215,15 @@
 		(slot (find-condition-class-slot class name)))
             (unless slot
 	      (error "missing slot ~S of ~S" name condition))
-	    (dolist (initarg (condition-slot-initargs slot))
-	      (let ((val (getf actual-initargs
-			       initarg
-			       *empty-condition-slot*)))
-		(unless (eq val *empty-condition-slot*)
-		  (return-from condition-reader-function
-			       (setf (getf (condition-assigned-slots condition)
-					   name)
-				     val)))))
-	    (setf (getf (condition-assigned-slots condition) name)
-		  (find-slot-default class slot)))
+	    (do ((initargs actual-initargs (cddr initargs)))
+		((endp initargs)
+		 (setf (getf (condition-assigned-slots condition) name)
+		       (find-slot-default class slot)))
+	      (when (member (car initargs) (condition-slot-initargs slot))
+		(return-from condition-reader-function
+		  (setf (getf (condition-assigned-slots condition)
+			      name)
+			(cadr initargs))))))
 	  val))))
 
 ;;;; MAKE-CONDITION
@@ -327,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)
@@ -430,6 +430,7 @@
 	       (slot-name (first spec))
 	       (allocation :instance)
 	       (initform-p nil)
+	       documentation
 	       initform)
 	  (collect ((initargs)
 		    (readers)
@@ -453,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))))))
@@ -465,6 +473,7 @@
 		     :readers ',(readers)
 		     :writers ',(writers)
 		     :initform-p ',initform-p
+		     :documentation ',documentation
 		     :initform
 		     ,(if (constantp initform)
 			  `',(eval initform)
@@ -517,7 +526,7 @@
 ;;; methods)
 (defun describe-condition (condition stream)
   (format stream
-	  "~@<~S ~_is a ~S. ~_Its slot values are ~_~S.~:>"
+	  "~&~@<~S ~_is a ~S. ~_Its slot values are ~_~S.~:>~%"
 	  condition
 	  (type-of condition)
 	  (concatenate 'list
@@ -663,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
@@ -770,10 +788,19 @@
 	       (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) ())
 
+(define-condition defconstant-uneql (error)
+  ((name :initarg :name :reader defconstant-uneql-name)
+   (old-value :initarg :old-value :reader defconstant-uneql-old-value)
+   (new-value :initarg :new-value :reader defconstant-uneql-new-value))
+  (:report
+   (lambda (condition stream)
+     (format stream
+	     "~@<The constant ~S is being redefined (from ~S to ~S)~@:>"
+	     (defconstant-uneql-name condition)
+	     (defconstant-uneql-old-value condition)
+	     (defconstant-uneql-new-value condition)))))
 
 ;;;; special SBCL extension conditions
 
@@ -866,8 +893,9 @@
 		#!+sb-doc ,doc
 		;; FIXME: Perhaps this shared logic should be pulled out into
 		;; FLET MAYBE-INVOKE-RESTART? See whether it shrinks code..
-		(when (find-restart ',name condition)
-		  (invoke-restart ',name ,@args)))))
+	        (let ((restart (find-restart ',name condition)))
+		  (when restart
+		    (invoke-restart restart ,@args))))))
   (define-nil-returning-restart continue ()
     "Transfer control to a restart named CONTINUE, or return NIL if none exists.")
   (define-nil-returning-restart store-value (value)