basis/alien/enums/enums.factor

   1 ! (c)2010 Joe Groff bsd license
   2 USING: accessors alien.c-types arrays combinators delegate fry
   3 kernel quotations sequences words.symbol words ;
   4 IN: alien.enums
   5
   6 TUPLE: enum-c-type base-type members ;
   7
   8 CONSULT: c-type-protocol enum-c-type
   9     base-type>> ;
  10
  11 <PRIVATE
  12 : map-to-case ( quot: ( x -- y ) -- case )
  13     { } map-as [ ] suffix ; inline
  14 PRIVATE>
  15
  16 : enum-unboxer ( members -- quot )
  17     [ first2 '[ _ ] 2array ] map-to-case '[ _ case ] ;
  18
  19 : enum-boxer ( members -- quot )
  20     [ first2 swap '[ _ ] 2array ] map-to-case '[ _ case ] ;
  21
  22 M: enum-c-type c-type-boxed-class drop object ;
  23 M: enum-c-type c-type-boxer-quot members>> enum-boxer ;
  24 M: enum-c-type c-type-unboxer-quot members>> enum-unboxer ;
  25 M: enum-c-type c-type-setter
  26     [ members>> enum-unboxer ] [ base-type>> c-type-setter ] bi
  27     '[ _ 2dip @ ] ;
  28
  29 C: <enum-c-type> enum-c-type
  30
  31 : enum>int ( enum enum-c-type -- int )
  32     c-type-unboxer-quot call( x -- y ) ; inline
  33
  34 : int>enum ( int enum-c-type -- enum )
  35     c-type-boxer-quot call( x -- y ) ; inline
  36
  37 <PRIVATE
  38
  39 : define-enum-members ( member-names -- )
  40     [ first define-symbol ] each ;
  41
  42 PRIVATE>
  43
  44 : define-enum ( word base-type members -- )
  45     [ define-enum-members ] [ <enum-c-type> swap typedef ] bi ;
  46
  47 PREDICATE: enum-c-type-word < c-type-word
  48     "c-type" word-prop enum-c-type? ;