X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcondition.lisp;h=08f2f99a562d58dad4649d6f5125c76cffe42b11;hb=02313fc9ceecedacefc2e2a13c5c67a2ca9a57e8;hp=5384c446d355a984ec79c912579d21dbbf96dcca;hpb=fe962ba01d267b92f638c8f0d19be41054219f04;p=sbcl.git diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 5384c44..08f2f99 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -171,7 +171,12 @@ ;;; 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-value x 'format-control)) + (print-unreadable-object (x stream :type t :identity t) + (write (simple-condition-format-control x) + :stream stream + :lines 1)) + (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! @@ -259,7 +264,8 @@ (condition-classoid type) (class ;; Punt to CLOS. - (return-from make-condition (apply #'make-instance type args))) + (return-from make-condition + (apply #'make-instance type args))) (classoid (error 'simple-type-error :datum type @@ -270,7 +276,8 @@ (error 'simple-type-error :datum type :expected-type 'condition-class - :format-control "Bad type argument:~% ~S" + :format-control + "~s doesn't designate a condition class." :format-arguments (list type))))) (res (make-condition-object args))) (setf (%instance-layout res) (classoid-layout class)) @@ -393,8 +400,12 @@ (defvar *define-condition-hooks* nil) +(defun %set-condition-report (name report) + (setf (condition-classoid-report (find-classoid name)) + report)) + (defun %define-condition (name parent-types layout slots documentation - report default-initargs all-readers all-writers + default-initargs all-readers all-writers source-location) (with-single-package-locked-error (:symbol name "defining ~A as a condition") @@ -404,7 +415,6 @@ source-location)) (let ((class (find-classoid name))) (setf (condition-classoid-slots class) slots) - (setf (condition-classoid-report class) report) (setf (condition-classoid-default-initargs class) default-initargs) (setf (fdocumentation name 'type) documentation) @@ -543,10 +553,10 @@ (setq report (if (stringp arg) `#'(lambda (condition stream) - (declare (ignore condition)) - (write-string ,arg stream)) + (declare (ignore condition)) + (write-string ,arg stream)) `#'(lambda (condition stream) - (funcall #',arg condition stream)))))) + (funcall #',arg condition stream)))))) (:default-initargs (do ((initargs (rest option) (cddr initargs))) ((endp initargs)) @@ -570,25 +580,16 @@ ',layout (list ,@(slots)) ,documentation - ,report (list ,@default-initargs) ',(all-readers) ',(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)))) + (sb!c:source-location)) + ;; This needs to be after %DEFINE-CONDITION in case :REPORT + ;; is a lambda referring to condition slot accessors: + ;; they're not proclaimed as functions before it has run if + ;; we're under EVAL or loaded as source. + (%set-condition-report ',name ,report) + ',name))))) ;;;; various CONDITIONs specified by ANSI @@ -600,18 +601,21 @@ (define-condition style-warning (warning) ()) (defun simple-condition-printer (condition stream) - (apply #'format - stream - (simple-condition-format-control condition) - (simple-condition-format-arguments condition))) + (let ((control (simple-condition-format-control condition))) + (if control + (apply #'format stream + control + (simple-condition-format-arguments condition)) + (error "No format-control for ~S" condition)))) (define-condition simple-condition () ((format-control :reader simple-condition-format-control :initarg :format-control + :initform nil :type format-control) (format-arguments :reader simple-condition-format-arguments :initarg :format-arguments - :initform '() + :initform nil :type list)) (:report simple-condition-printer)) @@ -619,9 +623,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,8 +635,32 @@ (type-error-datum condition) (type-error-expected-type condition))))) +(def!method print-object ((condition type-error) stream) + (if *print-escape* + (flet ((maybe-string (thing) + (ignore-errors + (write-to-string thing :lines 1 :readably nil :array nil :pretty t)))) + (let ((type (maybe-string (type-error-expected-type condition))) + (datum (maybe-string (type-error-datum condition)))) + (if (and type datum) + (print-unreadable-object (condition stream :type t) + (format stream "~@" type datum)) + (call-next-method)))) + (call-next-method))) + +;;; 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) ()) +;; 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) ()) @@ -649,6 +674,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 @@ -678,7 +708,7 @@ (:report (lambda (condition stream) (format stream - "The function ~S is undefined." + "The function ~/sb-impl::print-symbol-with-prefix/ is undefined." (cell-error-name condition))))) (define-condition special-form-function (undefined-function) () @@ -718,50 +748,65 @@ (*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)))) + +(defun stream-error-position-info (stream &optional position) + (unless (interactive-stream-p stream) + (let ((now (file-position-or-nil-for-error stream)) + (pos position)) + (when (and (not pos) now (plusp now)) + ;; FILE-POSITION is the next character -- error is at the previous one. + (setf pos (1- now))) + (let (lineno colno) + (when (and pos + (< pos sb!xc:array-dimension-limit) + (file-position stream :start)) + (let ((string + (make-string pos :element-type (stream-element-type stream)))) + (when (= pos (read-sequence string stream)) + ;; Lines count from 1, columns from 0. It's stupid and traditional. + (setq lineno (1+ (count #\Newline string)) + colno (- pos (or (position #\Newline string :from-end t) 0))))) + (file-position-or-nil-for-error stream now)) + (remove-if-not #'second + (list (list :line lineno) + (list :column colno) + (list :file-position pos))))))) + +;;; 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 position) + (let ((error-stream (stream-error-stream condition))) + (pprint-logical-block (stream nil) + (if simple + (apply #'format stream + (simple-condition-format-control condition) + (simple-condition-format-arguments condition)) + (prin1 (class-name (class-of condition)) stream)) + (format stream "~2I~@[~_~_~:{~:(~A~): ~S~:^, ~:_~}~]~_~_Stream: ~S" + (stream-error-position-info error-stream position) + error-stream)))) ;;;; special SBCL extension conditions @@ -795,7 +840,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 +857,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)) @@ -881,6 +926,16 @@ (unless (null (cdr rs)) (terpri s))))))) +(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) @@ -924,15 +979,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) () @@ -949,6 +1001,14 @@ (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) + (let ((*package* (find-package :keyword))) + (format stream "~@" + (implicit-generic-function-name condition)))))) + (define-condition extension-failure (reference-condition simple-error) ()) @@ -960,22 +1020,26 @@ #!+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)) +(define-condition package-lock-violation (package-error + reference-condition + simple-condition) + ((current-package :initform *package* + :reader package-lock-violation-in-package)) (:report (lambda (condition stream) - (let ((control (package-error-format-control condition))) + (let ((control (simple-condition-format-control condition)) + (error-package (package-name (package-error-package condition))) + (current-package (package-name (package-lock-violation-in-package condition)))) (if control (apply #'format stream - (format nil "~~@" - (package-name (package-error-package condition)) - control) - (package-error-format-arguments condition)) - (format stream "~@" - (package-name (package-error-package condition))))))) + (format nil "~~@" + error-package + control + current-package) + (simple-condition-format-arguments condition)) + (format stream "~@" + error-package + current-package))))) ;; no :default-initargs -- reference-stuff provided by the ;; signalling form in target-package.lisp #!+sb-doc @@ -1030,15 +1094,6 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (define-condition encapsulated-condition (condition) ((condition :initarg :condition :reader encapsulated-condition))) -(define-condition values-type-error (type-error) - () - (:report - (lambda (condition stream) - (format stream - "~@" - (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 @@ -1064,6 +1119,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 @@ -1125,7 +1210,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 package-error) ()) (define-condition reader-eof-error (end-of-file) ((context :reader reader-eof-error-context :initarg :context)) @@ -1136,17 +1221,37 @@ 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 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) @@ -1159,7 +1264,7 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (lambda (condition stream) (declare (type stream stream)) (format stream - "I/O timeout ~(~A~)ing ~S." + "I/O timeout while doing ~(~A~) on ~S." (io-timeout-direction condition) (stream-error-stream condition))))) @@ -1211,14 +1316,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))) @@ -1243,7 +1340,338 @@ the values returned by the form as a list. No associated restarts.")) (format stream "Returning from STEP"))) #!+sb-doc (: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 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 +;; redefinitions, but other redefinitions could be done later +;; (e.g. methods). +(define-condition redefinition-warning (style-warning) + ((name + :initarg :name + :reader redefinition-warning-name) + (new-location + :initarg :new-location + :reader redefinition-warning-new-location))) + +(define-condition function-redefinition-warning (redefinition-warning) + ((new-function + :initarg :new-function + :reader function-redefinition-warning-new-function))) + +(define-condition redefinition-with-defun (function-redefinition-warning) + () + (:report (lambda (warning stream) + (format stream "redefining ~/sb-impl::print-symbol-with-prefix/ ~ + in DEFUN" + (redefinition-warning-name warning))))) +(define-condition redefinition-with-defmacro (function-redefinition-warning) + () + (:report (lambda (warning stream) + (format stream "redefining ~/sb-impl::print-symbol-with-prefix/ ~ + in DEFMACRO" + (redefinition-warning-name warning))))) + +(define-condition redefinition-with-defgeneric (redefinition-warning) + () + (:report (lambda (warning stream) + (format stream "redefining ~/sb-impl::print-symbol-with-prefix/ ~ + in DEFGENERIC" + (redefinition-warning-name warning))))) + +(define-condition redefinition-with-defmethod (redefinition-warning) + ((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-warning-name warning) + (redefinition-with-defmethod-qualifiers warning) + (redefinition-with-defmethod-specializers warning))))) + +;;;; Deciding which redefinitions are "interesting". + +(defun function-file-namestring (function) + #!+sb-eval + (when (typep function 'sb!eval:interpreted-function) + (return-from function-file-namestring + (sb!c:definition-source-location-namestring + (sb!eval:interpreted-function-source-location function)))) + (let* ((fun (sb!kernel:%fun-fun function)) + (code (sb!kernel:fun-code-header fun)) + (debug-info (sb!kernel:%code-debug-info code)) + (debug-source (when debug-info + (sb!c::debug-info-source debug-info))) + (namestring (when debug-source + (sb!c::debug-source-namestring debug-source)))) + namestring)) + +(defun interesting-function-redefinition-warning-p (warning old) + (let ((new (function-redefinition-warning-new-function warning)) + (source-location (redefinition-warning-new-location warning))) + (or + ;; Compiled->Interpreted is interesting. + (and (typep old 'compiled-function) + (typep new '(not compiled-function))) + ;; FIN->Regular is interesting. + (and (typep old 'funcallable-instance) + (typep new '(not funcallable-instance))) + ;; Different file or unknown location is interesting. + (let* ((old-namestring (function-file-namestring old)) + (new-namestring + (or (function-file-namestring new) + (when source-location + (sb!c::definition-source-location-namestring source-location))))) + (and (or (not old-namestring) + (not new-namestring) + (not (string= old-namestring new-namestring)))))))) + +(defun uninteresting-ordinary-function-redefinition-p (warning) + (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) + ;; Shared logic. + (let ((name (redefinition-warning-name warning))) + (not (interesting-function-redefinition-warning-p + warning (or (fdefinition name) (macro-function name))))))) + +(defun uninteresting-macro-redefinition-p (warning) + (and + (typep warning 'redefinition-with-defmacro) + ;; Shared logic. + (let ((name (redefinition-warning-name warning))) + (not (interesting-function-redefinition-warning-p + warning (or (macro-function name) (fdefinition name))))))) + +(defun uninteresting-generic-function-redefinition-p (warning) + (and + (typep warning 'redefinition-with-defgeneric) + ;; Can't use the shared logic above, since GF's don't get a "new" + ;; definition -- rather the FIN-FUNCTION is set. + (let* ((name (redefinition-warning-name warning)) + (old (fdefinition name)) + (old-location (when (typep old 'generic-function) + (sb!pcl::definition-source old))) + (old-namestring (when old-location + (sb!c:definition-source-location-namestring old-location))) + (new-location (redefinition-warning-new-location warning)) + (new-namestring (when new-location + (sb!c:definition-source-location-namestring new-location)))) + (and old-namestring + new-namestring + (string= old-namestring new-namestring))))) + +(defun uninteresting-method-redefinition-p (warning) + (and + (typep warning 'redefinition-with-defmethod) + ;; Can't use the shared logic above, since GF's don't get a "new" + ;; definition -- rather the FIN-FUNCTION is set. + (let* ((old-method (redefinition-with-defmethod-old-method warning)) + (old-location (sb!pcl::definition-source old-method)) + (old-namestring (when old-location + (sb!c:definition-source-location-namestring old-location))) + (new-location (redefinition-warning-new-location warning)) + (new-namestring (when new-location + (sb!c:definition-source-location-namestring new-location)))) + (and new-namestring + old-namestring + (string= new-namestring old-namestring))))) + +(deftype uninteresting-redefinition () + '(or (satisfies uninteresting-ordinary-function-redefinition-p) + (satisfies uninteresting-macro-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 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 + "~@" + (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))))) + +;;;; deprecation conditions + +(define-condition deprecation-condition () + ((name :initarg :name :reader deprecated-name) + (replacements :initarg :replacements :reader deprecated-name-replacements) + (since :initarg :since :reader deprecated-since) + (runtime-error :initarg :runtime-error :reader deprecated-name-runtime-error))) + +(def!method print-object ((condition deprecation-condition) stream) + (let ((*package* (find-package :keyword))) + (if *print-escape* + (print-unreadable-object (condition stream :type t) + (apply #'format + stream "~S is deprecated.~ + ~#[~; Use ~S instead.~; ~ + Use ~S or ~S instead.~:; ~ + Use~@{~#[~; or~] ~S~^,~} instead.~]" + (deprecated-name condition) + (deprecated-name-replacements condition))) + (apply #'format + stream "~@<~S has been deprecated as of SBCL ~A.~ + ~#[~; Use ~S instead.~; ~ + Use ~S or ~S instead.~:; ~ + Use~@{~#[~; or~] ~S~^,~:_~} instead.~]~:@>" + (deprecated-name condition) + (deprecated-since condition) + (deprecated-name-replacements condition))))) + +(define-condition early-deprecation-warning (style-warning deprecation-condition) + ()) + +(def!method print-object :after ((warning early-deprecation-warning) stream) + (unless *print-escape* + (let ((*package* (find-package :keyword))) + (format stream "~%~@<~:@_In future SBCL versions ~S will signal a full warning ~ + at compile-time.~:@>" + (deprecated-name warning))))) + +(define-condition late-deprecation-warning (warning deprecation-condition) + ()) + +(def!method print-object :after ((warning late-deprecation-warning) stream) + (unless *print-escape* + (when (deprecated-name-runtime-error warning) + (let ((*package* (find-package :keyword))) + (format stream "~%~@<~:@_In future SBCL versions ~S will signal a runtime error.~:@>" + (deprecated-name warning)))))) + +(define-condition final-deprecation-warning (warning deprecation-condition) + ()) + +(def!method print-object :after ((warning final-deprecation-warning) stream) + (unless *print-escape* + (when (deprecated-name-runtime-error warning) + (let ((*package* (find-package :keyword))) + (format stream "~%~@<~:@_An error will be signaled at runtime for ~S.~:@>" + (deprecated-name warning)))))) + +(define-condition deprecation-error (error deprecation-condition) + ()) ;;;; restart definitions @@ -1267,23 +1695,27 @@ the values returned by the form as a list. 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) - "Transfer control and VALUE to a restart named STORE-VALUE, or return NIL if - none exists.") + "Transfer control and VALUE to a restart named STORE-VALUE, or +return NIL if none exists.") (define-nil-returning-restart use-value (value) - "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if - none exists.")) + "Transfer control and VALUE to a restart named USE-VALUE, or +return NIL if none exists.") + (define-nil-returning-restart print-unreadably () + "Transfer control to a restart named SB-EXT:PRINT-UNREADABLY, or +return NIL if none exists.")) ;;; single-stepping restarts