1 ! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: alien alien.c-types alien.data arrays assocs byte-arrays
4 combinators combinators.short-circuit kernel kernel.private
5 layouts math math.bits sequences sequences.private
6 specialized-arrays words ;
8 SPECIALIZED-ARRAY: uchar
12 : clear-bit ( x n -- y ) 2^ bitnot bitand ; inline
13 : set-bit ( x n -- y ) 2^ bitor ; inline
14 : unmask ( x n -- y ) bitnot bitand ; inline
15 : unmask? ( x n -- ? ) unmask zero? not ; inline
16 : mask ( x n -- y ) bitand ; inline
17 : mask? ( x n -- ? ) [ mask ] [ = ] bi ; inline
18 : wrap ( m n -- m' ) 1 - bitand ; inline
19 : on-bits ( m -- n ) dup 0 <= [ drop 0 ] [ 2^ 1 - ] if ; inline
20 : bits ( m n -- m' ) on-bits mask ; inline
21 : mask-bit ( m n -- m' ) 2^ mask ; inline
22 : toggle-bit ( m n -- m' ) 2^ bitxor ; inline
23 : >signed ( x n -- y )
24 [ bits ] keep 2dup 1 - bit? [ 2^ - ] [ drop ] if ; inline
25 : >odd ( m -- n ) 0 set-bit ; foldable
26 : >even ( m -- n ) 0 clear-bit ; foldable
27 : next-even ( m -- n ) >even 2 + ; foldable
28 : next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable
29 : shift-mod ( m s w -- n ) [ shift ] dip 2^ wrap ; inline
31 ERROR: bit-range-error x high low ;
32 : bit-range ( x high low -- y )
33 2dup { [ nip 0 < ] [ < ] } 2|| [ bit-range-error ] when
34 [ nip neg shift ] [ - 1 + ] 2bi bits ; inline
36 : bitroll ( x s w -- y )
38 [ shift-mod ] [ [ - ] keep shift-mod ] 3bi bitor ; inline
40 : bitroll-32 ( m s -- n ) 32 bitroll ; inline
42 : bitroll-64 ( m s -- n ) 64 bitroll ; inline
45 : w+ ( x y -- z ) + 32 bits ; inline
46 : w- ( x y -- z ) - 32 bits ; inline
47 : w* ( x y -- z ) * 32 bits ; inline
50 : W+ ( x y -- z ) + 64 bits ; inline
51 : W- ( x y -- z ) - 64 bits ; inline
52 : W* ( x y -- z ) * 64 bits ; inline
54 : symbols>flags ( symbols assoc -- flag-bits )
55 '[ _ at ] map 0 [ bitor ] reduce ;
60 GENERIC: (bitfield-quot) ( spec -- quot )
62 M: integer (bitfield-quot)
65 M: pair (bitfield-quot)
66 first2-unsafe over word? [
67 '[ _ execute _ shift ]
72 : (bitfield) ( bitspec -- quot )
74 [ (bitfield-quot) ] [ '[ @ _ dip bitor ] ] map-reduce
79 MACRO: bitfield ( bitspec -- quot ) (bitfield) ;
81 MACRO: bitfield* ( bitspec -- quot ) reverse (bitfield) ;
92 8 <bits> 0 [ [ 1 + ] when ] reduce
93 ] B{ } map-as '[ 0xff bitand _ nth-unsafe ]
94 ( byte -- table ) define-declared
96 \ byte-bit-count make-inline
100 GENERIC: (bit-count) ( x -- n )
102 : fixnum-bit-count ( x -- n )
106 [ -8 shift byte-bit-count + ]
107 [ -16 shift byte-bit-count + ]
108 [ -24 shift byte-bit-count + ]
112 [ -32 shift byte-bit-count + ]
113 [ -40 shift byte-bit-count + ]
114 [ -48 shift byte-bit-count + ]
115 [ -56 shift byte-bit-count + ]
121 M: fixnum (bit-count)
122 fixnum-bit-count { fixnum } declare ; inline
124 M: bignum (bit-count)
126 [ byte-bit-count ] [ -8 shift (bit-count) ] bi +
129 : byte-array-bit-count ( byte-array -- n )
130 [ byte-bit-count ] map-sum ; inline
134 GENERIC: bit-count ( obj -- n )
137 dup 0 < [ non-negative-integer-expected ] when (bit-count) ; inline
139 M: byte-array bit-count
140 byte-array-bit-count ;
143 binary-object uchar <c-direct-array> byte-array-bit-count ;
145 : bit-length ( x -- n )
146 dup 0 < [ non-negative-integer-expected ] [
147 dup 1 > [ log2 1 + ] when
150 : even-parity? ( obj -- ? ) bit-count even? ;
152 : odd-parity? ( obj -- ? ) bit-count odd? ;