Chez Scheme: raise catchable exception for expt with huge result

c/scheme.c

@@ -365,6 +365,13 @@ static void idiot_checks(void) {
     oops = 1;
   }
 
+  if (most_positive_fixnum / bigit_bits >= maximum_bignum_length) {
+    /* operations like `expt` assume that a fixnum number of bits at least fits
+       into the representation of a bignum (although possible not into memory) */
+    fprintf(stderr, "most_positive_fixnum >= maximum_bignum_length * bigit_bits\n");
+    oops = 1;
+  }
+
   if (oops) S_abnormal_exit();
 }
 

mats/5_3.ms

@@ -2797,6 +2797,16 @@
     ($flexpt~= (expt .999999999999923 9113206036900123) 1.1282707411029136e-305)
     ($flexpt~= (expt .999999999999923 9113206036900124) 1.1282707411028267e-305)
     ($flexpt~= (expt .999999999999923 9113206036900125) 1.1282707411027398e-305)
+   ; large exponent: out of memory for integer bases with |x| > 1
+    (error? (expt 3 (expt 2 100)))
+    (error? (expt -2 (expt 2 100)))
+    (error? (expt (expt 10 100) (expt 2 100)))
+    (error? (expt 3 (- (expt 2 100))))
+   ; large exponent: special bases should still work
+    (eqv? (expt 0 (expt 2 100)) 0)
+    (eqv? (expt 1 (expt 2 100)) 1)
+    (eqv? (expt -1 (expt 2 100)) 1)
+    (eqv? (expt -1 (+ 1 (expt 2 100))) -1)
  )
 
 (mat expt-mod
@@ -3505,6 +3515,7 @@
        #t)
      #t)
    ($test-right-shift (lambda (x n) (ash x (- n))))
+   (eqv? (ash 0 (expt 2 28)) 0)
 )
 
 (mat bitwise-arithmetic-shift
@@ -5901,6 +5912,18 @@
               (if (fx= i (* (integer-length (ash (most-negative-fixnum) 5)) 2))
                   (g (fx- j 1))
                   (and (p? n i) (f (fx+ i 1)))))))))
+  (eqv? (logbit0 (expt 2 28) 0) 0)
+  ;; logbit0 with fixnum k at the integer-length boundary
+  (eqv? (logbit0 2 7) 3)   ; k < integer-length, bit set
+  (eqv? (logbit0 3 7) 7)   ; k = integer-length, bit clear
+  (eqv? (logbit0 4 7) 7)   ; k > integer-length, bit clear
+  ;; logbit0 with large fixnum k and non-negative n
+  (eqv? (logbit0 (most-positive-fixnum) 0) 0)
+  (eqv? (logbit0 (most-positive-fixnum) 5) 5)
+  ;; logbit0 at the fixnum/bignum k boundary
+  (eqv? (logbit0 (+ (most-positive-fixnum) 1) 0) 0)
+  (eqv? (logbit0 (+ (most-positive-fixnum) 1) 5) 5)
+  (eqv? (logbit0 (expt 2 100) 7) 7)
 )
 
 (mat logbit1
@@ -6036,6 +6059,12 @@
               (if (fx= i (* (integer-length (ash (most-negative-fixnum) 5)) 2))
                   (g (fx- j 1))
                   (and (p? n i) (f (fx+ i 1)))))))))
+  (eqv? (logbit1 (expt 2 28) -1) -1)
+  ;; logbit1 at the fixnum/bignum k boundary with negative n
+  (eqv? (logbit1 (+ (most-positive-fixnum) 1) -1) -1)
+  (eqv? (logbit1 (+ (most-positive-fixnum) 1) -5) -5)
+  (eqv? (logbit1 (expt 2 100) -1) -1)
+  (eqv? (logbit1 (expt 2 100) -5) -5)
 )
 
 (mat bitwise-copy-bit ; adapted from logbit0 and logbit1 above

mats/root-experr-compile-0-f-f-f

@@ -1410,6 +1410,10 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
 5_3.mo:Expected error in mat expt: "expt: undefined for values 0 and +nan.0+3.0i".
 5_3.mo:Expected error in mat expt: "expt: undefined for values 0 and 0+3i".
 5_3.mo:Expected error in mat expt: "expt: undefined for values 0 and -1/2".
+5_3.mo:Expected error in mat expt: "expt: out of memory".
+5_3.mo:Expected error in mat expt: "expt: out of memory".
+5_3.mo:Expected error in mat expt: "expt: out of memory".
+5_3.mo:Expected error in mat expt: "expt: out of memory".
 5_3.mo:Expected error in mat expt-mod: "incorrect argument count in call (expt-mod)".
 5_3.mo:Expected error in mat expt-mod: "incorrect argument count in call (expt-mod 5)".
 5_3.mo:Expected error in mat expt-mod: "incorrect argument count in call (expt-mod 4 5)".

release_notes/release_notes.stex

@@ -2933,6 +2933,17 @@ in fasl files does not generally make sense.
 %-----------------------------------------------------------------------------
 \section{Bug Fixes}\label{section:bugfixes}
 
+\subsection{Out-of-memory improvements for \scheme{expt}, \scheme{logbit0}, and \scheme{logbit1} (10.4.0)}
+
+A call to \scheme{expt} with an exact rational base and an integer exponent too large
+to allow the result to fit into a number representation now raises a catchable exception
+rather than exhausting memory and aborting the process. A call to
+\scheme{logbit0} with a large bit index and a non-negative second argument
+now returns the second argument directly, since the indicated bit is
+already clear, and \scheme{logbit1} with a large bit index and a
+negative second argument returns the second argument directly, since
+the indicated bit is already set.
+
 \subsection{Unicode Indic\_Conjunct\_Break support (10.4.0)}
 
 The grapheme cluster break algorithm neglected to consider the Indic\_Conjunct\_Break

s/5_3.ss

@@ -1714,7 +1714,12 @@
                  ($impoops 'expt "undefined for values ~s and ~s" x y)
                  0)]
             [(eq? x 1) 1]
-            [(eq? x 2) (if (< y 0) (/ (ash 1 (- y))) (ash 1 y))]
+            [(eq? x -1) (if (odd? y) -1 1)]
+            [(eq? x 2)
+             (let ([abs-y (if (< y 0) (- y) y)])
+               (when (> abs-y (* (constant maximum-bignum-length) (constant bigit-bits)))
+                 ($oops 'expt "out of memory"))
+               (if (< y 0) (/ (ash 1 (- y))) (ash 1 y)))]
             [(flonum? x)
              ;; By Bradley Lucier (@gambiteer) for Gambit, relies
              ;; on some special cases already handled by the time
@@ -1765,6 +1770,10 @@
                  (let ([y (- y)])
                    (/ (expt (denominator x) y) (expt (numerator x) y)))
                  (/ (expt (numerator x) y) (expt (denominator x) y)))]
+            [(and (or (fixnum? x) (bignum? x))
+                  (> (* (if (< y 0) (- y) y) (integer-length x))
+                     (* (constant maximum-bignum-length) (constant bigit-bits))))
+             ($oops 'expt "out of memory")]
             [else
              (let ()
                (define (f x n)

s/library.ss

@@ -984,12 +984,17 @@
           [(fixnum? k)
            (if (fx< k 0)
                (invalidindexoops 'logbit0 k)
-               ($logbit0 k n))]
+               (if (and (if (fixnum? n) (fxnonnegative? n) ($bigpositive? n))
+                        (>= k (integer-length n)))
+                   n
+                   ($logbit0 k n)))]
           [(bignum? k)
            (if (< k 0)
                (invalidindexoops 'logbit0 k)
-              ; $logbit0 requires k to be a fixnum
-               ($logand n ($lognot (ash 1 k))))]
+               (if (if (fixnum? n) (fxnonnegative? n) ($bigpositive? n))
+                   n
+                   ; $logbit0 requires k to be a fixnum
+                   ($logand n ($lognot (ash 1 k)))))]
           [else (invalidindexoops 'logbit0 k)])
         (exactintoops1 'logbit0 n)))
 
@@ -1003,8 +1008,10 @@
           [(bignum? k)
            (if (< k 0)
                (invalidindexoops 'logbit1 k)
-              ; $logbit1 requires k to be a fixnum
-               ($logor n (ash 1 k)))]
+               (if (if (fixnum? n) (fxnegative? n) (not ($bigpositive? n)))
+                   n
+                   ; $logbit1 requires k to be a fixnum
+                   ($logor n (ash 1 k))))]
           [else (invalidindexoops 'logbit1 k)])
         (exactintoops1 'logbit1 n)))