1 ! (c)2010 Joe Groff bsd license
2 USING: accessors alien.c-types arrays combinators delegate fry
3 kernel quotations sequences words.symbol ;
6 TUPLE: enum-c-type base-type members ;
8 CONSULT: c-type-protocol enum-c-type
12 : map-to-case ( quot: ( x -- y ) -- case )
13 { } map-as [ ] suffix ; inline
16 : enum-unboxer ( members -- quot )
17 [ first2 '[ _ ] 2array ] map-to-case '[ _ case ] ;
19 : enum-boxer ( members -- quot )
20 [ first2 swap '[ _ ] 2array ] map-to-case '[ _ case ] ;
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
29 C: <enum-c-type> enum-c-type
33 : define-enum-members ( member-names -- )
34 [ first define-symbol ] each ;
38 : define-enum ( word base-type members -- )
39 [ define-enum-members ] [ <enum-c-type> swap typedef ] bi ;
41 PREDICATE: enum-c-type-word < c-type-word
42 "c-type" word-prop enum-c-type? ;