Provide the ability for a user to specify how the digits generated by

the flonum printer are converted into a string.

diff --git a/v7/src/runtime/dragon4.scm b/v7/src/runtime/dragon4.scm
index 47d8a2dc53ba0617dac653499e88bd496ce2667a..e68015e0ceb2837afaf475fa2bd960897fb7720c 100644 (file)
--- a/v7/src/runtime/dragon4.scm
+++ b/v7/src/runtime/dragon4.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: dragon4.scm,v 1.11 1997/07/26 07:14:37 cph Exp $
+$Id: dragon4.scm,v 1.12 1997/07/26 07:39:07 cph Exp $
 
 Copyright (c) 1989-97 Massachusetts Institute of Technology
 
@@ -63,7 +63,7 @@ not much different to numbers within a few orders of magnitude of 1.
             (call-with-values (lambda () (dragon4-normalize x p))
               (lambda (f e)
                 (call-with-values flonum-unparser-cutoff-args
-                  (lambda (cutoff-mode cutoff display-mode)
+                  (lambda (cutoff-mode cutoff display-procedure)
                     (dragon4 f e p radix cutoff-mode cutoff
                       (lambda (u k generate)
                         (let ((digits
@@ -74,13 +74,7 @@ not much different to numbers within a few orders of magnitude of 1.
                                       '()
                                       (cons (digit->char u radix)
                                             (generate loop)))))))
-                          (case display-mode
-                            ((ENGINEERING)
-                             (scientific-output digits k radix (modulo k 3)))
-                            ((SCIENTIFIC)
-                             (scientific-output digits k radix 0))
-                            (else
-                             (normal-output digits k radix))))))))))))))
+                          (display-procedure digits k radix))))))))))))
     (or (and flonum-unparser-hook
             (flonum-unparser-hook x radix))
        (cond ((flo:positive? x)
@@ -97,7 +91,7 @@ not much different to numbers within a few orders of magnitude of 1.
              (else
               (string-copy "#[NaN]"))))))
 
-(define (normal-output digits k radix)
+(define (flonum-unparser:normal-output digits k radix)
   (let ((k+1 (+ k 1)))
     (let ((k+1-l (- k+1 (string-length digits)))
          (n (flo:significand-digits radix)))
@@ -114,6 +108,12 @@ not much different to numbers within a few orders of magnitude of 1.
            (else
             (scientific-output digits k radix 0))))))
 
+(define (flonum-unparser:scientific-output digits k radix)
+  (scientific-output digits k radix 0))
+
+(define (flonum-unparser:engineering-output digits k radix)
+  (scientific-output digits k radix (modulo k 3)))
+
 (define (scientific-output digits k radix kr)
   (let ((l (string-length digits))
        (i (+ kr 1))
@@ -131,7 +131,7 @@ not much different to numbers within a few orders of magnitude of 1.
 \f
 (define (flonum-unparser-cutoff-args)
   (cond ((eq? 'NORMAL flonum-unparser-cutoff)
-        (values 'NORMAL 0 'NORMAL))
+        (values 'NORMAL 0 flonum-unparser:normal-output))
        ((and (pair? flonum-unparser-cutoff)
              (pair? (cdr flonum-unparser-cutoff))
              (let ((mode (car flonum-unparser-cutoff))
@@ -143,17 +143,27 @@ not much different to numbers within a few orders of magnitude of 1.
              (or (null? (cddr flonum-unparser-cutoff))
                  (and (pair? (cddr flonum-unparser-cutoff))
                       (null? (cdddr flonum-unparser-cutoff))
-                      (memq (caddr flonum-unparser-cutoff)
-                            '(NORMAL SCIENTIFIC ENGINEERING)))))
+                      (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))
-                    'NORMAL
-                    (caddr 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 'NORMAL))))
+        (values 'NORMAL 0 flonum-unparser:normal-output))))
+
+(define (lookup-symbolic-display-mode mode)
+  (case mode
+    ((ENGINEERING) flonum-unparser:engineering-output)
+    ((SCIENTIFIC) flonum-unparser:scientific-output)
+    ((NORMAL) flonum-unparser:normal-output)
+    (else mode)))
 
 (define flonum-unparser-hook #f)
 (define flonum-unparser-cutoff 'NORMAL)

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 5f932bc2dd4977711ef61196d6778b8b33c0a4cd..e625cce522428b0e4a47f04ba164c19ed35cd4d7 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.285 1997/07/15 16:33:29 adams Exp $
+$Id: runtime.pkg,v 14.286 1997/07/26 07:40:41 cph Exp $
 
 Copyright (c) 1988-97 Massachusetts Institute of Technology
 
@@ -1530,6 +1530,9 @@ MIT in each case. |#
          exp
          expt
          flonum-unparser-cutoff
+         flonum-unparser:engineering-output
+         flonum-unparser:normal-output
+         flonum-unparser:scientific-output
          floor
          floor->exact
          gcd

diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index 77521471d3400adf1f083e0668a466a79d1f8399..9ea628a54da14712b528c089654c2ada18a85d67 100644 (file)
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.291 1997/07/15 05:16:25 adams Exp $
+$Id: runtime.pkg,v 14.292 1997/07/26 07:40:06 cph Exp $
 
 Copyright (c) 1988-97 Massachusetts Institute of Technology
 
@@ -1534,6 +1534,9 @@ MIT in each case. |#
          exp
          expt
          flonum-unparser-cutoff
+         flonum-unparser:engineering-output
+         flonum-unparser:normal-output
+         flonum-unparser:scientific-output
          floor
          floor->exact
          gcd