basis/gobject-introspection/ffi/ffi.factor

   1 ! Copyright (C) 2009 Anton Gorenko.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.c-types alien.parser arrays
   4 classes.parser classes.struct combinators
   5 combinators.short-circuit definitions effects fry
   6 gobject-introspection.common gobject-introspection.types kernel
   7 math.parser namespaces parser quotations sequences
   8 sequences.generalizations words words.constant ;
   9 IN: gobject-introspection.ffi
  10
  11 : string>c-type ( str -- c-type )
  12     parse-c-type ;
  13
  14 : define-each ( nodes quot -- )
  15     '[ dup @ >>ffi drop ] each ; inline
  16
  17 : function-ffi-invoker ( func -- quot )
  18     {
  19         [ return>> c-type>> string>c-type ]
  20         [ drop current-lib get-global ]
  21         [ identifier>> ]
  22         [ parameters>> [ c-type>> string>c-type ] map ]
  23         [ varargs?>> [ void* suffix ] when ]
  24     } cleave function-quot ;
  25
  26 : function-ffi-effect ( func -- effect )
  27     [ parameters>> [ name>> ] map ]
  28     [ varargs?>> [ "varargs" suffix ] when ]
  29     [ return>> type>> none-type? { } { "result" } ? ] tri
  30     <effect> ;
  31
  32 : define-ffi-function ( func -- word )
  33     [ identifier>> create-in dup ]
  34     [ function-ffi-invoker ] [ function-ffi-effect ] tri
  35     define-declared ;
  36
  37 : define-ffi-functions ( functions -- )
  38     [ define-ffi-function ] define-each ;
  39
  40 : callback-ffi-invoker ( callback -- quot )
  41     [ return>> c-type>> string>c-type ]
  42     [ parameters>> [ c-type>> string>c-type ] map ] bi
  43     cdecl callback-quot ;
  44
  45 : callback-ffi-effect ( callback -- effect )
  46     [ parameters>> [ name>> ] map ]
  47     [ return>> type>> none-type? { } { "result" } ? ] bi
  48     <effect> ;
  49
  50 : define-ffi-callback ( callback -- word )
  51     [ c-type>> create-in [ void* swap typedef ] keep dup ] keep
  52     [ callback-ffi-effect "callback-effect" set-word-prop ]
  53     [ drop current-lib get-global "callback-library" set-word-prop ]
  54     [ callback-ffi-invoker (( quot -- alien )) define-inline ] 2tri ;
  55
  56 : fix-signal-param-c-type ( param -- )
  57     dup [ c-type>> ] [ type>> ] bi
  58     {
  59         [ none-type? ]
  60         [ simple-type? ]
  61         [ enum-type? ]
  62         [ bitfield-type? ]
  63     } 1|| [ dup "*" tail? [ CHAR: * suffix ] unless ] unless
  64     >>c-type drop ;
  65
  66 : define-ffi-signal ( signal -- word )
  67     [ return>> fix-signal-param-c-type ]
  68     [ parameters>> [ fix-signal-param-c-type ] each ]
  69     [ define-ffi-callback ] tri ;
  70
  71 : define-ffi-signals ( signals -- )
  72     [ define-ffi-signal ] define-each ;
  73
  74 : const-value ( const -- value )
  75     [ value>> ] [ type>> name>> ] bi {
  76         { "int" [ string>number ] }
  77         { "double" [ string>number ] }
  78         { "utf8" [ ] }
  79     } case ;
  80
  81 : define-ffi-enum ( enum -- word )
  82     [
  83        members>> [
  84            [ c-identifier>> create-in ]
  85            [ value>> ] bi define-constant
  86        ] each
  87     ] [ c-type>> (CREATE-C-TYPE) [ int swap typedef ] keep ] bi ;
  88
  89 : define-ffi-enums ( enums -- )
  90     [ define-ffi-enum ] define-each ;
  91
  92 : define-ffi-bitfields ( bitfields -- )
  93     [ define-ffi-enum ] define-each ;
  94
  95 : fields>struct-slots ( fields -- slots )
  96     [
  97         [ name>> ]
  98         [
  99             [ c-type>> string>c-type ] [ array-info>> ] bi
 100             [ fixed-size>> [ 2array ] when* ] when*
 101         ]
 102         [ drop { } ] tri <struct-slot-spec>
 103     ] map ;
 104
 105 : define-ffi-record-defer ( record -- word )
 106     c-type>> create-in void* swap [ typedef ] keep ;
 107
 108 : define-ffi-records-defer ( records -- )
 109     [ define-ffi-record-defer ] define-each ;
 110
 111 : define-ffi-record ( record -- word )
 112     dup ffi>> forget
 113     dup {
 114         [ fields>> empty? not ]
 115         [ c-type>> implement-structs get-global member? ]
 116     } 1&&
 117     [
 118         [ c-type>> create-class-in dup ]
 119         [ fields>> fields>struct-slots ] bi define-struct-class
 120     ] [
 121         [ disguised?>> void* void ? ]
 122         [ c-type>> create-in ] bi [ typedef ] keep
 123     ] if ;
 124
 125 : define-ffi-records ( records -- )
 126     [ define-ffi-record ] define-each ;
 127
 128 : define-ffi-record-content ( record -- )
 129     {
 130         [ constructors>> define-ffi-functions ]
 131         [ functions>> define-ffi-functions ]
 132         [ methods>> define-ffi-functions ]
 133     } cleave ;
 134
 135 : define-ffi-records-content ( records -- )
 136     [ define-ffi-record-content ] each ;
 137
 138 : define-ffi-union ( union -- word )
 139     c-type>> create-in [ void* swap typedef ] keep ;
 140
 141 : define-ffi-unions ( unions -- )
 142     [ define-ffi-union ] define-each ;
 143
 144 : define-ffi-callbacks ( callbacks -- )
 145     [ define-ffi-callback ] define-each ;
 146
 147 : define-ffi-interface ( interface -- word )
 148     c-type>> create-in [ void swap typedef ] keep ;
 149
 150 : define-ffi-interfaces ( interfaces -- )
 151     [ define-ffi-interface ] define-each ;
 152
 153 : define-ffi-interface-content ( interface -- )
 154     {
 155         [ methods>> define-ffi-functions ]
 156     } cleave ;
 157
 158 : define-ffi-interfaces-content ( interfaces -- )
 159     [ define-ffi-interface-content ] each ;
 160
 161 : get-type-invoker ( name -- quot )
 162     [ "GType" current-lib get-global ] dip
 163     { } \ alien-invoke 5 narray >quotation ;
 164
 165 : define-ffi-class ( class -- word )
 166     c-type>> create-in [ void swap typedef ] keep ;
 167
 168 : define-ffi-classes ( class -- )
 169     [ define-ffi-class ] define-each ;
 170
 171 : define-ffi-class-content ( class -- )
 172     {
 173         [ constructors>> define-ffi-functions ]
 174         [ functions>> define-ffi-functions ]
 175         [ methods>> define-ffi-functions ]
 176         [ signals>> define-ffi-signals ]
 177     } cleave ;
 178
 179 : define-ffi-classes-content ( class -- )
 180     [ define-ffi-class-content ] each ;
 181
 182 : define-get-type ( node -- word )
 183     get-type>> dup { "intern" f } member? [ drop f ]
 184     [
 185         [ create-in dup ] [ get-type-invoker ] bi
 186         { } { "type" } <effect> define-declared
 187     ] if ;
 188
 189 : define-get-types ( namespace -- )
 190     {
 191         [ enums>> [ define-get-type drop ] each ]
 192         [ bitfields>> [ define-get-type drop ] each ]
 193         [ records>> [ define-get-type drop ] each ]
 194         [ unions>> [ define-get-type drop ] each ]
 195         [ interfaces>> [ define-get-type drop ] each ]
 196         [ classes>> [ define-get-type drop ] each ]
 197     } cleave ;
 198
 199 : define-ffi-const ( const -- word )
 200     [ c-identifier>> create-in dup ] [ const-value ] bi
 201     define-constant ;
 202
 203 : define-ffi-consts ( consts -- )
 204     [ define-ffi-const ] define-each ;
 205
 206 : define-ffi-alias ( alias -- )
 207     drop ;
 208
 209 : define-ffi-aliases ( aliases -- )
 210     [ define-ffi-alias ] each ;
 211
 212 : define-ffi-namespace ( namespace -- )
 213     {
 214         [ aliases>> define-ffi-aliases ]
 215         [ consts>> define-ffi-consts ]
 216         [ enums>> define-ffi-enums ]
 217         [ bitfields>> define-ffi-bitfields ]
 218
 219         [ records>> define-ffi-records-defer ]
 220
 221         [ unions>> define-ffi-unions ]
 222         [ interfaces>> define-ffi-interfaces ]
 223         [ classes>> define-ffi-classes ]
 224         [ callbacks>> define-ffi-callbacks ]
 225         [ records>> define-ffi-records ]
 226
 227         [ records>> define-ffi-records-content ]
 228         [ classes>> define-ffi-classes-content ]
 229         [ interfaces>> define-ffi-interfaces-content ]
 230         [ functions>> define-ffi-functions ]
 231     } cleave ;
 232
 233 : define-ffi-repository ( repository -- )
 234     namespace>> define-ffi-namespace ;
 235