summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Lisp/memory-management.lisp4
-rw-r--r--Lisp/method-invocation.lisp145
-rw-r--r--Lisp/tests.lisp2
-rw-r--r--Objective-C/libobjcl.m7
4 files changed, 84 insertions, 74 deletions
diff --git a/Lisp/memory-management.lisp b/Lisp/memory-management.lisp
index 849e9d0..de75626 100644
--- a/Lisp/memory-management.lisp
+++ b/Lisp/memory-management.lisp
@@ -30,7 +30,7 @@
:incomplete)
(let ((new-obj (call-next-method)))
(unless *skip-retaining*
- (unsafe-primitive-invoke new-obj "retain" id))
+ (primitive-invoke new-obj "retain" 'id))
(unless *skip-finalization*
;; We only put the new object into the hash
;; table if it is a regular wrapper object
@@ -56,7 +56,7 @@
(*skip-retaining* t))
(make-instance saved-type
:pointer saved-pointer))))
- (unsafe-primitive-invoke temp "release" id))))
+ (primitive-invoke temp "release" :void))))
(trivial-garbage:finalize new-obj #'finalizer))))
new-obj))
(t obj))))
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 41584ad..dbdde6c 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -148,7 +148,7 @@ Returns: *result* --- the return value of the method invocation.
(defmacro unsafe-primitive-invoke (receiver method-name return-type &rest args)
- (let ((real-return-type (if (member return-type '(id class exception))
+ (let ((real-return-type (if (member return-type '(id objc-class exception))
:pointer
return-type))
(real-receiver (gensym))
@@ -169,12 +169,12 @@ Returns: *result* --- the return value of the method invocation.
(list :pointer (pointer-to ,real-selector))
objc-arglist
(list ,real-return-type)))))
- ,(if (member return-type '(id class exception))
+ ,(if (member return-type '(id objc-class exception))
`(let (,@(when (constructor-name-p (selector-name selector))
`((*skip-retaining* t))))
(make-instance ',(case return-type
((id) 'id)
- ((class) 'objc-class)
+ ((objc-class) 'objc-class)
((exception) 'exception))
:pointer return-value))
`return-value))
@@ -182,73 +182,80 @@ Returns: *result* --- the return value of the method invocation.
(defun primitive-invoke (receiver method-name return-type &rest args)
- (let ((return-c-type (case return-type
- ((id class exception selector) :pointer)
- (otherwise return-type)))
- (return-type-cell (cffi:foreign-string-alloc
- (type-name->type-id return-type)))
- (selector (selector method-name)))
- (cffi:with-foreign-objects ((arg-types '(:pointer :char) (length args))
- (objc-args '(:pointer :void) (+ (length args) 2))
- (return-value-cell return-c-type))
- (flet ((ad-hoc-arglist->objc-arglist! (args)
- (setf (cffi:mem-aref objc-args '(:pointer :void) 0)
- (pointer-to receiver)
- (cffi:mem-aref objc-args '(:pointer :void) 1)
- (pointer-to selector))
- (loop for arg in args
- for i from 2
- do (let* ((type-name (lisp-value->type-name arg))
- #+(or)
- (cffi-type (type-name->lisp-type type-name)))
- (setf (cffi:mem-aref objc-args '(:pointer :void) i)
- (typecase arg
- #+(or)
- (c-pointer
- ;; Assume that arg points to a struct,
- ;; and that the method wants a copy of
- ;; that struct, not the pointer itself.
- arg)
- (t (cffi:foreign-alloc
- #+(or) cffi-type
- :pointer
- :initial-element (typecase arg
- (c-pointer-wrapper
- (print (pointer-to arg)))
- (t arg))))))
- (setf (cffi:mem-aref arg-types '(:pointer :char) i)
- (cffi:foreign-string-alloc
- (typecase arg
- #+(or) (c-pointer "{?=}")
- (t (type-name->type-id type-name))))))))
- (dealloc-ad-hoc-objc-arglist ()
- (dotimes (i (length args))
+ (flet ((make-void-pointer-pointer (ptr)
+ (cffi:foreign-alloc #+(or) cffi-type
+ '(:pointer :void)
+ :initial-element ptr)))
+ (let ((return-c-type (case return-type
+ ((id objc-class exception selector) :pointer)
+ (otherwise return-type)))
+ (return-type-cell (cffi:foreign-string-alloc
+ (type-name->type-id return-type)))
+ (selector (selector method-name)))
+ (cffi:with-foreign-objects ((arg-types '(:pointer :char) (length args))
+ (objc-args '(:pointer :void) (+ (length args) 2))
+ (return-value-cell return-c-type))
+ (flet ((ad-hoc-arglist->objc-arglist! (args)
+ (setf (cffi:mem-aref objc-args '(:pointer :void) 0)
+ (make-void-pointer-pointer (pointer-to receiver))
+ (cffi:mem-aref objc-args '(:pointer :void) 1)
+ (make-void-pointer-pointer (pointer-to selector)))
+ (loop for arg in args
+ for i from 0
+ do (let* ((type-name (lisp-value->type-name arg))
+ #+(or)
+ (cffi-type (type-name->lisp-type type-name)))
+ (setf (cffi:mem-aref objc-args
+ '(:pointer :void)
+ (+ i 2))
+ (typecase arg
+ #+(or)
+ (c-pointer
+ ;; Assume that arg points to a struct,
+ ;; and that the method wants a copy of
+ ;; that struct, not the pointer itself.
+ arg)
+ (t (make-void-pointer-pointer
+ (typecase arg
+ (c-pointer-wrapper (pointer-to arg))
+ (t arg))))))
+ (setf (cffi:mem-aref arg-types '(:pointer :char) i)
+ (cffi:foreign-string-alloc
+ (typecase arg
+ #+(or) (c-pointer "{?=}")
+ (t (type-name->type-id type-name))))))))
+ (dealloc-ad-hoc-objc-arglist ()
+ (cffi:foreign-free
+ (cffi:mem-aref objc-args '(:pointer :void) 0))
(cffi:foreign-free
- (cffi:mem-aref objc-args '(:pointer :void) (+ i 2)))
- (cffi:foreign-string-free
- (cffi:mem-aref arg-types '(:pointer :char) i)))))
- (ad-hoc-arglist->objc-arglist! args)
- (unwind-protect
- (let ((error-cell
- (%objcl-invoke-with-types (length args)
- return-type-cell
- arg-types
- return-value-cell
- objc-args)))
- (unless (cffi:null-pointer-p error-cell)
- (error (make-instance 'exception :pointer error-cell)))
- (case return-type
- ((id class exception selector)
- (let ((*skip-retaining*
- (or *skip-retaining*
- (constructor-name-p (selector-name selector)))))
- (make-instance return-type
- :pointer (cffi:mem-ref return-value-cell
- return-c-type))))
- (otherwise (cffi:mem-ref return-value-cell
- return-c-type))))
- (dealloc-ad-hoc-objc-arglist)
- (foreign-string-free return-type-cell))))))
+ (cffi:mem-aref objc-args '(:pointer :void) 1))
+ (dotimes (i (length args))
+ (cffi:foreign-free
+ (cffi:mem-aref objc-args '(:pointer :void) (+ i 2)))
+ (cffi:foreign-string-free
+ (cffi:mem-aref arg-types '(:pointer :char) i)))))
+ (ad-hoc-arglist->objc-arglist! args)
+ (unwind-protect
+ (let ((error-cell
+ (%objcl-invoke-with-types (length args)
+ return-type-cell
+ arg-types
+ return-value-cell
+ objc-args)))
+ (unless (cffi:null-pointer-p error-cell)
+ (error (make-instance 'exception :pointer error-cell)))
+ (case return-type
+ ((id objc-class exception selector)
+ (let ((*skip-retaining*
+ (or *skip-retaining*
+ (constructor-name-p (selector-name selector)))))
+ (make-instance return-type
+ :pointer (cffi:mem-ref return-value-cell
+ return-c-type))))
+ (otherwise (cffi:mem-ref return-value-cell
+ return-c-type))))
+ (dealloc-ad-hoc-objc-arglist)
+ (foreign-string-free return-type-cell)))))))
;;; (@* "Helper functions")
diff --git a/Lisp/tests.lisp b/Lisp/tests.lisp
index 855860a..90e1fcf 100644
--- a/Lisp/tests.lisp
+++ b/Lisp/tests.lisp
@@ -60,7 +60,7 @@
((ensure-same (primitive-invoke (find-objc-class 'ns-object)
'self 'id)
(primitive-invoke (find-objc-class 'ns-object)
- 'class 'class)))
+ 'class 'objc-class)))
((ensure-different (primitive-invoke (find-objc-class 'ns-object)
'self 'id)
(primitive-invoke (find-objc-class 'ns-number)
diff --git a/Objective-C/libobjcl.m b/Objective-C/libobjcl.m
index 4fe4aef..25fc11f 100644
--- a/Objective-C/libobjcl.m
+++ b/Objective-C/libobjcl.m
@@ -281,8 +281,8 @@ objcl_invoke_with_types (int argc,
ffi_type *arg_types[argc + 2];
ffi_status status;
- id receiver = (id) argv[0];
- SEL method_selector = (SEL) argv[1];
+ id receiver = *((id*)argv[0]);
+ SEL method_selector = *((SEL*)argv[1]);
static ffi_type *id_type = NULL;
static ffi_type *sel_type = NULL;
@@ -298,6 +298,9 @@ objcl_invoke_with_types (int argc,
method = class_getInstanceMethod ([receiver class], method_selector)->method_imp;
#else
method = objc_msg_lookup (receiver, method_selector);
+ /* Alternatively:
+ method = [receiver methodForSelector: method_selector];
+ */
#endif
if (method == NULL)
generated by cgit v1.2.3 (git 2.25.1) at 2024-09-28 07:30:01 +0000