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

* Added fxlength

This commit is contained in:
Abdulaziz Ghuloum 2007-11-13 23:24:21 -05:00
parent e06b84e75d
commit 82eda09ea0
5 changed files with 52 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
scheme/ikarus.numerics.ss
View File

@ -2838,13 +2838,16 @@
(library (ikarus bitwise misc)
(export bitwise-first-bit-set
fxbit-count bitwise-bit-count)
fxbit-count bitwise-bit-count
fxlength)
(import
(ikarus system $fx)
(ikarus system $bignums)
(ikarus system $flonums)
(except (ikarus)
bitwise-first-bit-set
fxbit-count bitwise-bit-count))
fxbit-count bitwise-bit-count
fxlength))
(define (bitwise-first-bit-set x)
(define (byte-first-bit-set x i)
@ -2917,6 +2920,19 @@
[(bignum? n) (bnbitcount n)]
[else (error 'bitwise-bit-count "not an exact integer" n)])))
(define (fxlength x)
(if (fixnum? x)
(let ([fl ($fixnum->flonum
(if ($fx< x 0) ($fxlognot x) x))])
(let ([sbe ($fxlogor
($fxsll ($flonum-u8-ref fl 0) 4)
($fxsra ($flonum-u8-ref fl 1) 4))])
(cond
[($fx= sbe 0) 0]
[else ($fx- sbe 1022)])))
(error 'fxlength "not a fixnum" x)))
)

2
scheme/makefile.ss
View File

@ -798,7 +798,7 @@
[fxfirst-bit-set r fx]
[fxif i r fx]
[fxior i r fx]
[fxlength r fx]
[fxlength i r fx]
[fxmax i r fx]
[fxmin i r fx]
[fxmod i r fx]

1
scheme/run-tests.ss
View File

@ -63,5 +63,6 @@
(test-fldiv0-and-mod0)
(test-fxdiv-and-mod)
(test-fxdiv0-and-mod0)
(test-fxlength)
(test-bitwise-bit-count)
(printf "Happy Happy Joy Joy\n")

32
scheme/tests/fixnums.ss
View File

@ -1,6 +1,7 @@
(library (tests fixnums)
(export test-fxdiv-and-mod test-fxdiv0-and-mod0)
(export test-fxdiv-and-mod test-fxdiv0-and-mod0
test-fxlength)
(import (ikarus))
(define (test-fxdiv-and-mod)
@ -82,5 +83,34 @@
(test (least-fixnum) (greatest-fixnum))
(test (greatest-fixnum) (greatest-fixnum)))
(define (test-fxlength)
(define (test x)
(define (bitlen x)
(if (zero? x)
0
(+ 1 (bitlen (bitwise-arithmetic-shift-right x 1)))))
(define (len x)
(if (< x 0)
(bitlen (bitwise-not x))
(bitlen x)))
(let ([c0 (len x)]
[c1 (fxlength x)])
(unless (= c0 c1)
(error 'test-fxlength "failed/expected/got" x c0 c1))))
(define (fxtest x)
(when (fixnum? x)
(when (zero? (bitwise-and x #xFFFFFFF))
(printf "fxlength ~s\n" x))
(test x)
(fxtest (+ x #x100))))
(test 0)
(test 1)
(test 2)
(test 3)
(test -1)
(test -2)
(test -3)
(fxtest (least-fixnum)))
)

2
scheme/todo-r6rs.ss
View File

@ -301,7 +301,7 @@
[fxfirst-bit-set S fx]
[fxif C fx]
[fxior C fx]
[fxlength S fx]
[fxlength C fx]
[fxmax C fx]
[fxmin C fx]
[fxmod C fx]