! 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 specialized-arrays ;
+byte-arrays alien alien.c-types alien.data specialized-arrays
+kernel.private layouts ;
SPECIALIZED-ARRAY: uchar
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
\ 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
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)
- 0 swap [
- dup 0 >
- ] [
- [ 8 bits byte-bit-count ] [ -8 shift ] bi
- [ + ] dip
- ] while drop ;
+ fixnum-bit-count { fixnum } declare ; inline
M: bignum (bit-count)
dup 0 = [ drop 0 ] [
] if ;
: byte-array-bit-count ( byte-array -- n )
- 0 [ byte-bit-count + ] reduce ;
+ 0 [ byte-bit-count + ] reduce ; inline
PRIVATE>
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 ;
-
-: >odd ( n -- int ) 0 set-bit ; foldable
-
-: >even ( n -- int ) 0 clear-bit ; foldable
-
-: next-even ( m -- n ) >even 2 + ; foldable
-
-: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable
+ binary-object uchar <c-direct-array> byte-array-bit-count ;
: even-parity? ( obj -- ? ) bit-count even? ;