From 74fdb4a9c030a4c1fe2f489663434a6e5cbbcfbb Mon Sep 17 00:00:00 2001
From: "Arthur A. Gleckler" <gnu@speechcode.com>
Date: Tue, 31 Aug 2010 21:16:03 -0700
Subject: [PATCH] Added primitives `cast-flonum-to-integer' and
 `cast-integer-to-flonum' and tests.

---
 src/microcode/flonum.c                | 31 ++++++++++
 src/runtime/runtime.pkg               |  1 +
 tests/microcode/test-flonum-casts.scm | 84 +++++++++++++++++++++++++++
 3 files changed, 116 insertions(+)
 create mode 100644 tests/microcode/test-flonum-casts.scm

diff --git a/src/microcode/flonum.c b/src/microcode/flonum.c
index e191bb492..b18726715 100644
--- a/src/microcode/flonum.c
+++ b/src/microcode/flonum.c
@@ -260,3 +260,34 @@ 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))));
 }
+
+typedef
+union
+{
+  double dbl;
+  unsigned long ul;
+} double_unsigned_long_cast;
+
+DEFINE_PRIMITIVE ("CAST-FLONUM-TO-INTEGER", Prim_cast_flonum_to_integer, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  CHECK_ARG (1, FLONUM_P);
+
+  double_unsigned_long_cast cast;
+
+  cast.dbl = FLONUM_TO_DOUBLE (ARG_REF (1));
+
+  PRIMITIVE_RETURN (ulong_to_integer (cast.ul));
+}
+
+DEFINE_PRIMITIVE ("CAST-INTEGER-TO-FLONUM", Prim_cast_integer_to_flonum, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  CHECK_ARG (1, INTEGER_P);
+
+  double_unsigned_long_cast cast;
+
+  cast.ul = integer_to_long (ARG_REF (1));
+
+  PRIMITIVE_RETURN (double_to_flonum (cast.dbl));
+}
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 43ab5365f..47fa4d19b 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2770,6 +2770,7 @@ USA.
 	  error:not-real
 	  exact-nonnegative-integer?
 	  exact-positive-integer?
+	  flo:nan?
 	  flo:significand-digits-base-10
 	  flo:significand-digits-base-2
 	  flonum-unparser-cutoff
diff --git a/tests/microcode/test-flonum-casts.scm b/tests/microcode/test-flonum-casts.scm
new file mode 100644
index 000000000..e27e60d16
--- /dev/null
+++ b/tests/microcode/test-flonum-casts.scm
@@ -0,0 +1,84 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Tests of flonum casting
+
+(declare (usual-integrations))
+
+(define-test 'test-casting
+  (lambda ()
+
+    (define cast-flonum-to-integer
+      (make-primitive-procedure 'cast-flonum-to-integer))
+
+    (define cast-integer-to-flonum
+      (make-primitive-procedure 'cast-integer-to-flonum))
+
+    (define (itof integer-as-bit-string)
+       (cast-integer-to-flonum
+	(bit-string->unsigned-integer integer-as-bit-string)))
+
+    (define (factorial n)
+      (if (< n 2)
+	  1
+	  (* n (factorial (- n 1)))))
+
+    (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)))
+
+    (test (/ 1.0 0.0)
+	  #*0111111111110000000000000000000000000000000000000000000000000000)
+    (test (/ -1.0 0.0)
+	  #*1111111111110000000000000000000000000000000000000000000000000000)
+    (test 0.0
+	  #*0000000000000000000000000000000000000000000000000000000000000000)
+    (test -0.0
+	  #*1000000000000000000000000000000000000000000000000000000000000000)
+    (test 1.0
+	  #*0011111111110000000000000000000000000000000000000000000000000000)
+    (test 2.0
+	  #*0100000000000000000000000000000000000000000000000000000000000000)
+    (test 4.0
+	  #*0100000000010000000000000000000000000000000000000000000000000000)
+    (test 8.0
+	  #*0100000000100000000000000000000000000000000000000000000000000000)
+    (test (->flonum (factorial 100))
+	  #*0110000010111011001100001001011001001110110000111001010111011100)
+    (test -1.0
+	  #*1011111111110000000000000000000000000000000000000000000000000000)
+
+    (assert-true
+     (flo:nan?
+      (itof
+       #*0111111111110000000000000000000000000000000000000000000000000001)))
+    (assert-true
+     (flo:nan?
+      (itof
+       #*0111111111111111111111111111111111111111111111111111111111111111)))))
\ No newline at end of file
-- 
2.25.1