Fix the coercion rules for FLOAT and BOOLEAN values.

darcs-hash:d24e207d8f1e0357c8a63ec058ec61318675e89f

8 files changed, 56 insertions, 28 deletions

diff --git a/Lisp/constant-data.lisp b/Lisp/constant-data.lisp
index f936908..7922c4f 100644
--- a/Lisp/constant-data.lisp
+++ b/Lisp/constant-data.lisp
@@ -17,6 +17,7 @@
 (defconstant +pessimistic-allocation-size+
   (cffi:foreign-type-size +pessimistic-allocation-type+))
 
+
 ;;;; (@* "The constant data")
 ;;; Copied from objc-api.h
 ;;; Probably ought to be generated by C code at initialisation time.
diff --git a/Lisp/init.lisp b/Lisp/init.lisp
index 84ae511..72d616f 100644
--- a/Lisp/init.lisp
+++ b/Lisp/init.lisp
@@ -1,3 +1,12 @@
 (in-package #:mulk.objective-cl)
 
 (initialise-runtime)
+
+(eval-when (:load-toplevel)
+  (unless (boundp '+nil+)
+    (defconstant +nil+
+      (make-instance 'id :pointer (objcl-get-nil))))
+  (unless (boundp '+yes+)
+    (defconstant +yes+ (objcl-get-yes)))
+  (unless (boundp '+no+)
+    (defconstant +no+ (objcl-get-no))))
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
index 9849392..85dfc45 100644
--- a/Lisp/libobjcl.lisp
+++ b/Lisp/libobjcl.lisp
@@ -72,7 +72,8 @@
   (obj :pointer))
 
 (defcfun objcl-get-nil :pointer)
-
+(defcfun objcl-get-yes :long)
+(defcfun objcl-get-no :long)
 
 (defun initialise-runtime ()
   "Initialise the Objective C runtime.
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 9f9e056..dbf6f33 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -1,12 +1,6 @@
 (in-package #:mulk.objective-cl)
 
 
-(eval-when (:execute)
-  (unless (boundp '+nil+)
-    (defconstant +nil+
-      (make-instance 'id :pointer (objcl-get-nil)))))
-
-
 ;;; (@* "Method invocation")
 (defun invoke (receiver message-start &rest message-components)
   "Send a message to an Objective C instance.
@@ -539,7 +533,7 @@ Returns: *result* --- the return value of the method invocation.
 (defcoercion id ((x id))
   x)
 
-(defcoercion id ((x class))
+(defcoercion id ((x objc-class))
   x)
 
 (defcoercion id ((x exception))
@@ -551,15 +545,13 @@ Returns: *result* --- the return value of the method invocation.
                     'id
                     x))
 
-(defcoercion id ((x double-float))
-  (primitive-invoke (find-objc-class 'ns-number)
-                    :number-with-double
-                    'id
-                    x))
-
-(defcoercion id ((x single-float))
+(defcoercion id ((x float))
   (primitive-invoke (find-objc-class 'ns-number)
-                    :number-with-float
+                    (etypecase x
+                      (long-float :number-with-double)
+                      (double-float :number-with-double)
+                      (short-float :number-with-float)
+                      (single-float :number-with-float))
                     'id
                     x))
 
@@ -589,7 +581,7 @@ Returns: *result* --- the return value of the method invocation.
 (defcoercion class ((x exception))
   (object-get-class x))
 
-(defcoercion class ((x class))
+(defcoercion class ((x objc-class))
   x)
 
 (defcoercion class ((x string))
@@ -649,15 +641,13 @@ Returns: *result* --- the return value of the method invocation.
   (float x))
 
 
+;; Note that this refers to the Objective-C BOOL type, not the Lisp
+;; BOOLEAN type.
 (defcoercion bool ((x null))
-  x)
+  +no+)
 
-(defcoercion bool ((x symbol))
-  (assert (eq 't x))
-  x)
-
-(defcoercion bool ((x integer))
-  x)
+(defcoercion bool (x)
+  +yes+)
 
 
 (defcoercion string ((x string))
diff --git a/Lisp/utilities.lisp b/Lisp/utilities.lisp
index b44c05d..a5c1723 100644
--- a/Lisp/utilities.lisp
+++ b/Lisp/utilities.lisp
@@ -8,7 +8,7 @@
 (defun truep (b)
   (or (eq b t)
       (and (numberp b)
-           (not (zerop b)))))
+           (not (eql b +no+)))))
 
 
 (defun id-eql (x y)
@@ -17,10 +17,10 @@
 
 (defun id-equal (x y)
   (truep (if (typep x '(or id objc-class exception))
-             (primitive-invoke x :is-equal :boolean y)
+             (primitive-invoke x :is-equal :char y)
              (progn
                (assert (typep y '(or id objc-class exception)))
-               (primitive-invoke y :is-equal :boolean x)))))
+               (primitive-invoke y :is-equal :char x)))))
 
 
 (defun objc-typep (x class-designator)
diff --git a/Objective-C/libobjcl.h b/Objective-C/libobjcl.h
index a912748..8b37609 100644
--- a/Objective-C/libobjcl.h
+++ b/Objective-C/libobjcl.h
@@ -94,3 +94,11 @@ objcl_object_get_meta_class (id obj);
 
 id
 objcl_get_nil (void);
+
+/* In principle, we do not know whether a BOOL fits into a long.  In
+   practise, it is very likely. */
+long
+objcl_get_yes ();
+
+long
+objcl_get_no ();
diff --git a/Objective-C/libobjcl.m b/Objective-C/libobjcl.m
index eaffb8c..15855ed 100644
--- a/Objective-C/libobjcl.m
+++ b/Objective-C/libobjcl.m
@@ -457,3 +457,21 @@ objcl_get_nil (void)
 {
   return nil;
 }
+
+
+long
+objcl_get_yes ()
+{
+  if (sizeof (YES) > sizeof (long))
+    fprintf (stderr, "WARNING: objcl_get_yes: YES might not fit into a long.\n");
+  return YES;
+}
+
+
+long
+objcl_get_no ()
+{
+  if (sizeof (NO) > sizeof (long))
+    fprintf (stderr, "WARNING: objcl_get_no: NO might not fit into a long.\n");
+  return NO;
+}
diff --git a/objective-cl.asd b/objective-cl.asd
index c936614..25de346 100644
--- a/objective-cl.asd
+++ b/objective-cl.asd
@@ -25,7 +25,8 @@
                                                           "data-types"
                                                           "libobjcl"
                                                           "internal-utilities"
-                                                          "parameters"))
+                                                          "parameters"
+                                                          "init"))
                  (:file "memory-management"  :depends-on ("defpackage"
                                                           "init"
                                                           "weak-hash-tables"