diff options
| author | Matthias Benkard <code@mail.matthias.benkard.de> | 2008-02-17 15:44:38 +0100 |
|---|---|---|
| committer | Matthias Benkard <code@mail.matthias.benkard.de> | 2008-02-17 15:44:38 +0100 |
| commit | b5e4426cc60b55e0c38edfbf4757363a224cb4b7 (patch) | |
| tree | 865819a683985a489470d1622c83dee7d287a51e | |
| parent | 9cddfd4497f9e16decadabbc38873d2f710c24cd (diff) | |
Fix PRINT-OBJECT (EXCEPTION T).
darcs-hash:28e399d1243d9825ae590aba3fd55dc1a4d9706c
| -rw-r--r-- | Lisp/method-invocation.lisp | 3 | ||||
| -rw-r--r-- | Lisp/utilities.lisp | 11 |
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 |