summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthias Benkard <code@mail.matthias.benkard.de>2007-09-16 02:25:39 +0200
committerMatthias Benkard <code@mail.matthias.benkard.de>2007-09-16 02:25:39 +0200
commitcbd39a338256d64deac9d2b049c9473f6be31eb2 (patch)
tree0f12630070b5b12376e5ce829e619d14b0a1a102
parenta989ea1318574332c31cc48defdbd01f88d74461 (diff)
PRIMITIVE-INVOKE: Support string arguments.
darcs-hash:88071caa7b863276de551edbcca8010961ca1d14
-rw-r--r--Lisp/method-invocation.lisp142
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")