diff options
| -rw-r--r-- | Lisp/memory-management.lisp | 4 | ||||
| -rw-r--r-- | Lisp/method-invocation.lisp | 145 | ||||
| -rw-r--r-- | Lisp/tests.lisp | 2 | ||||
| -rw-r--r-- | Objective-C/libobjcl.m | 7 |
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) |