0.pre7.5:

[sbcl.git] / src / code / late-target-error.lisp

diff --git a/src/code/late-target-error.lisp b/src/code/late-target-error.lisp
index af708fe..86732a5 100644 (file)
--- 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) ())