From a3f1feefb9e72a4dd08973086709d5c5e92c377d Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Tue, 13 Nov 2007 22:17:02 -0500 Subject: [PATCH] * Added bitwise-bit-count --- scheme/ikarus.numerics.ss | 73 +++++++++++++++++++++++++++++---------- scheme/makefile.ss | 2 +- scheme/run-tests.ss | 1 + scheme/tests/bignums.ss | 26 +++++++++++++- scheme/todo-r6rs.ss | 2 +- 5 files changed, 83 insertions(+), 21 deletions(-) diff --git a/scheme/ikarus.numerics.ss b/scheme/ikarus.numerics.ss index 3e51661..765f147 100644 --- a/scheme/ikarus.numerics.ss +++ b/scheme/ikarus.numerics.ss @@ -2837,43 +2837,80 @@ (error 'fldiv0-and-mod0 "not a flonum" n)))) (library (ikarus bitwise misc) - (export bitwise-first-bit-set) + (export bitwise-first-bit-set + bitwise-bit-count) (import (ikarus system $fx) (ikarus system $bignums) - (except (ikarus) bitwise-first-bit-set)) + (except (ikarus) + bitwise-first-bit-set + bitwise-bit-count)) - (module (bitwise-first-bit-set) + (define (bitwise-first-bit-set x) (define (byte-first-bit-set x i) (case ($fxlogand x #b11) [(0) (byte-first-bit-set ($fxsra x 2) ($fx+ i 2))] [(2) ($fx+ i 1)] [else i])) - (define (fx-first-bit-set x i) (let ([y ($fxlogand x 255)]) (if ($fx= y 0) (fx-first-bit-set ($fxsra x 8) ($fx+ i 8)) (byte-first-bit-set y i)))) - (define (bn-first-bit-set x i idx) (let ([b ($bignum-byte-ref x idx)]) (if ($fxzero? b) (bn-first-bit-set x ($fx+ i 8) ($fx+ idx 1)) (byte-first-bit-set b i)))) - - (define (bitwise-first-bit-set x) - (cond - [(fixnum? x) - (if ($fx> x 0) - (fx-first-bit-set x 0) - (if ($fx= x 0) - -1 - (if ($fx> x (least-fixnum)) - (fx-first-bit-set ($fx- 0 x) 0) - (bn-first-bit-set (- x) 0 0))))] - [(bignum? x) (bn-first-bit-set x 0 0)] - [else (error 'bitwise-first-bit-set "not an exact integer" x)]))) + (cond + [(fixnum? x) + (if ($fx> x 0) + (fx-first-bit-set x 0) + (if ($fx= x 0) + -1 + (if ($fx> x (least-fixnum)) + (fx-first-bit-set ($fx- 0 x) 0) + (bn-first-bit-set (- x) 0 0))))] + [(bignum? x) (bn-first-bit-set x 0 0)] + [else (error 'bitwise-first-bit-set "not an exact integer" x)])) + + (define (bitwise-bit-count n) + (define (pos-fxbitcount n) + ;;; nifty parrallel count from: + ;;; http://infolab.stanford.edu/~manku/bitcount/bitcount.html + (let ([m0 #x15555555] + [m1 #x13333333] + [m2 #x0f0f0f0f]) + (let* ([n ($fx+ ($fxlogand n m0) ($fxlogand ($fxsra n 1) m0))] + [n ($fx+ ($fxlogand n m1) ($fxlogand ($fxsra n 2) m1))] + [n ($fx+ ($fxlogand n m2) ($fxlogand ($fxsra n 4) m2))]) + ($fxmodulo n 255)))) + (define (fxbitcount n) + (if ($fx< n 0) + (fxlognot (pos-fxbitcount (fxlognot n))) + (pos-fxbitcount n))) + (define (bnbitcount n) + (define (poscount x idx c) + (let ([c (+ c + ($fx+ (pos-fxbitcount + ($fxlogor + ($fxsll ($bignum-byte-ref x ($fx+ idx 3)) 8) + ($bignum-byte-ref x ($fx+ idx 2)))) + (pos-fxbitcount + ($fxlogor + ($fxsll ($bignum-byte-ref x ($fxadd1 idx)) 8) + ($bignum-byte-ref x idx)))))]) + (if ($fx= idx 0) + c + (poscount x ($fx- idx 4) c)))) + (if ($bignum-positive? n) + (poscount n ($fx- ($bignum-size n) 4) 0) + (let ([n (bitwise-not n)]) + (bitwise-not (poscount n ($fx- ($bignum-size n) 4) 0))))) + (cond + [(fixnum? n) (fxbitcount n)] + [(bignum? n) (bnbitcount n)] + [else (error 'bitwise-bit-count "not an exact integer" n)])) ) diff --git a/scheme/makefile.ss b/scheme/makefile.ss index c1cb99c..0d60186 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -756,7 +756,7 @@ [bitwise-and i r bw] [bitwise-ior r bw] [bitwise-xor r bw] - [bitwise-bit-count r bw] + [bitwise-bit-count i r bw] [bitwise-bit-field r bw] [bitwise-bit-set? r bw] [bitwise-copy-bit r bw] diff --git a/scheme/run-tests.ss b/scheme/run-tests.ss index 911286e..05a02f6 100755 --- a/scheme/run-tests.ss +++ b/scheme/run-tests.ss @@ -63,4 +63,5 @@ (test-fldiv0-and-mod0) (test-fxdiv-and-mod) (test-fxdiv0-and-mod0) +(test-bitwise-bit-count) (printf "Happy Happy Joy Joy\n") diff --git a/scheme/tests/bignums.ss b/scheme/tests/bignums.ss index c4f94f0..c77f0d1 100644 --- a/scheme/tests/bignums.ss +++ b/scheme/tests/bignums.ss @@ -1,5 +1,5 @@ (library (tests bignums) - (export test-bignums test-bignum-conversion) + (export test-bignums test-bignum-conversion test-bitwise-bit-count) (import (ikarus) (tests framework)) (define (test-bignum-conversion) @@ -19,6 +19,30 @@ (test -39487932748923498234)) + (define (test-bitwise-bit-count) + (define (test n) + (define (pos-count-bits n) + (if (zero? n) + 0 + (let ([c (count-bits (bitwise-arithmetic-shift-right n 1))]) + (if (even? n) c (+ c 1))))) + (define (count-bits n) + (if (>= n 0) + (pos-count-bits n) + (bitwise-not (pos-count-bits (bitwise-not n))))) + (let ([bc0 (bitwise-bit-count n)] + [bc1 (count-bits n)]) + (unless (= bc0 bc1) + (error 'test-bitcount "failed/expected/got" n bc1 bc0)))) + (define (test-fx n) + (when (fixnum? n) + (when (zero? (fxlogand n #x7FFFFFF)) + (printf "bitwise-bit-count ~s\n" n)) + (test n) + (test-fx (+ n 512)))) + (test-fx (least-fixnum)) + (test 28472347823493290482390849023840928390482309480923840923840983) + (test -847234234903290482390849023840928390482309480923840923840983)) (define-tests test-bignums ; first, some simple quotients diff --git a/scheme/todo-r6rs.ss b/scheme/todo-r6rs.ss index 4909401..30e6a2e 100755 --- a/scheme/todo-r6rs.ss +++ b/scheme/todo-r6rs.ss @@ -258,7 +258,7 @@ [bitwise-and C bw] [bitwise-ior S bw] [bitwise-xor S bw] - [bitwise-bit-count S bw] + [bitwise-bit-count C bw] [bitwise-bit-field S bw] [bitwise-bit-set? S bw] [bitwise-copy-bit S bw]