1.0.42.43: FD-STREAMS no longer hook into SERVE-EVENT by default

[sbcl.git] / src / code / condition.lisp

diff --git a/src/code/condition.lisp b/src/code/condition.lisp
index 317d8bc..35603bc 100644 (file)
--- 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)))))))
 \f
-;;;; 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))))
-\f
 ;;;; various CONDITIONs specified by ANSI
 
 (define-condition serious-condition (condition) ())
@@ -635,6 +624,15 @@
 (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 +680,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 +909,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 +959,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 +1222,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 +1245,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)))))
 
@@ -1281,14 +1297,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)))
 
@@ -1345,14 +1353,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)