X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-target-error.lisp;h=86732a541018667c689d0bd155fd5f4a7d0fb13c;hb=18d4de696bc5063aad026ba62be613c7b07f5fc8;hp=af708febcb902b1abf3ab7e31b35c89793888e86;hpb=231721189e1e2431597dc013aaf5eee01bc41a51;p=sbcl.git

diff --git a/src/code/late-target-error.lisp b/src/code/late-target-error.lisp
index af708fe..86732a5 100644
--- a/src/code/late-target-error.lisp
+++ b/src/code/late-target-error.lisp
@@ -77,19 +77,6 @@
   ;; If ALLOCATION is :CLASS, this is a cons whose car holds the value.
   (cell nil :type (or cons null)))
 
-(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
-  ;; the appropriate initialization value for the CPL slot of a
-  ;; CONDITION, calculated by looking at the INHERITS information in
-  ;; the LAYOUT of the CONDITION
-  (defun condition-class-cpl-from-layout (condition)
-    (declare (type condition condition))
-    (let* ((class (sb!xc:find-class condition))
-	   (layout (class-layout class))
-	   (superset (map 'list #'identity (layout-inherits layout))))
-      (delete-if (lambda (superclass)
-		   (not (typep superclass 'condition-class)))
-		 superset))))
-
 ;;; 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
 ;;; have themselves listed in their CPLs. This behavior is inherited
@@ -130,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
@@ -312,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)
@@ -560,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) ())
@@ -576,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) ())