use radix literals

[factor.git] / basis / math / bitwise / bitwise.factor

diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor
old mode 100755 (executable)
new mode 100644 (file)
index cea944a..785f77c
--- a/basis/math/bitwise/bitwise.factor
+++ b/basis/math/bitwise/bitwise.factor
@@ -1,8 +1,10 @@
 ! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs kernel math sequences accessors
-math.bits sequences.private words namespaces macros
-hints combinators fry io.binary combinators.smart ;
+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 ;
+SPECIALIZED-ARRAY: uchar
 IN: math.bitwise
 
 ! utilities
@@ -14,35 +16,35 @@ IN: math.bitwise
 : mask ( x n -- ? ) bitand ; inline
 : mask? ( x n -- ? ) mask 0 > ; inline
 : wrap ( m n -- m' ) 1 - bitand ; inline
-: bits ( m n -- m' ) 2^ wrap ; inline
+: on-bits ( m -- n ) 2^ 1 - ; inline
+: bits ( m n -- m' ) on-bits mask ; inline
 : mask-bit ( m n -- m' ) 2^ mask ; inline
-: on-bits ( n -- m ) 2^ 1 - ; inline
 : toggle-bit ( m n -- m' ) 2^ bitxor ; inline
-
-: shift-mod ( n s w -- n )
-    [ shift ] dip 2^ wrap ; inline
+: >signed ( x n -- y )
+    [ bits ] keep 2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
+: >odd ( m -- n ) 0 set-bit ; foldable
+: >even ( m -- n ) 0 clear-bit ; foldable
+: 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
 
 : bitroll ( x s w -- y )
     [ wrap ] keep
     [ shift-mod ] [ [ - ] keep shift-mod ] 3bi bitor ; inline
 
-: bitroll-32 ( n s -- n' ) 32 bitroll ; inline
+: bitroll-32 ( m s -- n ) 32 bitroll ; inline
 
-: bitroll-64 ( n s -- n' ) 64 bitroll ; inline
+: bitroll-64 ( m s -- n ) 64 bitroll ; inline
 
 ! 32-bit arithmetic
-: w+ ( int int -- int ) + 32 bits ; inline
-: w- ( int int -- int ) - 32 bits ; inline
-: w* ( int int -- int ) * 32 bits ; inline
+: w+ ( x y -- z ) + 32 bits ; inline
+: w- ( x y -- z ) - 32 bits ; inline
+: w* ( x y -- z ) * 32 bits ; inline
 
 ! 64-bit arithmetic
-: W+ ( int int -- int ) + 64 bits ; inline
-: W- ( int int -- int ) - 64 bits ; inline
-: W* ( int int -- int ) * 64 bits ; inline
-
-! flags
-MACRO: flags ( values -- )
-    [ 0 ] [ [ ?execute bitor ] curry compose ] reduce ;
+: W+ ( x y -- z ) + 64 bits ; inline
+: W- ( x y -- z ) - 64 bits ; inline
+: W* ( x y -- z ) * 64 bits ; inline
 
 : symbols>flags ( symbols assoc -- flag-bits )
     [ at ] curry map
@@ -75,8 +77,8 @@ DEFER: byte-bit-count
 \ byte-bit-count
 256 iota [
     8 <bits> 0 [ [ 1 + ] when ] reduce
-] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ]
-(( byte -- table )) define-declared
+] B{ } map-as '[ 0xff bitand _ nth-unsafe ]
+( byte -- table ) define-declared
 
 \ byte-bit-count make-inline
 
@@ -84,41 +86,51 @@ DEFER: byte-bit-count
 
 GENERIC: (bit-count) ( x -- n )
 
+: fixnum-bit-count ( x -- n )
+    { fixnum } declare
+    {
+        [ byte-bit-count ]
+        [ -8 shift byte-bit-count + ]
+        [ -16 shift byte-bit-count + ]
+        [ -24 shift byte-bit-count + ]
+        [
+            cell 8 = [
+                {
+                    [ -32 shift byte-bit-count + ]
+                    [ -40 shift byte-bit-count + ]
+                    [ -48 shift byte-bit-count + ]
+                    [ -56 shift byte-bit-count + ]
+                } cleave >fixnum
+            ] [ drop ] if
+        ]
+    } cleave ;
+
 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 ;
+    fixnum-bit-count { fixnum } declare ; inline
 
 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 ; inline
+
 PRIVATE>
 
-: bit-count ( x -- n )
-    dup 0 < [ bitnot ] when (bit-count) ; inline
+ERROR: invalid-bit-count-target object ;
 
-! Signed byte array to integer conversion
-: signed-le> ( bytes -- x )
-    [ le> ] [ length 8 * 1 - on-bits ] bi
-    2dup > [ bitnot bitor ] [ drop ] if ;
+GENERIC: bit-count ( obj -- n )
 
-: signed-be> ( bytes -- x )
-    <reversed> signed-le> ;
+M: integer bit-count
+    dup 0 < [ invalid-bit-count-target ] when (bit-count) ; inline
 
-: >signed ( x n -- y )
-    2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
+M: byte-array bit-count
+    byte-array-bit-count ;
 
-: >odd ( n -- int ) 0 set-bit ; foldable
+M: object bit-count
+    binary-object uchar <c-direct-array> byte-array-bit-count ;
 
-: >even ( n -- int ) 0 clear-bit ; foldable
+: even-parity? ( obj -- ? ) bit-count even? ;
 
-: next-even ( m -- n ) >even 2 + ; foldable
-
-: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable
+: odd-parity? ( obj -- ? ) bit-count odd? ;