X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcondition.lisp;h=53f6b183ae635d10f2c4eb6ecd0108a0e8a4b77b;hb=4fa1c71c7dfa5c6d361304321cc67069a6410694;hp=7592df61085d53e3bdd8f8e27ec64aa2f454fcd3;hpb=c593dc26733b179db6c12c7085ed76b762ac256b;p=sbcl.git diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 7592df6..53f6b18 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -171,7 +171,10 @@ ;;; The current code doesn't seem to quite match that. (def!method print-object ((x condition) stream) (if *print-escape* - (print-unreadable-object (x stream :type t :identity t)) + (if (and (typep x 'simple-condition) (slot-boundp x 'format-control)) + (print-unreadable-object (x stream :type t :identity t) + (format stream "~S" (simple-condition-format-control x))) + (print-unreadable-object (x stream :type t :identity t))) ;; KLUDGE: A comment from CMU CL here said ;; 7/13/98 BUG? CPL is not sorted and results here depend on order of ;; superclasses in define-condition call! @@ -576,20 +579,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) ()) @@ -631,10 +620,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) ()) @@ -682,7 +693,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) () @@ -911,6 +922,10 @@ (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) @@ -957,6 +972,9 @@ (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) () @@ -1217,6 +1235,17 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (: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) @@ -1229,7 +1258,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))))) @@ -1337,14 +1366,16 @@ handled by any other handler, it will be muffled.") (new-location :initarg :new-location :reader redefinition-with-defun-new-location)) (:report (lambda (warning stream) - (format stream "redefining ~S in DEFUN" + (format stream "redefining ~/sb-impl::print-symbol-with-prefix/ ~ + 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" + (format stream "redefining ~/sb-impl::print-symbol-with-prefix/ ~ + in DEFGENERIC" (function-redefinition-warning-name warning))))) (define-condition redefinition-with-defmethod (redefinition-warning) @@ -1608,6 +1639,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) ()