diff --git a/basis/classes/struct/bit-accessors/bit-accessors-tests.factor b/basis/classes/struct/bit-accessors/bit-accessors-tests.factor new file mode 100644 index 0000000000..e2ff6dbd9c --- /dev/null +++ b/basis/classes/struct/bit-accessors/bit-accessors-tests.factor @@ -0,0 +1,7 @@ +! 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 diff --git a/basis/classes/struct/bit-accessors/bit-accessors.factor b/basis/classes/struct/bit-accessors/bit-accessors.factor index 9d625beab3..04757a233a 100644 --- a/basis/classes/struct/bit-accessors/bit-accessors.factor +++ b/basis/classes/struct/bit-accessors/bit-accessors.factor @@ -9,15 +9,15 @@ IN: classes.struct.bit-accessors : 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 * @@ -27,3 +27,25 @@ IN: classes.struct.bit-accessors 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 ; diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 6593e8350d..af23834383 100755 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -116,23 +116,9 @@ M: struct-slot-spec (writer-quot) [ type>> c-setter ] [ offset>> [ >c-ptr ] swap suffix ] bi prepend ; -QUALIFIED: math.bits - -: bytes>bits ( byte-array -- bit-array ) - [ 8 math.bits: ] { } map-as ?{ } join ; - -: (write-bits) ( value offset end byte-array -- ) - ! This is absurdly inefficient - [ - [ [ swap - math.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 ] ;