Reimplement PRIMITIVE-INVOKE and rename the old version UNSAFE-PRIMITIVE-INVOKE.

darcs-hash:a941bade2677db3d5773c20ffda171c7c9721a98

1 files changed, 74 insertions, 6 deletions

diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 9d5eada..43a3365 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -147,8 +147,8 @@ Returns: *result* --- the return value of the method invocation.
         (dealloc-objc-arglist objc-arglist)))))
 
 
-(defmacro primitive-invoke (receiver method-name return-type &rest args)
-  (let ((real-return-type (if (member return-type '(:id :class :exception))
+(defmacro unsafe-primitive-invoke (receiver method-name return-type &rest args)
+  (let ((real-return-type (if (member return-type '(id class exception))
                               :pointer
                               return-type))
         (real-receiver (gensym))
@@ -169,18 +169,86 @@ Returns: *result* --- the return value of the method invocation.
                                            (list :pointer (pointer-to ,real-selector))
                                            objc-arglist
                                            (list ,real-return-type)))))
-                 ,(if (member return-type '(:id :class :exception))
+                 ,(if (member return-type '(id class exception))
                       `(let (,@(when (constructor-name-p (selector-name selector))
                                  `((*skip-retaining* t))))
                          (make-instance ',(case return-type
-                                            ((:id) 'id)
-                                            ((:class) 'objc-class)
-                                            ((:exception) 'exception))
+                                            ((id) 'id)
+                                            ((class) 'objc-class)
+                                            ((exception) 'exception))
                             :pointer return-value))
                       `return-value))
              (dealloc-objc-arglist objc-arglist)))))))
 
 
+(defun primitive-invoke (receiver method-name return-type &rest args)
+  (let ((return-c-type (case return-type
+                         ((id class exception selector) :pointer)
+                         (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))
+                                (return-value-cell return-c-type))
+      (flet ((ad-hoc-arglist->objc-arglist! (args)
+               (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)
+                                (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 (cffi:foreign-alloc
+                                      #+(or) cffi-type
+                                      :pointer
+                                      :initial-element (typecase arg
+                                                         (c-pointer-wrapper
+                                                          (print (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 ()
+               (dotimes (i (length args))
+                 (cffi:foreign-free
+                  (cffi:mem-aref objc-args '(:pointer :void) i))
+                 (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 (pointer-to receiver)
+                                             (pointer-to selector)
+                                             (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 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")
 (defun arglist->objc-arglist (arglist)
   (arglist-intersperse-types (mapcar #'lisp->obj-data arglist)))