summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2016-06-21 09:32:30 +0200
committerAndy Wingo <wingo@pobox.com>2016-06-21 09:32:30 +0200
commitbeea6302e06e7e41b1b835b2327febc97177010e (patch)
treec6827adc5e0606f3c22f5209ce0822b4c320af5b
parent845c873acf8cb57766dfbd565640a84d5d05ddb0 (diff)
downloadguile-beea6302e06e7e41b1b835b2327febc97177010e.tar.gz
Fix fixnum-range changes in R6RS fixnum bitops
* module/rnrs/arithmetic/fixnums.scm (fxcopy-bit, fxbit-field) (fxcopy-bit-field, fxarithmetic-shift) (fxarithmetic-shift-left, fx-arithmetic-shift-right) (fxrotate-bit-field, fxreverse-bit-field): Enforce range on amount by which to shift. Fixes #14917. * test-suite/tests/r6rs-arithmetic-fixnums.test ("fxarithmetic-shift-left"): Update test to not shift left by a negative amount.
-rw-r--r--module/rnrs/arithmetic/fixnums.scm28
-rw-r--r--test-suite/tests/r6rs-arithmetic-fixnums.test2
2 files changed, 26 insertions, 4 deletions
diff --git a/module/rnrs/arithmetic/fixnums.scm b/module/rnrs/arithmetic/fixnums.scm
index 7a5a6215e..4ec1cae0c 100644
--- a/module/rnrs/arithmetic/fixnums.scm
+++ b/module/rnrs/arithmetic/fixnums.scm
@@ -242,28 +242,50 @@
(define (fxcopy-bit fx1 fx2 fx3)
(assert-fixnum fx1 fx2 fx3)
+ (unless (and (<= 0 fx2) (< fx2 (fixnum-width)))
+ (raise (make-assertion-violation)))
(bitwise-copy-bit fx1 fx2 fx3))
(define (fxbit-field fx1 fx2 fx3)
(assert-fixnum fx1 fx2 fx3)
+ (unless (and (<= 0 fx2 fx3) (< fx3 (fixnum-width)))
+ (raise (make-assertion-violation)))
(bitwise-bit-field fx1 fx2 fx3))
(define (fxcopy-bit-field fx1 fx2 fx3 fx4)
(assert-fixnum fx1 fx2 fx3 fx4)
+ (unless (and (<= 0 fx2 fx3) (< fx3 (fixnum-width)))
+ (raise (make-assertion-violation)))
(bitwise-copy-bit-field fx1 fx2 fx3 fx4))
- (define (fxarithmetic-shift fx1 fx2) (assert-fixnum fx1 fx2) (ash fx1 fx2))
- (define fxarithmetic-shift-left fxarithmetic-shift)
+ (define (fxarithmetic-shift fx1 fx2)
+ (assert-fixnum fx1 fx2)
+ (unless (< (abs fx2) (fixnum-width))
+ (raise (make-assertion-violation)))
+ (ash fx1 fx2))
+
+ (define (fxarithmetic-shift-left fx1 fx2)
+ (assert-fixnum fx1 fx2)
+ (unless (and (<= 0 fx2) (< fx2 (fixnum-width)))
+ (raise (make-assertion-violation)))
+ (ash fx1 fx2))
(define (fxarithmetic-shift-right fx1 fx2)
- (assert-fixnum fx1 fx2) (ash fx1 (- fx2)))
+ (assert-fixnum fx1 fx2)
+ (unless (and (<= 0 fx2) (< fx2 (fixnum-width)))
+ (raise (make-assertion-violation)))
+ (ash fx1 (- fx2)))
(define (fxrotate-bit-field fx1 fx2 fx3 fx4)
(assert-fixnum fx1 fx2 fx3 fx4)
+ (unless (and (<= 0 fx2 fx3) (< fx3 (fixnum-width)) (< fx4 (- fx3 fx2)))
+ (raise (make-assertion-violation)))
(bitwise-rotate-bit-field fx1 fx2 fx3 fx4))
(define (fxreverse-bit-field fx1 fx2 fx3)
(assert-fixnum fx1 fx2 fx3)
+ (unless (and (<= 0 fx2 fx3) (< fx3 (fixnum-width)))
+ (raise (make-assertion-violation)))
(bitwise-reverse-bit-field fx1 fx2 fx3))
)
diff --git a/test-suite/tests/r6rs-arithmetic-fixnums.test b/test-suite/tests/r6rs-arithmetic-fixnums.test
index 2d9b177f7..9f244722f 100644
--- a/test-suite/tests/r6rs-arithmetic-fixnums.test
+++ b/test-suite/tests/r6rs-arithmetic-fixnums.test
@@ -202,7 +202,7 @@
(fx=? (fxarithmetic-shift -1 -1) -1))))
(with-test-prefix "fxarithmetic-shift-left"
- (pass-if "simple" (fx=? (fxarithmetic-shift-left -6 -1) -3)))
+ (pass-if "simple" (fx=? (fxarithmetic-shift-left -6 1) -12)))
(with-test-prefix "fxarithmetic-shift-right"
(pass-if "simple" (fx=? (fxarithmetic-shift-right -6 1) -3)))