extra/bitfields/bitfields.factor

   1 USING: parser lexer kernel math sequences namespaces make assocs
   2 summary words splitting math.parser arrays sequences.next
   3 mirrors generalizations compiler.units ;
   4 IN: bitfields
   5
   6 ! Example:
   7 ! BITFIELD: blah short:16 char:8 nothing:5 ;
   8 ! defines <blah> blah-short blah-char blah-nothing.
   9
  10 ! An efficient bitfield has a sum of 29 bits or less
  11 ! so it can fit in a fixnum.
  12 ! No class is defined and there is no overflow checking.
  13 ! The first field is the most significant.
  14
  15 : >ranges ( slots/sizes -- slots/ranges )
  16     ! range is { start length }
  17     reverse 0 swap [
  18         swap >r tuck >r [ + ] keep r> 2array r> swap
  19     ] assoc-map nip reverse ;
  20
  21 SYMBOL: safe-bitfields? ! default f; set at parsetime
  22
  23 TUPLE: check< number bound ;
  24 M: check< summary drop "Number exceeds upper bound" ;
  25
  26 : check< ( num cmp -- num )
  27     2dup < [ drop ] [ \ check< boa throw ] if ;
  28
  29 : ?check ( length -- )
  30     safe-bitfields? get [ 2^ , \ check< , ] [ drop ] if ;
  31
  32 : put-together ( lengths -- )
  33     ! messy because of bounds checking
  34     dup length 1- [ \ >r , ] times [ 0 swap ] % [
  35         ?check [ \ bitor , , [ shift r> ] % ] when*
  36     ] each-next \ bitor , ;
  37
  38 : padding-name? ( string -- ? )
  39     [ "10" member? ] all? ;
  40
  41 : pad ( i name -- )
  42     bin> , , \ -nrot , ;
  43
  44 : add-padding ( names -- )
  45     <enum>
  46     [ dup padding-name? [ pad ] [ 2drop ] if ] assoc-each ;
  47
  48 : [constructor] ( names lengths -- quot )
  49     [ swap add-padding put-together ] [ ] make ;
  50
  51 : define-constructor ( classname slots -- )
  52     [ keys ] keep values [constructor]
  53     >r in get constructor-word dup save-location r>
  54     define ;
  55
  56 : range>accessor ( range -- quot )
  57     [
  58         dup first neg , \ shift ,
  59         second 2^ 1- , \ bitand ,
  60     ] [ ] make ;
  61
  62 : [accessors] ( lengths -- accessors )
  63     [ range>accessor ] map ;
  64
  65 : clear-range ( range -- num )
  66     first2 dupd + [ 2^ 1- ] bi@ bitnot bitor ;
  67
  68 : range>setter ( range -- quot )
  69     [
  70         \ >r , dup second ?check \ r> ,
  71         dup clear-range ,
  72         [ bitand >r ] %
  73         first , [ shift r> bitor ] %
  74     ] [ ] make ;
  75
  76 : [setters] ( lengths -- setters )
  77     [ range>setter ] map ;
  78
  79 : parse-slots ( slotspecs -- slots )
  80     [ ":" split1 string>number [ dup length ] unless* ] { } map>assoc ;
  81
  82 : define-slots ( prefix names quots -- )
  83     >r [ "-" swap 3append create-in ] with map r>
  84     [ define ] 2each ;
  85
  86 : define-accessors ( classname slots -- )
  87     dup values [accessors]
  88     >r keys r> define-slots ;
  89
  90 : define-setters ( classname slots -- )
  91     >r "with-" prepend r>
  92     dup values [setters]
  93     >r keys r> define-slots ;
  94
  95 : filter-pad ( slots -- slots )
  96     [ drop padding-name? not ] assoc-filter ;
  97
  98 : define-bitfield ( classname slots -- )
  99     [
 100         [ define-constructor ] 2keep
 101         >ranges filter-pad [ define-setters ] 2keep define-accessors
 102     ] with-compilation-unit ;
 103
 104 : parse-bitfield ( -- )
 105     scan ";" parse-tokens parse-slots define-bitfield ;
 106
 107 : BITFIELD:
 108     parse-bitfield ; parsing
 109
 110 : SAFE-BITFIELD:
 111     [ safe-bitfields? on parse-bitfield ] with-scope ; parsing