summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Lisp/class-definition.lisp14
-rw-r--r--Lisp/libobjcl.lisp7
-rw-r--r--Lisp/method-invocation.lisp68
-rw-r--r--Lisp/policy.lisp10
-rw-r--r--Objective-C/libobjcl.h6
-rw-r--r--Objective-C/libobjcl.m18
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)
{