summaryrefslogtreecommitdiff
path: root/Lisp
diff options
context:
space:
mode:
Diffstat (limited to 'Lisp')
-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
4 files changed, 59 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))))