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
(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)
(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) ())
(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) ())