From c31e45dda43e1bf10e66a724cb90d51cd6cfaa26 Mon Sep 17 00:00:00 2001 From: Matthias Benkard Date: Mon, 13 Aug 2007 13:59:04 +0200 Subject: Add a SELECTOR function and use coerced selectors in Objective C code rather than strings. darcs-hash:d10f9eafc3b21bfcfc027a263e8cee007155b89c --- Lisp/defpackage.lisp | 1 + Lisp/libobjcl.lisp | 51 ++++++++++++++++++++++++++++++++++++++++++++- Lisp/method-invocation.lisp | 21 ++++++++++++++----- Lisp/tests.lisp | 16 +++++++------- Lisp/type-conversion.lisp | 1 + 5 files changed, 77 insertions(+), 13 deletions(-) (limited to 'Lisp') diff --git a/Lisp/defpackage.lisp b/Lisp/defpackage.lisp index c3008af..17ccf76 100644 --- a/Lisp/defpackage.lisp +++ b/Lisp/defpackage.lisp @@ -10,6 +10,7 @@ #:invoke #:find-objc-class #:find-selector + #:selector ;; Generic functions #:objc-eql diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp index 00560fe..a713c8e 100644 --- a/Lisp/libobjcl.lisp +++ b/Lisp/libobjcl.lisp @@ -70,7 +70,7 @@ objects or classes, let alone send messages to them. (defcfun ("objcl_invoke_method" %objcl-invoke-method) obj-data (receiver obj-data) - (method-name :string) + (method-selector obj-data) (argc :int) &rest) @@ -183,6 +183,55 @@ conventional case for namespace identifiers in Objective C." (foreign-string-to-lisp/dealloc (%objcl-selector-name obj-data)))) +(defun selector (designator) + "Convert an object into a selector. + +## Arguments and Values: + +*designator* --- a *selector designator*. + + +## Description: + +*selector-designator* must be a valid *selector designator*, that is: +either a __selector__ object or one of a **symbol**, a **string**, or a +**list** of **symbol**s representing a __selector__. + +If *selector-designator* is a **string** or a **list** of **symbol**s, +__find-selector__ is called and the value returned, except that if +__find-selector__ returns __nil__, an **error** is **signal**ed. + +If *selector-designator* is a single **symbol**, it is treated as if it +were a **list** whose **car** is the **symbol** and whose **cdr** is +__nil__. + +If *selector-designator* is a __selector__, it is simply returned. + + +## Examples: + + (selector \"self\") ;=> # + (selector '(self)) ;=> # + (selector 'self) ;=> # + (selector *) ;=> # + + (selector 'selph) ; error + + (selector \"stringWithCString:encoding:\") + ;=> # + + (selector '(:string-with-c-string :encoding)) + ;=> #" + + (ctypecase designator + (selector designator) + (symbol (selector (list designator))) + ((or string list) + (or (find-selector designator) + (error "Could not find the selector designated by ~S." + designator))))) + + (defun find-selector (selector-name) "Retrieve a method selector by name. diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp index 95784fa..17c7cf3 100644 --- a/Lisp/method-invocation.lisp +++ b/Lisp/method-invocation.lisp @@ -131,23 +131,34 @@ Returns: *result* --- the return value of the method invocation. (if (typep lisp-value 'condition) (cerror "Return NIL from OBJCL-INVOKE-METHOD." lisp-value) lisp-value)))) - (let* ((objc-args (mapcar #'lisp->obj-data args)) - (arglist (arglist-intersperse-types objc-args))) + (let ((objc-arglist (arglist->objc-arglist args)) + (selector (selector method-name))) (unwind-protect (with-foreign-conversion ((objc-receiver receiver)) (with-foreign-objects ((return-value (apply-macro '%objcl-invoke-method objc-receiver - method-name + (pointer-to selector) (length args) - arglist))) + objc-arglist))) (let ((*skip-retaining* (or *skip-retaining* (constructor-name-p method-name)))) (convert/signal return-value)))) - (mapc #'dealloc-obj-data objc-args))))) + (dealloc-objc-arglist objc-arglist))))) ;;; (@* "Helper functions") +(defun arglist->objc-arglist (arglist) + (arglist-intersperse-types (mapcar #'lisp->obj-data arglist))) + + +(defun dealloc-objc-arglist (objc-arglist) + (do ((objc-arglist objc-arglist (cddr objc-arglist))) + ((null objc-arglist)) + ;; (first objc-arglist) is a CFFI type name. + (dealloc-obj-data (second objc-arglist)))) + + (defun arglist-intersperse-types (arglist) (mapcan #'(lambda (arg) (list :pointer arg)) diff --git a/Lisp/tests.lisp b/Lisp/tests.lisp index 28c4c9f..eec76ee 100644 --- a/Lisp/tests.lisp +++ b/Lisp/tests.lisp @@ -60,7 +60,7 @@ [NSString stringWithCString: "Klum."])) ((ensure [NSString isSubclassOfClass: [NSObject class]])) ((ensure [NSString performSelector: - (find-selector "isSubclassOfClass:") + (selector "isSubclassOfClass:") withObject: [NSObject class]])))) @@ -70,9 +70,9 @@ (:tests ((ensure-same [NSString stringWithCString: "Mulk."] [NSString stringWithCString: "Mulk." encoding: 4])) - ((ensure-same [NSString respondsToSelector: (find-selector "new")] + ((ensure-same [NSString respondsToSelector: (selector "new")] [NSString respondsToSelector: 'new])) - ((ensure-same [NSString respondsToSelector: (find-selector "new")] + ((ensure-same [NSString respondsToSelector: (selector "new")] [NSString respondsToSelector: "new"])) ((ensure (typep [NSString isEqual: [NSString self]] 'boolean))) ((ensure (typep [NSString isEqual: [NSObject self]] 'boolean))))) @@ -113,8 +113,10 @@ (invoke (find-objc-class 'ns-string) :string-with-c-string "Mulk." :encoding 4))) ((ensure-same [NSString performSelector: - (find-selector "isSubclassOfClass:") - withObject: [NSObject class]] + (selector "isSubclassOfClass:") + withObject: [NSObject self]] (invoke (find-objc-class 'ns-string) - :performSelector (find-selector "isSubclassOfClass") - :with-object (find-objc-class 'ns-object)))))) + :perform-selector (selector "isSubclassOfClass:") + :with-object (invoke + (find-objc-class 'ns-object) + 'self)))))) diff --git a/Lisp/type-conversion.lisp b/Lisp/type-conversion.lisp index bba40e7..42f3a98 100644 --- a/Lisp/type-conversion.lisp +++ b/Lisp/type-conversion.lisp @@ -10,6 +10,7 @@ 'obj-data-union (type-name->slot-name type-name)) (typecase value + (symbol (selector value)) ((or id objc-class selector exception) (pointer-to value)) (string (foreign-string-alloc value)) -- cgit v1.2.3