1 ! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays kernel math sequences accessors math.bits
4 sequences.private words namespaces macros hints
5 combinators fry io.binary combinators.smart ;
9 : clear-bit ( x n -- y ) 2^ bitnot bitand ; inline
10 : set-bit ( x n -- y ) 2^ bitor ; inline
11 : bit-clear? ( x n -- ? ) 2^ bitand 0 = ; inline
12 : unmask ( x n -- ? ) bitnot bitand ; inline
13 : unmask? ( x n -- ? ) unmask 0 > ; inline
14 : mask ( x n -- ? ) bitand ; inline
15 : mask? ( x n -- ? ) mask 0 > ; inline
16 : wrap ( m n -- m' ) 1 - bitand ; inline
17 : bits ( m n -- m' ) 2^ wrap ; inline
18 : mask-bit ( m n -- m' ) 2^ mask ; inline
19 : on-bits ( n -- m ) 2^ 1 - ; inline
20 : toggle-bit ( m n -- m' ) 2^ bitxor ; inline
22 : shift-mod ( n s w -- n )
23 [ shift ] dip 2^ wrap ; inline
25 : bitroll ( x s w -- y )
27 [ shift-mod ] [ [ - ] keep shift-mod ] 3bi bitor ; inline
29 : bitroll-32 ( n s -- n' ) 32 bitroll ; inline
31 : bitroll-64 ( n s -- n' ) 64 bitroll ; inline
34 : w+ ( int int -- int ) + 32 bits ; inline
35 : w- ( int int -- int ) - 32 bits ; inline
36 : w* ( int int -- int ) * 32 bits ; inline
39 : W+ ( int int -- int ) + 64 bits ; inline
40 : W- ( int int -- int ) - 64 bits ; inline
41 : W* ( int int -- int ) * 64 bits ; inline
44 MACRO: flags ( values -- )
45 [ 0 ] [ [ ?execute bitor ] curry compose ] reduce ;
50 GENERIC: (bitfield-quot) ( spec -- quot )
52 M: integer (bitfield-quot) ( spec -- quot )
53 [ swapd shift bitor ] curry ;
55 M: pair (bitfield-quot) ( spec -- quot )
56 first2 over word? [ [ swapd execute ] dip ] [ ] ?
57 [ shift bitor ] append 2curry ;
61 MACRO: bitfield ( bitspec -- )
62 [ 0 ] [ (bitfield-quot) compose ] reduce ;
73 8 <bits> 0 [ [ 1 + ] when ] reduce
74 ] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ]
75 (( byte -- table )) define-declared
77 \ byte-bit-count make-inline
81 GENERIC: (bit-count) ( x -- n )
87 [ -8 shift byte-bit-count ]
88 [ -16 shift byte-bit-count ]
89 [ -24 shift byte-bit-count ]
95 [ byte-bit-count ] [ -8 shift (bit-count) ] bi +
100 : bit-count ( x -- n )
101 dup 0 < [ bitnot ] when (bit-count) ; inline
103 ! Signed byte array to integer conversion
104 : signed-le> ( bytes -- x )
105 [ le> ] [ length 8 * 1 - on-bits ] bi
106 2dup > [ bitnot bitor ] [ drop ] if ;
108 : signed-be> ( bytes -- x )
109 <reversed> signed-le> ;
111 : >signed ( x n -- y )
112 2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;