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

* Added fxfirst-bit-set.

This commit is contained in:
Abdulaziz Ghuloum 2007-11-15 06:33:21 -05:00
parent 745c3be26e
commit 42866c21c3
3 changed files with 43 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
scheme/ikarus.fixnums.ss
View File

@ -565,3 +565,4 @@
(error 'fxmod0 "not a fixnum" x))) (error 'fxmod0 "not a fixnum" x)))
) )

63
scheme/ikarus.numerics.ss
View File

@ -2886,7 +2886,7 @@
(error 'fldiv0-and-mod0 "not a flonum" n)))) (error 'fldiv0-and-mod0 "not a flonum" n))))
(library (ikarus bitwise misc) (library (ikarus bitwise misc)
(export bitwise-first-bit-set (export fxfirst-bit-set bitwise-first-bit-set
fxbit-count bitwise-bit-count fxbit-count bitwise-bit-count
fxlength) fxlength)
(import (import
@ -2894,37 +2894,56 @@
(ikarus system $bignums) (ikarus system $bignums)
(ikarus system $flonums) (ikarus system $flonums)
(except (ikarus) (except (ikarus)
bitwise-first-bit-set fxfirst-bit-set bitwise-first-bit-set
fxbit-count bitwise-bit-count fxbit-count bitwise-bit-count
fxlength)) fxlength))
(define (bitwise-first-bit-set x) (module (bitwise-first-bit-set fxfirst-bit-set)
(define (byte-first-bit-set x i) (define (byte-first-bit-set x i)
(case ($fxlogand x #b11) (import (ikarus system $bytevectors))
[(0) (byte-first-bit-set ($fxsra x 2) ($fx+ i 2))] (define-syntax make-first-bit-set-bytevector
[(2) ($fx+ i 1)] (lambda (x)
[else i])) (define (fst n)
(define (fx-first-bit-set x i) (cond
[(zero? n) 0]
[(even? n) (fst (bitwise-arithmetic-shift-right n 1))]
[else (+ 1 (fst (bitwise-arithmetic-shift-right n 1)))]))
(u8-list->bytevector
(let f ([i 0])
(cond
[(= i 256) '()]
[else (cons (fst i) (f (+ i 1)))])))))
(define bv (make-first-bit-set-bytevector))
($fx+ i ($bytevector-u8-ref bv i)))
(define ($fxloop x i)
(let ([y ($fxlogand x 255)]) (let ([y ($fxlogand x 255)])
(if ($fx= y 0) (if ($fx= y 0)
(fx-first-bit-set ($fxsra x 8) ($fx+ i 8)) ($fxloop ($fxsra x 8) ($fx+ i 8))
(byte-first-bit-set y i)))) (byte-first-bit-set y i))))
(define (bn-first-bit-set x i idx) (define ($bnloop x i idx)
(let ([b ($bignum-byte-ref x idx)]) (let ([b ($bignum-byte-ref x idx)])
(if ($fxzero? b) (if ($fxzero? b)
(bn-first-bit-set x ($fx+ i 8) ($fx+ idx 1)) ($bnloop x ($fx+ i 8) ($fx+ idx 1))
(byte-first-bit-set b i)))) (byte-first-bit-set b i))))
(cond (define ($fxfirst-bit-set x)
[(fixnum? x) (if ($fx> x 0)
(if ($fx> x 0) ($fxloop x 0)
(fx-first-bit-set x 0) (if ($fx= x 0)
(if ($fx= x 0) -1
-1 (if ($fx> x (least-fixnum))
(if ($fx> x (least-fixnum)) ($fxloop ($fx- 0 x) 0)
(fx-first-bit-set ($fx- 0 x) 0) ($bnloop (- x) 0 0)))))
(bn-first-bit-set (- x) 0 0))))] (define (fxfirst-bit-set x)
[(bignum? x) (bn-first-bit-set x 0 0)] (cond
[else (error 'bitwise-first-bit-set "not an exact integer" x)])) [(fixnum? x)
($fxfirst-bit-set x)]
[else (error 'fxfirst-bit-set "not a fixnum" x)]))
(define (bitwise-first-bit-set x)
(cond
[(fixnum? x)
($fxfirst-bit-set x)]
[(bignum? x) ($bnloop x 0 0)]
[else (error 'bitwise-first-bit-set "not an exact integer" x)])))
(module (fxbit-count bitwise-bit-count) (module (fxbit-count bitwise-bit-count)
(define (pos-fxbitcount n) (define (pos-fxbitcount n)

2
scheme/makefile.ss
View File

@ -796,7 +796,7 @@
[fxdiv0 i r fx] [fxdiv0 i r fx]
[fxdiv0-and-mod0 i r fx] [fxdiv0-and-mod0 i r fx]
[fxeven? i r fx] [fxeven? i r fx]
[fxfirst-bit-set r fx] [fxfirst-bit-set i r fx]
[fxif i r fx] [fxif i r fx]
[fxior i r fx] [fxior i r fx]
[fxlength i r fx] [fxlength i r fx]