Add new variable `flonum-unparser-cutoff', which controls the flonum

printer's precision.  Acceptable values of this variable are:

NORMAL		use all available precision
(RELATIVE <n>)	<n> digits of precision
(ABSOLUTE <n>)	<n> digits of precision after the decimal point

diff --git a/v7/src/runtime/dragon4.scm b/v7/src/runtime/dragon4.scm
index b694cce8ec5776ff02c4dcc69f547e2910f716b9..d1bf8b200db20285f2afa9df20c162cc8c78fa9b 100644 (file)
--- a/v7/src/runtime/dragon4.scm
+++ b/v7/src/runtime/dragon4.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dragon4.scm,v 1.2 1989/10/30 22:36:38 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dragon4.scm,v 1.3 1990/01/15 21:27:25 cph Exp $
 
-Copyright (c) 1989 Massachusetts Institute of Technology
+Copyright (c) 1989, 1990 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -43,49 +43,71 @@ MIT in each case. |#
           (let ((p flo:significand-digits-base-2))
             (with-values (lambda () (dragon4-normalize x p))
               (lambda (f e)
-                (dragon4 f e p radix 'NORMAL 0
-                  (lambda (u k generate)
-                    (let ((digits
-                           (list->string
-                            (let loop ((u u) (k k) (generate generate))
-                              k        ;ignore
-                              (if (negative? u)
-                                  '()
-                                  (cons (digit->char u radix)
-                                        (generate loop)))))))
-                      (let ((k+1 (1+ k)))
-                        (let ((k+1-l (- k+1 (string-length digits)))
-                              (n (flo:significand-digits radix))
-                              (scientific
-                               (lambda ()
-                                 (string-append (string-head digits 1)
-                                                "."
-                                                (string-tail digits 1)
-                                                "e"
-                                                (int:->string k radix)))))
-                          (cond ((< k+1-l (- n))
-                                 (scientific))
-                                ((negative? k)
-                                 (string-append "."
-                                                (make-string (- k+1) #\0)
-                                                digits))
-                                ((negative? k+1-l)
-                                 (string-append (string-head digits k+1)
-                                                "."
-                                                (string-tail digits k+1)))
-                                ((<= k n)
-                                 (string-append digits
-                                                (make-string k+1-l #\0)
-                                                "."))
-                                (else
-                                 (scientific))))))))))))))
+                (with-values flonum-unparser-cutoff-args
+                  (lambda (cutoff-mode cutoff)
+                    (dragon4 f e p radix cutoff-mode cutoff
+                      (lambda (u k generate)
+                        (let ((digits
+                               (list->string
+                                (let loop ((u u) (k k) (generate generate))
+                                  k    ;ignore
+                                  (if (negative? u)
+                                      '()
+                                      (cons (digit->char u radix)
+                                            (generate loop)))))))
+                          (let ((k+1 (1+ k)))
+                            (let ((k+1-l (- k+1 (string-length digits)))
+                                  (n (flo:significand-digits radix))
+                                  (scientific
+                                   (lambda ()
+                                     (string-append (string-head digits 1)
+                                                    "."
+                                                    (string-tail digits 1)
+                                                    "e"
+                                                    (int:->string k radix)))))
+                              (cond ((< k+1-l (- n))
+                                     (scientific))
+                                    ((negative? k)
+                                     (string-append "."
+                                                    (make-string (- k+1) #\0)
+                                                    digits))
+                                    ((negative? k+1-l)
+                                     (string-append (string-head digits k+1)
+                                                    "."
+                                                    (string-tail digits k+1)))
+                                    ((<= k n)
+                                     (string-append digits
+                                                    (make-string k+1-l #\0)
+                                                    "."))
+                                    (else
+                                     (scientific))))))))))))))))
     (or (and flonum-unparser-hook
             (flonum-unparser-hook x radix))
        (cond ((flo:positive? x) (x>0 x))
              ((flo:negative? x) (string-append "-" (x>0 (flo:negate x))))
              (else (string-copy "0."))))))
 
+(define (flonum-unparser-cutoff-args)
+  (cond ((eq? 'NORMAL flonum-unparser-cutoff)
+        (values 'NORMAL 0))
+       ((and (pair? flonum-unparser-cutoff)
+             (pair? (cdr flonum-unparser-cutoff))
+             (null? (cddr 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)))))
+        (values (car flonum-unparser-cutoff)
+                (- (cadr flonum-unparser-cutoff))))
+       (else
+        (warn "illegal flonum unparser cutoff parameter"
+              flonum-unparser-cutoff)
+        (values 'NORMAL 0))))
+
 (define flonum-unparser-hook #f)
+(define flonum-unparser-cutoff 'NORMAL)
 \f
 (define (dragon4-normalize x precision)
   (with-values (lambda () (flo:normalize x))

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 026697374fc8ae82a8b40f0defc3fbc449e9c0ee..f4f8cd0e588ac144be5679fe0114d47a390f9bc4 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.56 1989/12/07 05:32:23 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.57 1990/01/15 21:27:38 cph Exp $
 
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -977,6 +977,7 @@ MIT in each case. |#
          exact?
          exp
          expt
+         flonum-unparser-cutoff
          floor
          floor->exact
          gcd

diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm
index 185c9e0c2966928ba987dbaea39a45e29079b79f..475b714b450e7bff90562f654c9350083458ed46 100644 (file)
--- a/v7/src/runtime/version.scm
+++ b/v7/src/runtime/version.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.70 1990/01/10 12:39:17 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.71 1990/01/15 21:27:55 cph Exp $
 
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -45,7 +45,7 @@ MIT in each case. |#
                     '()))
   (add-system! microcode-system)
   (add-event-receiver! event:after-restore snarf-microcode-version!)
-  (add-identification! "Runtime" 14 70))
+  (add-identification! "Runtime" 14 71))
 
 (define microcode-system)
 

diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index bf638d138f584654920e11921b6fb6312c10d54f..3b76b2919896aab0e25b0640825d2d21b0a9067c 100644 (file)
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.56 1989/12/07 05:32:23 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.57 1990/01/15 21:27:38 cph Exp $
 
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -977,6 +977,7 @@ MIT in each case. |#
          exact?
          exp
          expt
+         flonum-unparser-cutoff
          floor
          floor->exact
          gcd