adjust | parsing for very large precision requests

Avoiding running out of memory for a very large precision request when
the number with adjusted precision should take about as much memory as
the number without an adjustment.

mats/5_3.ms

@@ -140,15 +140,33 @@
    (< -.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

s/strnum.ss

@@ -204,13 +204,30 @@ an exception.
 
 (define noround (lambda (x) x))
 (define rounder
-  (lambda (p)
+  (lambda (p ex)
     (if (zero? p)
         (lambda (n) 0)
         (lambda (n)
           (let ([a (numerator n)]
                 [b (denominator n)])
-	    (let ([d (- (bitwise-length a) (bitwise-length b))])
+	    (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 (+ (max 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 b-bits))]
+                        [else p])])
 	      (let*-values
 		  ([(a b)
 		    (if (positive? d)
@@ -476,9 +493,9 @@ an exception.
   [(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)))
+  (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)))])
+  [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