+
+(define-condition format-args-mismatch (reference-condition)
+ ()
+ (:default-initargs :references (list '(:ansi-cl :section (22 3 10 2)))))
+
+(define-condition format-too-few-args-warning
+ (format-args-mismatch simple-warning)
+ ())
+(define-condition format-too-many-args-warning
+ (format-args-mismatch simple-style-warning)
+ ())
+
+(define-condition implicit-generic-function-warning (style-warning)
+ ((name :initarg :name :reader implicit-generic-function-name))
+ (:report
+ (lambda (condition stream)
+ (format stream "~@<Implicitly creating new generic function ~S.~:@>"
+ (implicit-generic-function-name condition)))))
+
+(define-condition extension-failure (reference-condition simple-error)
+ ())
+
+(define-condition structure-initarg-not-keyword
+ (reference-condition simple-style-warning)
+ ()
+ (:default-initargs :references (list '(:ansi-cl :section (2 4 8 13)))))
+
+#!+sb-package-locks
+(progn
+
+(define-condition package-lock-violation (reference-condition package-error)
+ ((format-control :initform nil :initarg :format-control
+ :reader package-error-format-control)
+ (format-arguments :initform nil :initarg :format-arguments
+ :reader package-error-format-arguments))
+ (:report
+ (lambda (condition stream)
+ (let ((control (package-error-format-control condition)))
+ (if control
+ (apply #'format stream
+ (format nil "~~@<Lock on package ~A violated when ~A.~~:@>"
+ (package-name (package-error-package condition))
+ control)
+ (package-error-format-arguments condition))
+ (format stream "~@<Lock on package ~A violated.~:@>"
+ (package-name (package-error-package condition)))))))
+ ;; no :default-initargs -- reference-stuff provided by the
+ ;; signalling form in target-package.lisp
+ #!+sb-doc
+ (:documentation
+ "Subtype of CL:PACKAGE-ERROR. A subtype of this error is signalled
+when a package-lock is violated."))
+
+(define-condition package-locked-error (package-lock-violation) ()
+ #!+sb-doc
+ (:documentation
+ "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is
+signalled when an operation on a package violates a package lock."))
+
+(define-condition symbol-package-locked-error (package-lock-violation)
+ ((symbol :initarg :symbol :reader package-locked-error-symbol))
+ #!+sb-doc
+ (:documentation
+ "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is
+signalled when an operation on a symbol violates a package lock. The
+symbol that caused the violation is accessed by the function
+SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL."))
+
+) ; progn
+
+(define-condition undefined-alien-error (cell-error) ()
+ (:report
+ (lambda (condition stream)
+ (if (slot-boundp condition 'name)
+ (format stream "Undefined alien: ~S" (cell-error-name condition))
+ (format stream "Undefined alien symbol.")))))
+
+(define-condition undefined-alien-variable-error (undefined-alien-error) ()
+ (:report
+ (lambda (condition stream)
+ (declare (ignore condition))
+ (format stream "Attempt to access an undefined alien variable."))))
+
+(define-condition undefined-alien-function-error (undefined-alien-error) ()
+ (:report
+ (lambda (condition stream)
+ (declare (ignore condition))
+ (format stream "Attempt to call an undefined alien function."))))
+
+\f
+;;;; various other (not specified by ANSI) CONDITIONs
+;;;;
+;;;; These might logically belong in other files; they're here, after
+;;;; setup of CONDITION machinery, only because that makes it easier to
+;;;; get cold init to work.
+
+;;; OAOOM warning: see cross-condition.lisp
+(define-condition encapsulated-condition (condition)
+ ((condition :initarg :condition :reader encapsulated-condition)))
+
+(define-condition values-type-error (type-error)
+ ()
+ (:report
+ (lambda (condition stream)
+ (format stream
+ "~@<The values set ~2I~:_[~{~S~^ ~}] ~I~_is not of type ~2I~_~S.~:>"
+ (type-error-datum condition)
+ (type-error-expected-type condition)))))
+
+;;; KLUDGE: a condition for floating point errors when we can't or
+;;; won't figure out what type they are. (In FreeBSD and OpenBSD we
+;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably
+;;; know how but the old code was broken by the conversion to POSIX
+;;; signal handling and hasn't been fixed as of sbcl-0.6.7.)
+;;;
+;;; FIXME: Perhaps this should also be a base class for all
+;;; 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
+ "An arithmetic error ~S was signalled.~%"
+ (type-of condition))
+ (let ((traps (floating-point-exception-traps condition)))
+ (if traps
+ (format stream
+ "Trapping conditions are: ~%~{ ~S~^~}~%"
+ traps)
+ (write-line
+ "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
+ (lambda (condition stream)
+ (format stream
+ "The index ~S is too large."
+ (type-error-datum condition)))))
+
+(define-condition bounding-indices-bad-error (reference-condition type-error)
+ ((object :reader bounding-indices-bad-object :initarg :object))
+ (:report
+ (lambda (condition stream)
+ (let* ((datum (type-error-datum condition))
+ (start (car datum))
+ (end (cdr datum))
+ (object (bounding-indices-bad-object condition)))
+ (etypecase object
+ (sequence
+ (format stream
+ "The bounding indices ~S and ~S are bad ~
+ for a sequence of length ~S."
+ start end (length object)))
+ (array
+ ;; from WITH-ARRAY-DATA
+ (format stream
+ "The START and END parameters ~S and ~S are ~
+ bad for an array of total size ~S."
+ start end (array-total-size object)))))))
+ (:default-initargs
+ :references
+ (list '(:ansi-cl :glossary "bounding index designator")
+ '(:ansi-cl :issue "SUBSEQ-OUT-OF-BOUNDS:IS-AN-ERROR"))))
+
+(define-condition nil-array-accessed-error (reference-condition type-error)
+ ()
+ (:report (lambda (condition stream)
+ (declare (ignore condition))
+ (format stream
+ "An attempt to access an array of element-type ~
+ NIL was made. Congratulations!")))
+ (:default-initargs
+ :references (list '(:ansi-cl :function sb!xc:upgraded-array-element-type)
+ '(:ansi-cl :section (15 1 2 1))
+ '(:ansi-cl :section (15 1 2 2)))))
+
+(define-condition namestring-parse-error (parse-error)
+ ((complaint :reader namestring-parse-error-complaint :initarg :complaint)
+ (args :reader namestring-parse-error-args :initarg :args :initform nil)
+ (namestring :reader namestring-parse-error-namestring :initarg :namestring)
+ (offset :reader namestring-parse-error-offset :initarg :offset))
+ (:report
+ (lambda (condition stream)
+ (format stream
+ "parse error in namestring: ~?~% ~A~% ~V@T^"
+ (namestring-parse-error-complaint condition)
+ (namestring-parse-error-args condition)
+ (namestring-parse-error-namestring condition)
+ (namestring-parse-error-offset condition)))))
+
+(define-condition simple-package-error (simple-condition package-error) ())
+
+(define-condition simple-reader-package-error (simple-reader-error) ())
+
+(define-condition reader-eof-error (end-of-file)
+ ((context :reader reader-eof-error-context :initarg :context))
+ (:report
+ (lambda (condition stream)
+ (format stream
+ "unexpected end of file on ~S ~A"
+ (stream-error-stream condition)
+ (reader-eof-error-context condition)))))
+
+(define-condition reader-impossible-number-error (simple-reader-error)
+ ((error :reader reader-impossible-number-error-error :initarg :error))
+ (:report
+ (lambda (condition stream)
+ (let ((error-stream (stream-error-stream condition)))
+ (format stream
+ "READER-ERROR ~@[at ~W ~]on ~S:~%~?~%Original error: ~A"
+ (file-position-or-nil-for-error error-stream) error-stream
+ (simple-condition-format-control condition)
+ (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 timeout (serious-condition)
+ ((seconds :initarg :seconds :initform nil :reader timeout-seconds))
+ (:report (lambda (condition stream)
+ (format stream "Timeout occurred~@[ after ~A seconds~]."
+ (timeout-seconds condition)))))
+
+(define-condition io-timeout (stream-error timeout)
+ ((direction :reader io-timeout-direction :initarg :direction))
+ (:report
+ (lambda (condition stream)
+ (declare (type stream stream))
+ (format stream
+ "I/O timeout ~(~A~)ing ~S."
+ (io-timeout-direction condition)
+ (stream-error-stream condition)))))
+
+(define-condition deadline-timeout (timeout) ()
+ (:report (lambda (condition stream)
+ (format stream "A deadline was reached after ~A seconds."
+ (timeout-seconds condition)))))
+
+(define-condition declaration-type-conflict-error (reference-condition
+ simple-error)
+ ()
+ (:default-initargs
+ :format-control "symbol ~S cannot be both the name of a type and the name of a declaration"
+ :references (list '(:ansi-cl :section (3 8 21)))))
+
+;;; Single stepping conditions
+
+(define-condition step-condition ()
+ ((form :initarg :form :reader step-condition-form))
+
+ #!+sb-doc
+ (:documentation "Common base class of single-stepping conditions.
+STEP-CONDITION-FORM holds a string representation of the form being
+stepped."))
+
+#!+sb-doc
+(setf (fdocumentation 'step-condition-form 'function)
+ "Form associated with the STEP-CONDITION.")
+
+(define-condition step-form-condition (step-condition)
+ ((args :initarg :args :reader step-condition-args))
+ (:report
+ (lambda (condition stream)
+ (let ((*print-circle* t)
+ (*print-pretty* t)
+ (*print-readably* nil))
+ (format stream
+ "Evaluating call:~%~< ~@;~A~:>~%~
+ ~:[With arguments:~%~{ ~S~%~}~;With unknown arguments~]~%"
+ (list (step-condition-form condition))
+ (eq (step-condition-args condition) :unknown)
+ (step-condition-args condition)))))
+ #!+sb-doc
+ (:documentation "Condition signalled by code compiled with
+single-stepping information when about to execute a form.
+STEP-CONDITION-FORM holds the form, STEP-CONDITION-PATHNAME holds the
+pathname of the original file or NIL, and STEP-CONDITION-SOURCE-PATH
+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."))
+
+(define-condition step-result-condition (step-condition)
+ ((result :initarg :result :reader step-condition-result)))
+
+#!+sb-doc
+(setf (fdocumentation 'step-condition-result 'function)
+ "Return values associated with STEP-VALUES-CONDITION as a list,
+or the variable value associated with STEP-VARIABLE-CONDITION.")
+
+(define-condition step-values-condition (step-result-condition)
+ ()
+ #!+sb-doc
+ (:documentation "Condition signalled by code compiled with
+single-stepping information after executing a form.
+STEP-CONDITION-FORM holds the form, and STEP-CONDITION-RESULT holds
+the values returned by the form as a list. No associated restarts."))
+
+(define-condition step-finished-condition (step-condition)
+ ()
+ (:report
+ (lambda (condition stream)
+ (declare (ignore condition))
+ (format stream "Returning from STEP")))
+ #!+sb-doc
+ (:documentation "Condition signaled when STEP returns."))
+\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 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
+;; redefinitions, but other redefinitions could be done later
+;; (e.g. methods).
+(define-condition redefinition-warning (style-warning)
+ ())
+
+(define-condition function-redefinition-warning (redefinition-warning)
+ ((name :initarg :name :reader function-redefinition-warning-name)
+ (old :initarg :old :reader function-redefinition-warning-old-fdefinition)
+ ;; For DEFGENERIC and perhaps others, the redefinition
+ ;; destructively modifies the original, rather than storing a new
+ ;; object, so there's no NEW here, but only in subclasses.
+ ))
+
+(define-condition redefinition-with-defun (function-redefinition-warning)
+ ((new :initarg :new :reader redefinition-with-defun-new-fdefinition)
+ ;; KLUDGE: it would be nice to fix the unreasonably late
+ ;; back-patching of DEBUG-SOURCEs in the DEBUG-INFO during
+ ;; fasloading and just use the new fdefinition, but for the moment
+ ;; we'll compare the SOURCE-LOCATION created during DEFUN with the
+ ;; previous DEBUG-SOURCE.
+ (new-location :initarg :new-location
+ :reader redefinition-with-defun-new-location))
+ (:report (lambda (warning stream)
+ (format stream "redefining ~S in DEFUN"
+ (function-redefinition-warning-name warning)))))
+
+(define-condition redefinition-with-defgeneric (function-redefinition-warning)
+ ((new-location :initarg :new-location
+ :reader redefinition-with-defgeneric-new-location))
+ (:report (lambda (warning stream)
+ (format stream "redefining ~S in DEFGENERIC"
+ (function-redefinition-warning-name warning)))))
+
+(define-condition redefinition-with-defmethod (redefinition-warning)
+ ((gf :initarg :generic-function
+ :reader redefinition-with-defmethod-generic-function)
+ (qualifiers :initarg :qualifiers
+ :reader redefinition-with-defmethod-qualifiers)
+ (specializers :initarg :specializers
+ :reader redefinition-with-defmethod-specializers)
+ (new-location :initarg :new-location
+ :reader redefinition-with-defmethod-new-location)
+ (old-method :initarg :old-method
+ :reader redefinition-with-defmethod-old-method))
+ (:report (lambda (warning stream)
+ (format stream "redefining ~S~{ ~S~} ~S in DEFMETHOD"
+ (redefinition-with-defmethod-generic-function warning)
+ (redefinition-with-defmethod-qualifiers warning)
+ (redefinition-with-defmethod-specializers warning)))))
+
+;; FIXME: see the FIXMEs in defmacro.lisp, then maybe instantiate this.
+(define-condition redefinition-with-defmacro (function-redefinition-warning)
+ ())
+
+;; Here are a few predicates for what people might find interesting
+;; about redefinitions.
+
+;; DEFUN can replace a generic function with an ordinary function.
+;; (Attempting to replace an ordinary function with a generic one
+;; causes an error, though.)
+(defun redefinition-replaces-generic-function-p (warning)
+ (and (typep warning 'redefinition-with-defun)
+ (typep (function-redefinition-warning-old-fdefinition warning)
+ 'generic-function)))
+
+(defun redefinition-replaces-compiled-function-with-interpreted-p (warning)
+ (and (typep warning 'redefinition-with-defun)
+ (compiled-function-p
+ (function-redefinition-warning-old-fdefinition warning))
+ (not (compiled-function-p
+ (redefinition-with-defun-new-fdefinition warning)))))
+
+;; Most people seem to agree that re-running a DEFUN in a file is
+;; completely uninteresting.
+(defun uninteresting-ordinary-function-redefinition-p (warning)
+ ;; OAOO violation: this duplicates code in SB-INTROSPECT.
+ ;; Additionally, there are some functions that aren't
+ ;; funcallable-instances for which finding the source location is
+ ;; complicated (e.g. DEFSTRUCT-defined predicates and accessors),
+ ;; but I don't think they're defined with %DEFUN, so the warning
+ ;; isn't raised.
+ (flet ((fdefinition-file-namestring (fdefn)
+ #!+sb-eval
+ (when (typep fdefn 'sb!eval:interpreted-function)
+ (return-from fdefinition-file-namestring
+ (sb!c:definition-source-location-namestring
+ (sb!eval:interpreted-function-source-location fdefn))))
+ ;; All the following accesses are guarded with conditionals
+ ;; because it's not clear whether any of the slots we're
+ ;; chasing down are guaranteed to be filled in.
+ (let* ((fdefn
+ ;; KLUDGE: although this looks like it only works
+ ;; for %SIMPLE-FUNs, in fact there's a pun such
+ ;; that %SIMPLE-FUN-SELF returns the simple-fun
+ ;; object for closures and
+ ;; funcallable-instances. -- CSR, circa 2005
+ (sb!kernel:%simple-fun-self fdefn))
+ (code (if fdefn (sb!kernel:fun-code-header fdefn)))
+ (debug-info (if code (sb!kernel:%code-debug-info code)))
+ (debug-source (if debug-info
+ (sb!c::debug-info-source debug-info)))
+ (namestring (if debug-source
+ (sb!c::debug-source-namestring debug-source))))
+ namestring)))
+ (and
+ ;; There's garbage in various places when the first DEFUN runs in
+ ;; cold-init.
+ sb!kernel::*cold-init-complete-p*
+ (typep warning 'redefinition-with-defun)
+ (let ((old-fdefn
+ (function-redefinition-warning-old-fdefinition warning))
+ (new-fdefn
+ (redefinition-with-defun-new-fdefinition warning)))
+ ;; Replacing a compiled function with a compiled function is
+ ;; 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 case.
+ (when (or (typep
+ old-fdefn
+ '(or #!+sb-eval sb!eval:interpreted-function))
+ (and (typep old-fdefn
+ '(and compiled-function
+ (not funcallable-instance)))
+ ;; Since this is a REDEFINITION-WITH-DEFUN,
+ ;; NEW-FDEFN can't be a FUNCALLABLE-INSTANCE.
+ (typep new-fdefn 'compiled-function)))
+ (let* ((old-namestring (fdefinition-file-namestring old-fdefn))
+ (new-namestring
+ (or (fdefinition-file-namestring new-fdefn)
+ (let ((srcloc
+ (redefinition-with-defun-new-location warning)))
+ (if srcloc
+ (sb!c::definition-source-location-namestring
+ srcloc))))))
+ (and old-namestring
+ new-namestring
+ (equal old-namestring new-namestring))))))))
+
+(defun uninteresting-generic-function-redefinition-p (warning)
+ (and (typep warning 'redefinition-with-defgeneric)
+ (let* ((old-fdefn
+ (function-redefinition-warning-old-fdefinition warning))
+ (old-location
+ (if (typep old-fdefn 'generic-function)
+ (sb!pcl::definition-source old-fdefn)))
+ (old-namestring
+ (if old-location
+ (sb!c:definition-source-location-namestring old-location)))
+ (new-location
+ (redefinition-with-defgeneric-new-location warning))
+ (new-namestring
+ (if new-location
+ (sb!c:definition-source-location-namestring new-location))))
+ (and old-namestring
+ new-namestring
+ (equal old-namestring new-namestring)))))
+
+(defun uninteresting-method-redefinition-p (warning)
+ (and (typep warning 'redefinition-with-defmethod)
+ (let* ((old-method (redefinition-with-defmethod-old-method warning))
+ (old-location (sb!pcl::definition-source old-method))
+ (old-namestring (if old-location
+ (sb!c:definition-source-location-namestring
+ old-location)))
+ (new-location (redefinition-with-defmethod-new-location warning))
+ (new-namestring (if new-location
+ (sb!c:definition-source-location-namestring
+ new-location))))
+ (and new-namestring
+ old-namestring
+ (equal new-namestring old-namestring)))))
+
+(deftype uninteresting-redefinition ()
+ '(or (satisfies uninteresting-ordinary-function-redefinition-p)
+ (satisfies uninteresting-generic-function-redefinition-p)
+ (satisfies uninteresting-method-redefinition-p)))
+
+(define-condition redefinition-with-deftransform (redefinition-warning)
+ ((transform :initarg :transform
+ :reader redefinition-with-deftransform-transform))
+ (:report (lambda (warning stream)
+ (format stream "Overwriting ~S"
+ (redefinition-with-deftransform-transform warning)))))
+\f
+;;; Various other STYLE-WARNINGS
+(define-condition dubious-asterisks-around-variable-name
+ (style-warning simple-condition)
+ ()
+ (:report (lambda (warning stream)
+ (format stream "~@?, even though the name follows~@
+the usual naming convention (names like *FOO*) for special variables"
+ (simple-condition-format-control warning)
+ (simple-condition-format-arguments warning)))))
+
+(define-condition asterisks-around-lexical-variable-name
+ (dubious-asterisks-around-variable-name)
+ ())
+
+(define-condition asterisks-around-constant-variable-name
+ (dubious-asterisks-around-variable-name)
+ ())
+
+;; 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"
+ (undefined-alien-symbol warning)))))
+
+#!+sb-eval
+(define-condition lexical-environment-too-complex (style-warning)
+ ((form :initarg :form :reader lexical-environment-too-complex-form)
+ (lexenv :initarg :lexenv :reader lexical-environment-too-complex-lexenv))
+ (:report (lambda (warning stream)
+ (format stream
+ "~@<Native lexical environment too complex for ~
+ SB-EVAL to evaluate ~S, falling back to ~
+ SIMPLE-EVAL-IN-LEXENV. Lexenv: ~S~:@>"
+ (lexical-environment-too-complex-form warning)
+ (lexical-environment-too-complex-lexenv warning)))))
+
+;; Although this has -ERROR- in the name, it's just a STYLE-WARNING.
+(define-condition character-decoding-error-in-comment (style-warning)
+ ((stream :initarg :stream :reader decoding-error-in-comment-stream)
+ (position :initarg :position :reader decoding-error-in-comment-position))
+ (:report (lambda (warning stream)
+ (format stream
+ "Character decoding error in a ~A-comment at ~
+ position ~A reading source stream ~A, ~
+ resyncing."
+ (decoding-error-in-comment-macro warning)
+ (decoding-error-in-comment-position warning)
+ (decoding-error-in-comment-stream warning)))))
+
+(define-condition character-decoding-error-in-macro-char-comment
+ (character-decoding-error-in-comment)
+ ((char :initform #\; :initarg :char
+ :reader character-decoding-error-in-macro-char-comment-char)))
+
+(define-condition character-decoding-error-in-dispatch-macro-char-comment
+ (character-decoding-error-in-comment)
+ ;; ANSI doesn't give a way for a reader function invoked by a
+ ;; dispatch macro character to determine which dispatch character
+ ;; was used, so if a user wants to signal one of these from a custom
+ ;; comment reader, he'll have to supply the :DISP-CHAR himself.
+ ((disp-char :initform #\# :initarg :disp-char
+ :reader character-decoding-error-in-macro-char-comment-disp-char)
+ (sub-char :initarg :sub-char
+ :reader character-decoding-error-in-macro-char-comment-sub-char)))
+
+(defun decoding-error-in-comment-macro (warning)
+ (etypecase warning
+ (character-decoding-error-in-macro-char-comment
+ (character-decoding-error-in-macro-char-comment-char warning))
+ (character-decoding-error-in-dispatch-macro-char-comment
+ (format
+ nil "~C~C"
+ (character-decoding-error-in-macro-char-comment-disp-char warning)
+ (character-decoding-error-in-macro-char-comment-sub-char warning)))))
+
+(define-condition deprecated-eval-when-situations (style-warning)
+ ((situations :initarg :situations
+ :reader deprecated-eval-when-situations-situations))
+ (:report (lambda (warning stream)
+ (format stream "using deprecated EVAL-WHEN situation names~{ ~S~}"
+ (deprecated-eval-when-situations-situations warning)))))
+
+(define-condition proclamation-mismatch (style-warning)
+ ((name :initarg :name :reader proclamation-mismatch-name)
+ (old :initarg :old :reader proclamation-mismatch-old)
+ (new :initarg :new :reader proclamation-mismatch-new)))
+
+(define-condition type-proclamation-mismatch (proclamation-mismatch)
+ ()
+ (:report (lambda (warning stream)
+ (format stream
+ "The new TYPE proclamation~% ~S for ~S does not ~
+ match the old TYPE proclamation ~S"
+ (proclamation-mismatch-new warning)
+ (proclamation-mismatch-name warning)
+ (proclamation-mismatch-old warning)))))
+
+(define-condition ftype-proclamation-mismatch (proclamation-mismatch)
+ ()
+ (:report (lambda (warning stream)
+ (format stream
+ "The new FTYPE proclamation~% ~S for ~S does not ~
+ match the old FTYPE proclamation ~S"
+ (proclamation-mismatch-new warning)
+ (proclamation-mismatch-name warning)
+ (proclamation-mismatch-old warning)))))