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

* Added fxbit-count.

This commit is contained in:
Abdulaziz Ghuloum 2007-11-13 22:33:37 -05:00
parent a3f1feefb9
commit de635ef3bd
3 changed files with 15 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
scheme/ikarus.numerics.ss
View File

@ -2838,13 +2838,13 @@
(library (ikarus bitwise misc) (library (ikarus bitwise misc)
(export bitwise-first-bit-set (export bitwise-first-bit-set
bitwise-bit-count) fxbit-count bitwise-bit-count)
(import (import
(ikarus system $fx) (ikarus system $fx)
(ikarus system $bignums) (ikarus system $bignums)
(except (ikarus) (except (ikarus)
bitwise-first-bit-set bitwise-first-bit-set
bitwise-bit-count)) fxbit-count bitwise-bit-count))
(define (bitwise-first-bit-set x) (define (bitwise-first-bit-set x)
(define (byte-first-bit-set x i) (define (byte-first-bit-set x i)
@ -2874,7 +2874,7 @@
[(bignum? x) (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)])) [else (error 'bitwise-first-bit-set "not an exact integer" x)]))
(define (bitwise-bit-count n) (module (fxbit-count bitwise-bit-count)
(define (pos-fxbitcount n) (define (pos-fxbitcount n)
;;; nifty parrallel count from: ;;; nifty parrallel count from:
;;; http://infolab.stanford.edu/~manku/bitcount/bitcount.html ;;; http://infolab.stanford.edu/~manku/bitcount/bitcount.html
@ -2885,7 +2885,7 @@
[n ($fx+ ($fxlogand n m1) ($fxlogand ($fxsra n 2) m1))] [n ($fx+ ($fxlogand n m1) ($fxlogand ($fxsra n 2) m1))]
[n ($fx+ ($fxlogand n m2) ($fxlogand ($fxsra n 4) m2))]) [n ($fx+ ($fxlogand n m2) ($fxlogand ($fxsra n 4) m2))])
($fxmodulo n 255)))) ($fxmodulo n 255))))
(define (fxbitcount n) (define ($fxbitcount n)
(if ($fx< n 0) (if ($fx< n 0)
(fxlognot (pos-fxbitcount (fxlognot n))) (fxlognot (pos-fxbitcount (fxlognot n)))
(pos-fxbitcount n))) (pos-fxbitcount n)))
@ -2907,10 +2907,15 @@
(poscount n ($fx- ($bignum-size n) 4) 0) (poscount n ($fx- ($bignum-size n) 4) 0)
(let ([n (bitwise-not n)]) (let ([n (bitwise-not n)])
(bitwise-not (poscount n ($fx- ($bignum-size n) 4) 0))))) (bitwise-not (poscount n ($fx- ($bignum-size n) 4) 0)))))
(cond (define (fxbit-count n)
[(fixnum? n) (fxbitcount n)] (cond
[(bignum? n) (bnbitcount n)] [(fixnum? n) ($fxbitcount n)]
[else (error 'bitwise-bit-count "not an exact integer" n)])) [else (error 'fxbit-count "not a fixnum" n)]))
(define (bitwise-bit-count n)
(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

@ -785,7 +785,7 @@
[fxarithmetic-shift i r fx] [fxarithmetic-shift i r fx]
[fxarithmetic-shift-left i r fx] [fxarithmetic-shift-left i r fx]
[fxarithmetic-shift-right i r fx] [fxarithmetic-shift-right i r fx]
[fxbit-count r fx] [fxbit-count i r fx]
[fxbit-field r fx] [fxbit-field r fx]
[fxbit-set? r fx] [fxbit-set? r fx]
[fxcopy-bit r fx] [fxcopy-bit r fx]

2
scheme/todo-r6rs.ss
View File

@ -288,7 +288,7 @@
[fxarithmetic-shift C fx] [fxarithmetic-shift C fx]
[fxarithmetic-shift-left C fx] [fxarithmetic-shift-left C fx]
[fxarithmetic-shift-right C fx] [fxarithmetic-shift-right C fx]
[fxbit-count S fx] [fxbit-count C fx]
[fxbit-field S fx] [fxbit-field S fx]
[fxbit-set? S fx] [fxbit-set? S fx]
[fxcopy-bit S fx] [fxcopy-bit S fx]