X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcondition.lisp;h=59afa4a4c731f547388995c8542b36567094b05c;hb=5d04a95274c9ddaebbcd6ddffc5d646e2c25598c;hp=253b76f7bc7c8b3af7fa037fedf41f6b4f65a4a1;hpb=5ee902ed6ceef841efee4a50459ff545293a1d95;p=sbcl.git
diff --git a/src/code/condition.lisp b/src/code/condition.lisp
index 253b76f..59afa4a 100644
--- a/src/code/condition.lisp
+++ b/src/code/condition.lisp
@@ -619,9 +619,6 @@
(define-condition simple-error (simple-condition error) ())
-;;; not specified by ANSI, but too useful not to have around.
-(define-condition simple-style-warning (simple-condition style-warning) ())
-
(define-condition storage-condition (serious-condition) ())
(define-condition type-error (error)
@@ -634,6 +631,8 @@
(type-error-datum condition)
(type-error-expected-type condition)))))
+;;; not specified by ANSI, but too useful not to have around.
+(define-condition simple-style-warning (simple-condition style-warning) ())
(define-condition simple-type-error (simple-condition type-error) ())
(define-condition program-error (error) ())
@@ -718,50 +717,70 @@
(*print-array* nil))
(format stream "~S cannot be printed readably." obj)))))
-(define-condition reader-error (parse-error stream-error)
- ((format-control
- :reader reader-error-format-control
- :initarg :format-control)
- (format-arguments
- :reader reader-error-format-arguments
- :initarg :format-arguments
- :initform '()))
- (:report
- (lambda (condition stream)
- (let* ((error-stream (stream-error-stream condition))
- (pos (file-position-or-nil-for-error error-stream)))
- (let (lineno colno)
- (when (and pos
- (< pos sb!xc:array-dimension-limit)
- ;; KLUDGE: lseek() (which is what FILE-POSITION
- ;; reduces to on file-streams) is undefined on
- ;; "some devices", which in practice means that it
- ;; can claim to succeed on /dev/stdin on Darwin
- ;; and Solaris. This is obviously bad news,
- ;; because the READ-SEQUENCE below will then
- ;; block, not complete, and the report will never
- ;; be printed. As a workaround, we exclude
- ;; interactive streams from this attempt to report
- ;; positions. -- CSR, 2003-08-21
- (not (interactive-stream-p error-stream))
- (file-position error-stream :start))
- (let ((string
- (make-string pos
- :element-type (stream-element-type
- error-stream))))
- (when (= pos (read-sequence string error-stream))
- (setq lineno (1+ (count #\Newline string))
- colno (- pos
- (or (position #\Newline string :from-end t) -1)
- 1))))
- (file-position-or-nil-for-error error-stream pos))
- (format stream
- "READER-ERROR ~@[at ~W ~]~
- ~@[(line ~W~]~@[, column ~W) ~]~
- on ~S:~%~?"
- pos lineno colno error-stream
- (reader-error-format-control condition)
- (reader-error-format-arguments condition)))))))
+(define-condition reader-error (parse-error stream-error) ()
+ (:report (lambda (condition stream)
+ (%report-reader-error condition stream))))
+
+;;; a READER-ERROR whose REPORTing is controlled by FORMAT-CONTROL and
+;;; FORMAT-ARGS (the usual case for READER-ERRORs signalled from
+;;; within SBCL itself)
+;;;
+;;; (Inheriting CL:SIMPLE-CONDITION here isn't quite consistent with
+;;; the letter of the ANSI spec: this is not a condition signalled by
+;;; SIGNAL when a format-control is supplied by the function's first
+;;; argument. It seems to me (WHN) to be basically in the spirit of
+;;; the spec, but if not, it'd be straightforward to do our own
+;;; DEFINE-CONDITION SB-INT:SIMPLISTIC-CONDITION with
+;;; FORMAT-CONTROL and FORMAT-ARGS slots, and use that condition in
+;;; place of CL:SIMPLE-CONDITION here.)
+(define-condition simple-reader-error (reader-error simple-condition)
+ ()
+ (:report (lambda (condition stream)
+ (%report-reader-error condition stream :simple t))))
+
+;;; base REPORTing of a READER-ERROR
+;;;
+;;; When SIMPLE, we expect and use SIMPLE-CONDITION-ish FORMAT-CONTROL
+;;; and FORMAT-ARGS slots.
+(defun %report-reader-error (condition stream &key simple)
+ (let* ((error-stream (stream-error-stream condition))
+ (pos (file-position-or-nil-for-error error-stream)))
+ (let (lineno colno)
+ (when (and pos
+ (< pos sb!xc:array-dimension-limit)
+ ;; KLUDGE: lseek() (which is what FILE-POSITION
+ ;; reduces to on file-streams) is undefined on
+ ;; "some devices", which in practice means that it
+ ;; can claim to succeed on /dev/stdin on Darwin
+ ;; and Solaris. This is obviously bad news,
+ ;; because the READ-SEQUENCE below will then
+ ;; block, not complete, and the report will never
+ ;; be printed. As a workaround, we exclude
+ ;; interactive streams from this attempt to report
+ ;; positions. -- CSR, 2003-08-21
+ (not (interactive-stream-p error-stream))
+ (file-position error-stream :start))
+ (let ((string
+ (make-string pos
+ :element-type (stream-element-type
+ error-stream))))
+ (when (= pos (read-sequence string error-stream))
+ (setq lineno (1+ (count #\Newline string))
+ colno (- pos
+ (or (position #\Newline string :from-end t) -1)
+ 1))))
+ (file-position-or-nil-for-error error-stream pos))
+ (pprint-logical-block (stream nil)
+ (format stream
+ "~S ~@[at ~W ~]~
+ ~@[(line ~W~]~@[, column ~W) ~]~
+ on ~S"
+ (class-name (class-of condition))
+ pos lineno colno error-stream)
+ (when simple
+ (format stream ":~2I~_~?"
+ (simple-condition-format-control condition)
+ (simple-condition-format-arguments condition)))))))
;;;; special SBCL extension conditions
@@ -795,7 +814,8 @@
.~:@>"
'((fmakunbound 'compile))))))
-(define-condition simple-storage-condition (storage-condition simple-condition) ())
+(define-condition simple-storage-condition (storage-condition simple-condition)
+ ())
;;; a condition for use in stubs for operations which aren't supported
;;; on some platforms
@@ -811,14 +831,13 @@
;;; unimplemented and (2) unintentionally just screwed up somehow.
;;; (Before this condition was defined, test code tried to deal with
;;; this by checking for FBOUNDP, but that didn't work reliably. In
-;;; sbcl-0.7.0, a a package screwup left the definition of
+;;; sbcl-0.7.0, a package screwup left the definition of
;;; LOAD-FOREIGN in the wrong package, so it was unFBOUNDP even on
;;; architectures where it was supposed to be supported, and the
;;; regression tests cheerfully passed because they assumed that
;;; unFBOUNDPness meant they were running on an system which didn't
;;; support the extension.)
(define-condition unsupported-operator (simple-error) ())
-
;;; (:ansi-cl :function remove)
;;; (:ansi-cl :section (a b c))
@@ -835,10 +854,13 @@
(format stream ", ")
(destructuring-bind (type data) (cdr reference)
(ecase type
+ (:readers "Readers for ~:(~A~) Metaobjects"
+ (substitute #\ #\- (symbol-name data)))
(:initialization
(format stream "Initialization of ~:(~A~) Metaobjects"
(substitute #\ #\- (symbol-name data))))
(:generic-function (format stream "Generic Function ~S" data))
+ (:function (format stream "Function ~S" data))
(:section (format stream "Section ~{~D~^.~}" data)))))
(:ansi-cl
(format stream "The ANSI Standard")
@@ -878,6 +900,9 @@
(unless (null (cdr rs))
(terpri s)))))))
+(define-condition simple-reference-error (reference-condition simple-error)
+ ())
+
(define-condition duplicate-definition (reference-condition warning)
((name :initarg :name :reader duplicate-definition-name))
(:report (lambda (c s)
@@ -946,6 +971,13 @@
(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 "~@"
+ (implicit-generic-function-name condition)))))
+
(define-condition extension-failure (reference-condition simple-error)
())
@@ -1106,16 +1138,6 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL."))
'(:ansi-cl :section (15 1 2 1))
'(:ansi-cl :section (15 1 2 2)))))
-(define-condition io-timeout (stream-error)
- ((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 namestring-parse-error (parse-error)
((complaint :reader namestring-parse-error-complaint :initarg :complaint)
(args :reader namestring-parse-error-args :initarg :args :initform nil)
@@ -1132,7 +1154,7 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL."))
(define-condition simple-package-error (simple-condition package-error) ())
-(define-condition reader-package-error (reader-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))
@@ -1143,18 +1165,38 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL."))
(stream-error-stream condition)
(reader-eof-error-context condition)))))
-(define-condition reader-impossible-number-error (reader-error)
+(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"
+ (format stream
+ "READER-ERROR ~@[at ~W ~]on ~S:~%~?~%Original error: ~A"
(file-position-or-nil-for-error error-stream) error-stream
- (reader-error-format-control condition)
- (reader-error-format-arguments condition)
+ (simple-condition-format-control condition)
+ (simple-condition-format-arguments condition)
(reader-impossible-number-error-error condition))))))
-(define-condition timeout (serious-condition) ())
+(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)
@@ -1167,6 +1209,7 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL."))
(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
@@ -1177,8 +1220,18 @@ stepped."))
"Form associated with the STEP-CONDITION.")
(define-condition step-form-condition (step-condition)
- ((source-path :initarg :source-path :reader step-condition-source-path)
- (pathname :initarg :pathname :reader step-condition-pathname))
+ ((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.
@@ -1212,14 +1265,314 @@ 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-variable-condition (step-result-condition)
+(define-condition step-finished-condition (step-condition)
()
+ (:report
+ (lambda (condition stream)
+ (declare (ignore condition))
+ (format stream "Returning from STEP")))
#!+sb-doc
- (:documentation "Condition signalled by code compiled with
-single-stepping information when referencing a variable.
-STEP-CONDITION-FORM hold the symbol, and STEP-CONDITION-RESULT holds
-the value of the variable. No associated restarts."))
+ (:documentation "Condition signaled when STEP returns."))
+
+;;; 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.")
+
+;;; 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 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)))
+ (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)))))
+
+;;; Various other STYLE-WARNINGS
+(define-condition ignoring-asterisks-in-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 ignoring-asterisks-in-lexical-variable-name
+ (ignoring-asterisks-in-variable-name)
+ ())
+
+(define-condition ignoring-asterisks-in-constant-variable-name
+ (ignoring-asterisks-in-variable-name)
+ ())
+
+(define-condition undefined-alien (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
+ "~@"
+ (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)))))
;;;; restart definitions
@@ -1243,15 +1596,16 @@ the value of the variable. No associated restarts."))
CONTROL-ERROR if none exists."
(invoke-restart (find-restart-or-control-error 'muffle-warning condition)))
+(defun try-restart (name condition &rest arguments)
+ (let ((restart (find-restart name condition)))
+ (when restart
+ (apply #'invoke-restart restart arguments))))
+
(macrolet ((define-nil-returning-restart (name args doc)
#!-sb-doc (declare (ignore doc))
`(defun ,name (,@args &optional condition)
#!+sb-doc ,doc
- ;; FIXME: Perhaps this shared logic should be pulled out into
- ;; FLET MAYBE-INVOKE-RESTART? See whether it shrinks code..
- (let ((restart (find-restart ',name condition)))
- (when restart
- (invoke-restart restart ,@args))))))
+ (try-restart ',name condition ,@args))))
(define-nil-returning-restart continue ()
"Transfer control to a restart named CONTINUE, or return NIL if none exists.")
(define-nil-returning-restart store-value (value)