Add a policy for distinguishing between char and BOOL return values.

darcs-hash:09dbdf5e230a28071f1933a48077d562065df71f

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)