1 ! Copyright (C) 2010 Joe Groff, Erik Charlebois.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.c-types arrays assocs classes.singleton
4 combinators delegate fry kernel macros math parser sequences
9 TUPLE: enum-c-type base-type members ;
10 C: <enum-c-type> enum-c-type
11 CONSULT: c-type-protocol enum-c-type
15 GENERIC: enum>number ( enum -- number ) foldable
16 M: integer enum>number ;
17 M: word enum>number "enum-value" word-prop ;
20 : enum-boxer ( members -- quot )
21 [ first2 swap '[ _ ] 2array ]
22 { } map-as [ ] suffix '[ _ case ] ;
25 MACRO: number>enum ( enum-c-type -- quot )
26 lookup-c-type members>> enum-boxer ;
28 M: enum-c-type c-type-boxed-class drop object ;
29 M: enum-c-type c-type-boxer-quot members>> enum-boxer ;
30 M: enum-c-type c-type-unboxer-quot drop [ enum>number ] ;
31 M: enum-c-type c-type-setter
32 [ enum>number ] swap base-type>> c-type-setter '[ _ 2dip @ ] ;
34 : define-enum-value ( class value -- )
35 enum>number "enum-value" set-word-prop ;
39 : define-enum-members ( members -- )
40 [ first define-singleton-class ] each ;
42 : define-enum-constructor ( word -- )
43 [ name>> "<" ">" surround create-word-in ] keep
44 [ number>enum ] curry ( number -- enum ) define-inline ;
48 : (define-enum) ( word base-type members -- )
49 [ dup define-enum-constructor ] 2dip
50 [ define-enum-members ]
51 [ <enum-c-type> swap typedef ] bi ;
53 : define-enum ( word base-type members -- )
55 [ [ define-enum-value ] assoc-each ] bi ;
57 PREDICATE: enum-c-type-word < c-type-word
58 "c-type" word-prop enum-c-type? ;
60 : enum>values ( enum -- seq )
61 "c-type" word-prop members>> values ;
63 : enum>keys ( enum -- seq )
64 "c-type" word-prop members>> keys [ name>> ] map ;