X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Flate-target-error.lisp;h=86732a541018667c689d0bd155fd5f4a7d0fb13c;hb=7dd568fb64927be78556ac27f1f0dc60e79cf942;hp=abd375fab38b284c7942423f8a013207f676fe52;hpb=f2aa2d01b8d69f1c7bff18f86279d4f1018fe127;p=sbcl.git

diff --git a/src/code/late-target-error.lisp b/src/code/late-target-error.lisp
index abd375f..86732a5 100644
--- a/src/code/late-target-error.lisp
+++ b/src/code/late-target-error.lisp
@@ -117,10 +117,15 @@
 				parent-types)))))
 	 (cond-layout (info :type :compiler-layout 'condition))
 	 (olayout (info :type :compiler-layout name))
+	 ;; FIXME: Does this do the right thing in case of multiple
+	 ;; inheritance? A quick look at DEFINE-CONDITION didn't make
+	 ;; it obvious what ANSI intends to be done in the case of
+	 ;; multiple inheritance, so it's not actually clear what the
+	 ;; right thing is..
 	 (new-inherits
-	  (concatenate 'simple-vector
-		       (layout-inherits cond-layout)
-		       (mapcar #'class-layout cpl))))
+	  (order-layout-inherits (concatenate 'simple-vector
+					      (layout-inherits cond-layout)
+					      (mapcar #'class-layout cpl)))))
     (if (and olayout
 	     (not (mismatch (layout-inherits olayout) new-inherits)))
 	olayout
@@ -299,31 +304,27 @@
 
     (setf (sb!xc:find-class name) class)
 
-    ;; Initialize CPL slot from layout.
-    (collect ((cpl))
-      (cpl class)
-      (let ((inherits (layout-inherits layout)))
-	(do ((i (1- (length inherits)) (1- i)))
-	    ((minusp i))
-	  (let ((super (sb!xc:find-class
-			(sb!xc:class-name
-			 (layout-class (svref inherits i))))))
-	    (when (typep super 'condition-class)
-	      (cpl super)))))
-      (setf (condition-class-cpl class) (cpl))))
-
+    ;; Initialize CPL slot.
+    (setf (condition-class-cpl class)
+	  (remove-if-not #'condition-class-p 
+			 (std-compute-class-precedence-list class))))
   (values))
 
 ) ; EVAL-WHEN
 
-;;; Compute the effective slots of class, copying inherited slots and
-;;; side-effecting direct slots.
+;;; Compute the effective slots of CLASS, copying inherited slots and
+;;; destructively modifying direct slots.
+;;;
+;;; FIXME: It'd be nice to explain why it's OK to destructively modify
+;;; direct slots. Presumably it follows from the semantics of
+;;; inheritance and redefinition of conditions, but finding the cite
+;;; and documenting it here would be good. (Or, if this is not in fact
+;;; ANSI-compliant, fixing it would also be good.:-)
 (defun compute-effective-slots (class)
   (collect ((res (copy-list (condition-class-slots class))))
     (dolist (sclass (condition-class-cpl class))
       (dolist (sslot (condition-class-slots sclass))
-	(let ((found (find (condition-slot-name sslot) (res)
-			   :test #'eq)))
+	(let ((found (find (condition-slot-name sslot) (res))))
 	  (cond (found
 		 (setf (condition-slot-initargs found)
 		       (union (condition-slot-initargs found)
@@ -547,8 +548,6 @@
 
 (define-condition simple-warning (simple-condition warning) ())
 
-;;; This is the condition type used by ERROR and CERROR when
-;;; a format-control string is supplied as the first argument.
 (define-condition simple-error (simple-condition error) ())
 
 (define-condition storage-condition (serious-condition) ())
@@ -563,6 +562,8 @@
 	     (type-error-datum condition)
 	     (type-error-expected-type condition)))))
 
+(define-condition simple-type-error (simple-condition type-error) ())
+
 (define-condition program-error (error) ())
 (define-condition parse-error   (error) ())
 (define-condition control-error (error) ())