Reimplement slot reading.

darcs-hash:bdef9c8f4c3fb2121456295da23fbe679265a15b

6 files changed, 83 insertions, 40 deletions

diff --git a/Lisp/class-definition.lisp b/Lisp/class-definition.lisp
index 6ecb189..e228c56 100644
--- a/Lisp/class-definition.lisp
+++ b/Lisp/class-definition.lisp
@@ -149,12 +149,14 @@
                                          (effective-slot-definition
                                           foreign-effective-slot-definition))
   (with-slots (foreign-name foreign-type) effective-slot-definition
-    ;; FIXME: Do proper value conversion here (like LOW-LEVEL-INVOKE).
-    (cffi:with-foreign-object
-        (return-value-cell (typespec->c-type foreign-type))
-      (%objcl-get-slot-value (pointer-to instance)
-                             foreign-name return-value-cell)
-      (mem-ref return-value-cell (typespec->c-type foreign-type)))))
+    (let ((slot-offset
+           (%objcl-get-slot-offset
+            (%objcl-get-slot (pointer-to class) foreign-name))))
+      (convert-from-foreign-value (inc-pointer (pointer-to instance)
+                                               slot-offset)
+                                  foreign-type
+                                  nil
+                                  t))))
 
 
 (defmethod (setf c2mop:slot-value-using-class) (value
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
index 79734cc..f28d4b8 100644
--- a/Lisp/libobjcl.lisp
+++ b/Lisp/libobjcl.lisp
@@ -112,6 +112,13 @@
   (slot-name :string)
   (value-out :pointer))
 
+(defcfun ("objcl_get_slot" %objcl-get-slot) :pointer
+  (class :pointer) ; Class
+  (slot-name :string))
+
+(defcfun ("objcl_get_slot_offset" %objcl-get-slot-offset) :long
+  (slot :pointer))
+
 (defcfun ("objcl_class_direct_slots" %objcl-class-direct-slots) :pointer
   (class :pointer) ; Class
   (count :pointer) ; unsigned int
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")
diff --git a/Lisp/policy.lisp b/Lisp/policy.lisp
index 03b4e62..71f7795 100644
--- a/Lisp/policy.lisp
+++ b/Lisp/policy.lisp
@@ -38,8 +38,12 @@
 (define-returns-boolean-exception "characterAtIndex:")
 
 
-(defun objc-char->lisp-value (objc-char receiver selector)
+(defun returned-char-is-bool-p (receiver selector)
   (declare (ignore receiver))
-  (if (gethash (selector-name selector) *boolean-return-exceptions* nil)
+  (gethash (selector-name selector) *boolean-return-exceptions* nil))
+
+
+(defun objc-char->lisp-value (objc-char char-is-bool-p)
+  (if char-is-bool-p
       objc-char
-      (not (zerop objc-char))))
\ No newline at end of file
+      (not (zerop objc-char))))
diff --git a/Objective-C/libobjcl.h b/Objective-C/libobjcl.h
index e7194a5..c2e2fac 100644
--- a/Objective-C/libobjcl.h
+++ b/Objective-C/libobjcl.h
@@ -153,6 +153,12 @@ objcl_set_slot_value (id obj, const char *ivar_name, void *value);
 void
 objcl_get_slot_value (id obj, const char *ivar_name, void *value_out);
 
+void *
+objcl_get_slot (Class class, const char *ivar_name);
+
+long  /* actually ptrdiff_t */
+objcl_get_slot_offset (void *slot);
+
 /* The following function returns a freshly consed array that the caller
    must deallocate. */
 IVAR_T *
diff --git a/Objective-C/libobjcl.m b/Objective-C/libobjcl.m
index 87e4c28..f244e50 100644
--- a/Objective-C/libobjcl.m
+++ b/Objective-C/libobjcl.m
@@ -532,6 +532,24 @@ objcl_get_slot_value (id obj, const char *ivar_name, void *value_out)
 }
 
 
+void *
+objcl_get_slot (Class class, const char *ivar_name)
+{
+  return class_getInstanceVariable (class, ivar_name);
+}
+
+
+long
+objcl_get_slot_offset (void *slot)
+{
+#ifdef __NEXT_RUNTIME__
+  return (ivar_getOffset ((Ivar) slot));
+#else
+  return ((Ivar_t) slot)->ivar_offset;
+#endif
+}
+
+
 IVAR_T *
 objcl_class_direct_slots (Class class, unsigned int *count, unsigned int *element_size)
 {