summaryrefslogtreecommitdiff
path: root/Lisp
diff options
context:
space:
mode:
authorMatthias Benkard <code@mail.matthias.benkard.de>2007-09-17 21:29:49 +0200
committerMatthias Benkard <code@mail.matthias.benkard.de>2007-09-17 21:29:49 +0200
commit1bd58fa0e733f1137c2fc46d61bb9faf41551813 (patch)
tree8a2bdcdf14303b1d990bc99ec4c4975dee10ad23 /Lisp
parent47d7a405495b68062924a4d9cb4738e0b0af14a1 (diff)
Add INVOKE-WITH-CONVERSION, a reliable INVOKE-BY-NAME alternative.
darcs-hash:fb4eed75cbc7db6627f756944232bc1944eb5a5f
Diffstat (limited to 'Lisp')
-rw-r--r--Lisp/method-invocation.lisp149
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)))