* Renamed `cast-flonum-to-integer' to `cast-ieee754-double-to-integer'.

* Renamed `cast-integer-to-flonum' to `cast-integer-to-ieee754-double'.

* Changed both to use <uint64_t> instead of <unsigned long> for
conversion.  That way, they should work on 32-bit systems.  (Thanks to
Taylor for pointing out that bug.)

* Added `cast-ieee754-single-to-integer' and `cast-integer-to-ieee754-single'.

* Updated existing tests.

* Added tests for casts to and from single-precision floating-point numbers.

diff --git a/src/microcode/flonum.c b/src/microcode/flonum.c
index b18726715c5d7dd3a46a5e45ec6c0e7c0aabc39e..c72252af9914529e9c7c5f5b29e77b288526f88c 100644 (file)
--- a/src/microcode/flonum.c
+++ b/src/microcode/flonum.c
@@ -260,34 +260,70 @@ DEFINE_PRIMITIVE ("FLONUM-DENORMALIZE", Prim_flonum_denormalize, 2, 2, 0)
   CHECK_ARG (2, INTEGER_P);
   PRIMITIVE_RETURN (flonum_denormalize ((ARG_REF (1)), (ARG_REF (2))));
 }
-
+\f
+/* These conversion primitives don't require IEEE 754, but they do
+ * make assumptions about the sizes of doubles and floats.  If we want
+ * to support using these primitives with non-IEEE 754 floating-point
+ * numbers, we may have to adjust them.
+ */
 typedef
 union
 {
   double dbl;
-  unsigned long ul;
-} double_unsigned_long_cast;
+  uint64_t u64;
+} double_uint64_t_cast;
 
-DEFINE_PRIMITIVE ("CAST-FLONUM-TO-INTEGER", Prim_cast_flonum_to_integer, 1, 1, 0)
+DEFINE_PRIMITIVE ("CAST-IEEE754-DOUBLE-TO-INTEGER", Prim_cast_ieee754_double_to_integer, 1, 1, 0)
 {
   PRIMITIVE_HEADER (1);
   CHECK_ARG (1, FLONUM_P);
 
-  double_unsigned_long_cast cast;
+  double_uint64_t_cast cast;
 
   cast.dbl = FLONUM_TO_DOUBLE (ARG_REF (1));
 
-  PRIMITIVE_RETURN (ulong_to_integer (cast.ul));
+  PRIMITIVE_RETURN (uintmax_to_integer (cast.u64));
 }
 
-DEFINE_PRIMITIVE ("CAST-INTEGER-TO-FLONUM", Prim_cast_integer_to_flonum, 1, 1, 0)
+DEFINE_PRIMITIVE ("CAST-INTEGER-TO-IEEE754-DOUBLE", Prim_cast_integer_to_ieee754_double, 1, 1, 0)
 {
   PRIMITIVE_HEADER (1);
   CHECK_ARG (1, INTEGER_P);
 
-  double_unsigned_long_cast cast;
+  double_uint64_t_cast cast;
 
-  cast.ul = integer_to_long (ARG_REF (1));
+  cast.u64 = integer_to_uintmax (ARG_REF (1));
 
   PRIMITIVE_RETURN (double_to_flonum (cast.dbl));
 }
+
+typedef
+union
+{
+  float f;
+  uint32_t u32;
+} float_uint32_t_cast;
+
+DEFINE_PRIMITIVE ("CAST-IEEE754-SINGLE-TO-INTEGER", Prim_cast_ieee754_single_to_integer, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  CHECK_ARG (1, FLONUM_P);
+
+  float_uint32_t_cast cast;
+
+  cast.f = (float) FLONUM_TO_DOUBLE (ARG_REF (1));
+
+  PRIMITIVE_RETURN (uintmax_to_integer (cast.u32));
+}
+
+DEFINE_PRIMITIVE ("CAST-INTEGER-TO-IEEE754-SINGLE", Prim_cast_integer_to_ieee754_single, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  CHECK_ARG (1, INTEGER_P);
+
+  float_uint32_t_cast cast;
+
+  cast.u32 = integer_to_uintmax (ARG_REF (1));
+
+  PRIMITIVE_RETURN (double_to_flonum ((double) cast.f));
+}

diff --git a/tests/microcode/test-flonum-casts.scm b/tests/microcode/test-flonum-casts.scm
index 48b7a64188541042dbebe22f986039af70345b36..31e7162b74bba4a75e90b60236ea00aec5a75982 100644 (file)
--- a/tests/microcode/test-flonum-casts.scm
+++ b/tests/microcode/test-flonum-casts.scm
@@ -27,54 +27,103 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define-test 'test-casting
-  (lambda ()
+(define (factorial n)
+  (if (< n 2)
+      1
+      (* n (factorial (- n 1)))))
 
-    (define cast-flonum-to-integer
-      (make-primitive-procedure 'cast-flonum-to-integer))
+(define ((make-cast-tester cast-to-integer cast-to-flonum size-in-bits)
+        flonum
+        integer-as-bit-string)
+  (assert-equal
+   (unsigned-integer->bit-string size-in-bits (cast-to-integer flonum))
+   integer-as-bit-string)
+  (assert-equal
+   flonum
+   (cast-to-flonum integer-as-bit-string)))
 
-    (define cast-integer-to-flonum
-      (make-primitive-procedure 'cast-integer-to-flonum))
+(define-test 'test-casting-doubles
+  (lambda ()
+    (define cast-ieee754-double-to-integer
+      (make-primitive-procedure 'cast-ieee754-double-to-integer))
 
-    (define (itof integer-as-bit-string)
-       (cast-integer-to-flonum
-       (bit-string->unsigned-integer integer-as-bit-string)))
+    (define cast-integer-to-ieee754-double
+      (make-primitive-procedure 'cast-integer-to-ieee754-double))
 
-    (define (factorial n)
-      (if (< n 2)
-         1
-         (* n (factorial (- n 1)))))
+    (define (integer-to-double integer-as-bit-string)
+      (cast-integer-to-ieee754-double
+       (bit-string->unsigned-integer integer-as-bit-string)))
 
-    (define (test flonum integer-as-bit-string)
-      (assert-equal
-       (unsigned-integer->bit-string 64 (cast-flonum-to-integer flonum))
-       integer-as-bit-string)
-      (assert-equal
-       flonum
-       (itof integer-as-bit-string)))
+    (define test-double
+      (make-cast-tester cast-ieee754-double-to-integer
+                       integer-to-double
+                       64))
 
-    (test 0.0
+    (test-double 0.0
          #*0000000000000000000000000000000000000000000000000000000000000000)
-    (test -0.0
+    (test-double -0.0
          #*1000000000000000000000000000000000000000000000000000000000000000)
-    (test 1.0
+    (test-double 1.0
          #*0011111111110000000000000000000000000000000000000000000000000000)
-    (test 2.0
+    (test-double 2.0
          #*0100000000000000000000000000000000000000000000000000000000000000)
-    (test 4.0
+    (test-double 4.0
          #*0100000000010000000000000000000000000000000000000000000000000000)
-    (test 8.0
+    (test-double 8.0
          #*0100000000100000000000000000000000000000000000000000000000000000)
-    (test (->flonum (factorial 100))
+    (test-double (->flonum (factorial 100))
          #*0110000010111011001100001001011001001110110000111001010111011100)
-    (test -1.0
+    (test-double -1.0
          #*1011111111110000000000000000000000000000000000000000000000000000)
 
     (assert-true
      (flo:nan?
-      (itof
+      (integer-to-double
        #*0111111111110000000000000000000000000000000000000000000000000001)))
     (assert-true
      (flo:nan?
-      (itof
-       #*0111111111111111111111111111111111111111111111111111111111111111)))))
\ No newline at end of file
+      (integer-to-double
+       #*0111111111111111111111111111111111111111111111111111111111111111)))))
+
+(define-test 'test-casting-singles
+  (lambda ()
+    (define cast-ieee754-single-to-integer
+      (make-primitive-procedure 'cast-ieee754-single-to-integer))
+
+    (define cast-integer-to-ieee754-single
+      (make-primitive-procedure 'cast-integer-to-ieee754-single))
+
+    (define (integer-to-single integer-as-bit-string)
+      (cast-integer-to-ieee754-single
+       (bit-string->unsigned-integer integer-as-bit-string)))
+
+    (define test-single
+      (make-cast-tester cast-ieee754-single-to-integer
+                       integer-to-single
+                       32))
+
+    (test-single 0.0
+         #*00000000000000000000000000000000)
+    (test-single -0.0
+         #*10000000000000000000000000000000)
+    (test-single 1.0
+         #*00111111100000000000000000000000)
+    (test-single 2.0
+         #*01000000000000000000000000000000)
+    (test-single 4.0
+         #*01000000100000000000000000000000)
+    (test-single 8.0
+         #*01000001000000000000000000000000)
+    (test-single (->flonum (factorial 10))
+         #*01001010010111010111110000000000)
+    (test-single -1.0
+         #*10111111100000000000000000000000)
+
+    (assert-true
+     (flo:nan?
+      (integer-to-single
+       #*01111111100000000000000000000001)))
+    (assert-true
+     (flo:nan?
+      (integer-to-single
+       #*01111111111111111111111111111111)))))
\ No newline at end of file