summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthias Benkard <code@mail.matthias.benkard.de>2008-02-17 15:44:38 +0100
committerMatthias Benkard <code@mail.matthias.benkard.de>2008-02-17 15:44:38 +0100
commitb5e4426cc60b55e0c38edfbf4757363a224cb4b7 (patch)
tree865819a683985a489470d1622c83dee7d287a51e
parent9cddfd4497f9e16decadabbc38873d2f710c24cd (diff)
Fix PRINT-OBJECT (EXCEPTION T).
darcs-hash:28e399d1243d9825ae590aba3fd55dc1a4d9706c
-rw-r--r--Lisp/method-invocation.lisp3
-rw-r--r--Lisp/utilities.lisp11
2 files changed, 12 insertions, 2 deletions
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 72abefd..0227db0 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -441,7 +441,8 @@ easier to use with __apply__.
objc-return-value-cell)
objc-arg-ptrs)))
(unless (cffi:null-pointer-p error-cell)
- (error (make-condition 'exception :pointer error-cell)))
+ (error (make-condition 'exception :pointer error-cell)
+ #+(or) (intern-pointer-wrapper 'exception :pointer error-cell)))
(case (or (typespec-nominal-type return-type)
(typespec-primary-type return-type))
((id objective-c-class exception selector)
diff --git a/Lisp/utilities.lisp b/Lisp/utilities.lisp
index 384c7e2..175e3df 100644
--- a/Lisp/utilities.lisp
+++ b/Lisp/utilities.lisp
@@ -275,7 +275,9 @@ invocations will return numbers.)
(defmethod print-object ((exception exception) stream)
(print-unreadable-object (exception stream)
- (with-slots (pointer) exception
+ ;; 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)
@@ -283,6 +285,13 @@ invocations will return numbers.)
(cffi:pointer-address pointer)))))
+(defmethod describe-object :after ((exception exception) stream)
+ (format stream "Objective-C runtime type: ~S~&~
+ Reason: ~S"
+ (invoke-by-name (invoke-by-name exception "name") "UTF8String")
+ (invoke-by-name (invoke-by-name exception "reason") "UTF8String")))
+
+
(defmethod print-object ((struct foreign-struct) stream)
(print-unreadable-object (struct stream)
(with-slots (pointer name) struct