1 ! Copyright (C) 2007, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays kernel math math.functions sequences
4 sequences.private words namespaces macros hints
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 zero? ; 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' ) 1- 2^ mask ; inline
20 : shift-mod ( n s w -- n )
21 >r shift r> 2^ wrap ; inline
23 : bitroll ( x s w -- y )
26 [ [ - ] keep shift-mod ] 3bi bitor ; inline
28 : bitroll-32 ( n s -- n' ) 32 bitroll ;
30 HINTS: bitroll-32 bignum fixnum ;
32 : bitroll-64 ( n s -- n' ) 64 bitroll ;
34 HINTS: bitroll-64 bignum fixnum ;
37 : w+ ( int int -- int ) + 32 bits ; inline
38 : w- ( int int -- int ) - 32 bits ; inline
39 : w* ( int int -- int ) * 32 bits ; inline
42 MACRO: flags ( values -- )
43 [ 0 ] [ [ execute bitor ] curry compose ] reduce ;
48 GENERIC: (bitfield-quot) ( spec -- quot )
50 M: integer (bitfield-quot) ( spec -- quot )
51 [ swapd shift bitor ] curry ;
53 M: pair (bitfield-quot) ( spec -- quot )
54 first2 over word? [ >r swapd execute r> ] [ ] ?
55 [ shift bitor ] append 2curry ;
59 MACRO: bitfield ( bitspec -- )
60 [ 0 ] [ (bitfield-quot) compose ] reduce ;
71 0 swap [ [ 1+ ] when ] each-bit
72 ] B{ } map-as '[ HEX: ff bitand , nth-unsafe ] define-inline
76 GENERIC: (bit-count) ( x -- n )
81 [ -8 shift byte-bit-count ]
82 [ -16 shift byte-bit-count ]
83 [ -24 shift byte-bit-count ]
88 [ byte-bit-count ] [ -8 shift (bit-count) ] bi +
93 : bit-count ( x -- n )
94 dup 0 >= [ (bit-count) ] [ bitnot (bit-count) ] if ; inline