diff options
Diffstat (limited to 'Lisp/method-invocation.lisp')
-rw-r--r-- | Lisp/method-invocation.lisp | 113 |
1 files changed, 50 insertions, 63 deletions
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp index 820afd7..ec1913f 100644 --- a/Lisp/method-invocation.lisp +++ b/Lisp/method-invocation.lisp @@ -182,67 +182,55 @@ 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 objc-class exception selector) :pointer) - (otherwise return-type))) - (selector (selector method-name)) - (temporary-foreign-objects (list)) - (temporary-foreign-strings (list))) - (labels ((make-void-pointer-pointer (ptr) - (cffi:foreign-alloc '(:pointer :void) - :initial-element ptr)) - (register-temporary-object (object) - (push object temporary-foreign-objects) - object) - (register-temporary-string (string) - (push string temporary-foreign-strings) - string) - (alloc-pointer-and-register (target) - (register-temporary-object - (make-void-pointer-pointer target))) - (alloc-string-and-register (string) - (register-temporary-string - (cffi:foreign-string-alloc string)))) - (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) - (alloc-pointer-and-register (pointer-to receiver)) - (cffi:mem-aref objc-args '(:pointer :void) 1) - (alloc-pointer-and-register (pointer-to selector))) - (loop for arg in args - for i from 0 - do (let* ((type-name (lisp-value->type-name arg))) - (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) - (string (alloc-pointer-and-register - (alloc-string-and-register - arg))) - (t (alloc-pointer-and-register - (typecase arg - (c-pointer-wrapper (pointer-to arg)) - (t arg)))))) - (setf (cffi:mem-aref arg-types '(:pointer :char) i) - (alloc-string-and-register - (typecase arg - #+(or) (c-pointer "{?=}") - (t (type-name->type-id type-name)))))))) - (dealloc-registered-objects () - (dolist (x temporary-foreign-objects) - (cffi:foreign-free x)) - (dolist (x temporary-foreign-strings) - (cffi:foreign-string-free x)))) - (ad-hoc-arglist->objc-arglist! args) - (unwind-protect + (with-foreign-string-pool (register-temporary-string) + (with-foreign-object-pool (register-temporary-object) + (let ((return-c-type (case return-type + ((id objc-class exception selector) :pointer) + (otherwise return-type))) + (selector (selector method-name))) + (labels ((make-void-pointer-pointer (ptr) + (cffi:foreign-alloc '(:pointer :void) + :initial-element ptr)) + (alloc-pointer-and-register (target) + (register-temporary-object + (make-void-pointer-pointer target))) + (alloc-string-and-register (string) + (register-temporary-string + (cffi:foreign-string-alloc string)))) + (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) + (alloc-pointer-and-register (pointer-to receiver)) + (cffi:mem-aref objc-args '(:pointer :void) 1) + (alloc-pointer-and-register (pointer-to selector))) + (loop for arg in args + for i from 0 + do (let* ((type-name (lisp-value->type-name arg))) + (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) + (string (alloc-pointer-and-register + (alloc-string-and-register + arg))) + (t (alloc-pointer-and-register + (typecase arg + (c-pointer-wrapper (pointer-to arg)) + (t arg)))))) + (setf (cffi:mem-aref arg-types '(:pointer :char) i) + (alloc-string-and-register + (typecase arg + #+(or) (c-pointer "{?=}") + (t (type-name->type-id type-name))))))))) + (ad-hoc-arglist->objc-arglist! args) (let* ((return-type-cell (alloc-string-and-register (type-name->type-id return-type))) (error-cell @@ -262,8 +250,7 @@ Returns: *result* --- the return value of the method invocation. :pointer (cffi:mem-ref return-value-cell return-c-type)))) (otherwise (cffi:mem-ref return-value-cell - return-c-type)))) - (dealloc-registered-objects))))))) + return-c-type))))))))))) ;;; (@* "Helper functions") |