From 2e0809c9cf80f7c6d95c5cd21ae4374941c5fd17 Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Tue, 4 Mar 2008 17:19:52 +0100
Subject: Move exception reporting to PRINT-OBJECT (EXCEPTION T).
darcs-hash:7487d34005f69ab123278791d00991d50fde3496
---
Lisp/data-types.lisp | 10 +---------
Lisp/utilities.lisp | 27 ++++++++++++++++++---------
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)
--
cgit v1.2.3