basis/alien/enums/enums.factor

   1 ! (c)2010 Joe Groff, Erik Charlebois bsd license
   2 USING: accessors alien.c-types arrays classes.singleton combinators
   3 delegate fry generic.parser kernel math parser sequences words ;
   4 IN: alien.enums
   5
   6 <PRIVATE
   7 TUPLE: enum-c-type base-type members ;
   8 C: <enum-c-type> enum-c-type
   9 CONSULT: c-type-protocol enum-c-type
  10     base-type>> ;
  11 PRIVATE>
  12
  13 GENERIC: enum>number ( enum -- number )
  14 M: integer enum>number ;
  15
  16 : number>enum ( number enum-c-type -- enum )
  17     c-type-boxer-quot call( x -- y ) ; inline
  18
  19 <PRIVATE
  20 : enum-boxer ( members -- quot )
  21     [ first2 swap '[ _ ] 2array ]
  22     { } map-as [ ] suffix '[ _ case ] ;
  23 PRIVATE>
  24
  25 M: enum-c-type c-type-boxed-class drop object ;
  26 M: enum-c-type c-type-boxer-quot members>> enum-boxer ;
  27 M: enum-c-type c-type-unboxer-quot drop [ enum>number ] ;
  28 M: enum-c-type c-type-setter
  29    [ enum>number ] swap base-type>> c-type-setter '[ _ 2dip @ ] ;
  30
  31 <PRIVATE
  32
  33 : define-enum>number ( class value -- )
  34     [ \ enum>number create-method-in ]
  35     [ '[ drop _ ] ] bi* define ;
  36
  37 : define-enum-members ( member-names -- )
  38     [
  39         [ first define-singleton-class ]
  40         [ first2 define-enum>number ] bi
  41     ] each ;
  42
  43 : define-enum-constructor ( word -- )
  44     [ name>> "<" ">" surround create-in ] keep
  45     [ number>enum ] curry (( enum -- number )) define-inline ;
  46
  47 PRIVATE>
  48
  49 : define-enum ( word base-type members -- )
  50     [ dup define-enum-constructor ] 2dip
  51     dup define-enum-members
  52     <enum-c-type> swap typedef ;
  53
  54 PREDICATE: enum-c-type-word < c-type-word
  55     "c-type" word-prop enum-c-type? ;