From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 27 Sep 2008 03:59:13 +0000 (+0000)
Subject: Implement primitives to control the floating-point rounding mode.
X-Git-Tag: 20090517-FFI~111
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=175d921a2da22ae3e04d5ce03b2e2bce04cd000b;p=mit-scheme.git

Implement primitives to control the floating-point rounding mode.
---

diff --git a/v7/src/microcode/configure.ac b/v7/src/microcode/configure.ac
index 3e09a5dac..a772bcfba 100644
--- a/v7/src/microcode/configure.ac
+++ b/v7/src/microcode/configure.ac
@@ -1,7 +1,7 @@
 dnl Process this file with autoconf to produce a configure script.
 
 AC_INIT([MIT/GNU Scheme microcode], [15.1], [bug-mit-scheme@gnu.org], [mit-scheme])
-AC_REVISION([$Id: configure.ac,v 1.60 2008/01/30 20:02:11 cph Exp $])
+AC_REVISION([$Id: configure.ac,v 1.61 2008/09/27 03:59:05 cph Exp $])
 AC_CONFIG_SRCDIR([boot.c])
 AC_CONFIG_HEADERS([config.h])
 AC_PROG_MAKE_SET
@@ -353,7 +353,7 @@ AC_HEADER_STDC
 AC_HEADER_STDBOOL
 AC_HEADER_SYS_WAIT
 AC_HEADER_TIME
-AC_CHECK_HEADERS([bsdtty.h fcntl.h limits.h malloc.h sgtty.h stropts.h time.h])
+AC_CHECK_HEADERS([bsdtty.h fcntl.h fenv.h limits.h malloc.h sgtty.h stropts.h time.h])
 AC_CHECK_HEADERS([sys/file.h sys/ioctl.h sys/mount.h sys/param.h sys/poll.h])
 AC_CHECK_HEADERS([sys/ptyio.h sys/socket.h sys/time.h sys/un.h sys/vfs.h])
 AC_CHECK_HEADERS([termio.h termios.h unistd.h utime.h])
@@ -621,7 +621,7 @@ AC_FUNC_VPRINTF
 AC_FUNC_WAIT3
 AC_CHECK_FUNCS([ctermid])
 AC_CHECK_FUNCS([dup2])
-AC_CHECK_FUNCS([fcntl floor fpathconf frexp ftruncate])
+AC_CHECK_FUNCS([fcntl fegetround fesetround floor fpathconf frexp ftruncate])
 AC_CHECK_FUNCS([getcwd gethostbyname gethostname getlogin getpagesize getpgrp])
 AC_CHECK_FUNCS([getpt gettimeofday getwd grantpt])
 AC_CHECK_FUNCS([kill])
diff --git a/v7/src/microcode/interp.c b/v7/src/microcode/interp.c
index 78da3b1da..b7df59724 100644
--- a/v7/src/microcode/interp.c
+++ b/v7/src/microcode/interp.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: interp.c,v 9.110 2008/02/14 08:20:22 riastradh Exp $
+$Id: interp.c,v 9.111 2008/09/27 03:59:09 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -36,6 +36,7 @@ USA.
 extern void * obstack_chunk_alloc (size_t);
 #define obstack_chunk_free free
 extern void preserve_signal_mask (void);
+extern void fixup_float_rounding_mode (void);
 
 /* In order to make the interpreter tail recursive (i.e.
  * to avoid calling procedures and thus saving unnecessary
@@ -270,6 +271,7 @@ Interpret (void)
   bind_interpreter_state (&new_state);
   dispatch_code = (setjmp (interpreter_catch_env));
   preserve_signal_mask ();
+  fixup_float_rounding_mode ();
 
   switch (dispatch_code)
     {
diff --git a/v7/src/microcode/sysprim.c b/v7/src/microcode/sysprim.c
index 2bd239907..13d3cc137 100644
--- a/v7/src/microcode/sysprim.c
+++ b/v7/src/microcode/sysprim.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: sysprim.c,v 9.56 2008/01/30 20:02:21 cph Exp $
+$Id: sysprim.c,v 9.57 2008/09/27 03:59:13 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -33,6 +33,10 @@ USA.
 #include "ostty.h"
 #include "ostop.h"
 
+#ifdef HAVE_FENV_H
+#  include <fenv.h>
+#endif
+
 extern long OS_set_trap_state (long);
 extern double arg_flonum (int);
 
@@ -194,3 +198,108 @@ Write FLOAT to memory at ADDRESS.")
    (* ((double *) (arg_ulong_integer (2)))) = (arg_flonum (1));
   PRIMITIVE_RETURN (UNSPECIFIC);
 }
+
+#pragma STDC FENV_ACCESS on
+
+enum { FRMODE_NEAREST, FRMODE_TOWARD_ZERO, FRMODE_DOWNWARD, FRMODE_UPWARD };
+
+DEFINE_PRIMITIVE ("FLOAT-ROUNDING-MODES", Prim_float_rounding_modes, 0, 0, 0)
+{
+  unsigned int modes = 0;
+  PRIMITIVE_HEADER (0);
+#ifdef HAVE_FEGETROUND
+#  ifdef FE_TONEAREST
+  modes |= (1 << FRMODE_NEAREST);
+#  endif
+#  ifdef FE_TOWARDZERO
+  modes |= (1 << FRMODE_TOWARD_ZERO);
+#  endif
+#  ifdef FE_DOWNWARD
+  modes |= (1 << FRMODE_DOWNWARD);
+#  endif
+#  ifdef FE_UPWARD
+  modes |= (1 << FRMODE_UPWARD);
+#  endif
+#endif
+  PRIMITIVE_RETURN (ulong_to_integer (modes));
+}
+
+DEFINE_PRIMITIVE ("GET-FLOAT-ROUNDING-MODE", Prim_get_float_rounding_mode, 0, 0, 0)
+{
+  int mode;
+  PRIMITIVE_HEADER (0);
+#ifdef HAVE_FEGETROUND
+  mode = (fegetround ());
+  if (mode < 0)
+    error_external_return ();
+  switch (mode)
+    {
+#ifdef FE_TONEAREST
+    case FE_TONEAREST: PRIMITIVE_RETURN (ulong_to_integer (FRMODE_NEAREST));
+#endif
+#ifdef FE_TOWARDZERO
+    case FE_TOWARDZERO: PRIMITIVE_RETURN (ulong_to_integer (FRMODE_TOWARD_ZERO));
+#endif
+#ifdef FE_DOWNWARD
+    case FE_DOWNWARD: PRIMITIVE_RETURN (ulong_to_integer (FRMODE_DOWNWARD));
+#endif
+#ifdef FE_UPWARD
+    case FE_UPWARD: PRIMITIVE_RETURN (ulong_to_integer (FRMODE_UPWARD));
+#endif
+    default: PRIMITIVE_RETURN (SHARP_F);
+    }
+#else
+  error_unimplemented_primitive ();
+  PRIMITIVE_RETURN (UNSPECIFIC);
+#endif
+}
+
+static int float_rounding_mode = (-1);
+
+DEFINE_PRIMITIVE ("SET-FLOAT-ROUNDING-MODE", Prim_set_float_rounding_mode, 1, 1, 0)
+{
+  int mode = (-1);
+  PRIMITIVE_HEADER (1);
+#ifdef HAVE_FESETROUND
+  switch (arg_ulong_integer (1))
+    {
+#ifdef FE_TONEAREST
+    case FRMODE_NEAREST: mode = FE_TONEAREST; break;
+#endif
+#ifdef FE_TOWARDZERO
+    case FRMODE_TOWARD_ZERO: mode = FE_TOWARDZERO; break;
+#endif
+#ifdef FE_DOWNWARD
+    case FRMODE_DOWNWARD: mode = FE_DOWNWARD; break;
+#endif
+#ifdef FE_UPWARD
+    case FRMODE_UPWARD: mode = FE_UPWARD; break;
+#endif
+    default: error_bad_range_arg (1); break;
+    }
+  if ((fesetround (mode)) == 0)
+    {
+      float_rounding_mode = mode;
+      PRIMITIVE_RETURN (SHARP_T);
+    }
+  else
+    {
+      float_rounding_mode = (-1);
+      PRIMITIVE_RETURN (SHARP_F);
+    }
+#else
+  error_unimplemented_primitive ();
+  PRIMITIVE_RETURN (UNSPECIFIC);
+#endif
+}
+
+/* This kludge is to work around the fact that setjmp saves the
+    floating-point rounding mode and longjmp restores it.  */
+void
+fixup_float_rounding_mode (void)
+{
+#ifdef HAVE_FESETROUND
+  if (float_rounding_mode >= 0)
+    fesetround (float_rounding_mode);
+#endif
+}