diff options
| -rw-r--r-- | Lisp/class-definition.lisp | 14 | ||||
| -rw-r--r-- | Lisp/libobjcl.lisp | 7 | ||||
| -rw-r--r-- | Lisp/method-invocation.lisp | 68 | ||||
| -rw-r--r-- | Lisp/policy.lisp | 10 | ||||
| -rw-r--r-- | Objective-C/libobjcl.h | 6 | ||||
| -rw-r--r-- | Objective-C/libobjcl.m | 18 |
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) { |