From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 26 Jul 1997 07:40:41 +0000 (+0000)
Subject: Provide the ability for a user to specify how the digits generated by
X-Git-Tag: 20090517-FFI~5033
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2e1b6e8745d344e7c07911187a16b9fe23865f0c;p=mit-scheme.git

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 47d8a2dc5..e68015e0c 100644
--- 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.
 
 (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 5f932bc2d..e625cce52 100644
--- 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 77521471d..9ea628a54 100644
--- 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