diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2020-07-27 14:50:37 +0200 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-07-28 02:02:27 -0400 |
| commit | 6ee07b494ddd0131d53ea2fd6a4bb29cd05f4dd8 (patch) | |
| tree | cd98755c2466c9fdb6a736a8442d55fa44ac4bf3 /libraries | |
| parent | 0bd60059b0edfee9e8f66c6817257bbb946656cd (diff) | |
| download | haskell-6ee07b494ddd0131d53ea2fd6a4bb29cd05f4dd8.tar.gz | |
Bignum: add support for negative shifts (fix #18499)
shiftR/shiftL support negative arguments despite Haskell 2010 report
saying otherwise. We explicitly test for negative values which is bad
(it gets in the way of constant folding, etc.). Anyway, for consistency
we fix Bits instancesof Integer/Natural.
Diffstat (limited to 'libraries')
| -rw-r--r-- | libraries/base/Data/Bits.hs | 20 |
1 files changed, 16 insertions, 4 deletions
diff --git a/libraries/base/Data/Bits.hs b/libraries/base/Data/Bits.hs index 5379eac571..89702105eb 100644 --- a/libraries/base/Data/Bits.hs +++ b/libraries/base/Data/Bits.hs @@ -537,8 +537,14 @@ instance Bits Integer where (.|.) = integerOr xor = integerXor complement = integerComplement - shiftR x i = integerShiftR x (fromIntegral i) - shiftL x i = integerShiftL x (fromIntegral i) + unsafeShiftR x i = integerShiftR x (fromIntegral i) + unsafeShiftL x i = integerShiftL x (fromIntegral i) + shiftR x i@(I# i#) + | isTrue# (i# >=# 0#) = unsafeShiftR x i + | otherwise = overflowError + shiftL x i@(I# i#) + | isTrue# (i# >=# 0#) = unsafeShiftL x i + | otherwise = overflowError shift x i | i >= 0 = integerShiftL x (fromIntegral i) | otherwise = integerShiftR x (fromIntegral (negate i)) testBit x i = integerTestBit x (fromIntegral i) @@ -560,8 +566,14 @@ instance Bits Natural where xor = naturalXor complement _ = errorWithoutStackTrace "Bits.complement: Natural complement undefined" - shiftR x i = naturalShiftR x (fromIntegral i) - shiftL x i = naturalShiftL x (fromIntegral i) + unsafeShiftR x i = naturalShiftR x (fromIntegral i) + unsafeShiftL x i = naturalShiftL x (fromIntegral i) + shiftR x i@(I# i#) + | isTrue# (i# >=# 0#) = unsafeShiftR x i + | otherwise = overflowError + shiftL x i@(I# i#) + | isTrue# (i# >=# 0#) = unsafeShiftL x i + | otherwise = overflowError shift x i | i >= 0 = naturalShiftL x (fromIntegral i) | otherwise = naturalShiftR x (fromIntegral (negate i)) |