summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Lisp/method-invocation.lisp131
1 files changed, 26 insertions, 105 deletions
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 879996d..5601edf 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -241,111 +241,32 @@ easier to use with __apply__.
(defun primitive-invoke (receiver method-name return-type &rest args)
- "An invocation mechanism with ad-hoc argument conversion."
- (with-foreign-string-pool (register-temporary-string)
- (let* ((raw-argc (the argument-number (length args)))
- (real-argc (+ raw-argc 2))
- (return-c-type (case return-type
- ((id objective-c-class exception selector) :pointer)
- (otherwise return-type)))
- (selector (if (typep method-name 'selector)
- method-name
- (find-selector method-name))))
- (labels ((alloc-string-and-register (string)
- (register-temporary-string
- (cffi:foreign-string-alloc string))))
- ;; We allocate a conservatively-sized buffer for arguments of
- ;; primitive types called OBJC-ARG-BUFFER. Non-primitive types
- ;; don't need allocation, anyway, because we can just pass the
- ;; pointer directly. It's unfortunate that we can't do this for
- ;; `id' values, because we can't just pass a pointer to the `id'
- ;; SAP (which would be highly implementation-dependent and might
- ;; even change at any time, especially during GC).
- ;;
- ;; In any case, OBJC-ARGS-PTRS is the array of pointers which
- ;; the libffi docs call AVALUES. It must therefore contain
- ;; pointers pointing into the argument buffer (or, in the case
- ;; of a newly allocated C string, to that string). This is what
- ;; the DOTIMES form below tries to ensure.
- (cffi:with-foreign-objects ((arg-types '(:pointer :char)
- (the fixnum (length args)))
- (objc-arg-ptrs '(:pointer :void)
- real-argc)
- (return-value-cell (if (eq return-c-type :void)
- :int
- return-c-type))
- (objc-arg-buffer +pessimistic-allocation-type+
- real-argc))
- (dotimes (i real-argc)
- (setf (cffi:mem-aref objc-arg-ptrs '(:pointer :void) 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+))))
- (flet ((ad-hoc-arglist->objc-arglist! (args)
- (setf (argref '(:pointer :void) 0)
- (if (pointerp receiver)
- receiver
- (pointer-to receiver))
- (argref '(:pointer :void) 1)
- (pointer-to selector))
- (loop for arg in args
- for i from 0 to raw-argc
- do (let* ((type-name (lisp-value->type-name arg)))
- (typecase arg
- ;; According to Allegro CL, strings
- ;; are POINTERP (and thus elements of
- ;; the C-POINTER type), so they have
- ;; to come first in this TYPECASE
- ;; form. Weird.
- ;;
- ;; By the way, pointers are
- ;; represented as integers in Allegro
- ;; CL, so all integers are POINTERP,
- ;; too.
- (string
- (setf (argref :string (+ i 2))
- (alloc-string-and-register arg)))
- ((or c-pointer-wrapper
- c-pointer)
- (setf (argref :pointer (+ i 2))
- (typecase arg
- (c-pointer-wrapper (pointer-to arg))
- (t arg))))
- (t (setf (argref (type-name->c-type type-name)
- (+ i 2))
- arg)))
- (setf (cffi:mem-aref arg-types '(:pointer :char) i)
- (alloc-string-and-register
- (type-name->type-id type-name)))))))
- (ad-hoc-arglist->objc-arglist! args)
- (let ((error-cell
- (%objcl-invoke-with-types raw-argc
- (type-name->type-id return-type)
- arg-types
- 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-pointer-wrapper 'exception :pointer error-cell)))
- (case return-type
- ((id objective-c-class exception selector)
- (let ((*skip-retaining*
- (or *skip-retaining*
- (constructor-name-p (selector-name selector))))
- (pointer (cffi:mem-ref return-value-cell
- return-c-type)))
- (if (cffi:null-pointer-p pointer)
- nil
- (make-pointer-wrapper return-type :pointer pointer))))
- ((:void) (values))
- (otherwise (cffi:mem-ref return-value-cell
- return-c-type)))))))))))
+ (flet ((ad-hoc-value->typespec (arg)
+ (typecase arg
+ ;; According to Allegro CL, strings
+ ;; are POINTERP (and thus elements of
+ ;; the C-POINTER type), so they have
+ ;; to come first in this TYPECASE
+ ;; form. Weird.
+ ;;
+ ;; By the way, pointers are
+ ;; represented as integers in Allegro
+ ;; CL, so all integers are POINTERP,
+ ;; too.
+ (string '(:string ()))
+ (c-pointer-wrapper '(id ()))
+ (c-pointer '(:pointer ()))
+ (t `(,return-type ())))))
+ (let ((return-typespec `(,return-type ()))
+ (arg-typespecs (mapcar #'ad-hoc-value->typespec args)))
+ (low-level-invoke receiver
+ (selector method-name)
+ (type-name->type-id (car return-typespec))
+ return-typespec
+ (mapcar #'type-name->type-id (mapcar #'car arg-typespecs))
+ arg-typespecs
+ (+ 2 (length args))
+ args))))
(define-cached-function retrieve-method-signature-info