1 ! Copyright (C) 2007, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: alien.c-types accessors math alien.accessors kernel
4 kernel.private sequences sequences.private byte-arrays
5 parser prettyprint.custom fry ;
9 { length array-capacity read-only }
10 { underlying byte-array read-only } ;
14 : n>byte ( m -- n ) -3 shift ; inline
16 : byte/bit ( n alien -- byte bit )
17 over n>byte alien-unsigned-1 swap 7 bitand ; inline
19 : set-bit ( ? byte bit -- byte )
20 2^ rot [ bitor ] [ bitnot bitand ] if ; inline
22 : bits>cells ( m -- n ) 31 + -5 shift ; inline
24 : bits>bytes ( m -- n ) 7 + n>byte ; inline
26 : (set-bits) ( bit-array n -- )
27 [ [ length bits>cells ] keep ] dip swap underlying>>
28 '[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each ; inline
32 : <bit-array> ( n -- bit-array )
33 dup bits>bytes <byte-array> bit-array boa ; inline
35 M: bit-array length length>> ;
37 M: bit-array nth-unsafe
38 [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ;
40 M: bit-array set-nth-unsafe
41 [ >fixnum ] [ underlying>> ] bi*
42 [ byte/bit set-bit ] 2keep
43 swap n>byte set-alien-unsigned-1 ;
45 GENERIC: clear-bits ( bit-array -- )
47 M: bit-array clear-bits 0 (set-bits) ;
49 GENERIC: set-bits ( bit-array -- )
51 M: bit-array set-bits -1 (set-bits) ;
54 [ length>> ] [ underlying>> clone ] bi bit-array boa ;
56 : >bit-array ( seq -- bit-array )
57 T{ bit-array f 0 B{ } } clone-like ; inline
59 M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
61 M: bit-array new-sequence drop <bit-array> ;
64 over bit-array? [ sequence= ] [ 2drop f ] if ;
68 [ bits>bytes ] [ underlying>> ] bi*
73 M: bit-array byte-length length 7 + -3 shift ;
75 SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
77 : integer>bit-array ( n -- bit-array )
81 [ log2 1+ <bit-array> 0 ] keep
83 [ pick underlying>> pick set-alien-unsigned-1 ] keep
84 [ 1+ ] [ -8 shift ] bi*
88 : bit-array>integer ( bit-array -- n )
89 0 swap underlying>> dup length <reversed> [
90 alien-unsigned-1 swap 8 shift bitor
93 INSTANCE: bit-array sequence
95 M: bit-array pprint-delims drop \ ?{ \ } ;
96 M: bit-array >pprint-sequence ;
97 M: bit-array pprint* pprint-object ;