0.9.17.15: silence %SAP-ALIEN compiler-note for MAKE-ALIEN in default policy

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

diff --git a/src/code/error.lisp b/src/code/error.lisp
index 9d8082b..6827435 100644 (file)
--- a/src/code/error.lisp
+++ b/src/code/error.lisp
@@ -27,7 +27,7 @@
 ;;; 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)
 ;;; 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)

-        (when (and arguments (not (eq fun-name 'cerror)))
+         (when (and arguments (not (eq fun-name 'cerror)))

            (cerror "Ignore the additional arguments."
                    'simple-type-error
                    :datum arguments
            (cerror "Ignore the additional arguments."
                    'simple-type-error
                    :datum arguments

@@ -35,30 +35,30 @@
                    :format-control "You may not supply additional arguments ~
                                     when giving ~S to ~S."
                    :format-arguments (list datum fun-name)))
                    :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)))))
+         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)

@@ -67,19 +67,30 @@
     (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 (program-error)
   ((message :initarg :message :reader program-error-message)
    (source :initarg :source :reader program-error-source))
   (:report (lambda (condition stream)
 
 (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)

-            (format stream "Execution of a form compiled with errors.~%~
+             (format stream "Execution of a form compiled with errors.~%~

                              Form:~%  ~A~%~
                              Form:~%  ~A~%~

-                             Compile-time-error:~%  ~A"
-                      (program-error-source condition)
-                      (program-error-message condition)))))
+                             Compile-time error:~%  ~A"
+                       (program-error-source condition)
+                       (program-error-message condition)))))
+
+(define-condition interpreted-program-error
+    (program-error encapsulated-condition)
+  ;; Unlike COMPILED-PROGRAM-ERROR, we don't need to dump these, so
+  ;; storing the original condition and form is OK.
+  ((form :initarg :form :reader program-error-form))
+  (:report (lambda (condition stream)
+             (format stream "~&Evaluation of~%  ~S~%~
+                             caused error:~%  ~A~%"
+                     (program-error-form condition)
+                     (encapsulated-condition 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)    ())

@@ -113,6 +124,24 @@
                stream ':external-format (stream-external-format stream)
                octets)))))
 
                stream ':external-format (stream-external-format stream)
                octets)))))
 

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

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

@@ -121,9 +150,24 @@
       (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 heap-exhausted-error (storage-condition)
+  ()
+  (:report
+   (lambda (condition stream)
+     (declare (special *heap-exhausted-error-available-bytes*
+                       *heap-exhausted-error-requested-bytes*))
+     ;; See comments in interr.lisp -- there is a method to this madness.
+     (if (and (boundp '*heap-exhausted-error-available-bytes*)
+              (boundp '*heap-exhausted-error-requested-bytes*))
+         (format stream
+                 "Heap exhausted: ~D bytes available, ~D requested. PROCEED WITH CAUTION!"
+                 *heap-exhausted-error-available-bytes*
+                 *heap-exhausted-error-requested-bytes*)
+         (print-unreadable-object (condition stream))))))
+

 (define-condition memory-fault-error (error)
   ()
   (:report
    (lambda (condition stream)
      (declare (ignore condition))
 (define-condition memory-fault-error (error)
   ()
   (:report
    (lambda (condition stream)
      (declare (ignore condition))

-     (format stream "memory fault"))))
\ No newline at end of file
+     (format stream "memory fault"))))