From 619b17ce5eb96b3cfd5f2d94174270a31e46871c Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Tue, 19 Feb 2008 12:54:49 +0100
Subject: Reimplement slot reading.

darcs-hash:bdef9c8f4c3fb2121456295da23fbe679265a15b
---
 Lisp/method-invocation.lisp | 68 ++++++++++++++++++++++++---------------------
 1 file changed, 37 insertions(+), 31 deletions(-)

(limited to 'Lisp/method-invocation.lisp')

diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index cb60067..8c94ecc 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -437,37 +437,43 @@ easier to use with __apply__.
           (unless (cffi:null-pointer-p 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)
-             (let ((*skip-retaining*
-                    (or *skip-retaining*
-                        (constructor-name-p (selector-name selector)))))
-               (intern-pointer-wrapper (car return-type)
-                                       :pointer (cffi:mem-ref
-                                                 objc-return-value-cell
-                                                 return-c-type))))
-            ((:char :unsigned-char)
-             ;; FIXME?  This is non-trivial.  See policy.lisp for
-             ;; details.
-             (objc-char->lisp-value (cffi:mem-ref objc-return-value-cell
-                                                  return-c-type)
-                                    receiver
-                                    selector))
-            ((struct union)
-             ;; The caller is responsible for preventing the return
-             ;; value from being garbage-collected by setting
-             ;; FOREIGN-VALUE-LISP-MANAGED-P to false.
-             (make-struct-wrapper objc-struct-return-value-cell
-                                  return-type
-                                  t))
-            ((array)
-             (error "Method ~A of object ~A tried to return an array.  ~
-                     It must be mistaken."
-                    selector receiver))
-            ((:void) (values))
-            (otherwise (cffi:mem-ref objc-return-value-cell
-                                     return-c-type))))))))
+          (when (eq (typespec-primary-type return-type) 'array)
+            (error "Method ~A of object ~A tried to return an array.  ~
+                    It must be mistaken."
+                   selector receiver))
+          (convert-from-foreign-value (or objc-struct-return-value-cell
+                                          objc-return-value-cell)
+                                      return-type
+                                      (or *skip-retaining*
+                                          (constructor-name-p
+                                           (selector-name selector)))
+                                      (returned-char-is-bool-p receiver
+                                                               selector)))))))
+
+
+(defun convert-from-foreign-value (foreign-value-cell typespec
+                                   skip-retaining-p char-is-bool-p)
+  (let ((c-type (typespec->c-type typespec)))
+    (case (or (typespec-nominal-type typespec)
+              (typespec-primary-type typespec))
+      ((id objective-c-class exception selector)
+       (let ((*skip-retaining*
+              skip-retaining-p))
+         (intern-pointer-wrapper (car typespec)
+                                 :pointer (cffi:mem-ref foreign-value-cell
+                                                        c-type))))
+      ((:char :unsigned-char)
+       ;; FIXME?  This is non-trivial.  See policy.lisp for
+       ;; details.
+       (objc-char->lisp-value (cffi:mem-ref foreign-value-cell c-type)
+                              char-is-bool-p))
+      ((struct union)
+       ;; The caller is responsible for preventing the return
+       ;; value from being garbage-collected by setting
+       ;; FOREIGN-VALUE-LISP-MANAGED-P to false.
+       (make-struct-wrapper foreign-value-cell typespec t))
+      ((:void) (values))
+      (otherwise (cffi:mem-ref foreign-value-cell c-type)))))
 
 
 ;;; (@* "Helper functions")
-- 
cgit v1.2.3