diff --git a/basis/classes/struct/bit-accessors/bit-accessors.factor b/basis/classes/struct/bit-accessors/bit-accessors.factor new file mode 100644 index 0000000000..9d625beab3 --- /dev/null +++ b/basis/classes/struct/bit-accessors/bit-accessors.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences math fry locals math.order alien.accessors ; +IN: classes.struct.bit-accessors + +! Bitfield accessors are little-endian on all platforms +! Why not? It's platform-dependent in C + +: ones-between ( start end -- n ) + [ 2^ 1 - ] bi@ swap bitnot bitand ; + +:: read-bits ( offset bits -- quot: ( byte-array -- 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 * + bits used-bits - ; + +: bit-reader ( offset bits -- quot: ( alien -- n ) ) + read-bits dup zero? [ 3drop ] [ + bit-reader swap '[ _ _ bi _ shift bitor ] + ] if ; diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index df0e07c964..6593e8350d 100755 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -6,7 +6,8 @@ combinators.smart cpu.architecture definitions functors.backend fry generalizations generic.parser kernel kernel.private lexer libc locals macros make math math.order parser quotations sequences slots slots.private specialized-arrays vectors words -summary namespaces assocs vocabs.parser math.functions bit-arrays ; +summary namespaces assocs vocabs.parser math.functions +classes.struct.bit-accessors bit-arrays ; QUALIFIED: math IN: classes.struct @@ -89,23 +90,14 @@ MACRO: ( class -- quot: ( ... -- struct ) ) : pad-struct-slots ( values class -- values' class ) [ struct-slots [ initial>> ] map over length tail append ] keep ; -: bits@ ( slot -- beginning end ) - [ offset>> ] [ bits>> ] bi dupd + ; - -QUALIFIED: math.bits - -: bytes>bits ( byte-array -- bit-array ) - [ 8 math.bits: ] { } map-as ?{ } join ; - -: read-bits ( beginning end byte-array -- n ) - ! This is absurdly inefficient - bytes>bits subseq bit-array>integer ; - : sign-extend ( n bits -- n' ) ! formula from: ! http://guru.multimedia.cx/fast-sign-extension/ 1 - -1 swap shift [ + ] keep bitxor ; inline +: sign-extender ( signed? bits -- quot ) + '[ _ [ _ sign-extend ] when ] ; + GENERIC: (reader-quot) ( slot -- quot ) M: struct-slot-spec (reader-quot) @@ -113,10 +105,10 @@ M: struct-slot-spec (reader-quot) [ offset>> [ >c-ptr ] swap suffix ] bi prepend ; M: struct-bit-slot-spec (reader-quot) - [ bits@ ] [ signed?>> ] [ bits>> ] tri '[ - [ _ _ ] dip (underlying)>> read-bits - _ [ _ sign-extend ] when - ] ; + [ [ offset>> ] [ bits>> ] bi bit-reader ] + [ [ signed?>> ] [ bits>> ] bi sign-extender ] + bi compose + [ >c-ptr ] prepose ; GENERIC: (writer-quot) ( slot -- quot ) @@ -124,6 +116,11 @@ 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 [ @@ -131,6 +128,9 @@ M: struct-slot-spec (writer-quot) 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) ] ;