PRIMITIVE-INVOKE: More refactoring.

darcs-hash:1440c933de066bcb07053118d3472d18b63bf5a9

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