summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Lisp/internal-utilities.lisp16
-rw-r--r--Lisp/method-invocation.lisp45
2 files changed, 42 insertions, 19 deletions
diff --git a/Lisp/internal-utilities.lisp b/Lisp/internal-utilities.lisp
index 1c54068..9be74a9 100644
--- a/Lisp/internal-utilities.lisp
+++ b/Lisp/internal-utilities.lisp
@@ -27,6 +27,22 @@
(member symbol *features*))
+(defun objc-null (value)
+ (or (null value)
+ (and (typep value 'c-pointer-wrapper)
+ (objc-pointer-null (pointer-to value)))))
+
+
+(defmacro objc-or (&rest forms)
+ (let ((sym (gensym)))
+ `(let ((,sym ,(first forms)))
+ (if (objc-null ,sym)
+ ,(if (rest forms)
+ `(objc-or ,@(rest forms))
+ 'nil)
+ ,sym))))
+
+
(defmacro with-foreign-string-pool ((register-fn-name) &body body)
(let ((pool-var (gensym)))
`(let ((,pool-var (list)))
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 5601edf..4408a1b 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -242,7 +242,7 @@ easier to use with __apply__.
(defun primitive-invoke (receiver method-name return-type &rest args)
(flet ((ad-hoc-value->typespec (arg)
- (typecase arg
+ (etypecase arg
;; According to Allegro CL, strings
;; are POINTERP (and thus elements of
;; the C-POINTER type), so they have
@@ -254,16 +254,19 @@ easier to use with __apply__.
;; CL, so all integers are POINTERP,
;; too.
(string '(:string ()))
+ (selector '(selector ()))
(c-pointer-wrapper '(id ()))
(c-pointer '(:pointer ()))
- (t `(,return-type ())))))
+ (integer '(:int ())))))
(let ((return-typespec `(,return-type ()))
- (arg-typespecs (mapcar #'ad-hoc-value->typespec args)))
+ (arg-typespecs (list* '(id ())
+ '(selector ())
+ (mapcar #'ad-hoc-value->typespec args))))
(low-level-invoke receiver
(selector method-name)
- (type-name->type-id (car return-typespec))
+ (print-typespec-to-string return-typespec)
return-typespec
- (mapcar #'type-name->type-id (mapcar #'car arg-typespecs))
+ (mapcar #'print-typespec-to-string arg-typespecs)
arg-typespecs
(+ 2 (length args))
args))))
@@ -274,18 +277,18 @@ easier to use with __apply__.
(cons (cffi:pointer-address (pointer-to class))
(cffi:pointer-address (pointer-to selector)))
(let* ((signature
- (or (if (eq instance-or-class :instance)
- (primitive-invoke class
- "instanceMethodSignatureForSelector:"
- 'id
- selector)
- (primitive-invoke class
- "methodSignatureForSelector:"
- 'id
- selector))
- (error (make-condition 'message-not-understood
- :class class
- :selector selector))))
+ (objc-or (if (eq instance-or-class :instance)
+ (primitive-invoke class
+ "instanceMethodSignatureForSelector:"
+ 'id
+ selector)
+ (primitive-invoke class
+ "methodSignatureForSelector:"
+ 'id
+ selector))
+ (error (make-condition 'message-not-understood
+ :class class
+ :selector selector))))
(argc (primitive-invoke signature "numberOfArguments" :unsigned-int))
(method-return-typestring (primitive-invoke signature
"methodReturnType"
@@ -348,8 +351,12 @@ easier to use with __apply__.
`(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))
+ (setf (argref :pointer 0) (if (pointerp receiver)
+ receiver
+ (pointer-to receiver)))
+ (setf (argref :pointer 1) (if (pointerp selector)
+ selector
+ (pointer-to selector)))
(loop for i from 2
for arg in args
for arg-type in (cddr arg-types) ;skip the first two arguments