Move exception reporting to PRINT-OBJECT (EXCEPTION T).

darcs-hash:7487d34005f69ab123278791d00991d50fde3496

2 files changed, 19 insertions, 18 deletions

diff --git a/Lisp/data-types.lisp b/Lisp/data-types.lisp
index 6c1a6e8..2c309e7 100644
--- a/Lisp/data-types.lisp
+++ b/Lisp/data-types.lisp
@@ -192,7 +192,7 @@ a suitable class method instead as you would in Objective-C.
               :reader   pointer-to
               :initarg  :pointer))
   (:report (lambda (condition stream)
-             (describe-object condition stream)))
+             (print-object condition stream)))
   (:documentation "The condition type for Objective-C exceptions.
 
 ## Description:
@@ -232,14 +232,6 @@ an __exception__, you can simply send it the `self' message.
   __id__"))
 
 
-(defmethod describe-object ((condition exception) stream)
-  (format stream "The Objective-C runtime has issued an exception of ~
-                  type `~A'.~&~
-                  Reason: ~A."
-          (invoke-by-name (invoke-by-name condition "name") "UTF8String")
-          (invoke-by-name (invoke-by-name condition "reason") "UTF8String")))
-
-
 (defclass foreign-value (c-pointer-wrapper)
      ((lisp-managed-cell :type (array boolean ())
                          :accessor foreign-value-lisp-managed-cell-p
diff --git a/Lisp/utilities.lisp b/Lisp/utilities.lisp
index 175e3df..757fc6e 100644
--- a/Lisp/utilities.lisp
+++ b/Lisp/utilities.lisp
@@ -274,15 +274,24 @@ invocations will return numbers.)
 
 
 (defmethod print-object ((exception exception) stream)
-  (print-unreadable-object (exception stream)
-    ;; FIXME: Inexplicably, WITH-SLOTS doesn't work for exceptions.  Is
-    ;; direct slot access disallowed for instances of type CONDITION?
-    (with-accessors ((pointer pointer-to)) exception
-      (format stream "~S ~A {~X}"
-              (type-of exception)
-              (primitive-invoke (primitive-invoke exception "name" 'id)
-                                "UTF8String" :string)
-              (cffi:pointer-address pointer)))))
+  (cond (*print-escape*
+         (print-unreadable-object (exception stream)
+           ;; FIXME: Inexplicably, WITH-SLOTS doesn't work for
+           ;; exceptions.  Is direct slot access disallowed for
+           ;; instances of type CONDITION?
+           (with-accessors ((pointer pointer-to)) exception
+             (format stream "~S ~A {~X}"
+                     (type-of exception)
+                     (primitive-invoke (primitive-invoke exception "name" 'id)
+                                       "UTF8String" :string)
+                     (cffi:pointer-address pointer)))))
+        (t (format stream "The Objective-C runtime has issued an exception ~
+                           of type `~A'.~&~
+                           Reason: ~A."
+                   (invoke-by-name (invoke-by-name exception "name")
+                                   "UTF8String")
+                   (invoke-by-name (invoke-by-name exception "reason")
+                                   "UTF8String")))))
 
 
 (defmethod describe-object :after ((exception exception) stream)