basis/alien/enums/enums.factor

   1 ! (c)2010 Joe Groff, Erik Charlebois bsd license
   2 USING: accessors alien.c-types arrays combinators delegate fry
   3 generic.parser kernel macros math parser sequences words words.symbol ;
   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 ) foldable
  14 M: integer enum>number ;
  15 M: word enum>number "enum-value" word-prop ;
  16
  17 <PRIVATE
  18 : enum-boxer ( members -- quot )
  19     [ first2 swap '[ _ ] 2array ]
  20     { } map-as [ ] suffix '[ _ case ] ;
  21 PRIVATE>
  22
  23 MACRO: number>enum ( enum-c-type -- )
  24     c-type members>> enum-boxer ;
  25
  26 M: enum-c-type c-type-boxed-class drop object ;
  27 M: enum-c-type c-type-boxer-quot members>> enum-boxer ;
  28 M: enum-c-type c-type-unboxer-quot drop [ enum>number ] ;
  29 M: enum-c-type c-type-setter
  30    [ enum>number ] swap base-type>> c-type-setter '[ _ 2dip @ ] ;
  31
  32 : define-enum-value ( class value -- )
  33     enum>number "enum-value" set-word-prop ;
  34
  35 <PRIVATE
  36
  37 : define-enum-members ( member-names -- )
  38     [ first define-symbol ] each ;
  39
  40 : define-enum-constructor ( word -- )
  41     [ name>> "<" ">" surround create-in ] keep
  42     [ number>enum ] curry (( number -- enum )) define-inline ;
  43
  44 PRIVATE>
  45
  46 : (define-enum) ( word base-type members -- )
  47     [ dup define-enum-constructor ] 2dip
  48     dup define-enum-members
  49     <enum-c-type> swap typedef ;
  50
  51 : define-enum ( word base-type members -- )
  52     [ (define-enum) ]
  53     [ [ first2 define-enum-value ] each ] bi ;
  54
  55 PREDICATE: enum-c-type-word < c-type-word
  56     "c-type" word-prop enum-c-type? ;