diff --git a/mats/5_3.ms b/mats/5_3.ms index dd7542a6a..edf548a0f 100644 --- a/mats/5_3.ms +++ b/mats/5_3.ms @@ -138,6 +138,12 @@ (symbol? '2@3+4i) ; check for float read bug introduced into 3.0: (< -.039 -.038413 -.038) +; non-empty mantissa widths + (eqv? #e0.1|1 1/8) + (eqv? 77|1 64.0) + (eqv? 12|0 0.0) + (eqv? 9|3 8.0) + (eqv? -10|3 -10.0) ) (mat string->number diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 5421e6f60..74f66bb6c 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -2726,6 +2726,11 @@ in fasl files does not generally make sense. %----------------------------------------------------------------------------- \section{Bug Fixes}\label{section:bugfixes} +\subsection{Non-empty mantissa widths (10.1.0)} + +Non-empty mantissa widths are now taken into account. For example, +\scheme{(string->number "#e0.1|1")} now evaluates to \scheme{1/8}. + \subsection{Case-insensitive ``V'' format directive (10.1.0)} The ``V'' format directive is now recognized in uppercase as well as lowercase. diff --git a/s/strnum.ss b/s/strnum.ss index a10e51a9c..33d352e83 100644 --- a/s/strnum.ss +++ b/s/strnum.ss @@ -1,12 +1,12 @@ ;;; strnum.ss ;;; Copyright 1984-2017 Cisco Systems, Inc. -;;; +;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at -;;; +;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 -;;; +;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. @@ -180,14 +180,15 @@ an exception. ; other "interesting" variables: ; r: radix, 2 <= r <= 36 (can be outside this range while constructing #r prefix) ; ex: exactness: 'i, 'e, or #f -; s: function to add sign to number +; s: function to add sign to number ; ms: meta-state: real, imag, angle ; n: exact integer ; m: exact or inexact integer ; w: exact or inexact integer or norep ; wi: exact integer or norep or 'inf or 'nan -; x: number, thunk, or norep +; x: number, thunk, procedure taking rounding procedure, or norep ; e: exact integer exponent +; mw: exact integer mantissa width ; i?: #t if number should be made inexact ; invariant: (thunk) != exact 0. @@ -201,18 +202,33 @@ an exception. (define (implied-i ex) (if (not ex) 'i ex)) +(define noround (lambda (x) x)) +(define rounder + (lambda (mw) + (if (zero? mw) + (lambda (n) 0) + (lambda (n) + (let ([a (numerator n)] + [b (denominator n)]) + (let ([sa (bitwise-length a)] + [sb (bitwise-length b)]) + (let ([m (round (* n (expt 2 (+ mw 1 (- sb sa)))))]) + (let ([k (bitwise-length m)]) + (* (round (/ m (expt 2 (- k mw)))) + (expt 2 (- k mw mw 1 (- sb sa)))))))))))) + (define make-part (lambda (i? s n) (s (if i? (inexact n) n)))) (define make-part/exponent - (lambda (i? s wi r e) + (lambda (i? s t wi r e) ; get out quick for really large/small exponents, like 1e1000000000 ; no need for great precision here; using 2x the min/max base two ; exponent, which should be conservative for all bases. 1x should ; actually work for positive n, but for negative e we need something ; smaller than 1x to allow denormalized numbers. - ; s must be the actual sign of the result, with w >= 0 + ; s must be the actual sign of the result, with w >= 0 (define max-float-exponent (float-type-case [(ieee) 1023])) @@ -230,10 +246,10 @@ an exception. (integer-length (denominator wi))) (log r 2))) (* max-float-exponent 2)) - (inexact (* wi (expt r e))) + (inexact (t (* wi (expt r e)))) (if (< e 0) 0.0 +inf.0))))] [(eqv? wi 0) 0] - [else (lambda () (s (* wi (expt r e))))]))) + [else (lambda () (s (t (* wi (expt r e)))))]))) (define (thaw x) (if (procedure? x) (x) x)) @@ -329,7 +345,7 @@ an exception. (finish-number ms ex x1 (make-part (eq? ex 'i) s n)) [(digit r) (num2 r ex ms s (+ (* n r) d))] [#\/ (rat0 r ex ex ms s (make-part #f plus n))] - [#\| (mwidth0 r ex ms (make-part (not (eq? ex 'e)) s n))] + [#\| (mwidth0 r ex ms (lambda (t) (make-part (not (eq? ex 'e)) s (t n))))] [#\. (let ([!r6rs (or !r6rs (not (fx= r 10)))]) (float1 r ex ms s n (fx+ i 1) 0))] [#\# (let ([!r6rs #t]) (numhash r ex ms s (* n r)))] [(#\e #\s #\f #\d #\l) (let ([!r6rs (or !r6rs (not (fx= r 10)))]) (exp0 r ex ms s n))] @@ -415,7 +431,7 @@ an exception. (mknum-state float1 (r ex ms s m j n) ; saw fraction digit at j (finish-number ms ex x1 (make-part (not (eq? ex 'e)) s (+ m (* n (expt r (- j i)))))) [(digit r) (float1 r ex ms s m j (+ (* n r) d))] - [#\| (mwidth0 r ex ms (make-part (not (eq? ex 'e)) s (+ m (* n (expt r (- j i))))))] + [#\| (mwidth0 r ex ms (lambda (t) (make-part (not (eq? ex 'e)) s (t (+ m (* n (expt r (- j i))))))))] [#\# (let ([!r6rs #t]) (floathash r ex ms s m j (* n r)))] [(#\e #\s #\f #\d #\l) (exp0 r ex ms s (+ m (* n (expt r (- j i)))))] [else (complex0 r ex ms (make-part (not (eq? ex 'e)) s (+ m (* n (expt r (- j i))))))]) @@ -437,19 +453,19 @@ an exception. [(digit r) (exp2 r ex ms sm wi s d)]) (mknum-state exp2 (r ex ms sm wi s e) ; saw exponent digit(s) - (finish-number ms ex x1 (make-part/exponent (not (eq? ex 'e)) sm wi r (s e))) + (finish-number ms ex x1 (make-part/exponent (not (eq? ex 'e)) sm noround wi r (s e))) [(digit r) (exp2 r ex ms sm wi s (+ (* e r) d))] - [#\| (mwidth0 r ex ms (make-part/exponent (not (eq? ex 'e)) sm wi r (s e)))] - [else (complex0 r ex ms (make-part/exponent (not (eq? ex 'e)) sm wi r (s e)))]) + [#\| (mwidth0 r ex ms (lambda (t) (make-part/exponent (not (eq? ex 'e)) sm t wi r (s e))))] + [else (complex0 r ex ms (make-part/exponent (not (eq? ex 'e)) sm noround wi r (s e)))]) -(mknum-state mwidth0 (r ex ms x) ; saw vertical bar +(mknum-state mwidth0 (r ex ms x) ; saw vertical bar #f - [(digit 10) (mwidth1 r ex ms x)]) - -(mknum-state mwidth1 (r ex ms x) ; saw digit after vertical bar - (finish-number ms ex x1 x) - [(digit 10) (mwidth1 r ex ms x)] - [else (complex0 r ex ms x)]) + [(digit 10) (mwidth1 r ex ms d x)]) + +(mknum-state mwidth1 (r ex ms mw x) ; saw digit after vertical bar + (finish-number ms ex x1 (x (rounder mw))) + [(digit 10) (mwidth1 r ex ms (+ (* 10 mw) d) x)] + [else (complex0 r ex ms (x (rounder mw)))]) (mknum-state complex0 (r ex ms x) ; saw end of real part before end of string (assert #f) ; should arrive here only from else clauses, thus not at the end of the string