Add INVOKE-WITH-CONVERSION, a reliable INVOKE-BY-NAME alternative.

darcs-hash:fb4eed75cbc7db6627f756944232bc1944eb5a5f

1 files changed, 149 insertions, 0 deletions

diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index c1742f8..29c6d63 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -254,6 +254,11 @@ Returns: *result* --- the return value of the method invocation.
                                                 return-value-cell
                                                 objc-arg-ptrs)))
                 (unless (cffi:null-pointer-p error-cell)
+                  ;; Note that we do not FOREIGN-FREE the error cell,
+                  ;; because it is either a null pointer or a pointer to
+                  ;; an Objective-C object.  In the latter case,
+                  ;; INITIALIZE-INSTANCE does the memory management for
+                  ;; us.
                   (error (make-condition 'exception :pointer error-cell)))
                 (case return-type
                   ((id objc-class exception selector)
@@ -267,6 +272,125 @@ Returns: *result* --- the return value of the method invocation.
                                            return-c-type)))))))))))
 
 
+(defun retrieve-method-signature-info (class selector)
+  (let* ((signature (primitive-invoke class
+                                      :instance-method-signature-for-selector
+                                      'id
+                                      selector))
+         (argc (primitive-invoke signature 'number-of-arguments :unsigned-int))
+         (method-return-typestring (primitive-invoke signature
+                                                     'method-return-type
+                                                     :string))
+         (method-return-type (parse-typespec method-return-typestring))
+         (method-arg-typestrings (loop for x from 0 below argc
+                                       collect (primitive-invoke
+                                                         signature
+                                                         :get-argument-type-at-index
+                                                         :string
+                                                         x)))
+         (method-arg-types (mapcar #'parse-typespec method-arg-typestrings)))
+    (values argc
+            method-return-typestring
+            method-return-type
+            method-arg-typestrings
+            method-arg-types)))
+
+
+(defun typespec->c-type (typespec)
+  (case (car typespec)
+    ((:pointer struct union id objc-class exception array) :pointer)
+    ((:string) :string)
+    (otherwise (car typespec))))
+
+
+(defun low-level-invoke (receiver selector return-typestring return-type
+                         arg-typestrings arg-types argc args)
+  (let ((return-c-type (typespec->c-type return-type))
+        (arg-c-types (mapcar #'typespec->c-type arg-types)))
+    (with-foreign-string-pool (register-temporary-string)
+      (flet ((alloc-string-and-register (string)
+               (register-temporary-string
+                (cffi:foreign-string-alloc string))))
+      (cffi:with-foreign-objects ((objc-arg-typestrings :string
+                                                        (- argc 2))
+                                  (objc-arg-ptrs :pointer argc)
+                                  (objc-return-value-cell return-c-type)
+                                  (objc-arg-buffer +pessimistic-allocation-type+
+                                                   argc))
+        ;; Prepare the argument pointer vector.
+        (loop for i from 0 below argc
+              do (setf (cffi:mem-aref objc-arg-ptrs :pointer i)
+                       (cffi:inc-pointer objc-arg-buffer
+                                         (* i +pessimistic-allocation-size+))))
+        (macrolet ((argref (type num)
+                     `(cffi:mem-ref objc-arg-buffer ,type
+                                    (* ,num +pessimistic-allocation-size+))))
+          ;; Prepare the arguments.
+          (setf (argref :pointer 0) (pointer-to receiver))
+          (setf (argref :pointer 1) (pointer-to selector))
+          (loop for i from 2
+                for arg in args
+                for arg-type in (cddr arg-types) ;skip the first two arguments
+                for arg-c-type in (cddr arg-c-types) ;likewise
+                do (case (car arg-type)
+                     ((:pointer)
+                      (setf (argref :pointer i) arg))
+                     ((id objc-class exception)
+                      (setf (argref :pointer i) (pointer-to arg)))
+                     (:string
+                      (setf (argref :string i)
+                            (alloc-string-and-register arg)))
+                     ((array struct union) (error "~A: Not implemented."
+                                                  arg-type))
+                     (t (setf (argref arg-c-type i) arg)))))
+        ;; Prepare the argument typestring vector.
+        (loop for i from 0
+              for arg-typestring in arg-typestrings
+              do (setf (mem-aref objc-arg-typestrings :string i)
+                       (alloc-string-and-register arg-typestring)))
+        (let* ((error-cell
+                (%objcl-invoke-with-types (- argc 2)
+                                          return-typestring
+                                          objc-arg-typestrings
+                                          objc-return-value-cell
+                                          objc-arg-ptrs)))
+          (unless (cffi:null-pointer-p error-cell)
+            (error (make-condition 'exception :pointer error-cell)))
+          (case (car 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 objc-return-value-cell
+                                         return-c-type))))
+            (otherwise (cffi:mem-ref objc-return-value-cell
+                                     return-c-type)))))))))
+
+
+(defun invoke-with-conversion (receiver method-name &rest args)
+  (let* ((selector (selector method-name))
+         (class (primitive-invoke receiver 'class 'objc-class)))
+    (multiple-value-bind (argc
+                          method-return-typestring
+                          method-return-type
+                          method-arg-typestrings
+                          method-arg-types)
+        (retrieve-method-signature-info class selector)
+      (assert (= argc (+ 2 (length args)))
+              (args)
+              "Wrong number of arguments (expected ~A, got ~A)."
+              argc (+ 2 (length args)))
+      (low-level-invoke receiver
+                        selector
+                        method-return-typestring
+                        method-return-type
+                        method-arg-typestrings
+                        method-arg-types
+                        argc
+                        args))))
+
+
 ;; Optimise constant method names away by converting them to selectors
 ;; at load-time.
 (define-compiler-macro primitive-invoke (&whole form
@@ -292,6 +416,31 @@ Returns: *result* --- the return value of the method invocation.
       form))
 
 
+;; Do the same optimisations for INVOKE-WITH-CONVERSION as for
+;; PRIMITIVE-INVOKE.
+(define-compiler-macro invoke-with-conversion (&whole form
+                                               receiver method-name
+                                               &rest args)
+  (if (and (constantp method-name)
+           (not (and (listp method-name)
+                     (eq 'load-time-value (car method-name)))))
+      `(invoke-with-conversion
+        ,receiver
+        (load-time-value (handler-case
+                             (selector ,method-name)
+                           (serious-condition ()
+                             (warn
+                              (make-condition 'style-warning
+                                              :format-control
+                                              "~S designates an unknown ~
+                                               method selector."
+                                              :format-arguments
+                                              (list ,method-name)))
+                             ,method-name)))
+        ,@args)
+      form))
+
+
 ;;; (@* "Helper functions")
 (defun arglist->objc-arglist (arglist)
   (arglist-intersperse-types (mapcar #'lisp->obj-data arglist)))