X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-target-error.lisp;h=7c28116490a166d1faf695760d8a5ddbdec3a242;hb=2abf77f6c4c559a3e5b7fc351a4743305381feb6;hp=d2a1cc1b55b10aa74578e1ed10b5509557b7e2dd;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/code/late-target-error.lisp b/src/code/late-target-error.lisp index d2a1cc1..7c28116 100644 --- a/src/code/late-target-error.lisp +++ b/src/code/late-target-error.lisp @@ -13,10 +13,7 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. -(in-package "SB!CONDITIONS") - -(sb!int:file-comment - "$Header$") +(in-package "SB!KERNEL") ;;;; the CONDITION class @@ -24,20 +21,23 @@ (def!struct (condition-class (:include slot-class) (:constructor bare-make-condition-class)) - ;; List of CONDITION-SLOT structures for the direct slots of this class. + ;; list of CONDITION-SLOT structures for the direct slots of this + ;; class (slots nil :type list) - ;; List of CONDITION-SLOT structures for all of the effective class slots of - ;; this class. + ;; list of CONDITION-SLOT structures for all of the effective class + ;; slots of this class (class-slots nil :type list) - ;; Report function or NIL. + ;; report function or NIL (report nil :type (or function null)) - ;; List of alternating initargs and initforms. + ;; list of alternating initargs and initforms (default-initargs () :type list) - ;; CPL as a list of class objects, with all non-condition classes removed. + ;; class precedence list as a list of class objects, with all + ;; non-condition classes removed (cpl () :type list) - ;; A list of all the effective instance allocation slots of this class that - ;; have a non-constant initform or default-initarg. Values for these slots - ;; must be computed in the dynamic environment of MAKE-CONDITION. + ;; a list of all the effective instance allocation slots of this + ;; class that have a non-constant initform or default-initarg. + ;; Values for these slots must be computed in the dynamic + ;; environment of MAKE-CONDITION. (hairy-slots nil :type list)) (defun make-condition-class (&rest rest) @@ -54,26 +54,27 @@ (:copier nil)) (function-name nil) - ;; Actual initargs supplied to MAKE-CONDITION. + ;; actual initargs supplied to MAKE-CONDITION (actual-initargs (required-argument) :type list) - ;; Plist mapping slot names to any values that were assigned or defaulted - ;; after creation. + ;; plist mapping slot names to any values that were assigned or + ;; defaulted after creation (assigned-slots () :type list)) (defstruct condition-slot (name (required-argument) :type symbol) - ;; List of all applicable initargs. + ;; list of all applicable initargs (initargs (required-argument) :type list) - ;; Names of reader and writer functions. + ;; names of reader and writer functions (readers (required-argument) :type list) (writers (required-argument) :type list) - ;; True if :INITFORM was specified. + ;; true if :INITFORM was specified (initform-p (required-argument) :type (member t nil)) - ;; If a function, call it with no args. Otherwise, the actual value. + ;; If this is a function, call it with no args. Otherwise, it's the + ;; actual value. (initform (required-argument) :type t) - ;; Allocation of this slot. Nil only until defaulted. + ;; allocation of this slot, or NIL until defaulted (allocation nil :type (member :instance :class nil)) - ;; If :class allocation, a cons whose car holds the value. + ;; 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) @@ -89,11 +90,11 @@ (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 from CMU CL, and didn't -;;; seem to be explained there, and I haven't figured out whether it's right. -;;; -- WHN 19990612 +;;; 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 +;;; from CMU CL, and didn't seem to be explained there, and I haven't +;;; figured out whether it's right. -- WHN 19990612 (eval-when (:compile-toplevel :load-toplevel :execute) (let ((condition-class (locally ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for @@ -144,10 +145,10 @@ ) ; EVAL-WHEN ;;; FIXME: ANSI's definition of DEFINE-CONDITION says -;;; Condition reporting is mediated through the print-object method for -;;; the condition type in question, with *print-escape* always being nil. -;;; Specifying (:report report-name) in the definition of a condition -;;; type C is equivalent to: +;;; Condition reporting is mediated through the PRINT-OBJECT method +;;; for the condition type in question, with *PRINT-ESCAPE* always +;;; being nil. Specifying (:REPORT REPORT-NAME) in the definition of +;;; a condition type C is equivalent to: ;;; (defmethod print-object ((x c) stream) ;;; (if *print-escape* (call-next-method) (report-name x stream))) ;;; The current code doesn't seem to quite match that. @@ -246,7 +247,7 @@ (error 'simple-type-error :datum thing :expected-type 'condition-class - :format-control "bad thing for class arg:~% ~S" + :format-control "bad thing for class argument:~% ~S" :format-arguments (list thing))))) (res (make-condition-object args))) (setf (%instance-layout res) (class-layout class)) @@ -512,9 +513,23 @@ ,report (list ,@default-initargs)))))) +;;;; DESCRIBE on CONDITIONs + +;;; a function to be used as the guts of DESCRIBE-OBJECT (CONDITION T) +;;; eventually (once we get CLOS up and running so that we can define +;;; methods) +(defun describe-condition (condition stream) + (format stream + "~@<~S ~_is a ~S. ~_Its slot values are ~_~S.~:>" + condition + (type-of condition) + (concatenate 'list + (condition-actual-initargs condition) + (condition-assigned-slots condition)))) + ;;;; various CONDITIONs specified by ANSI -(define-condition serious-condition (condition)()) +(define-condition serious-condition (condition) ()) (define-condition error (serious-condition) ()) @@ -627,11 +642,11 @@ (arithmetic-error-operation condition) (arithmetic-error-operands condition)))))) -(define-condition division-by-zero (arithmetic-error) ()) +(define-condition division-by-zero (arithmetic-error) ()) (define-condition floating-point-overflow (arithmetic-error) ()) (define-condition floating-point-underflow (arithmetic-error) ()) (define-condition floating-point-inexact (arithmetic-error) ()) -(define-condition floating-point-invalid-operation (arithmetic-error) ()) +(define-condition floating-point-invalid-operation (arithmetic-error) ()) (define-condition print-not-readable (error) ((object :reader print-not-readable-object :initarg :object)) @@ -642,6 +657,8 @@ (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) @@ -673,6 +690,7 @@ ;;; floating point exceptions? (define-condition floating-point-exception (arithmetic-error) ((flags :initarg :traps + :initform nil :reader floating-point-exception-traps)) (:report (lambda (condition stream) (format stream @@ -712,7 +730,14 @@ :initform nil) (namestring :reader namestring-parse-error-namestring :initarg :namestring) (offset :reader namestring-parse-error-offset :initarg :offset)) - (:report %print-namestring-parse-error)) + (:report + (lambda (condition stream) + (format stream + "parse error in namestring: ~?~% ~A~% ~V@T^" + (namestring-parse-error-complaint condition) + (namestring-parse-error-arguments condition) + (namestring-parse-error-namestring condition) + (namestring-parse-error-offset condition))))) (define-condition simple-package-error (simple-condition package-error) ()) @@ -738,7 +763,7 @@ "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if none exists." (invoke-restart (find-restart 'abort condition)) - ;; ABORT signals an error in case there was a restart named abort that did + ;; ABORT signals an error in case there was a restart named ABORT that did ;; not transfer control dynamically. This could happen with RESTART-BIND. (error 'abort-failure))