Added primitives `cast-flonum-to-integer' and `cast-integer-to-flonum'

and tests.

diff --git a/src/microcode/flonum.c b/src/microcode/flonum.c
index e191bb492c5527e185bcd2d01180dffc54fe8081..b18726715c5d7dd3a46a5e45ec6c0e7c0aabc39e 100644 (file)
--- 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 43ab5365ff22c6abdb691e4cdf4188d399f33d52..47fa4d19b18c1d330448e69ed8eb7ef5ac895183 100644 (file)
--- 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 (file)
index 0000000..e27e60d
--- /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))
+\f
+(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