do not ignore explicitly given mantissa width

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

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.

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>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