PRIMITIVE-INVOKE: Support string arguments.

darcs-hash:88071caa7b863276de551edbcca8010961ca1d14

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")