From: Matt Birkholz Date: Sat, 8 Feb 2014 19:57:21 +0000 (-0700) Subject: Fluidize flonum-unparser-cutoff. X-Git-Tag: mit-scheme-pucked-9.2.12~401^2~6 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8af1b574ca709ee7124231a219c5bcb171509146;p=mit-scheme.git Fluidize flonum-unparser-cutoff. --- diff --git a/doc/ref-manual/numbers.texi b/doc/ref-manual/numbers.texi index 865f86784..72b047c1b 100644 --- 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 90ad99b27..8e51cd805 100644 --- 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 dbbe751de..6d1b46e7e 100644 --- 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))))) (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 10476a7d7..9e4559a97 100644 --- 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))