X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-target-error.lisp;h=320a8c2e82f728dc42cb9bdf94a4ddd859c2c394;hb=fbe6e22af842835f7c70309f4d48064ca3984ad0;hp=4a89b6becd39b11d81a320334c2a521d06bde985;hpb=f0338f6fa732b21daa4405e19465bd460e0526d9;p=sbcl.git diff --git a/src/code/late-target-error.lisp b/src/code/late-target-error.lisp index 4a89b6b..320a8c2 100644 --- a/src/code/late-target-error.lisp +++ b/src/code/late-target-error.lisp @@ -54,11 +54,9 @@ condition-class make-condition-class) (:copier nil)) - - (function-name nil) ;; actual initargs supplied to MAKE-CONDITION (actual-initargs (required-argument) :type list) - ;; plist mapping slot names to any values that were assigned or + ;; a plist mapping slot names to any values that were assigned or ;; defaulted after creation (assigned-slots () :type list)) @@ -79,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 @@ -132,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 @@ -314,19 +304,10 @@ (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 @@ -562,41 +543,22 @@ (define-condition simple-warning (simple-condition warning) ()) -(defun print-simple-error (condition stream) - (format stream - ;; FIXME: It seems reasonable to display the "in function - ;; ~S" information, but doesn't the logic to display it - ;; belong in the debugger or someplace like that instead of - ;; in the format string for this particular family of - ;; conditions? Then this printer might look more - ;; ("~@<~S: ~2I~:_~?~:>" (TYPE-OF C) ..) instead. - "~@" - (condition-function-name condition) - (simple-condition-format-control condition) - (simple-condition-format-arguments condition))) - -(define-condition simple-error (simple-condition error) () - ;; This is the condition type used by ERROR and CERROR when - ;; a format-control string is supplied as the first argument. - (:report print-simple-error)) +(define-condition simple-error (simple-condition error) ()) (define-condition storage-condition (serious-condition) ()) -;;; FIXME: Should we really be reporting CONDITION-FUNCTION-NAME data -;;; on an ad hoc basis, for some conditions and not others? Why not -;;; standardize it somehow? perhaps by making the debugger report it? - (define-condition type-error (error) ((datum :reader type-error-datum :initarg :datum) (expected-type :reader type-error-expected-type :initarg :expected-type)) (:report (lambda (condition stream) (format stream - "~@." - (condition-function-name 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) ()) @@ -607,7 +569,7 @@ (:report (lambda (condition stream) (format stream - "END-OF-FILE on ~S" + "end of file on ~S" (stream-error-stream condition))))) (define-condition file-error (error) @@ -615,8 +577,12 @@ (:report (lambda (condition stream) (format stream - "~@" - (condition-function-name condition) + "~@" + (file-error-pathname condition) + ;; FIXME: ANSI's FILE-ERROR doesn't have FORMAT-CONTROL and + ;; FORMAT-ARGUMENTS, and the inheritance here doesn't seem + ;; to give us FORMAT-CONTROL or FORMAT-ARGUMENTS either. + ;; So how does this work? (serious-condition-format-control condition) (serious-condition-format-arguments condition))))) @@ -630,16 +596,14 @@ (:report (lambda (condition stream) (format stream - "error in ~S: The variable ~S is unbound." - (condition-function-name condition) + "The variable ~S is unbound." (cell-error-name condition))))) (define-condition undefined-function (cell-error) () (:report (lambda (condition stream) (format stream - "error in ~S: The function ~S is undefined." - (condition-function-name condition) + "The function ~S is undefined." (cell-error-name condition))))) (define-condition arithmetic-error (error) @@ -673,8 +637,6 @@ (format stream "~S cannot be printed readably." obj))))) (define-condition reader-error (parse-error stream-error) - ;; FIXME: Do we need FORMAT-CONTROL and FORMAT-ARGUMENTS when - ;; we have an explicit :REPORT function? I thought we didn't.. ((format-control :reader reader-error-format-control :initarg :format-control) @@ -726,8 +688,7 @@ (:report (lambda (condition stream) (format stream - "error in ~S: ~S: index too large" - (condition-function-name condition) + "The index ~S is too large." (type-error-datum condition))))) (define-condition io-timeout (stream-error) @@ -736,7 +697,7 @@ (lambda (condition stream) (declare (type stream stream)) (format stream - "IO-TIMEOUT ~(~A~)ing ~S" + "I/O timeout ~(~A~)ing ~S" (io-timeout-direction condition) (stream-error-stream condition))))) @@ -764,7 +725,7 @@ (:report (lambda (condition stream) (format stream - "unexpected EOF on ~S ~A" + "unexpected end of file on ~S ~A" (stream-error-stream condition) (reader-eof-error-context condition)))))