X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcondition.lisp;h=ee00b04325d42faa6dba35968f8885b760a716b9;hb=65b5ab7e713d04e0d76bc0ee196374f6e57b922f;hp=ace650cf790205e1fdca02d0c96ad200f9c9392b;hpb=ee8c58af0f59d9e5b4307efcbf944f88b850343b;p=sbcl.git diff --git a/src/code/condition.lisp b/src/code/condition.lisp index ace650c..ee00b04 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -171,7 +171,10 @@ ;;; The current code doesn't seem to quite match that. (def!method print-object ((x condition) stream) (if *print-escape* - (print-unreadable-object (x stream :type t :identity t)) + (if (and (typep x 'simple-condition) (slot-boundp x 'format-control)) + (print-unreadable-object (x stream :type t :identity t) + (format stream "~S" (simple-condition-format-control x))) + (print-unreadable-object (x stream :type t :identity t))) ;; KLUDGE: A comment from CMU CL here said ;; 7/13/98 BUG? CPL is not sorted and results here depend on order of ;; superclasses in define-condition call! @@ -576,20 +579,6 @@ ',(all-writers) (sb!c:source-location))))))) -;;;; 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) ()) @@ -648,6 +637,11 @@ "end of file on ~S" (stream-error-stream condition))))) +(define-condition closed-stream-error (stream-error) () + (:report + (lambda (condition stream) + (format stream "~S is closed" (stream-error-stream condition))))) + (define-condition file-error (error) ((pathname :reader file-error-pathname :initarg :pathname)) (:report @@ -903,6 +897,9 @@ (define-condition simple-reference-error (reference-condition simple-error) ()) +(define-condition simple-reference-warning (reference-condition simple-warning) + ()) + (define-condition duplicate-definition (reference-condition warning) ((name :initarg :name :reader duplicate-definition-name)) (:report (lambda (c s) @@ -946,15 +943,12 @@ '(:ansi-cl :function make-array) '(:ansi-cl :function sb!xc:upgraded-array-element-type)))) -(define-condition displaced-to-array-too-small-error - (reference-condition simple-error) - () - (:default-initargs - :references (list '(:ansi-cl :function adjust-array)))) - (define-condition type-warning (reference-condition simple-warning) () (:default-initargs :references (list '(:sbcl :node "Handling of Types")))) +(define-condition type-style-warning (reference-condition simple-style-warning) + () + (:default-initargs :references (list '(:sbcl :node "Handling of Types")))) (define-condition local-argument-mismatch (reference-condition simple-warning) () @@ -1093,6 +1087,36 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) "No traps are enabled? How can this be?" stream)))))) +(define-condition invalid-array-index-error (type-error) + ((array :initarg :array :reader invalid-array-index-error-array) + (axis :initarg :axis :reader invalid-array-index-error-axis)) + (:report + (lambda (condition stream) + (let ((array (invalid-array-index-error-array condition))) + (format stream "Index ~W out of bounds for ~@[axis ~W of ~]~S, ~ + should be nonnegative and <~W." + (type-error-datum condition) + (when (> (array-rank array) 1) + (invalid-array-index-error-axis condition)) + (type-of array) + ;; Extract the bound from (INTEGER 0 (BOUND)) + (caaddr (type-error-expected-type condition))))))) + +(define-condition invalid-array-error (reference-condition type-error) () + (:report + (lambda (condition stream) + (let ((*print-array* nil)) + (format stream + "~@" + (type-error-expected-type condition) + (array-displacement (type-error-datum condition)))))) + (:default-initargs + :references + (list '(:ansi-cl :function adjust-array)))) + (define-condition index-too-large-error (type-error) () (:report @@ -1177,6 +1201,25 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (simple-condition-format-arguments condition) (reader-impossible-number-error-error condition)))))) +(define-condition standard-readtable-modified-error (reference-condition error) + ((operation :initarg :operation :reader standard-readtable-modified-operation)) + (:report (lambda (condition stream) + (format stream "~S would modify the standard readtable." + (standard-readtable-modified-operation condition)))) + (:default-initargs :references `((:ansi-cl :section (2 1 1 2)) + (:ansi-cl :glossary "standard readtable")))) + +(define-condition standard-pprint-dispatch-table-modified-error + (reference-condition error) + ((operation :initarg :operation + :reader standard-pprint-dispatch-table-modified-operation)) + (:report (lambda (condition stream) + (format stream "~S would modify the standard pprint dispatch table." + (standard-pprint-dispatch-table-modified-operation + condition)))) + (:default-initargs + :references `((:ansi-cl :glossary "standard pprint dispatch table")))) + (define-condition timeout (serious-condition) ((seconds :initarg :seconds :initform nil :reader timeout-seconds)) (:report (lambda (condition stream) @@ -1241,14 +1284,6 @@ holds the source-path to the original form within that file or NIL. Associated with this condition are always the restarts STEP-INTO, STEP-NEXT, and STEP-CONTINUE.")) -#!+sb-doc -(setf (fdocumentation 'step-condition-source-path 'function) - "Source-path of the original form associated with the -STEP-FORM-CONDITION or NIL." - (fdocumentation 'step-condition-pathname 'function) - "Pathname of the original source-file associated with the -STEP-FORM-CONDITION or NIL.") - (define-condition step-result-condition (step-condition) ((result :initarg :result :reader step-condition-result))) @@ -1276,8 +1311,9 @@ the values returned by the form as a list. No associated restarts.")) ;;; A knob for muffling warnings, mostly for use while loading files. (defvar *muffled-warnings* 'uninteresting-redefinition - "A type that ought to specify a subtype of WARNING. Whenever a warning -is signaled, if the warning if of this type, it will be muffled.") + "A type that ought to specify a subtype of WARNING. Whenever a +warning is signaled, if the warning if of this type and is not +handled by any other handler, it will be muffled.") ;;; Various STYLE-WARNING signaled in the system. ;; For the moment, we're only getting into the details for function @@ -1398,11 +1434,10 @@ is signaled, if the warning if of this type, it will be muffled.") ;; clearly uninteresting, and we'll say arbitrarily that ;; replacing an interpreted function with an interpreted ;; function is uninteresting, too, but leave out the - ;; compiled-to-interpreted and interpreted-to-compiled cases. - (when (or (and (typep old-fdefn - '(or #!+sb-eval sb!eval:interpreted-function)) - (typep new-fdefn - '(or #!+sb-eval sb!eval:interpreted-function))) + ;; compiled-to-interpreted case. + (when (or (typep + old-fdefn + '(or #!+sb-eval sb!eval:interpreted-function)) (and (typep old-fdefn '(and compiled-function (not funcallable-instance)))