;;; 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!
',(all-writers)
(sb!c:source-location)))))))
\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 simple-style-warning (simple-condition style-warning) ())
(define-condition simple-type-error (simple-condition type-error) ())
+;; Can't have a function called SIMPLE-TYPE-ERROR or TYPE-ERROR...
+(declaim (ftype (sfunction (t t t &rest t) nil) bad-type))
+(defun bad-type (datum type control &rest arguments)
+ (error 'simple-type-error
+ :datum datum
+ :expected-type type
+ :format-control control
+ :format-arguments arguments))
+
(define-condition program-error (error) ())
(define-condition parse-error (error) ())
(define-condition control-error (error) ())
"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
(define-condition simple-reference-error (reference-condition simple-error)
())
+(define-condition simple-reference-warning (reference-condition simple-warning)
+ ())
+
+(define-condition arguments-out-of-domain-error
+ (arithmetic-error reference-condition)
+ ())
+
(define-condition duplicate-definition (reference-condition warning)
((name :initarg :name :reader duplicate-definition-name))
(:report (lambda (c s)
'(: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)
()
"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
+ "~@<Displaced array originally of type ~S has been invalidated ~
+ due its displaced-to array ~S having become too small to hold ~
+ it: the displaced array's dimensions have all been set to zero ~
+ to trap accesses to it.~:@>"
+ (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
(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)
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)))
\f
;;; 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.")
\f
;;; Various STYLE-WARNING signaled in the system.
;; For the moment, we're only getting into the details for function
;; 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)))
(redefinition-with-deftransform-transform warning)))))
\f
;;; Various other STYLE-WARNINGS
-(define-condition ignoring-asterisks-in-variable-name
+(define-condition dubious-asterisks-around-variable-name
(style-warning simple-condition)
()
(:report (lambda (warning stream)
(simple-condition-format-control warning)
(simple-condition-format-arguments warning)))))
-(define-condition ignoring-asterisks-in-lexical-variable-name
- (ignoring-asterisks-in-variable-name)
+(define-condition asterisks-around-lexical-variable-name
+ (dubious-asterisks-around-variable-name)
())
-(define-condition ignoring-asterisks-in-constant-variable-name
- (ignoring-asterisks-in-variable-name)
+(define-condition asterisks-around-constant-variable-name
+ (dubious-asterisks-around-variable-name)
())
-(define-condition undefined-alien (style-warning)
+;; We call this UNDEFINED-ALIEN-STYLE-WARNING because there are some
+;; subclasses of ERROR above having to do with undefined aliens.
+(define-condition undefined-alien-style-warning (style-warning)
((symbol :initarg :symbol :reader undefined-alien-symbol))
(:report (lambda (warning stream)
(format stream "Undefined alien: ~S"