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