;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
-(in-package "SB!CONDITIONS")
+(in-package "SB!KERNEL")
\f
;;;; the CONDITION class
+(/show0 "late-target-error.lisp 20")
+
(eval-when (:compile-toplevel :load-toplevel :execute)
(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)
(apply #'bare-make-condition-class
- (rename-keyword-args '((:name :%name)) rest)))
+ (rename-key-args '((:name :%name)) rest)))
) ; EVAL-WHEN
(: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
+(defstruct (condition-slot (:copier nil))
(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)
- ;; the appropriate initialization value for the CPL slot of a CONDITION,
- ;; calculated by looking at the INHERITS information in the LAYOUT
- ;; of the CONDITION
+ ;; 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))
(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
) ; 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.
\f
;;;; slots of CONDITION objects
-(defvar *empty-slot* '(empty))
+(defvar *empty-condition-slot* '(empty))
(defun find-slot-default (class slot)
(let ((initargs (condition-slot-initargs slot))
(dolist (class cpl)
(let ((default-initargs (condition-class-default-initargs class)))
(dolist (initarg initargs)
- (let ((val (getf default-initargs initarg *empty-slot*)))
- (unless (eq val *empty-slot*)
+ (let ((val (getf default-initargs initarg *empty-condition-slot*)))
+ (unless (eq val *empty-condition-slot*)
(return-from find-slot-default
(if (functionp val)
(funcall val)
initform))
(error "unbound condition slot: ~S" (condition-slot-name slot)))))
-(defun find-slot (classes name)
- (dolist (sclass classes nil)
+(defun find-condition-class-slot (condition-class slot-name)
+ (dolist (sclass
+ (condition-class-cpl condition-class)
+ (error "There is no slot named ~S in ~S."
+ slot-name condition-class))
(dolist (slot (condition-class-slots sclass))
- (when (eq (condition-slot-name slot) name)
- (return-from find-slot slot)))))
+ (when (eq (condition-slot-name slot) slot-name)
+ (return-from find-condition-class-slot slot)))))
(defun condition-writer-function (condition new-value name)
(dolist (cslot (condition-class-class-slots
(car (condition-slot-cell cslot)))))
(let ((val (getf (condition-assigned-slots condition) name
- *empty-slot*)))
- (if (eq val *empty-slot*)
+ *empty-condition-slot*)))
+ (if (eq val *empty-condition-slot*)
(let ((actual-initargs (condition-actual-initargs condition))
- (slot (find-slot (condition-class-cpl class) name)))
+ (slot (find-condition-class-slot class name)))
+ (unless slot
+ (error "missing slot ~S of ~S" name condition))
(dolist (initarg (condition-slot-initargs slot))
- (let ((val (getf actual-initargs initarg *empty-slot*)))
- (unless (eq val *empty-slot*)
+ (let ((val (getf actual-initargs
+ initarg
+ *empty-condition-slot*)))
+ (unless (eq val *empty-condition-slot*)
(return-from condition-reader-function
(setf (getf (condition-assigned-slots condition)
name)
(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))
;; Set any class slots with initargs present in this call.
(dolist (cslot (condition-class-class-slots class))
(dolist (initarg (condition-slot-initargs cslot))
- (let ((val (getf args initarg *empty-slot*)))
- (unless (eq val *empty-slot*)
+ (let ((val (getf args initarg *empty-condition-slot*)))
+ (unless (eq val *empty-condition-slot*)
(setf (car (condition-slot-cell cslot)) val)))))
;; Default any slots with non-constant defaults now.
(dolist (hslot (condition-class-hairy-slots class))
(when (dolist (initarg (condition-slot-initargs hslot) t)
- (unless (eq (getf args initarg *empty-slot*) *empty-slot*)
+ (unless (eq (getf args initarg *empty-condition-slot*)
+ *empty-condition-slot*)
(return nil)))
(setf (getf (condition-assigned-slots res) (condition-slot-name hslot))
(find-slot-default class hslot))))
#'(lambda (new-value condition)
(condition-writer-function condition new-value name))))))
- ;; Compute effective slots and set up the class and hairy slots (subsets of
- ;; the effective slots.)
+ ;; Compute effective slots and set up the class and hairy slots
+ ;; (subsets of the effective slots.)
(let ((eslots (compute-effective-slots class))
(e-def-initargs
(reduce #'append
(if (functionp initform)
(funcall initform)
initform))
- *empty-slot*))))
+ *empty-condition-slot*))))
(push slot (condition-class-class-slots class)))
((:instance nil)
(setf (condition-slot-allocation slot) :instance)
,report
(list ,@default-initargs))))))
\f
+;;;; 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))))
+\f
;;;; various CONDITIONs specified by ANSI
-(define-condition serious-condition (condition)())
+(define-condition serious-condition (condition) ())
(define-condition error (serious-condition) ())
(define-condition style-warning (warning) ())
(defun simple-condition-printer (condition stream)
- ;; FIXME: Why use APPLY instead of an ordinary form? To stop the optimizer
- ;; from doing something?
- (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
(defun print-simple-error (condition stream)
(format stream
- "~&~@<error in function ~S: ~3I~:_~?~:>"
+ ;; 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.
+ "~@<error in function ~S: ~2I~:_~?~:>"
(condition-function-name condition)
(simple-condition-format-control condition)
(simple-condition-format-arguments condition)))
(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?
+;;; 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)
(:report
(lambda (condition stream)
(format stream
- "~@<TYPE-ERROR in ~S: ~3I~:_~S is not of type ~S~:>."
+ "~@<TYPE-ERROR in ~S: ~2I~:_~S is not of type ~S~:>."
(condition-function-name condition)
(type-error-datum condition)
(type-error-expected-type condition)))))
(:report
(lambda (condition stream)
(format stream
- "~&~@<FILE-ERROR in function ~S: ~3i~:_~?~:>"
+ "~@<FILE-ERROR in function ~S: ~2I~:_~?~:>"
(condition-function-name condition)
(serious-condition-format-control condition)
(serious-condition-format-arguments condition)))))
(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))
(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)
;;; 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
: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) ())
"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
- ;; not transfer control dynamically. This could happen with RESTART-BIND.
+ ;; 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))
(defun muffle-warning (&optional condition)
(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")
+
projects / sbcl.git / blobdiff