Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

do not ignore explicitly given mantissa width #868

Merged
merged 3 commits into from
Nov 8, 2024
Merged

do not ignore explicitly given mantissa width #868

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
c9661c9
do not ignore explicitly given mantissa width
mnieper Aug 28, 2024
f483697
adjust `|` parsing for very large precision requests
mflatt Sep 29, 2024
2d927ce
refine precision cutoffs for very large requests
mflatt Nov 5, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
30 changes: 29 additions & 1 deletion mats/5_3.ms
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
6 changes: 5 additions & 1 deletion release_notes/release_notes.stex
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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}))}
Expand All @@ -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.
Expand Down
88 changes: 67 additions & 21 deletions s/strnum.ss
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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.
Expand Down Expand Up @@ -180,14 +180,15 @@ an exception.
; other "interesting" variables:
; r: radix, 2 <= r <= 36 (can be outside this range while constructing #<r>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.

Expand All @@ -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]))
Expand All @@ -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))

Expand Down Expand Up @@ -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))]
Expand Down Expand Up @@ -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))))))])
Expand All @@ -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
Expand Down
Loading