conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* Added bitwise-bit-count

This commit is contained in:
Abdulaziz Ghuloum 2007-11-13 22:17:02 -05:00
parent a0ba3d3d4f
commit a3f1feefb9
5 changed files with 83 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
scheme/ikarus.numerics.ss
View File

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

2
scheme/makefile.ss
View File

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

1
scheme/run-tests.ss
View File

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

26
scheme/tests/bignums.ss
View File

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

2
scheme/todo-r6rs.ss
View File

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