basis/classes/struct/bit-accessors/bit-accessors.factor

   1 ! Copyright (C) 2009 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien.accessors kernel math math.bitwise math.order ;
   4 IN: classes.struct.bit-accessors
   5
   6 ! Bitfield accessors are little-endian on all platforms
   7 ! Why not? It's unspecified in C
   8
   9 : ones-between ( start end -- n )
  10     [ on-bits ] bi@ swap unmask ;
  11
  12 :: manipulate-bits ( offset bits step-quot -- quot shift-amount offset' bits' )
  13     offset 8 /mod :> ( i start-bit )
  14     start-bit bits + 8 min :> end-bit
  15     start-bit end-bit ones-between :> mask
  16     end-bit start-bit - :> used-bits
  17
  18     i mask start-bit step-quot call( i mask start-bit -- quot )
  19     used-bits
  20     i 1 + 8 *
  21     bits used-bits - ; inline
  22
  23 :: bit-manipulator ( offset bits
  24                     step-quot: ( i mask start-bit -- quot )
  25                     combine-quot: ( prev-quot shift-amount next-quot -- quot )
  26                     -- quot )
  27     offset bits step-quot manipulate-bits
  28     [ 2drop ] [
  29         step-quot combine-quot bit-manipulator
  30         combine-quot call( prev shift next -- quot )
  31     ] if-zero ; inline recursive
  32
  33 : bit-reader ( offset bits -- quot: ( alien -- n ) )
  34     [ neg '[ _ alien-unsigned-1 _ bitand _ shift ] ]
  35     [ swap '[ _ _ bi _ shift bitor ] ]
  36     bit-manipulator ;
  37
  38 :: write-bits ( n alien i mask start-bit -- )
  39     n start-bit shift mask bitand
  40     alien i alien-unsigned-1 mask bitnot bitand
  41     bitor alien i set-alien-unsigned-1 ; inline
  42
  43 : bit-writer ( offset bits -- quot: ( n alien -- ) )
  44     [ '[ _ _ _ write-bits ] ]
  45     [ '[ _ [ [ _ neg shift ] dip @ ] 2bi ] ]
  46     bit-manipulator ;