0.9.5.47: minor INSPECT & DESCRIBE improvements

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

diff --git a/src/code/error.lisp b/src/code/error.lisp
index daa38c7..522df87 100644 (file)
--- a/src/code/error.lisp
+++ b/src/code/error.lisp
@@ -17,47 +17,48 @@
 (defun style-warn (format-control &rest format-arguments)
   (/show0 "entering STYLE-WARN")
   (/show format-control format-arguments)
 (defun style-warn (format-control &rest format-arguments)
   (/show0 "entering STYLE-WARN")
   (/show format-control format-arguments)

-  (warn 'simple-style-warning
-       :format-control format-control
-       :format-arguments format-arguments))
+  (with-sane-io-syntax
+      (warn 'simple-style-warning
+            :format-control format-control
+            :format-arguments format-arguments)))

 
 ;;; a utility for SIGNAL, ERROR, CERROR, WARN, COMPILER-NOTIFY and
 ;;; INVOKE-DEBUGGER: Parse the hairy argument conventions into a
 ;;; single argument that's directly usable by all the other routines.
 (defun coerce-to-condition (datum arguments default-type fun-name)
   (cond ((typep datum 'condition)
 
 ;;; a utility for SIGNAL, ERROR, CERROR, WARN, COMPILER-NOTIFY and
 ;;; INVOKE-DEBUGGER: Parse the hairy argument conventions into a
 ;;; single argument that's directly usable by all the other routines.
 (defun coerce-to-condition (datum arguments default-type fun-name)
   (cond ((typep datum 'condition)

-        (if arguments
-            (cerror "Ignore the additional arguments."
-                    'simple-type-error
-                    :datum arguments
-                    :expected-type 'null
-                    :format-control "You may not supply additional arguments ~
-                                    when giving ~S to ~S."
-                    :format-arguments (list datum fun-name)))
-        datum)
-       ((symbolp datum) ; roughly, (SUBTYPEP DATUM 'CONDITION)
-        (apply #'make-condition datum arguments))
-       ((or (stringp datum) (functionp datum))
-        (make-condition default-type
-                        :format-control datum
-                        :format-arguments arguments))
-       (t
-        (error 'simple-type-error
-               :datum datum
-               :expected-type '(or symbol string)
-               :format-control "bad argument to ~S: ~S"
-               :format-arguments (list fun-name datum)))))
+         (when (and arguments (not (eq fun-name 'cerror)))
+           (cerror "Ignore the additional arguments."
+                   'simple-type-error
+                   :datum arguments
+                   :expected-type 'null
+                   :format-control "You may not supply additional arguments ~
+                                    when giving ~S to ~S."
+                   :format-arguments (list datum fun-name)))
+         datum)
+        ((symbolp datum) ; roughly, (SUBTYPEP DATUM 'CONDITION)
+         (apply #'make-condition datum arguments))
+        ((or (stringp datum) (functionp datum))
+         (make-condition default-type
+                         :format-control datum
+                         :format-arguments arguments))
+        (t
+         (error 'simple-type-error
+                :datum datum
+                :expected-type '(or symbol string)
+                :format-control "bad argument to ~S: ~S"
+                :format-arguments (list fun-name datum)))))

 
 (define-condition layout-invalid (type-error)
   ()
   (:report
    (lambda (condition stream)
      (format stream
 
 (define-condition layout-invalid (type-error)
   ()
   (:report
    (lambda (condition stream)
      (format stream

-            "~@<invalid structure layout: ~
+             "~@<invalid structure layout: ~

               ~2I~_A test for class ~4I~_~S ~
               ~2I~_was passed the obsolete instance ~4I~_~S~:>"
               ~2I~_A test for class ~4I~_~S ~
               ~2I~_was passed the obsolete instance ~4I~_~S~:>"

-            (classoid-proper-name (type-error-expected-type condition))
-            (type-error-datum condition)))))
+             (classoid-proper-name (type-error-expected-type condition))
+             (type-error-datum condition)))))

 
 (define-condition case-failure (type-error)
   ((name :reader case-failure-name :initarg :name)
 
 (define-condition case-failure (type-error)
   ((name :reader case-failure-name :initarg :name)

@@ -66,64 +67,19 @@
     (lambda (condition stream)
       (format stream "~@<~S fell through ~S expression. ~
                       ~:_Wanted one of ~:S.~:>"
     (lambda (condition stream)
       (format stream "~@<~S fell through ~S expression. ~
                       ~:_Wanted one of ~:S.~:>"

-             (type-error-datum condition)
-             (case-failure-name condition)
-             (case-failure-possibilities condition)))))
+              (type-error-datum condition)
+              (case-failure-name condition)
+              (case-failure-possibilities condition)))))

 
 

-(define-condition compiled-program-error (encapsulated-condition program-error)
-  ((source :initarg :source :reader program-error-source))
+(define-condition compiled-program-error (program-error)
+  ((message :initarg :message :reader program-error-message)
+   (source :initarg :source :reader program-error-source))

   (:report (lambda (condition stream)
   (:report (lambda (condition stream)

-             (let ((source (program-error-source condition)))
-              ;; Source may be either a list or string, and
-              ;; string needs to be printed without escapes.
-              (format stream "Execution of a form compiled with errors.~%~
-                               Form:~%  ~
-                               ~:[~S~;~A~]~%~
-                               Compile-time-error:~%  "
-                      (stringp source) source)
-              (print-object (encapsulated-condition condition) stream)))))
-
-(def!method make-load-form ((condition compiled-program-error) &optional env)
-  (let ((source (program-error-source condition)))
-    ;; Safe since the encapsulated condition shouldn't contain
-    ;; references back up to the main condition. The source needs to
-    ;; be converted to a string, since it may contain arbitrary
-    ;; unexternalizable objects.
-    `(make-condition 'compiled-program-error
-                    :condition ,(make-condition-load-form
-                                 (encapsulated-condition condition) env)
-                    :source ,(if (stringp source)
-                                 source
-                                 (write-to-string
-                                  source :pretty t :circle t :escape t :readably nil)))))
-
-(define-condition make-load-form-error (encapsulated-condition error)
-  ((object :initarg :object :reader make-load-form-error-object))
-  (:report (lambda (condition stream)
-            (let ((object (make-load-form-error-object condition)))
-              ;; If the MAKE-LOAD-FORM-ERROR itself has been
-              ;; externalized, the object will only have it's string
-              ;; representation.
-              (format stream "~@<Unable to externalize ~:[~S~;~A~], ~
-                              error from ~S:~:@>~%  "
-                      (stringp object)
-                      object
-                      'make-load-form)
-              (print-object (encapsulated-condition condition) stream)))))
-
-(def!method make-load-form ((condition make-load-form-error) &optional env)
-  (let ((object (make-load-form-error-object condition)))
-    ;; Safe, because neither the object nor the encapsulated condition
-    ;; should contain any references to the error itself. However, the
-    ;; object will need to be converted to its string representation,
-    ;; since the chances are that it's not externalizable.
-    `(make-condition 'make-load-form-error
-                    :condition ,(make-condition-load-form
-                                 (encapsulated-condition condition) env)
-                    :object ,(if (stringp object)
-                                 object
-                                 (write-to-string
-                                  object :pretty t :circle t :escape t :readably nil)))))
+             (format stream "Execution of a form compiled with errors.~%~
+                             Form:~%  ~A~%~
+                             Compile-time-error:~%  ~A"
+                       (program-error-source condition)
+                       (program-error-message condition)))))

 
 (define-condition simple-control-error (simple-condition control-error) ())
 (define-condition simple-file-error    (simple-condition file-error)    ())
 
 (define-condition simple-control-error (simple-condition control-error) ())
 (define-condition simple-file-error    (simple-condition file-error)    ())

@@ -131,6 +87,32 @@
 (define-condition simple-stream-error  (simple-condition stream-error)  ())
 (define-condition simple-parse-error   (simple-condition parse-error)   ())
 
 (define-condition simple-stream-error  (simple-condition stream-error)  ())
 (define-condition simple-parse-error   (simple-condition parse-error)   ())
 

+(define-condition character-coding-error (error) ())
+(define-condition character-encoding-error (character-coding-error)
+  ((code :initarg :code :reader character-encoding-error-code)))
+(define-condition character-decoding-error (character-coding-error)
+  ((octets :initarg :octets :reader character-decoding-error-octets)))
+(define-condition stream-encoding-error (stream-error character-encoding-error)
+  ()
+  (:report
+   (lambda (c s)
+     (let ((stream (stream-error-stream c))
+           (code (character-encoding-error-code c)))
+       (format s "~@<encoding error on stream ~S (~S ~S): ~2I~_~
+                  the character with code ~D cannot be encoded.~@:>"
+               stream ':external-format (stream-external-format stream)
+               code)))))
+(define-condition stream-decoding-error (stream-error character-decoding-error)
+  ()
+  (:report
+   (lambda (c s)
+     (let ((stream (stream-error-stream c))
+           (octets (character-decoding-error-octets c)))
+       (format s "~@<decoding error on stream ~S (~S ~S): ~2I~_~
+                  the octet sequence ~S cannot be decoded.~@:>"
+               stream ':external-format (stream-external-format stream)
+               octets)))))
+

 (define-condition control-stack-exhausted (storage-condition)
   ()
   (:report
 (define-condition control-stack-exhausted (storage-condition)
   ()
   (:report

@@ -139,3 +121,9 @@
       (format stream
              "Control stack exhausted (no more space for function call frames).  This is probably due to heavily nested or infinitely recursive function calls, or a tail call that SBCL cannot or has not optimized away."))))
 
       (format stream
              "Control stack exhausted (no more space for function call frames).  This is probably due to heavily nested or infinitely recursive function calls, or a tail call that SBCL cannot or has not optimized away."))))
 

+(define-condition memory-fault-error (error)
+  ()
+  (:report
+   (lambda (condition stream)
+     (declare (ignore condition))
+     (format stream "memory fault"))))
\ No newline at end of file