diff options
Diffstat (limited to 'Lisp')
| -rw-r--r-- | Lisp/method-invocation.lisp | 142 |
1 files changed, 77 insertions, 65 deletions
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp index dbdde6c..6af5d5e 100644 --- a/Lisp/method-invocation.lisp +++ b/Lisp/method-invocation.lisp @@ -191,71 +191,83 @@ Returns: *result* --- the return value of the method invocation. (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) 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))))))) + (selector (selector method-name)) + (temporary-foreign-objects (list)) + (temporary-foreign-strings (list))) + (flet ((register-temporary-string (string) + (push string temporary-foreign-strings) + string) + (register-temporary-object (object) + (push object temporary-foreign-objects) + object)) + (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) + (register-temporary-object + (make-void-pointer-pointer (pointer-to receiver))) + (cffi:mem-aref objc-args '(:pointer :void) 1) + (register-temporary-object + (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) + (string (register-temporary-object + (make-void-pointer-pointer + (register-temporary-string + (cffi:foreign-string-alloc + arg))))) + (t (register-temporary-object + (make-void-pointer-pointer + (typecase arg + (c-pointer-wrapper (pointer-to arg)) + (t arg))))))) + (setf (cffi:mem-aref arg-types '(:pointer :char) i) + (register-temporary-string + (cffi:foreign-string-alloc + (typecase arg + #+(or) (c-pointer "{?=}") + (t (type-name->type-id type-name))))))))) + (dealloc-ad-hoc-objc-arglist () + (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 + (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") |