From f383076784b6c5c051ce048115ea30c602d5b329 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 20 Apr 2021 18:01:37 -0600
Subject: [PATCH] Chez Scheme: repair bignum shift right

When a negative bignum is shifted right by a multiple of the bigint
bit size (which is 32), when a shifted-off bit is non-0, and when the
result would be a sequence of bigints with all 1 bits before rounding
to deal with the dropped bits, a carry that should have been delivered
to a new high bigint was dropped.

Closes #3794
---
 pkgs/racket-test-core/tests/racket/number.rktl |  2 ++
 racket/src/ChezScheme/c/number.c               | 13 +++++++++++--
 racket/src/ChezScheme/mats/5_3.ms              |  2 ++
 3 files changed, 15 insertions(+), 2 deletions(-)

diff --git a/pkgs/racket-test-core/tests/racket/number.rktl b/pkgs/racket-test-core/tests/racket/number.rktl
index 6487528682..2f118c53f9 100644
--- a/pkgs/racket-test-core/tests/racket/number.rktl
+++ b/pkgs/racket-test-core/tests/racket/number.rktl
@@ -1328,6 +1328,8 @@
 (test -1 arithmetic-shift -1 (- (expt 2 100)))
 (test -1 arithmetic-shift (- (expt 2 100)) (- (expt 2 100)))
 
+(test (- (expt 16 232)) arithmetic-shift (- 307 (expt 16 240)) -32)
+
 (arity-test arithmetic-shift 2 2)
 (err/rt-test (arithmetic-shift "a" 1))
 (err/rt-test (arithmetic-shift 1 "a"))
diff --git a/racket/src/ChezScheme/c/number.c b/racket/src/ChezScheme/c/number.c
index 2585c18440..6b37d7cbbb 100644
--- a/racket/src/ChezScheme/c/number.c
+++ b/racket/src/ChezScheme/c/number.c
@@ -1322,8 +1322,10 @@ static ptr s_big_ash(tc, xp, xl, sign, cnt) ptr tc; bigit *xp; iptr xl; IBOOL si
     if ((xl -= (whole_bigits = (cnt = -cnt) / bigit_bits)) <= 0) return sign ? FIX(-1) : FIX(0);
     cnt -= whole_bigits * bigit_bits;
 
-    /* shift by remaining count to scratch bignum, tracking bits shifted off to the right */
-    PREPARE_BIGNUM(tc, W(tc),xl)
+    /* shift by remaining count to scratch bignum, tracking bits shifted off to the right;
+       prepare a bignum one large than probably needed, in case we have to deal with a
+       carry bit when rounding down for a negative number */
+    PREPARE_BIGNUM(tc, W(tc),xl+1)
     p1 = &BIGIT(W(tc), 0);
     p2 = xp;
     k = 0;
@@ -1353,6 +1355,13 @@ static ptr s_big_ash(tc, xp, xl, sign, cnt) ptr tc; bigit *xp; iptr xl; IBOOL si
         p1 = &BIGIT(W(tc), xl - 1);
         for (i = xl, k = 1; k != 0 && i-- > 0; p1 -= 1)
           EADDC(0, *p1, p1, &k)
+        if (k) {
+          /* add carry bit back; we prepared a large enough bignum,
+             and since of all the middle are zero, we don't have to reshift */
+          BIGIT(W(tc), xl) = 0;
+          BIGIT(W(tc), 0) = 1;
+          xl++;
+        }
       }
     }
 
diff --git a/racket/src/ChezScheme/mats/5_3.ms b/racket/src/ChezScheme/mats/5_3.ms
index c51f040b1b..bb77e06e3d 100644
--- a/racket/src/ChezScheme/mats/5_3.ms
+++ b/racket/src/ChezScheme/mats/5_3.ms
@@ -3300,6 +3300,7 @@
    (eqv? (bitwise-arithmetic-shift 0 (- (expt 2 100))) 0)
    (eqv? (bitwise-arithmetic-shift 0 (expt 2 100)) 0)
    (eqv? (bitwise-arithmetic-shift 0 (expt 2 100)) 0)
+   (eqv? (- (expt 16 232)) (bitwise-arithmetic-shift (- 307 (expt 16 240)) -32))
    ($test-right-shift (lambda (x n) (bitwise-arithmetic-shift x (- n))))
 )
 
@@ -3348,6 +3349,7 @@
    (eqv? (bitwise-arithmetic-shift-right #x-8000000000000000 31) #x-100000000)
    (eqv? (bitwise-arithmetic-shift-right #x-8000000000000000 32) #x-80000000)
    (eqv? (bitwise-arithmetic-shift-right #x-8000000000000000 33) #x-40000000)
+   (eqv? (- (expt 16 232)) (bitwise-arithmetic-shift-right (- 307 (expt 16 240)) 32))
    ($test-right-shift (lambda (x n) (bitwise-arithmetic-shift-right x n)))
 )