X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Flate-target-error.lisp;h=af708febcb902b1abf3ab7e31b35c89793888e86;hb=cb7837b769ce190baec60a2159c33099816ea6e3;hp=45b4bd1b1d189a8bdb31bb985fdc098cf9af3769;hpb=099d6dd1f6a5ac2ffec5c14d07a4b905322ef968;p=sbcl.git diff --git a/src/code/late-target-error.lisp b/src/code/late-target-error.lisp index 45b4bd1..af708fe 100644 --- a/src/code/late-target-error.lisp +++ b/src/code/late-target-error.lisp @@ -17,6 +17,8 @@ ;;;; the CONDITION class +(/show0 "late-target-error.lisp 20") + (eval-when (:compile-toplevel :load-toplevel :execute) (def!struct (condition-class (:include slot-class) @@ -42,7 +44,7 @@ (defun make-condition-class (&rest rest) (apply #'bare-make-condition-class - (rename-keyword-args '((:name :%name)) rest))) + (rename-key-args '((:name :%name)) rest))) ) ; EVAL-WHEN @@ -52,15 +54,13 @@ 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)) -(defstruct condition-slot +(defstruct (condition-slot (:copier nil)) (name (required-argument) :type symbol) ;; list of all applicable initargs (initargs (required-argument) :type list) @@ -217,10 +217,8 @@ (if (eq val *empty-condition-slot*) (let ((actual-initargs (condition-actual-initargs condition)) (slot (find-condition-class-slot class name))) - ;; MNA: cmucl-commit: Mon, 8 Jan 2001 21:21:23 -0800 (PST) - ;; Catch missing slots in condition-reader-function, and signal an error. (unless slot - (error "Slot ~S of ~S missing." name condition)) + (error "missing slot ~S of ~S" name condition)) (dolist (initarg (condition-slot-initargs slot)) (let ((val (getf actual-initargs initarg @@ -547,8 +545,10 @@ (define-condition style-warning (warning) ()) (defun simple-condition-printer (condition stream) - (apply #'format stream (simple-condition-format-control condition) - (simple-condition-format-arguments condition))) + (apply #'format + stream + (simple-condition-format-control condition) + (simple-condition-format-arguments condition))) (define-condition simple-condition () ((format-control :reader simple-condition-format-control @@ -560,32 +560,19 @@ (define-condition simple-warning (simple-condition warning) ()) -(defun print-simple-error (condition stream) - (format stream - "~&~@" - (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)) +;;; 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) ()) -;;; 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))))) @@ -599,7 +586,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) @@ -607,8 +594,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))))) @@ -622,16 +613,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) @@ -665,8 +654,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) @@ -718,8 +705,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) @@ -728,7 +714,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))))) @@ -756,7 +742,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))))) @@ -798,3 +784,6 @@ (define-nil-returning-restart use-value (value) "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if none exists.")) + +(/show0 "late-target-error.lisp end of file") +