fix a bug in bit-count that assumed 32bit fixnums, make bit-count work on byte-arrays...

diff --git a/basis/math/bitwise/bitwise-docs.factor b/basis/math/bitwise/bitwise-docs.factor
index 2d487a621a094344c2d7ae020d3c32f4578c85b6..5dce9646f4e53283aba051ca5ad3b367263d57fe 100755 (executable)
--- a/basis/math/bitwise/bitwise-docs.factor
+++ b/basis/math/bitwise/bitwise-docs.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs help.markup help.syntax math sequences ;
+USING: assocs help.markup help.syntax math sequences kernel ;
 IN: math.bitwise
 
 HELP: bitfield
@@ -67,17 +67,21 @@ HELP: bit-clear?
 
 HELP: bit-count
 { $values
-     { "x" integer }
+     { "obj" object }
      { "n" integer }
 }
-{ $description "Returns the number of set bits as an integer." }
+{ $description "Returns the number of set bits as an object. This word only works on non-negative integers or objects that can be represented as a byte-array." }
 { $examples 
     { $example "USING: math.bitwise prettyprint ;"
                "HEX: f0 bit-count ."
                "4"
     }
     { $example "USING: math.bitwise prettyprint ;"
-               "-7 bit-count ."
+               "-1 32 bits bit-count ."
+               "32"
+    }
+    { $example "USING: math.bitwise prettyprint ;"
+               "B{ 1 0 1 } bit-count ."
                "2"
     }
 } ;
@@ -206,6 +210,20 @@ HELP: mask?
     }
 } ;
 
+HELP: even-parity?
+{ $values
+    { "obj" object }
+    { "?" boolean }
+}
+{ $description "Returns true if the number of set bits in an object is even." } ;
+
+HELP: odd-parity?
+{ $values
+    { "obj" object }
+    { "?" boolean }
+}
+{ $description "Returns true if the number of set bits in an object is odd." } ;
+
 HELP: on-bits
 { $values
      { "n" integer }
@@ -368,6 +386,8 @@ $nl
 { $subsections on-bits }
 "Counting the number of set bits:"
 { $subsections bit-count }
+"Testing the parity of an object:"
+{ $subsections even-parity? odd-parity? }
 "More efficient modding by powers of two:"
 { $subsections wrap }
 "Bit-rolling:"

diff --git a/basis/math/bitwise/bitwise-tests.factor b/basis/math/bitwise/bitwise-tests.factor
index d1e6c11b6c900a84e2a73afd1f4620d3335156fa..d10e4ccc87df42a1f1599e01191420bd93a2f81a 100644 (file)
--- a/basis/math/bitwise/bitwise-tests.factor
+++ b/basis/math/bitwise/bitwise-tests.factor
@@ -1,4 +1,7 @@
-USING: accessors math math.bitwise tools.test kernel words ;
+USING: accessors math math.bitwise tools.test kernel words
+specialized-arrays alien.c-types math.vectors.simd
+sequences destructors libc ;
+SPECIALIZED-ARRAY: int
 IN: math.bitwise.tests
 
 [ 0 ] [ 1 0 0 bitroll ] unit-test
@@ -37,3 +40,23 @@ CONSTANT: b 2
 [ 4 ] [ BIN: 1010101 bit-count ] unit-test
 [ 0 ] [ BIN: 0 bit-count ] unit-test
 [ 1 ] [ BIN: 1 bit-count ] unit-test
+
+SIMD: uint
+SPECIALIZED-ARRAY: uint
+SPECIALIZED-ARRAY: uint-4
+
+[ 1 ] [ uint-4{ 1 0 0 0 } bit-count ] unit-test
+
+[ 1 ] [
+    [
+        2 malloc-int-array &free 1 0 pick set-nth bit-count
+    ] with-destructors
+] unit-test
+
+[ 1 ] [ B{ 1 0 0 } bit-count ] unit-test
+[ 3 ] [ B{ 1 1 1 } bit-count ] unit-test
+
+[ t ] [ BIN: 0 even-parity? ] unit-test
+[ f ] [ BIN: 1 even-parity? ] unit-test
+[ f ] [ BIN: 0 odd-parity? ] unit-test
+[ t ] [ BIN: 1 odd-parity? ] unit-test

diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor
index bed065a800c0fc4eaf3f5de5eb71dec9eca366af..204f2959447ac0e1e7ef4a56d99620f2abc1935c 100755 (executable)
--- a/basis/math/bitwise/bitwise.factor
+++ b/basis/math/bitwise/bitwise.factor
@@ -1,7 +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 ;
+macros math math.bits sequences sequences.private words
+byte-arrays alien alien.c-types specialized-arrays ;
+SPECIALIZED-ARRAY: uchar
 IN: math.bitwise
 
 ! utilities
@@ -84,24 +86,36 @@ DEFER: byte-bit-count
 GENERIC: (bit-count) ( x -- n )
 
 M: fixnum (bit-count)
-    [
-        {
-            [           byte-bit-count ]
-            [ -8  shift byte-bit-count ]
-            [ -16 shift byte-bit-count ]
-            [ -24 shift byte-bit-count ]
-        } cleave
-    ] sum-outputs ;
+    0 swap [
+        dup 0 >
+    ] [
+        [ 8 bits byte-bit-count ] [ -8 shift ] bi
+        [ + ] dip
+    ] while drop ;
 
 M: bignum (bit-count)
     dup 0 = [ drop 0 ] [
         [ byte-bit-count ] [ -8 shift (bit-count) ] bi +
     ] if ;
 
+: byte-array-bit-count ( byte-array -- n )
+    0 [ byte-bit-count + ] reduce ;
+
 PRIVATE>
 
-: bit-count ( x -- n )
-    dup 0 < [ bitnot ] when (bit-count) ; inline
+ERROR: invalid-bit-count-target object ;
+
+GENERIC: bit-count ( obj -- n )
+
+M: integer bit-count
+    dup 0 < [ invalid-bit-count-target ] when (bit-count) ; inline
+
+M: byte-array bit-count
+    byte-array-bit-count ;
+
+M: object bit-count
+    [ >c-ptr ] [ byte-length ] bi <direct-uchar-array>
+    byte-array-bit-count ;
 
 : >signed ( x n -- y )
     2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
@@ -113,3 +127,7 @@ PRIVATE>
 : next-even ( m -- n ) >even 2 + ; foldable
 
 : next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable
+
+: even-parity? ( obj -- ? ) bit-count even? ;
+
+: odd-parity? ( obj -- ? ) bit-count odd? ;