X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-target-error.lisp;h=86732a541018667c689d0bd155fd5f4a7d0fb13c;hb=18d4de696bc5063aad026ba62be613c7b07f5fc8;hp=f941ab0701e1efb44039701c12fedf21a5df2f72;hpb=a26fc2e03904bd0dac626a43e169e2e3514344d4;p=sbcl.git diff --git a/src/code/late-target-error.lisp b/src/code/late-target-error.lisp index f941ab0..86732a5 100644 --- a/src/code/late-target-error.lisp +++ b/src/code/late-target-error.lisp @@ -13,10 +13,12 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. -(in-package "SB!CONDITIONS") +(in-package "SB!KERNEL") ;;;; 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) @@ -77,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 @@ -130,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 @@ -166,7 +158,7 @@ ;;;; 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)) @@ -174,8 +166,8 @@ (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) @@ -188,11 +180,14 @@ 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 @@ -210,13 +205,17 @@ (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) @@ -254,13 +253,14 @@ ;; 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)))) @@ -304,31 +304,27 @@ (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) @@ -365,8 +361,8 @@ #'(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 @@ -382,7 +378,7 @@ (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) @@ -537,10 +533,10 @@ (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 @@ -552,35 +548,22 @@ (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)) +(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) ()) @@ -591,7 +574,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) @@ -599,8 +582,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))))) @@ -614,16 +601,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) @@ -642,11 +627,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)) @@ -688,6 +673,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 @@ -707,8 +693,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) @@ -717,7 +702,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))))) @@ -727,7 +712,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 +730,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))))) @@ -753,8 +745,9 @@ "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) @@ -779,3 +772,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") +