1 ! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays assocs combinators combinators.smart fry kernel
4 macros math math.bits sequences sequences.private words
5 byte-arrays alien alien.c-types specialized-arrays ;
6 SPECIALIZED-ARRAY: uchar
10 : clear-bit ( x n -- y ) 2^ bitnot bitand ; inline
11 : set-bit ( x n -- y ) 2^ bitor ; inline
12 : bit-clear? ( x n -- ? ) 2^ bitand 0 = ; inline
13 : unmask ( x n -- ? ) bitnot bitand ; inline
14 : unmask? ( x n -- ? ) unmask 0 > ; inline
15 : mask ( x n -- ? ) bitand ; inline
16 : mask? ( x n -- ? ) mask 0 > ; inline
17 : wrap ( m n -- m' ) 1 - bitand ; inline
18 : on-bits ( m -- n ) 2^ 1 - ; inline
19 : bits ( m n -- m' ) on-bits mask ; inline
20 : mask-bit ( m n -- m' ) 2^ mask ; inline
21 : toggle-bit ( m n -- m' ) 2^ bitxor ; inline
22 : >signed ( x n -- y )
23 [ bits ] keep 2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
24 : >odd ( m -- n ) 0 set-bit ; foldable
25 : >even ( m -- n ) 0 clear-bit ; foldable
26 : next-even ( m -- n ) >even 2 + ; foldable
27 : next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable
28 : shift-mod ( m s w -- n ) [ shift ] dip 2^ wrap ; inline
30 : bitroll ( x s w -- y )
32 [ shift-mod ] [ [ - ] keep shift-mod ] 3bi bitor ; inline
34 : bitroll-32 ( m s -- n ) 32 bitroll ; inline
36 : bitroll-64 ( m s -- n ) 64 bitroll ; inline
39 : w+ ( x y -- z ) + 32 bits ; inline
40 : w- ( x y -- z ) - 32 bits ; inline
41 : w* ( x y -- z ) * 32 bits ; inline
44 : W+ ( x y -- z ) + 64 bits ; inline
45 : W- ( x y -- z ) - 64 bits ; inline
46 : W* ( x y -- z ) * 64 bits ; inline
48 : symbols>flags ( symbols assoc -- flag-bits )
55 GENERIC: (bitfield-quot) ( spec -- quot )
57 M: integer (bitfield-quot) ( spec -- quot )
58 [ swapd shift bitor ] curry ;
60 M: pair (bitfield-quot) ( spec -- quot )
61 first2 over word? [ [ swapd execute ] dip ] [ ] ?
62 [ shift bitor ] append 2curry ;
66 MACRO: bitfield ( bitspec -- )
67 [ 0 ] [ (bitfield-quot) compose ] reduce ;
78 8 <bits> 0 [ [ 1 + ] when ] reduce
79 ] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ]
80 (( byte -- table )) define-declared
82 \ byte-bit-count make-inline
86 GENERIC: (bit-count) ( x -- n )
88 : fixnum-bit-count ( x -- n )
92 [ 8 bits byte-bit-count ] [ -8 shift ] bi
97 fixnum-bit-count ; inline
101 [ byte-bit-count ] [ -8 shift (bit-count) ] bi +
104 : byte-array-bit-count ( byte-array -- n )
105 0 [ byte-bit-count + ] reduce ; inline
109 ERROR: invalid-bit-count-target object ;
111 GENERIC: bit-count ( obj -- n )
114 dup 0 < [ invalid-bit-count-target ] when (bit-count) ; inline
116 M: byte-array bit-count
117 byte-array-bit-count ;
120 binary-object <direct-uchar-array> byte-array-bit-count ;
122 : even-parity? ( obj -- ? ) bit-count even? ;
124 : odd-parity? ( obj -- ? ) bit-count odd? ;