summaryrefslogtreecommitdiff
path: root/Lisp
diff options
context:
space:
mode:
authorMatthias Benkard <code@mail.matthias.benkard.de>2008-02-12 16:25:03 +0100
committerMatthias Benkard <code@mail.matthias.benkard.de>2008-02-12 16:25:03 +0100
commita138a2b2921d7fc0329a21d2dbabe4211ff4ef3e (patch)
treea048bae191486ab698c96acf5cefe3f56dd03117 /Lisp
parentfc097fadb088e6c563f339d2b2090cee45295194 (diff)
Add a policy for distinguishing between char and BOOL return values.
darcs-hash:09dbdf5e230a28071f1933a48077d562065df71f
Diffstat (limited to 'Lisp')
-rw-r--r--Lisp/method-invocation.lisp13
-rw-r--r--Lisp/parameters.lisp2
-rw-r--r--Lisp/policy.lisp43
-rw-r--r--Lisp/tests.lisp18
4 files changed, 66 insertions, 10 deletions
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 4408a1b..929162f 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -423,6 +423,13 @@ easier to use with __apply__.
(make-pointer-wrapper (car return-type)
:pointer (cffi:mem-ref objc-return-value-cell
return-c-type))))
+ ((:char :unsigned-char)
+ ;; FIXME: This is non-trivial. See policy.lisp for
+ ;; details.
+ (objc-char->lisp-value (cffi:mem-ref objc-return-value-cell
+ return-c-type)
+ receiver
+ selector))
((:void) (values))
(otherwise (cffi:mem-ref objc-return-value-cell
return-c-type)))))))))
@@ -565,6 +572,12 @@ easier to use with __apply__.
+yes+)
+;; Note that this refers to the Lisp BOOLEAN type, not the Objective-C
+;; BOOL type.
+(defcoercion boolean ((x number))
+ (not (zerop x)))
+
+
(defcoercion string ((x string))
x)
diff --git a/Lisp/parameters.lisp b/Lisp/parameters.lisp
index 35fae3c..875adb8 100644
--- a/Lisp/parameters.lisp
+++ b/Lisp/parameters.lisp
@@ -20,6 +20,8 @@
(defvar *runtime-initialisation-level* 0)
+(defvar *boolean-return-exceptions* (make-hash-table :test #'equal))
+
(defvar *skip-retaining* nil)
(defvar *in-make-pointer-wrapper-p* nil
diff --git a/Lisp/policy.lisp b/Lisp/policy.lisp
new file mode 100644
index 0000000..41484fa
--- /dev/null
+++ b/Lisp/policy.lisp
@@ -0,0 +1,43 @@
+;;;; Objective-CL, an Objective-C bridge for Common Lisp.
+;;;; Copyright (C) 2007 Matthias Andreas Benkard.
+;;;;
+;;;; This program is free software: you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public License
+;;;; as published by the Free Software Foundation, either version 3 of
+;;;; the License, or (at your option) any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful, but
+;;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this program. If not, see
+;;;; <http://www.gnu.org/licenses/>.
+
+(in-package #:mulk.objective-cl)
+
+
+(defun define-returns-boolean-exception (selector-designator)
+ (let ((key (typecase selector-designator
+ (string selector-designator)
+ (t (selector-name (selector selector-designator))))))
+ (setf (gethash key *boolean-return-exceptions*) t)))
+
+
+(defun undefine-returns-boolean-exceptions (selector-designator)
+ (let ((key (typecase selector-designator
+ (string selector-designator)
+ (t (selector-name (selector selector-designator))))))
+ (remhash key *boolean-return-exceptions*)))
+
+
+(define-returns-boolean-exception "charValue")
+(define-returns-boolean-exception "characterAtIndex:")
+
+
+(defun objc-char->lisp-value (objc-char receiver selector)
+ (declare (ignore receiver))
+ (if (gethash (selector-name selector) *boolean-return-exceptions* nil)
+ objc-char
+ (not (zerop objc-char)))) \ No newline at end of file
diff --git a/Lisp/tests.lisp b/Lisp/tests.lisp
index 7a6d6d8..941e95b 100644
--- a/Lisp/tests.lisp
+++ b/Lisp/tests.lisp
@@ -106,19 +106,17 @@
(primitive-invoke (find-objc-class 'ns-string)
:string-with-u-t-f-8-string 'id
"Klum.")))
- ((ensure-same +yes+
- (primitive-invoke (find-objc-class 'ns-string)
- :is-subclass-of-class
- (first (parse-typespec "c" t))
- (find-objc-class 'ns-object))))
+ ((ensure (primitive-invoke (find-objc-class 'ns-string)
+ :is-subclass-of-class
+ (first (parse-typespec "c" t))
+ (find-objc-class 'ns-object))))
;; performSelector:withObject: cannot be used with non-id return
;; types.
#+(or)
- ((ensure-same +yes+
- (primitive-invoke (find-objc-class 'ns-string)
- '(:perform-selector :with-object) :char
- (selector "isSubclassOfClass:")
- (find-objc-class 'ns-object))))))
+ ((ensure (primitive-invoke (find-objc-class 'ns-string)
+ '(:perform-selector :with-object) :char
+ (selector "isSubclassOfClass:")
+ (find-objc-class 'ns-object))))))
(deftestsuite method-invocation (objective-cl)