--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes.struct.bit-accessors tools.test effects kernel random stack-checker ;
+IN: classes.struct.bit-accessors.test
+
+[ t ] [ 20 random 20 random bit-reader infer (( alien -- n )) effect= ] unit-test
+[ t ] [ 20 random 20 random bit-writer infer (( n alien -- )) effect= ] unit-test
: ones-between ( start end -- n )
[ 2^ 1 - ] bi@ swap bitnot bitand ;
-:: read-bits ( offset bits -- quot: ( byte-array -- n ) shift-amount offset' bits' )
+: ones-around ( start end -- n )
+ ones-between bitnot ;
+
+:: read-bits ( offset bits -- quot: ( alien -- n ) shift-amount offset' bits' )
offset 8 /mod :> start-bit :> i
start-bit bits + 8 min :> end-bit
start-bit end-bit ones-between :> mask
end-bit start-bit - :> used-bits
- ! The code generated for this isn't optimal
- ! To improve the code, algebraic simplifications should
- ! have interval information available
[ i alien-unsigned-1 mask bitand start-bit neg shift ]
used-bits
i 1 + 8 *
read-bits dup zero? [ 3drop ] [
bit-reader swap '[ _ _ bi _ shift bitor ]
] if ;
+
+:: write-bits ( offset bits -- quot: ( alien -- n ) shift-amount offset' bits' )
+ offset 8 /mod :> start-bit :> i
+ start-bit bits + 8 min :> end-bit
+ start-bit end-bit ones-between :> mask
+ end-bit start-bit - :> used-bits
+
+ [
+ [
+ [ start-bit shift mask bitand ]
+ [ i alien-unsigned-1 mask bitnot bitand ]
+ bi* bitor
+ ] keep i set-alien-unsigned-1
+ ]
+ used-bits
+ i 1 + 8 *
+ bits used-bits - ;
+
+: bit-writer ( offset bits -- quot: ( n alien -- ) )
+ write-bits dup zero? [ 3drop ] [
+ bit-writer '[ _ [ [ _ neg shift ] dip @ ] 2bi ]
+ ] if ;
[ type>> c-setter ]
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
-QUALIFIED: math.bits
-
-: bytes>bits ( byte-array -- bit-array )
- [ 8 math.bits:<bits> ] { } map-as ?{ } join ;
-
-: (write-bits) ( value offset end byte-array -- )
- ! This is absurdly inefficient
- [
- [ [ swap - math.bits:<bits> ] 2keep ] [ bytes>bits ] bi*
- replace-slice ?{ } like underlying>>
- ] keep 0 swap copy ;
-
-: bits@ ( slot -- beginning end )
- [ offset>> ] [ bits>> ] bi dupd + ;
-
-M: struct-bit-slot-spec (writer-quot) ( slot -- quot )
- bits@ '[ [ _ _ ] dip (underlying)>> (write-bits) ] ;
+M: struct-bit-slot-spec (writer-quot)
+ [ offset>> ] [ bits>> ] bi bit-writer
+ [ >c-ptr ] prepose ;
: (boxer-quot) ( class -- quot )
'[ _ memory>struct ] ;