From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Thu, 2 Jun 2011 03:54:13 +0000 (-0700)
Subject: Alienate the floenv (make it FE_DFL_ENV) outside Scheme.
X-Git-Tag: 20110609-Gtk~8
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0d4959eb6a58c9d1e7c730f577e4a630d46ab5eb;p=mit-scheme.git

Alienate the floenv (make it FE_DFL_ENV) outside Scheme.
---

diff --git a/src/gtk/gtkio.c.stay b/src/gtk/gtkio.c.stay
index 259c06cbf..fe816319c 100644
--- a/src/gtk/gtkio.c.stay
+++ b/src/gtk/gtkio.c.stay
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-Copyright (C) 2008, 2009, 2010  Matthew Birkholz
+Copyright (C) 2008, 2009, 2010, 2011  Matthew Birkholz
 
 This file is part of MIT/GNU Scheme.
 
@@ -27,11 +27,13 @@ USA.
 #include "osenv.h"
 #include "osproc.h"
 #include "osscheme.h"
+#define MIT_SCHEME     /* Avoid re-declaring things included above. */
+#include "pruxffi.h"
 #include <glib.h>
 #include <gtk/gtk.h>
 
 extern void Interpret (int pop_return_p);
-extern void abort_to_c (void);
+extern void alienate_float_environment (void);
 
 struct _SchemeSource
 {
@@ -207,7 +209,10 @@ scheme_source_dispatch (GSource * source,
 		    slice_counter);
       outf_flush_console ();
     }
+
   Interpret (1);
+  alienate_float_environment ();
+
   if (tracing_gtk_select)
     {
       outf_console (";scheme_source_dispatch: finished time slice %d\n",
diff --git a/src/microcode/pruxffi.c b/src/microcode/pruxffi.c
index 61f201759..fe3bf1c1a 100644
--- a/src/microcode/pruxffi.c
+++ b/src/microcode/pruxffi.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-Copyright (C) 2006, 2007, 2008, 2009, 2010 Matthew Birkholz
+Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Matthew Birkholz
 
 This file is part of MIT/GNU Scheme.
 
@@ -27,6 +27,7 @@ USA.
 #include "prims.h"
 #include "bignmint.h"
 #include "history.h"
+#include "floenv.h"
 #include "pruxffi.h"
 /* Using SCM instead of SCHEME_OBJECT here, hoping to ensure that
    these types always match. */
@@ -366,6 +367,46 @@ DEFINE_PRIMITIVE ("C-CALL", Prim_c_call, 1, LEXPR, 0)
   }
 }
 
+void
+alienate_float_environment (void)
+{
+  int s;
+
+#ifdef FE_DFL_ENV
+  s = fesetenv (FE_DFL_ENV);
+  if (s != 0)
+    {
+      outf_error ("Error status from fesetenv: %d\n", s);
+      outf_flush_error ();
+    }
+#else
+# ifdef HAVE_FECLEAREXCEPT
+#  ifdef HAVE_FEDISABLEEXCEPT
+#   ifdef HAVE_FESETROUND
+  s = feclearexcept (FE_ALL_EXCEPT);
+  if (s == -1)
+    {
+      outf_error ("Error status from feclearexcept: %d\n", s);
+      outf_flush_error ();
+    }
+  s = fedisableexcept (FE_ALL_EXCEPT);
+  if (s == -1)
+    {
+      outf_error ("Error status from fedisableexcept: %d\n", s);
+      outf_flush_error ();
+    }
+  s = fesetround (FE_TONEAREST);
+  if (s != 0)
+    {
+      outf_error ("Error status from fesetround: %d\n", s);
+      outf_flush_error ();
+    }
+#   endif
+#  endif
+# endif
+#endif
+}
+
 static SCM c_call_continue = SHARP_F;
 
 void
@@ -397,7 +438,7 @@ callout_seal (CalloutTrampIn tramp)
   /* Back out of C-CALL-CONTINUE. */
   SET_PRIMITIVE (c_call_continue);
   back_out_of_primitive ();
-  /* Ready for Interpret(1). */
+  alienate_float_environment ();
 }
 
 void
@@ -543,6 +584,7 @@ callback_run_kernel (long callback_id, CallbackKernel kernel)
   PUSH_APPLY_FRAME_HEADER (0);
   SAVE_CONT();
   Interpret (1);
+  alienate_float_environment ();
   cstack_depth -= 1;
 }