From: Arthur A. Gleckler <gnu@speechcode.com>
Date: Thu, 2 Sep 2010 05:23:39 +0000 (-0700)
Subject: * Renamed `cast-flonum-to-integer' to `cast-ieee754-double-to-integer'.
X-Git-Tag: 20101212-Gtk~71
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2b01d17888b36961f2c237766750c22930d45129;p=mit-scheme.git

* 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 b18726715..c72252af9 100644
--- 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))));
 }
-
+
+/* 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 48b7a6418..31e7162b7 100644
--- a/tests/microcode/test-flonum-casts.scm
+++ b/tests/microcode/test-flonum-casts.scm
@@ -27,54 +27,103 @@ USA.
 
 (declare (usual-integrations))
 
-(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