1 ! Copyright (C) 2008, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: math kernel sequences sequences.private byte-arrays
4 alien prettyprint.custom parser accessors locals ;
8 { length array-capacity read-only }
9 { underlying byte-array read-only } ;
13 CONSTANT: nibble 0b1111
15 : nibbles>bytes ( m -- n ) 1 + 2/ ; inline
17 : byte/nibble ( n -- shift n' )
18 [ 1 bitand 2 shift ] [ -1 shift ] bi ; inline
20 : get-nibble ( n byte -- nibble )
21 swap neg shift nibble bitand ; inline
23 :: set-nibble ( value n byte -- byte' )
24 byte nibble n shift bitnot bitand
28 : nibble@ ( n nibble-array -- shift n' byte-array )
29 [ >fixnum byte/nibble ] [ underlying>> ] bi* ; inline
33 ERROR: bad-array-length n ;
35 : <nibble-array> ( n -- nibble-array )
36 dup 0 < [ throw-bad-array-length ] when
37 dup nibbles>bytes <byte-array> nibble-array boa ; inline
39 M: nibble-array length length>> ;
41 M: nibble-array nth-unsafe
42 nibble@ nth-unsafe get-nibble ;
44 M: nibble-array set-nth-unsafe
45 nibble@ [ nth-unsafe set-nibble ] 2keep set-nth-unsafe ;
48 [ length>> ] [ underlying>> clone ] bi nibble-array boa ;
50 : >nibble-array ( seq -- nibble-array )
51 T{ nibble-array } clone-like ; inline
54 drop dup nibble-array? [ >nibble-array ] unless ;
56 M: nibble-array new-sequence drop <nibble-array> ;
58 M: nibble-array equal?
59 over nibble-array? [ sequence= ] [ 2drop f ] if ;
61 M: nibble-array resize
63 [ nibbles>bytes ] [ underlying>> ] bi*
68 M: nibble-array byte-length length nibbles>bytes ;
70 SYNTAX: N{ \ } [ >nibble-array ] parse-literal ;
72 INSTANCE: nibble-array sequence
74 M: nibble-array pprint-delims drop \ N{ \ } ;
75 M: nibble-array >pprint-sequence ;
76 M: nibble-array pprint* pprint-object ;