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

darcs-hash:7487d34005f69ab123278791d00991d50fde3496

1 files changed, 18 insertions, 9 deletions

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)