Refactor handling of flonum-unparser-cutoff.

* Change flonum-unparser-cutoff back to shallow-bound variable.
* Introduce new parameter param:flonum-unparser-cutoff.
* Remove commented-out unit tests (see next commit).

diff --git a/src/runtime/dragon4.scm b/src/runtime/dragon4.scm
index 42ab9f72c3cf96f0b455575a76d763457f02b983..f98dbec8bf478b8414fbd75b46de4c89c806ff5a 100644 (file)
--- a/src/runtime/dragon4.scm
+++ b/src/runtime/dragon4.scm
@@ -44,6 +44,27 @@ not much different to numbers within a few orders of magnitude of 1.
 
 (declare (usual-integrations))
 \f
+(define flonum-unparser-hook #f)
+(define flonum-unparser-cutoff #!default)
+(define param:flonum-unparser-cutoff)
+(define expt-radix)
+
+(define (initialize-dragon4!)
+  (set! param:flonum-unparser-cutoff
+       (make-parameter 'NORMAL
+                       (lambda (cutoff)
+                         (guarantee-cutoff-spec cutoff)
+                         cutoff)))
+  (set! expt-radix
+       (let ((v (make-initialized-vector 310 (lambda (i) (expt 10 i)))))
+         (lambda (base exponent)
+           (if (and (= base 10)
+                    (>= exponent 0)
+                    (< exponent (vector-length v)))
+               (vector-ref v exponent)
+               (rat:expt base exponent)))))
+  unspecific)
+\f
 (define (flo:->string x radix)
   (let ((inf?
         (lambda (x)
@@ -127,24 +148,13 @@ not much different to numbers within a few orders of magnitude of 1.
                          exponent)))))
 \f
 (define (flonum-unparser-cutoff-args)
-  (let ((cutoff (flonum-unparser-cutoff)))
+  (let ((cutoff
+        (if (default-object? flonum-unparser-cutoff)
+            (param:flonum-unparser-cutoff)
+            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)))))))
+         ((compound-cutoff-spec? cutoff)
           (values (car cutoff)
                   (- (cadr cutoff))
                   (if (null? (cddr cutoff))
@@ -156,6 +166,29 @@ not much different to numbers within a few orders of magnitude of 1.
                 cutoff)
           (values 'NORMAL 0 flonum-unparser:normal-output)))))
 
+(define (cutoff-spec? cutoff)
+  (or (eq? 'NORMAL cutoff)
+      (compound-cutoff-spec? cutoff)))
+
+(define (compound-cutoff-spec? cutoff)
+  (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))))))))
+
+(define-guarantee cutoff-spec "flonum unparser cutoff spec")
+
 (define (lookup-symbolic-display-mode mode)
   (case mode
     ((ENGINEERING) flonum-unparser:engineering-output)
@@ -163,9 +196,6 @@ not much different to numbers within a few orders of magnitude of 1.
     ((NORMAL) flonum-unparser:normal-output)
     (else mode)))
 
-(define flonum-unparser-hook #f)
-(define flonum-unparser-cutoff)
-
 (define (dragon4-normalize x precision)
   (call-with-values (lambda () (flo:normalize x))
     (lambda (f e-p)
@@ -274,88 +304,4 @@ not much different to numbers within a few orders of magnitude of 1.
 
   (if (int:= f (int:expt 2 (- p 1)))
       (scale (int:* 2 r) (int:* 2 s) (int:* 2 m-))
-      (scale r s m-)))
-
-(define expt-radix)
-
-(define (initialize-dragon4!)
-  (set! flonum-unparser-cutoff (make-parameter 'NORMAL))
-  (set! expt-radix
-       (let ((v (make-initialized-vector 310 (lambda (i) (expt 10 i)))))
-         (lambda (base exponent)
-           (if (and (= base 10)
-                    (>= exponent 0)
-                    (< exponent (vector-length v)))
-               (vector-ref v exponent)
-               (rat:expt base exponent)))))
-  unspecific)
-\f
-#|  Test code.  Re-run after changing anything.
-
-(define (test)
-  (define (try n settings . expecteds)
-    (let ((got (parameterize* (list (cons flonum-unparser-cutoff settings))
-                (lambda ()
-                  (number->string (exact->inexact n))))))
-      (if (member got expecteds)
-         (set! successes (+ successes 1))
-         (begin
-           (set! failures (+ failures 1))
-           (display "\nTest failed ") (write n) (display " ") (write settings)
-           (display "\n  expected:")
-           (for-each (lambda (s) (display " ") (write s))
-             expecteds)
-           (display "\n       got: ")  (write got)))))
-
-  (define failures 0)
-  (define successes 0)
-
-  ;; From the MIT/GNU Scheme Reference Manual:
-  (try (* 4 (atan 1 1))     '(relative 5)              "3.1416")
-  (try (* 4000 (atan 1 1))  '(relative 5)              "3141.6")
-  (try (* 4000 (atan 1 1))  '(relative 5 scientific)   "3.1416e3")
-  (try (* 40000 (atan 1 1)) '(relative 5 scientific)   "3.1416e4")
-  (try (* 40000 (atan 1 1)) '(relative 5 engineering)  "31.416e3")
-  (try (* 4 (atan 1 1))     '(absolute 5)              "3.14159")
-  (try (* 4000 (atan 1 1))  '(absolute 5)              "3141.59265")
-  (try (* 4e10 (atan 1 1))  '(absolute -4)             "31415930000.")
-  (try (* 4e10 (atan 1 1))  '(absolute -4 scientific)  "3.141593e10")
-  (try (* 4e10 (atan 1 1))  '(absolute -4 engineering) "31.41593e9")
-  (try (* 4e10 (atan 1 1))  '(absolute -5)             "31415900000.")
-
-  ;; Harder tests:
-  (try 0.          'normal  "0.")
-  (try 0.0123456   'normal  ".0123456")
-  (try 0.000123456 'normal  ".000123456")
-
-  (try 1/3       '(relative 4) ".3333")
-  (try 2/3       '(relative 4) ".6667")
-
-  (try 12345.67   '(absolute  1 normal) "12345.7")
-  (try 12345.67   '(absolute -4 normal) "10000.")
-  (try 4999.      '(absolute -4 normal) "0.")
-  (try 5001.      '(absolute -4 normal) "10000.")
-
-  (try 12345.67   '(absolute  1 scientific) "1.23457e4")
-  (try 12345.67   '(absolute -4 scientific) "1e4")
-  (try 4999.      '(absolute -4 scientific) "0." "0e4" "0e3")
-  (try 5001.      '(absolute -4 scientific) "1e4")
-
-  (try 12345.67   '(absolute  1 engineering) "12.3457e3")
-  (try 12345.67   '(absolute -4 engineering) "10e3")
-  (try 4999.      '(absolute -4 engineering) "0." "0e3")
-  (try 5001.      '(absolute -4 engineering) "10e3")
-  (try 5001.      '(absolute -5 engineering) "0." "0e3")
-  (try 5001.      '(absolute -6 engineering) "0." "0e3")
-  (try -5001.     '(absolute -6 engineering) "0." "-0e3")
-
-  (try 0.00499   '(absolute  2 normal) "0." ".00")  ; "0." would be prefereable
-
-  (try 0.00500   '(absolute  2 normal) ".01") ; (rounds up in binary)
-  (try 0.00501   '(absolute  2 normal) ".01")
-  (try 0.00499   '(absolute -3 normal) "0.")
-
-
-  (display "\n\nSuccesses: ") (display successes)
-  (display "    Failures: ") (display failures))
-|#
+      (scale r s m-)))
\ No newline at end of file

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 2a6de979e9f11612b825c2bfbf5d2746c66c07c8..551c679c4b23355558826bcc04986f1d1199ea19 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3027,6 +3027,7 @@ USA.
          non-positive?
          number->string
          odd?
+         param:flonum-unparser-cutoff
          quotient
          remainder
          smallest-fixnum