From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Fri, 12 Jan 2018 08:51:49 +0000 (-0700)
Subject: ffi: Re-alienate the floenv after Scheme is re-entered.
X-Git-Tag: mit-scheme-pucked-9.2.12~2
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7d3765a319a2edeb8f55ae5517e11862fb623ae1;p=mit-scheme.git

ffi: Re-alienate the floenv after Scheme is re-entered.

Also, preserve the floenv around callouts, and set it to the default
for callbacks (as for interrupts).  And clean up some trailing
whitespace.
---

diff --git a/src/microcode/pruxffi.c b/src/microcode/pruxffi.c
index 566e07175..d14a06dfc 100644
--- a/src/microcode/pruxffi.c
+++ b/src/microcode/pruxffi.c
@@ -719,6 +719,7 @@ callback_run_kernel (long callback_id, CallbackKernel kernel)
   SET_LEXPR_ACTUALS (nargs);
 
   cstack_depth -= 1;
+  alienate_float_environment ();
 }
 
 DEFINE_PRIMITIVE ("RUN-CALLBACK", Prim_run_callback, 0, 0, 0)
@@ -726,7 +727,7 @@ DEFINE_PRIMITIVE ("RUN-CALLBACK", Prim_run_callback, 0, 0, 0)
   /* All the smarts are in the kernel. */
 
   PRIMITIVE_HEADER (0);
-  { 
+  {
     char * tos;
     CallbackKernel kernel;
     int depth;
@@ -1098,7 +1099,7 @@ DEFINE_PRIMITIVE ("OUTF-ERROR", Prim_outf_error, 1, 1, 0)
   /* To avoid the normal IO system when debugging a callback. */
 
   PRIMITIVE_HEADER (1);
-  { 
+  {
     SCM arg = ARG_REF (1);
     if (STRING_P (arg))
       {
diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm
index fe2707ebc..64f6cf172 100644
--- a/src/runtime/ffi.scm
+++ b/src/runtime/ffi.scm
@@ -228,7 +228,7 @@ USA.
 (define-integrable alien-function/filename %alien-function/filename)
 
 (define-integrable (alien-function/name alienf)
-  (string-tail (%alien-function/name alienf) 4)) 
+  (string-tail (%alien-function/name alienf) 4))
 
 (define (%set-alien-function/address! alienf address)
   (let ((qr (integer-divide address %radix)))
@@ -370,7 +370,9 @@ USA.
    (lambda ()
      (without-interrupts
       (lambda ()
-	(call-alien* alien-function args))))))
+	(flo:preserving-environment
+	 (lambda ()
+	   (call-alien* alien-function args))))))))
 
 #;(define-integrable (call-alien* alien-function args)
   (apply (ucode-primitive c-call -1) alien-function args))
@@ -527,13 +529,15 @@ USA.
   ;; by a callback trampoline.  The callout should have already masked
   ;; all but the GC interrupts.
 
-  (if (not (< id (vector-length registered-callbacks)))
-      (error:bad-range-argument id 'apply-callback))
-  (let ((procedure (vector-ref registered-callbacks id)))
-    (if (not procedure)
-	(error:bad-range-argument id 'apply-callback))
-    (normalize-aliens! args)
-    (callback-handler* procedure args)))
+  (flo:with-default-environment
+   (lambda ()
+     (if (not (< id (vector-length registered-callbacks)))
+	 (error:bad-range-argument id 'apply-callback))
+     (let ((procedure (vector-ref registered-callbacks id)))
+       (if (not procedure)
+	   (error:bad-range-argument id 'apply-callback))
+       (normalize-aliens! args)
+       (callback-handler* procedure args)))))
 
 #;(define-integrable (callback-handler* procedure args)
   (apply-callback-proc procedure args))