basis/math/bitfields/bitfields.factor

   1 ! Copyright (C) 2007, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays kernel math sequences words
   4 namespaces stack-checker.transforms ;
   5 IN: math.bitfields
   6
   7 GENERIC: (bitfield) ( value accum shift -- newaccum )
   8
   9 M: integer (bitfield) ( value accum shift -- newaccum )
  10     swapd shift bitor ;
  11
  12 M: pair (bitfield) ( value accum pair -- newaccum )
  13     first2 >r dup word? [ swapd execute ] when r> shift bitor ;
  14
  15 : bitfield ( values... bitspec -- n )
  16     0 [ (bitfield) ] reduce ;
  17
  18 : flags ( values -- n )
  19     0 [ dup word? [ execute ] when bitor ] reduce ;
  20
  21 GENERIC: (bitfield-quot) ( spec -- quot )
  22
  23 M: integer (bitfield-quot) ( spec -- quot )
  24     [ swapd shift bitor ] curry ;
  25
  26 M: pair (bitfield-quot) ( spec -- quot )
  27     first2 over word? [ >r swapd execute r> ] [ ] ?
  28     [ shift bitor ] append 2curry ;
  29
  30 : bitfield-quot ( spec -- quot )
  31     [ (bitfield-quot) ] map [ 0 ] prefix concat ;
  32
  33 \ bitfield [ bitfield-quot ] 1 define-transform
  34
  35 \ flags [
  36     [ 0 , [ , \ bitor , ] each ] [ ] make
  37 ] 1 define-transform