-! (c)2010 Joe Groff bsd license
-USING: accessors alien.c-types arrays combinators delegate fry
-kernel quotations sequences words.symbol words ;
+! Copyright (C) 2010 Joe Groff, Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types arrays assocs classes.singleton
+combinators delegate kernel math parser sequences words ;
IN: alien.enums
+<PRIVATE
TUPLE: enum-c-type base-type members ;
-
+C: <enum-c-type> enum-c-type
CONSULT: c-type-protocol enum-c-type
base-type>> ;
-
-<PRIVATE
-: map-to-case ( quot: ( x -- y ) -- case )
- { } map-as [ ] suffix ; inline
PRIVATE>
-: enum-unboxer ( members -- quot )
- [ first2 '[ _ ] 2array ] map-to-case '[ _ case ] ;
+GENERIC: enum>number ( enum -- number ) foldable
+M: integer enum>number ;
+M: word enum>number "enum-value" word-prop ;
+<PRIVATE
: enum-boxer ( members -- quot )
- [ first2 swap '[ _ ] 2array ] map-to-case '[ _ case ] ;
+ [ first2 swap '[ _ ] 2array ]
+ { } map-as [ ] suffix '[ _ case ] ;
+PRIVATE>
+
+MACRO: number>enum ( enum-c-type -- quot )
+ lookup-c-type members>> enum-boxer ;
M: enum-c-type c-type-boxed-class drop object ;
M: enum-c-type c-type-boxer-quot members>> enum-boxer ;
-M: enum-c-type c-type-unboxer-quot members>> enum-unboxer ;
+M: enum-c-type c-type-unboxer-quot drop [ enum>number ] ;
M: enum-c-type c-type-setter
- [ members>> enum-unboxer ] [ base-type>> c-type-setter ] bi
- '[ _ 2dip @ ] ;
+ [ enum>number ] swap base-type>> c-type-setter '[ _ 2dip @ ] ;
-C: <enum-c-type> enum-c-type
-
-: enum>int ( enum enum-c-type -- int )
- c-type-unboxer-quot call( x -- y ) ; inline
-
-: int>enum ( int enum-c-type -- enum )
- c-type-boxer-quot call( x -- y ) ; inline
+: define-enum-value ( class value -- )
+ enum>number "enum-value" set-word-prop ;
<PRIVATE
-: define-enum-members ( member-names -- )
- [ first define-symbol ] each ;
+: define-enum-members ( members -- )
+ [ first define-singleton-class ] each ;
+
+: define-enum-constructor ( word -- )
+ [ name>> "<" ">" surround create-word-in ] keep
+ [ number>enum ] curry ( number -- enum ) define-declared ;
PRIVATE>
+: (define-enum) ( word base-type members -- )
+ [ dup define-enum-constructor ] 2dip
+ [ define-enum-members ]
+ [ <enum-c-type> swap typedef ] bi ;
+
: define-enum ( word base-type members -- )
- [ define-enum-members ] [ <enum-c-type> swap typedef ] bi ;
+ [ (define-enum) ]
+ [ [ define-enum-value ] assoc-each ] bi ;
PREDICATE: enum-c-type-word < c-type-word
"c-type" word-prop enum-c-type? ;
+
+: enum>values ( enum -- seq )
+ "c-type" word-prop members>> values ;
+
+: enum>keys ( enum -- seq )
+ "c-type" word-prop members>> keys [ name>> ] map ;
+
+: values>enum ( values enum -- seq )
+ '[ _ number>enum ] map ; inline
+