PRIMITIVE-INVOKE: More refactoring.

darcs-hash:1440c933de066bcb07053118d3472d18b63bf5a9

2 files changed, 127 insertions, 63 deletions

diff --git a/Lisp/internal-utilities.lisp b/Lisp/internal-utilities.lisp
new file mode 100644
index 0000000..818c18b
--- /dev/null
+++ b/Lisp/internal-utilities.lisp
@@ -0,0 +1,77 @@
+(in-package #:mulk.objective-cl)
+
+
+(defmacro atomically (&body body)
+  ;; Use a reentrant global lock here.
+  `(progn ,@body))
+
+
+(declaim (ftype (function (symbol * &rest *))))
+(defun apply-macro (macro-name arg &rest args)
+  "Because FOREIGN-FUNCALL is a macro.  Why, oh why is this?"
+  (funcall
+   (compile nil
+            `(lambda ()
+               (,macro-name ,@(butlast (cons arg args))
+                            ,@(car (last (cons arg args))))))))
+
+
+(defmacro with-foreign-conversion (bindings &body body)
+  `(with-obj-data-values
+       ,(mapcar #'(lambda (name-value-pair)
+                     (destructuring-bind (name value)
+                         name-value-pair
+                       `(,name (lisp->obj-data ,value))))
+                bindings)
+     ,@body))
+
+
+(defmacro with-obj-data-values (bindings &body body)
+  `(let ,(mapcar #'(lambda (name-value-pair)
+                     (destructuring-bind (name value)
+                         name-value-pair
+                       `(,name ,value)))
+                 bindings)
+     (unwind-protect
+          (progn ,@body)
+       ,@(mapcar #'(lambda (name-value-pair)
+                     `(dealloc-obj-data ,(first name-value-pair)))
+                 bindings))))
+
+
+(defmacro with-foreign-string-pool ((register-fn-name) &body body)
+  (let ((pool-var (gensym)))
+    `(let ((,pool-var (list)))
+       (flet ((,register-fn-name (x)
+                (push x ,pool-var)
+                x))
+         (unwind-protect
+             (progn ,@body)
+           (dolist (x ,pool-var)
+             (cffi:foreign-string-free x)))))))
+
+
+(defmacro with-foreign-object-pool ((register-fn-name) &body body)
+  (let ((pool-var (gensym)))
+    `(let ((,pool-var (list)))
+       (flet ((,register-fn-name (x)
+                (push x ,pool-var)
+                x))
+         (unwind-protect
+             (progn ,@body)
+           (dolist (x ,pool-var)
+             (cffi:foreign-free x)))))))
+
+
+(defmacro defcoercion (to-class (object) &body body)
+  (let ((type-sym (gensym)))
+    `(defmethod coerce-object (,object (,type-sym (eql ',to-class)))
+       ,@body)))
+
+
+;; Compatibility with older versions of CFFI.
+(unless (fboundp 'foreign-funcall-pointer)
+  (defmacro foreign-funcall-pointer (pointer options &rest args)
+    (if (find-symbol "FOREIGN-FUNCALL-POINTER" '#:cffi)
+        `(cffi:foreign-funcall-pointer ,pointer ,options ,@args)
+        `(cffi:foreign-funcall (,pointer ,@options) ,@args))))
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")