X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcondition.lisp;h=fc216f0691a569d08024ddc71627ad2825a40169;hb=0a8778552a8499dd4614c9aada7dfca3dfcc6997;hp=830721dde4b4843dd0f2140fdecf5bafd1a4d950;hpb=56d318ce89dd0c1cff3fd210691ac0367b1382e3;p=sbcl.git diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 830721d..fc216f0 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! @@ -576,20 +581,6 @@ ',(all-writers) (sb!c:source-location))))))) -;;;; DESCRIBE on CONDITIONs - -;;; a function to be used as the guts of DESCRIBE-OBJECT (CONDITION T) -;;; eventually (once we get CLOS up and running so that we can define -;;; methods) -(defun describe-condition (condition stream) - (format stream - "~&~@<~S ~_is a ~S. ~_Its slot values are ~_~S.~:>~%" - condition - (type-of condition) - (concatenate 'list - (condition-actual-initargs condition) - (condition-assigned-slots condition)))) - ;;;; various CONDITIONs specified by ANSI (define-condition serious-condition (condition) ()) @@ -600,18 +591,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)) @@ -631,10 +625,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) ()) @@ -648,6 +664,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 @@ -677,7 +698,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) () @@ -903,6 +924,13 @@ (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) @@ -946,15 +974,12 @@ '(:ansi-cl :function make-array) '(:ansi-cl :function sb!xc:upgraded-array-element-type)))) -(define-condition displaced-to-array-too-small-error - (reference-condition simple-error) - () - (:default-initargs - :references (list '(:ansi-cl :function adjust-array)))) - (define-condition type-warning (reference-condition simple-warning) () (:default-initargs :references (list '(:sbcl :node "Handling of Types")))) +(define-condition type-style-warning (reference-condition simple-style-warning) + () + (:default-initargs :references (list '(:sbcl :node "Handling of Types")))) (define-condition local-argument-mismatch (reference-condition simple-warning) () @@ -1093,6 +1118,36 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) "No traps are enabled? How can this be?" stream)))))) +(define-condition invalid-array-index-error (type-error) + ((array :initarg :array :reader invalid-array-index-error-array) + (axis :initarg :axis :reader invalid-array-index-error-axis)) + (:report + (lambda (condition stream) + (let ((array (invalid-array-index-error-array condition))) + (format stream "Index ~W out of bounds for ~@[axis ~W of ~]~S, ~ + should be nonnegative and <~W." + (type-error-datum condition) + (when (> (array-rank array) 1) + (invalid-array-index-error-axis condition)) + (type-of array) + ;; Extract the bound from (INTEGER 0 (BOUND)) + (caaddr (type-error-expected-type condition))))))) + +(define-condition invalid-array-error (reference-condition type-error) () + (:report + (lambda (condition stream) + (let ((*print-array* nil)) + (format stream + "~@" + (type-error-expected-type condition) + (array-displacement (type-error-datum condition)))))) + (:default-initargs + :references + (list '(:ansi-cl :function adjust-array)))) + (define-condition index-too-large-error (type-error) () (:report @@ -1177,6 +1232,25 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (simple-condition-format-arguments condition) (reader-impossible-number-error-error condition)))))) +(define-condition standard-readtable-modified-error (reference-condition error) + ((operation :initarg :operation :reader standard-readtable-modified-operation)) + (:report (lambda (condition stream) + (format stream "~S would modify the standard readtable." + (standard-readtable-modified-operation condition)))) + (:default-initargs :references `((:ansi-cl :section (2 1 1 2)) + (:ansi-cl :glossary "standard readtable")))) + +(define-condition standard-pprint-dispatch-table-modified-error + (reference-condition error) + ((operation :initarg :operation + :reader standard-pprint-dispatch-table-modified-operation)) + (:report (lambda (condition stream) + (format stream "~S would modify the standard pprint dispatch table." + (standard-pprint-dispatch-table-modified-operation + condition)))) + (:default-initargs + :references `((:ansi-cl :glossary "standard pprint dispatch table")))) + (define-condition timeout (serious-condition) ((seconds :initarg :seconds :initform nil :reader timeout-seconds)) (:report (lambda (condition stream) @@ -1189,7 +1263,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))))) @@ -1241,14 +1315,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))) @@ -1285,40 +1351,41 @@ handled by any other handler, it will be muffled.") ;; 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) - ((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. - )) + ((new-function + :initarg :new-function + :reader function-redefinition-warning-new-function))) (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 ~/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 ~S in DEFUN" - (function-redefinition-warning-name warning))))) + (format stream "redefining ~/sb-impl::print-symbol-with-prefix/ ~ + in DEFMACRO" + (redefinition-warning-name warning))))) -(define-condition redefinition-with-defgeneric (function-redefinition-warning) - ((new-location :initarg :new-location - :reader redefinition-with-defgeneric-new-location)) +(define-condition redefinition-with-defgeneric (redefinition-warning) + () (:report (lambda (warning stream) - (format stream "redefining ~S in DEFGENERIC" - (function-redefinition-warning-name warning))))) + (format stream "redefining ~/sb-impl::print-symbol-with-prefix/ ~ + in DEFGENERIC" + (redefinition-warning-name warning))))) (define-condition redefinition-with-defmethod (redefinition-warning) - ((gf :initarg :generic-function - :reader redefinition-with-defmethod-generic-function) - (qualifiers :initarg :qualifiers + ((qualifiers :initarg :qualifiers :reader redefinition-with-defmethod-qualifiers) (specializers :initarg :specializers :reader redefinition-with-defmethod-specializers) @@ -1328,135 +1395,103 @@ handled by any other handler, it will be muffled.") :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-warning-name 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) - ()) +;;;; 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)))))))) -;; 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)))))))) + (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) - (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))))) + (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) - (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 + (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 - (equal 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))) @@ -1576,6 +1611,60 @@ the usual naming convention (names like *FOO*) for special variables" (proclamation-mismatch-name warning) (proclamation-mismatch-old warning))))) +;;;; deprecation conditions + +(define-condition deprecation-condition () + ((name :initarg :name :reader deprecated-name) + (replacement :initarg :replacement :reader deprecated-name-replacement) + (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) + (format stream "~S is deprecated~@[, use ~S~]" + (deprecated-name condition) + (deprecated-name-replacement condition))) + (format stream "~@<~S has been deprecated as of SBCL ~A~ + ~@[, use ~S instead~].~:@>" + (deprecated-name condition) + (deprecated-since condition) + (deprecated-name-replacement 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 (define-condition abort-failure (control-error) ()