Fluidize flonum-unparser-cutoff.

diff --git a/doc/ref-manual/numbers.texi b/doc/ref-manual/numbers.texi
index 865f86784b96034fef42238d4587b7a3db7f5bc3..72b047c1ba39dc94d9ea0296645c14d0a534551b 100644 (file)
--- a/doc/ref-manual/numbers.texi
+++ b/doc/ref-manual/numbers.texi
@@ -934,9 +934,9 @@ the result, and consequently can be tolerated by many applications.
 @end defvr
 
 @defvr variable flonum-unparser-cutoff
-This variable controls the action of @code{number->string} when
+This fluid controls the action of @code{number->string} when
 @var{number} is a flonum (and consequently controls all printing of
-flonums).  The value of this variable is normally a list of three items:
+flonums).  The value of this fluid is normally a list of three items:
 
 @table @var
 @item rounding-type
@@ -995,38 +995,49 @@ Some examples of @code{flonum-unparser-cutoff}:
 @example
 (number->string (* 4 (atan 1 1)))
                                     @result{} "3.141592653589793"
-(fluid-let ((flonum-unparser-cutoff '(relative 5)))
-  (number->string (* 4 (atan 1 1))))
+(let-fluid flonum-unparser-cutoff '(relative 5)
+  (lambda ()
+    (number->string (* 4 (atan 1 1)))))
                                     @result{} "3.1416"
-(fluid-let ((flonum-unparser-cutoff '(relative 5)))
-  (number->string (* 4000 (atan 1 1))))
+(let-fluid flonum-unparser-cutoff '(relative 5)
+  (lambda ()
+    (number->string (* 4000 (atan 1 1)))))
                                     @result{} "3141.6"
-(fluid-let ((flonum-unparser-cutoff '(relative 5 scientific)))
-  (number->string (* 4000 (atan 1 1))))
+(let-fluid flonum-unparser-cutoff '(relative 5 scientific)
+  (lambda ()
+    (number->string (* 4000 (atan 1 1)))))
                                     @result{} "3.1416e3"
-(fluid-let ((flonum-unparser-cutoff '(relative 5 scientific)))
-  (number->string (* 40000 (atan 1 1))))
+(let-fluid flonum-unparser-cutoff '(relative 5 scientific)
+  (lambda ()
+    (number->string (* 40000 (atan 1 1)))))
                                     @result{} "3.1416e4"
-(fluid-let ((flonum-unparser-cutoff '(relative 5 engineering)))
-  (number->string (* 40000 (atan 1 1))))
+(let-fluid flonum-unparser-cutoff '(relative 5 engineering)
+  (lambda ()
+    (number->string (* 40000 (atan 1 1)))))
                                     @result{} "31.416e3"
-(fluid-let ((flonum-unparser-cutoff '(absolute 5)))
-  (number->string (* 4 (atan 1 1))))
+(let-fluid flonum-unparser-cutoff '(absolute 5)
+  (lambda ()
+    (number->string (* 4 (atan 1 1)))))
                                     @result{} "3.14159"
-(fluid-let ((flonum-unparser-cutoff '(absolute 5)))
-  (number->string (* 4000 (atan 1 1))))
+(let-fluid flonum-unparser-cutoff '(absolute 5)
+  (lambda ()
+    (number->string (* 4000 (atan 1 1)))))
                                     @result{} "3141.59265"
-(fluid-let ((flonum-unparser-cutoff '(absolute -4)))
-  (number->string (* 4e10 (atan 1 1))))
+(let-fluid flonum-unparser-cutoff '(absolute -4)
+  (lambda ()
+    (number->string (* 4e10 (atan 1 1)))))
                                     @result{} "31415930000."
-(fluid-let ((flonum-unparser-cutoff '(absolute -4 scientific)))
-  (number->string (* 4e10 (atan 1 1))))
+(let-fluid flonum-unparser-cutoff '(absolute -4 scientific)
+  (lambda ()
+    (number->string (* 4e10 (atan 1 1)))))
                                     @result{} "3.141593e10"
-(fluid-let ((flonum-unparser-cutoff '(absolute -4 engineering)))
-  (number->string (* 4e10 (atan 1 1))))
+(let-fluid flonum-unparser-cutoff '(absolute -4 engineering)
+  (lambda ()
+    (number->string (* 4e10 (atan 1 1)))))
                                     @result{} "31.41593e9"
-(fluid-let ((flonum-unparser-cutoff '(absolute -5)))
-  (number->string (* 4e10 (atan 1 1))))
+(let-fluid flonum-unparser-cutoff '(absolute -5)
+  (lambda ()
+    (number->string (* 4e10 (atan 1 1)))))
                                     @result{} "31415900000."
 @end example
 

diff --git a/src/imail/imail-util.scm b/src/imail/imail-util.scm
index 90ad99b27af557ee0fd3efe32f8c8801ee1d430e..8e51cd8055f7d558db7b714cc3a245b9e1a297f9 100644 (file)
--- a/src/imail/imail-util.scm
+++ b/src/imail/imail-util.scm
@@ -249,8 +249,9 @@ USA.
   (if (< n (expt 10 (- k 1)))
       (string-append (string-pad-left (number->string n) (- k 1)) " ")
       (let ((s
-            (fluid-let ((flonum-unparser-cutoff `(RELATIVE ,k ENGINEERING)))
-              (number->string (exact->inexact n)))))
+            (let-fluid flonum-unparser-cutoff `(RELATIVE ,k ENGINEERING)
+              (lambda ()
+                (number->string (exact->inexact n))))))
        (let ((regs (re-string-match "\\([0-9.]+\\)e\\([0-9]+\\)" s)))
          (let ((mantissa (re-match-extract s regs 1))
                (exponent (string->number (re-match-extract s regs 2))))

diff --git a/src/runtime/dragon4.scm b/src/runtime/dragon4.scm
index dbbe751dea9be7855205ff8c7dca881af73a0c80..6d1b46e7e0aa5e00db307014670afb7347eec290 100644 (file)
--- a/src/runtime/dragon4.scm
+++ b/src/runtime/dragon4.scm
@@ -127,33 +127,34 @@ not much different to numbers within a few orders of magnitude of 1.
                          exponent)))))
 \f
 (define (flonum-unparser-cutoff-args)
-  (cond ((eq? 'NORMAL flonum-unparser-cutoff)
-        (values 'NORMAL 0 flonum-unparser:normal-output))
-       ((and (pair? flonum-unparser-cutoff)
-             (pair? (cdr flonum-unparser-cutoff))
-             (let ((mode (car flonum-unparser-cutoff))
-                   (place (cadr flonum-unparser-cutoff)))
-               (and (memq mode '(ABSOLUTE RELATIVE NORMAL))
-                    (exact-integer? place)
-                    (or (not (eq? 'RELATIVE mode))
-                        (positive? place))))
-             (or (null? (cddr flonum-unparser-cutoff))
-                 (and (pair? (cddr flonum-unparser-cutoff))
-                      (null? (cdddr flonum-unparser-cutoff))
-                      (let ((mode (caddr flonum-unparser-cutoff)))
-                        (or (memq mode '(NORMAL SCIENTIFIC ENGINEERING))
-                            (and (procedure? mode)
-                                 (procedure-arity-valid? mode 3)))))))
-        (values (car flonum-unparser-cutoff)
-                (- (cadr flonum-unparser-cutoff))
-                (if (null? (cddr flonum-unparser-cutoff))
-                    flonum-unparser:normal-output
-                    (lookup-symbolic-display-mode
-                     (caddr flonum-unparser-cutoff)))))
-       (else
-        (warn "illegal flonum unparser cutoff parameter"
-              flonum-unparser-cutoff)
-        (values 'NORMAL 0 flonum-unparser:normal-output))))
+  (let ((cutoff (fluid flonum-unparser-cutoff)))
+    (cond ((eq? 'NORMAL cutoff)
+          (values 'NORMAL 0 flonum-unparser:normal-output))
+         ((and (pair? cutoff)
+               (pair? (cdr cutoff))
+               (let ((mode (car cutoff))
+                     (place (cadr cutoff)))
+                 (and (memq mode '(ABSOLUTE RELATIVE NORMAL))
+                      (exact-integer? place)
+                      (or (not (eq? 'RELATIVE mode))
+                          (positive? place))))
+               (or (null? (cddr cutoff))
+                   (and (pair? (cddr cutoff))
+                        (null? (cdddr cutoff))
+                        (let ((mode (caddr cutoff)))
+                          (or (memq mode '(NORMAL SCIENTIFIC ENGINEERING))
+                              (and (procedure? mode)
+                                   (procedure-arity-valid? mode 3)))))))
+          (values (car cutoff)
+                  (- (cadr cutoff))
+                  (if (null? (cddr cutoff))
+                      flonum-unparser:normal-output
+                      (lookup-symbolic-display-mode
+                       (caddr cutoff)))))
+         (else
+          (warn "illegal flonum unparser cutoff parameter"
+                cutoff)
+          (values 'NORMAL 0 flonum-unparser:normal-output)))))
 
 (define (lookup-symbolic-display-mode mode)
   (case mode
@@ -163,7 +164,7 @@ not much different to numbers within a few orders of magnitude of 1.
     (else mode)))
 
 (define flonum-unparser-hook #f)
-(define flonum-unparser-cutoff 'NORMAL)
+(define flonum-unparser-cutoff)
 
 (define (dragon4-normalize x precision)
   (call-with-values (lambda () (flo:normalize x))
@@ -278,6 +279,7 @@ not much different to numbers within a few orders of magnitude of 1.
 (define expt-radix)
 
 (define (initialize-dragon4!)
+  (set! flonum-unparser-cutoff (make-fluid 'NORMAL))
   (set! expt-radix
        (let ((v (make-initialized-vector 310 (lambda (i) (expt 10 i)))))
          (lambda (base exponent)
@@ -292,8 +294,9 @@ not much different to numbers within a few orders of magnitude of 1.
 
 (define (test)
   (define (try n settings . expecteds)
-    (let ((got (fluid-let ((flonum-unparser-cutoff settings))
-                (number->string (exact->inexact n)))))
+    (let ((got (let-fluid flonum-unparser-cutoff settings
+                (lambda ()
+                  (number->string (exact->inexact n))))))
       (if (member got expecteds)
          (set! successes (+ successes 1))
          (begin

diff --git a/src/sos/microbench.scm b/src/sos/microbench.scm
index 10476a7d799de1e347abf5df0f6652e571fa273d..9e4559a971109df496badd3278284bbe54aca97b 100644 (file)
--- a/src/sos/microbench.scm
+++ b/src/sos/microbench.scm
@@ -262,13 +262,14 @@ USA.
   (let ((f1-time (run-test f1-test)))
     (let ((report
           (lambda (name time scale)
-            (fluid-let ((flonum-unparser-cutoff '(ABSOLUTE 2)))
-              (newline)
-              (write name)
-              (write-string "-test:\t")
-              (write (exact->inexact time))
-              (write-string "\t")
-              (write (exact->inexact (/ (/ time scale) f1-time)))))))
+            (let-fluid flonum-unparser-cutoff '(ABSOLUTE 2)
+              (lambda ()
+                (newline)
+                (write name)
+                (write-string "-test:\t")
+                (write (exact->inexact time))
+                (write-string "\t")
+                (write (exact->inexact (/ (/ time scale) f1-time))))))))
       (report 'f1 f1-time 1)
       (for-each (lambda (name test scale)
                  (report name (run-test test) scale))