mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Fix fixnum-range changes in R6RS fixnum bitops

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2016-06-21 09:32:30 +02:00
parent 845c873acf
commit beea6302e0
2 changed files with 26 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

28
module/rnrs/arithmetic/fixnums.scm
View file

@ -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))
)

2
test-suite/tests/r6rs-arithmetic-fixnums.test
View file

@ -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)))