From f9a396e56d319c563db506b2c2e4d60a7b5577b4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marc=20Nieper-Wi=C3=9Fkirchen?= Date: Fri, 8 Nov 2024 14:50:19 +0100 Subject: [PATCH] do not ignore explicitly given mantissa width (#868) --- mats/5_3.ms | 30 ++++++++++- release_notes/release_notes.stex | 6 ++- s/strnum.ss | 88 ++++++++++++++++++++++++-------- 3 files changed, 101 insertions(+), 23 deletions(-) diff --git a/mats/5_3.ms b/mats/5_3.ms index dd7542a6a..cd70980f8 100644 --- a/mats/5_3.ms +++ b/mats/5_3.ms @@ -138,7 +138,35 @@ (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? 0.1|1 0.125) + (eqv? 77|1 64.0) + (eqv? 12|0 0.0) + (eqv? #e12|0 0) + (eqv? 9|3 8.0) + (eqv? -10|3 -10.0) + (eqv? #e99999999999999983222784|54 99999999999999983222784) + (eqv? #e99999999999999983222784|53 99999999999999991611392) + (eqv? #e99999999999999983222783|54 99999999999999983222784) + (eqv? #e99999999999999983222783|53 99999999999999974834176) + (eqv? 1000 (integer-length (numerator #e1.2345678901234567891012345|1000))) + (eqv? 1000 (integer-length (denominator #e1.2345678901234567891012345|1000))) + (eqv? 10000 (integer-length (numerator #e1.2345678901234567891012345|10000))) + (eqv? 10000 (integer-length (denominator #e1.2345678901234567891012345|10000))) +; don't run out of memory unnecessarily + (eqv? #e1234567|100000000000000000 1234567) + (eqv? #i1.234567|100000000000000000 1.234567) + (eqv? 1.234567|100000000000000000 1.234567) + (eqv? 1.234567e300|100000000000000000 1.234567e300) + (eqv? 0.1|100000000000000000 0.1|100) + (eqv? 0.3|100000000000000000 0.3|53) + (not (eqv? 0.3|52 0.3|53)) ; confirm boundary + (eqv? 0.3e300|100000000000000000 0.3e300|50) + (not (eqv? 0.3e300|50 0.3e300|49)) + (eqv? #e0.3e300|1000000000000000 #e0.3e300) + (eqv? #e0.3e300|696 #e0.3e300) + (not (eqv? #e0.3e300|695 #e0.3e300))) (mat string->number ; error cases diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 685f509f2..9f853ab0a 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -2755,7 +2755,6 @@ in fasl files does not generally make sense. %----------------------------------------------------------------------------- \section{Bug Fixes}\label{section:bugfixes} - \subsection{\scheme{quote-syntax} incorrectly applies wrap (10.1.0)} A bug in \scheme{quote-syntax} that caused \scheme{(identifier? (quote-syntax \var{symbol}))} @@ -2768,6 +2767,11 @@ and \scheme{(scheme-ieee-environment)} had some names incorrectly prefixed with \scheme{r6rs:}, such as \scheme{r6rs:<} instead of \scheme{<}. +\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..804a01f90 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,63 @@ an exception. (define (implied-i ex) (if (not ex) 'i ex)) +(define noround (lambda (x) x)) +(define rounder + (lambda (p ex) + (if (zero? p) + (lambda (n) 0) + (lambda (n) + (let ([a (numerator n)] + [b (denominator n)]) + (let* ([a-bits (bitwise-length a)] + [b-bits (bitwise-length b)] + [d (- a-bits b-bits)] + ;; If `p` is large, we might run out of memory by + ;; shifting by it directly, but in some cases, the right + ;; result should fit into memory no matter how big `p` is. + [p (cond + [(not (eq? ex 'e)) + ;; end result will have at most 53 bits, anyway, so + ;; bound p; we don't need a tight bound, and adding 2 + ;; extra bits over `double` precision to make sure + ;; rounding will be right + (min p (+ a-bits b-bits 53 2))] + [(= b (bitwise-arithmetic-shift-left 1 (- b-bits 1))) + ;; no need for extra precision if the + ;; denominator is a power of 2 + (min p a-bits)] + [else p])]) + (let*-values + ([(a b) + (if (positive? d) + (values a (bitwise-arithmetic-shift-left b d)) + (values (bitwise-arithmetic-shift-left a (- d)) b))] + [(b d) + (if (>= a b) + (values (bitwise-arithmetic-shift-left b 1) (+ d 1)) + (values b d))] + [(q r) + (div-and-mod (bitwise-arithmetic-shift-left a (+ p 1)) + b)]) + (* (+ q + (cond [(not (bitwise-bit-set? q 0)) 0] + [(or (not (zero? r)) + (bitwise-bit-set? q 1)) 1] + [else -1])) + (expt 2 (- d p 1)))))))))) + (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 +276,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 +375,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 +461,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 +483,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 ex))) + [(digit 10) (mwidth1 r ex ms (+ (* 10 mw) d) x)] + [else (complex0 r ex ms (x (rounder mw ex)))]) (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