mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-09 15:10:29 +02:00
Code Activity

Add 'round-ash', a rounding arithmetic shift operator

Browse source 
* libguile/numbers.c (left_shift_exact_integer,
  floor_right_shift_exact_integer, round_right_shift_exact_integer): New
  static functions.

  (scm_round_ash): New procedure.

  (scm_ash): Reimplement in terms of 'left_shift_exact_integer' and
  'floor_right_shift_exact_integer'.

* libguile/numbers.h: Add prototype for scm_round_ash.  Rename the
  second argument of 'scm_ash' from 'cnt' to 'count'.

* test-suite/tests/numbers.test (round-ash, ash): Add new unified
  testing framework for 'ash' and 'round-ash'.  Previously, the tests
  for 'ash' were not very comprehensive; for example, they did not
  include a single test where the number to be shifted was a bignum.

* doc/ref/api-data.texi (Bitwise Operations): Add documentation for
  'round-ash'.  Improve documentation for `ash'.
This commit is contained in:
Mark H Weaver 2013-03-03 04:35:09 -05:00
parent a285b18ca8
commit e08a12b535
4 changed files with 234 additions and 153 deletions
Download patch file Download diff file Expand all files Collapse all files

114
test-suite/tests/numbers.test
View file

@ -200,71 +200,6 @@
(pass-if "1- fixnum = bignum (64-bit)"
(eqv? -2305843009213693953 (1- -2305843009213693952))))
;;;
;;; ash
;;;
(with-test-prefix "ash"
(pass-if "documented?"
(documented? ash))
(pass-if (eqv? 0 (ash 0 0)))
(pass-if (eqv? 0 (ash 0 1)))
(pass-if (eqv? 0 (ash 0 1000)))
(pass-if (eqv? 0 (ash 0 -1)))
(pass-if (eqv? 0 (ash 0 -1000)))
(pass-if (eqv? 1 (ash 1 0)))
(pass-if (eqv? 2 (ash 1 1)))
(pass-if (eqv? 340282366920938463463374607431768211456 (ash 1 128)))
(pass-if (eqv? 0 (ash 1 -1)))
(pass-if (eqv? 0 (ash 1 -1000)))
(pass-if (eqv? -1 (ash -1 0)))
(pass-if (eqv? -2 (ash -1 1)))
(pass-if (eqv? -340282366920938463463374607431768211456 (ash -1 128)))
(pass-if (eqv? -1 (ash -1 -1)))
(pass-if (eqv? -1 (ash -1 -1000)))
(pass-if (eqv? -3 (ash -3 0)))
(pass-if (eqv? -6 (ash -3 1)))
(pass-if (eqv? -1020847100762815390390123822295304634368 (ash -3 128)))
(pass-if (eqv? -2 (ash -3 -1)))
(pass-if (eqv? -1 (ash -3 -1000)))
(pass-if (eqv? -6 (ash -23 -2)))
(pass-if (eqv? most-positive-fixnum (ash most-positive-fixnum 0)))
(pass-if (eqv? (* 2 most-positive-fixnum) (ash most-positive-fixnum 1)))
(pass-if (eqv? (* 4 most-positive-fixnum) (ash most-positive-fixnum 2)))
(pass-if
(eqv? (* most-positive-fixnum 340282366920938463463374607431768211456)
(ash most-positive-fixnum 128)))
(pass-if (eqv? (quotient most-positive-fixnum 2)
(ash most-positive-fixnum -1)))
(pass-if (eqv? 0 (ash most-positive-fixnum -1000)))
(let ((mpf4 (quotient most-positive-fixnum 4)))
(pass-if (eqv? (* 2 mpf4) (ash mpf4 1)))
(pass-if (eqv? (* 4 mpf4) (ash mpf4 2)))
(pass-if (eqv? (* 8 mpf4) (ash mpf4 3))))
(pass-if (eqv? most-negative-fixnum (ash most-negative-fixnum 0)))
(pass-if (eqv? (* 2 most-negative-fixnum) (ash most-negative-fixnum 1)))
(pass-if (eqv? (* 4 most-negative-fixnum) (ash most-negative-fixnum 2)))
(pass-if
(eqv? (* most-negative-fixnum 340282366920938463463374607431768211456)
(ash most-negative-fixnum 128)))
(pass-if (eqv? (quotient-floor most-negative-fixnum 2)
(ash most-negative-fixnum -1)))
(pass-if (eqv? -1 (ash most-negative-fixnum -1000)))
(let ((mnf4 (quotient-floor most-negative-fixnum 4)))
(pass-if (eqv? (* 2 mnf4) (ash mnf4 1)))
(pass-if (eqv? (* 4 mnf4) (ash mnf4 2)))
(pass-if (eqv? (* 8 mnf4) (ash mnf4 3)))))
;;;
;;; exact?
;;;
@ -4914,3 +4849,52 @@
round-quotient
round-remainder
valid-round-answer?)))
;;;
;;; ash
;;; round-ash
;;;
(let ()
(define (test-ash-variant name ash-variant round-variant)
(with-test-prefix name
(define (test n count)
(pass-if (list n count)
(eqv? (ash-variant n count)
(round-variant (* n (expt 2 count))))))
(pass-if "documented?"
(documented? ash-variant))
(for-each (lambda (n)
(for-each (lambda (count) (test n count))
'(-1000 -3 -2 -1 0 1 2 3 1000)))
(list 0 1 3 23 -1 -3 -23
fixnum-max
(1+ fixnum-max)
(1- fixnum-max)
(* fixnum-max 4)
(quotient fixnum-max 4)
fixnum-min
(1+ fixnum-min)
(1- fixnum-min)
(* fixnum-min 4)
(quotient fixnum-min 4)))
(do ((count -2 (1- count))
(vals '(1 3 5 7 9 11)
(map (lambda (n) (* 2 n)) vals)))
((> (car vals) (* 2 fixnum-max)) 'done)
(for-each (lambda (n)
(test n count)
(test (- n) count))
vals))
;; Test rounding
(for-each (lambda (base)
(for-each (lambda (offset) (test (+ base offset) -3))
'(#b11001 #b11100 #b11101 #b10001 #b10100 #b10101)))
(list 0 64 -64 (* 64 fixnum-max) (* 64 fixnum-min)))))
(test-ash-variant 'ash ash floor)
(test-ash-variant 'round-ash round-ash round))