steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

math.bitwise: Fix bit-range and test it.

db4
Doug Coleman 2012-09-19 17:03:13 -07:00
parent c1850f416a
commit 8e8712efab
2 changed files with 15 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
basis/math/bitwise/bitwise-tests.factor
View File

@ -78,8 +78,6 @@ SPECIALIZED-ARRAY: uint-4
[ -1 bit-count ] [ invalid-bit-count-target? ] must-fail-with
{ 0b11 } [ 0b110000 5 4 bit-range ] unit-test
{ 0b1111 } [ 4 on-bits ] unit-test
{ 0 } [ 0 on-bits ] unit-test
{ 0 } [ -2 on-bits ] unit-test
@ -102,3 +100,11 @@ SPECIALIZED-ARRAY: uint-4
{ 0b10 } [ 0 1 toggle-bit ] unit-test
{ 0 } [ 0 0 toggle-bit 0 toggle-bit ] unit-test
{ 0 } [ 0 1 toggle-bit 1 toggle-bit ] unit-test
{ 0 } [ 0b1111 33 33 bit-range ] unit-test
{ 0 } [ 0b1111 33 20 bit-range ] unit-test
{ 0b11 } [ 0b1111 3 2 bit-range ] unit-test
[ 0b1111 2 3 bit-range ] [ T{ bit-range-error f 0b1111 2 3 } = ] must-fail-with
[ 0b1111 -2 -4 bit-range ] [ T{ bit-range-error f 0b1111 -2 -4 } = ] must-fail-with

11
basis/math/bitwise/bitwise.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs combinators combinators.smart fry kernel
macros math math.bits sequences sequences.private words
byte-arrays alien alien.c-types alien.data specialized-arrays
kernel.private layouts ;
USING: alien alien.c-types alien.data arrays assocs byte-arrays
combinators combinators.short-circuit fry kernel kernel.private
layouts macros math math.bits sequences sequences.private
specialized-arrays words ;
SPECIALIZED-ARRAY: uchar
IN: math.bitwise
@ -28,7 +28,10 @@ IN: math.bitwise
: next-even ( m -- n ) >even 2 + ; foldable
: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable
: shift-mod ( m s w -- n ) [ shift ] dip 2^ wrap ; inline
ERROR: bit-range-error x high low ;
: bit-range ( x high low -- y )
2dup { [ nip 0 < ] [ < ] } 2|| [ bit-range-error ] when
[ nip neg shift ] [ - 1 + ] 2bi bits ; inline
: bitroll ( x s w -- y )