From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 24 Sep 1989 13:50:26 +0000 (+0000)
Subject: Add primitives to normalize flonums, and to produce the key flonum
X-Git-Tag: 20090517-FFI~11777
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=62be448859f66e275928251d20bab7c8c47387cc;p=mit-scheme.git

Add primitives to normalize flonums, and to produce the key flonum
parameters: number of bits in significand, and smallest number which
can be added to one and still produce different result.
---

diff --git a/v7/src/microcode/artutl.c b/v7/src/microcode/artutl.c
index a12b6ec35..6d32ccb7c 100644
--- a/v7/src/microcode/artutl.c
+++ b/v7/src/microcode/artutl.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/artutl.c,v 1.1 1989/09/20 23:19:25 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/artutl.c,v 1.2 1989/09/24 13:49:38 cph Exp $
 
 Copyright (c) 1989 Massachusetts Institute of Technology
 
@@ -155,6 +155,7 @@ Boolean
 flonum_integer_p (x)
      SCHEME_OBJECT x;
 {
+  extern double modf ();
   double iptr;
   return ((modf ((FLONUM_TO_DOUBLE (x)), (&iptr))) == 0);
 }
@@ -163,6 +164,7 @@ SCHEME_OBJECT
 flonum_floor (x)
      SCHEME_OBJECT x;
 {
+  extern double floor ();
   return (double_to_flonum (floor (FLONUM_TO_DOUBLE (x))));
 }
 
@@ -170,6 +172,7 @@ SCHEME_OBJECT
 flonum_ceiling (x)
      SCHEME_OBJECT x;
 {
+  extern double ceil ();
   return (double_to_flonum (ceil (FLONUM_TO_DOUBLE (x))));
 }
 
@@ -181,6 +184,17 @@ flonum_round (x)
   return
     (double_to_flonum (double_truncate ((dx < 0) ? (dx - 0.5) : (dx + 0.5))));
 }
+
+SCHEME_OBJECT
+flonum_normalize (x)
+     SCHEME_OBJECT x;
+{
+  extern double frexp ();
+  int exponent;
+  double significand = (frexp ((FLONUM_TO_DOUBLE (x)), (&exponent)));
+  return (cons ((double_to_flonum (significand)),
+		(double_to_flonum ((double) exponent))));
+}
 
 /* Generic Integer Operations */
 
diff --git a/v7/src/microcode/extern.h b/v7/src/microcode/extern.h
index 31d10e407..2a86b0019 100644
--- a/v7/src/microcode/extern.h
+++ b/v7/src/microcode/extern.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/extern.h,v 9.33 1989/09/20 23:07:50 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/extern.h,v 9.34 1989/09/24 13:49:05 cph Exp $
 
 Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
 
@@ -172,6 +172,7 @@ extern SCHEME_OBJECT bignum_to_flonum ();
 extern SCHEME_OBJECT flonum_floor ();
 extern SCHEME_OBJECT flonum_ceiling ();
 extern SCHEME_OBJECT flonum_round ();
+extern SCHEME_OBJECT flonum_normalize ();
 extern Boolean integer_zero_p ();
 extern Boolean integer_negative_p ();
 extern Boolean integer_positive_p ();
diff --git a/v7/src/microcode/flonum.c b/v7/src/microcode/flonum.c
index e899b3d3e..7163cb883 100644
--- a/v7/src/microcode/flonum.c
+++ b/v7/src/microcode/flonum.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/flonum.c,v 9.27 1989/09/20 23:08:30 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/flonum.c,v 9.28 1989/09/24 13:49:21 cph Exp $
 
 Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
 
@@ -253,3 +253,27 @@ DEFINE_PRIMITIVE ("FLONUM-CEILING->EXACT", Prim_flonum_ceiling_to_exact, 1, 1, 0
      FLONUM_EXACT_CONVERSION (flonum_ceiling)
 DEFINE_PRIMITIVE ("FLONUM-ROUND->EXACT", Prim_flonum_round_to_exact, 1, 1, 0)
      FLONUM_EXACT_CONVERSION (flonum_round)
+
+DEFINE_PRIMITIVE ("FLONUM-NORMALIZE", Prim_flonum_normalize, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  Set_Time_Zone (Zone_Math);
+  CHECK_ARG (1, FLONUM_P);
+  PRIMITIVE_RETURN (flonum_normalize (ARG_REF (1))); 
+}
+
+#include "float.h"
+#if (FLT_RADIX != 2)
+#include "error: floating point radix not 2!  Arithmetic won't work."
+#endif
+
+#define FLONUM_CONSTANT(expression)					\
+{									\
+  PRIMITIVE_HEADER (0);							\
+  PRIMITIVE_RETURN (expression);					\
+}
+
+DEFINE_PRIMITIVE ("FLONUM-MANTISSA-DIGITS", Prim_flonum_mantissa_digits, 0, 0, 0)
+     FLONUM_CONSTANT (long_to_integer (DBL_MANT_DIG))
+DEFINE_PRIMITIVE ("FLONUM-EPSILON", Prim_flonum_epsilon, 0, 0, 0)
+     FLONUM_CONSTANT (double_to_flonum ((double) DBL_EPSILON))
diff --git a/v7/src/microcode/unxutl/ymkfile b/v7/src/microcode/unxutl/ymkfile
index 36b3ef65d..24700e93d 100644
--- a/v7/src/microcode/unxutl/ymkfile
+++ b/v7/src/microcode/unxutl/ymkfile
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/unxutl/Attic/ymkfile,v 1.11 1989/09/22 08:47:32 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/unxutl/Attic/ymkfile,v 1.12 1989/09/24 13:50:26 cph Exp $
 
 Copyright (c) 1989 Massachusetts Institute of Technology
 
@@ -468,7 +468,8 @@ memmag.o gcloop.o purify.o purutl.o comutl.o : scheme.touch prims.h \
 
 artutl.o : scheme.touch
 bignum.o : scheme.touch bignumint.h
-bigprm.o flonum.o intprm.o generic.o : scheme.touch prims.h zones.h
+bigprm.o intprm.o generic.o : scheme.touch prims.h zones.h
+flonum.o : scheme.touch prims.h zones.h float.h
 
 storage.o : scheme.touch gctype.c
 
diff --git a/v7/src/microcode/version.h b/v7/src/microcode/version.h
index adec58430..eb72e3e04 100644
--- a/v7/src/microcode/version.h
+++ b/v7/src/microcode/version.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 11.1 1989/09/20 23:03:51 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 11.2 1989/09/24 13:50:06 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -46,7 +46,7 @@ MIT in each case. */
 #define VERSION		11
 #endif
 #ifndef SUBVERSION
-#define SUBVERSION	1
+#define SUBVERSION	2
 #endif
 
 #ifndef UCODE_TABLES_FILENAME
diff --git a/v8/src/microcode/version.h b/v8/src/microcode/version.h
index 1ec393049..61ff454b9 100644
--- a/v8/src/microcode/version.h
+++ b/v8/src/microcode/version.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 11.1 1989/09/20 23:03:51 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 11.2 1989/09/24 13:50:06 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -46,7 +46,7 @@ MIT in each case. */
 #define VERSION		11
 #endif
 #ifndef SUBVERSION
-#define SUBVERSION	1
+#define SUBVERSION	2
 #endif
 
 #ifndef UCODE_TABLES_FILENAME