basis/gobject-introspection/ffi/ffi.factor

   1 ! Copyright (C) 2010 Anton Gorenko.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.c-types alien.parser arrays ascii
   4 classes.parser classes.struct combinators gobject-introspection.common
   5 gobject-introspection.repository gobject-introspection.types kernel
   6 locals make math.parser namespaces parser sequences
   7 splitting.monotonic words words.constant ;
   8 IN: gobject-introspection.ffi
   9
  10 SYMBOL: constant-prefix
  11
  12 : def-c-type ( c-type-name base-c-type -- )
  13     swap (CREATE-C-TYPE) typedef ;
  14
  15 : defer-c-type ( c-type-name -- c-type )
  16     deferred-type swap (CREATE-C-TYPE) [ typedef ] keep ;
  17 !     create-in dup
  18 !     [ fake-definition ] [ undefined-def define ] bi ;
  19
  20 :: defer-types ( types type-info-class -- )
  21     types [
  22         [ c-type>> defer-c-type ]
  23         [ name>> qualified-name ] bi
  24         type-info-class new swap register-type
  25     ] each ;
  26
  27 : def-alias-c-type ( base-c-type c-type-name -- c-type )
  28     (CREATE-C-TYPE) [ typedef ] keep ;
  29
  30 : alias-c-type-name ( alias -- c-type-name )
  31     ! <workaround for alises w/o c:type (Atk)
  32     [ c-type>> ] [ name>> ] bi or ;
  33     ! workaround>
  34     ! c-type>> ;
  35
  36 :: def-alias ( alias -- )
  37     alias type>> get-type-info
  38     [ c-type>> alias alias-c-type-name def-alias-c-type ]
  39     [ clone ] bi alias name>> qualified-name register-type ;
  40
  41 : def-aliases ( aliases -- )
  42     [ def-alias ] each ;
  43
  44 GENERIC: type>c-type ( type -- c-type )
  45
  46 M: atomic-type type>c-type get-type-info c-type>> ;
  47 M: enum-type type>c-type get-type-info c-type>> ;
  48 M: bitfield-type type>c-type get-type-info c-type>> ;
  49 M: record-type type>c-type get-type-info c-type>> <pointer> ;
  50 M: union-type type>c-type get-type-info c-type>> <pointer> ;
  51 M: boxed-type type>c-type get-type-info c-type>> <pointer> ;
  52 M: callback-type type>c-type get-type-info c-type>> ;
  53 M: class-type type>c-type get-type-info c-type>> <pointer> ;
  54 M: interface-type type>c-type get-type-info c-type>> <pointer> ;
  55
  56 M: boxed-array-type type>c-type
  57     name>> simple-type new swap >>name type>c-type ;
  58
  59 M: c-array-type type>c-type
  60     element-type>> type>c-type <pointer> ;
  61
  62 M: fixed-size-array-type type>c-type
  63     [ element-type>> type>c-type ] [ fixed-size>> ] bi 2array ;
  64
  65 ! <workaround for <type/> (in some signals and properties)
  66 PREDICATE: incorrect-type < simple-type name>> not ;
  67 M: incorrect-type type>c-type drop void* ;
  68 ! workaround>
  69
  70 GENERIC: parse-const-value ( str data-type -- value )
  71
  72 M: atomic-type parse-const-value
  73     name>> {
  74         { "gint" [ string>number ] }
  75         { "gdouble" [ string>number ] }
  76     } case ;
  77
  78 M: utf8-type parse-const-value drop ;
  79
  80 : const-value ( const -- value )
  81     [ value>> ] [ type>> ] bi parse-const-value ;
  82
  83 : const-name ( const -- name )
  84     name>> constant-prefix get swap "_" glue ;
  85
  86 : def-const ( const -- )
  87     [ const-name create-in dup reset-generic ]
  88     [ const-value ] bi define-constant ;
  89
  90 : def-consts ( consts -- )
  91     [ def-const ] each ;
  92
  93 : define-enum-member ( member -- )
  94     [ c-identifier>> create-in dup reset-generic ]
  95     [ value>> ] bi define-constant ;
  96
  97 : def-enum-type ( enum -- )
  98     [ members>> [ define-enum-member ] each ]
  99     [ c-type>> int def-c-type ] bi ;
 100
 101 : def-bitfield-type ( bitfield -- )
 102     def-enum-type ;
 103
 104 GENERIC: parameter-type>c-type ( data-type -- c-type )
 105
 106 M: data-type parameter-type>c-type type>c-type ;
 107 M: varargs-type parameter-type>c-type drop void* ;
 108
 109 : parameter-c-type ( parameter -- c-type )
 110     [ type>> parameter-type>c-type ] keep
 111     direction>> "in" = [ <pointer> ] unless ;
 112
 113 GENERIC: return-type>c-type ( data-type -- c-type )
 114
 115 M: data-type return-type>c-type type>c-type ;
 116 M: none-type return-type>c-type drop void ;
 117
 118 : return-c-type ( return -- c-type )
 119     type>> return-type>c-type ;
 120
 121 : parameter-name ( parameter -- name )
 122     dup type>> varargs-type?
 123     [ drop "varargs" ] [ name>> "!incorrect-name!" or ] if ;
 124
 125 : error-parameter ( -- parameter )
 126     parameter new
 127         "error" >>name
 128         "in" >>direction
 129         "none" >>transfer-ownership
 130         simple-type new "GLib.Error" >>name >>type ;
 131
 132 : ?suffix-parameters-with-error ( callable -- parameters )
 133     [ parameters>> ] [ throws?>> ] bi
 134     [ error-parameter suffix ] when ;
 135
 136 : parameter-names&types ( callable -- names types )
 137     [ [ parameter-c-type ] map ] [ [ parameter-name ] map ] bi ;
 138
 139 : def-function ( function --  )
 140     {
 141         [ return>> return-c-type ]
 142         [ identifier>> ]
 143         [ drop current-library get ]
 144         [ ?suffix-parameters-with-error parameter-names&types ]
 145     } cleave make-function define-inline ;
 146
 147 : def-functions ( functions -- )
 148     [ def-function ] each ;
 149
 150 GENERIC: type>data-type ( type -- data-type )
 151
 152 M: type type>data-type
 153     [ simple-type new ] dip name>> >>name ;
 154
 155 : word-started? ( word letter -- ? )
 156     [ letter? ] [ LETTER? ] bi* and ; inline
 157
 158 : camel-case>underscore-separated ( str -- str' )
 159     [ word-started? not ] monotonic-split "_" join >lower ;
 160
 161 : type>parameter-name ( type -- name )
 162     name>> camel-case>underscore-separated ;
 163
 164 : type>parameter ( type -- parameter )
 165     [ parameter new ] dip {
 166         [ type>parameter-name >>name ]
 167         [ type>data-type >>type ]
 168         [ drop "in" >>direction "none" >>transfer-ownership ]
 169     } cleave ;
 170
 171 :: def-method ( method type --  )
 172     method {
 173         [ return>> return-c-type ]
 174         [ identifier>> ]
 175         [ drop current-library get ]
 176         [
 177             ?suffix-parameters-with-error
 178             type type>parameter prefix
 179             parameter-names&types
 180         ]
 181     } cleave make-function define-inline ;
 182
 183 : def-methods ( methods type -- )
 184     [ def-method ] curry each ;
 185
 186 : def-callback-type ( callback -- )
 187     {
 188         [ drop current-library get ]
 189         [ return>> return-c-type ]
 190         [ c-type>> ]
 191         [ ?suffix-parameters-with-error parameter-names&types ]
 192     } cleave make-callback-type define-inline ;
 193
 194 GENERIC: field-type>c-type ( data-type -- c-type )
 195
 196 M: simple-type field-type>c-type type>c-type ;
 197 M: inner-callback-type field-type>c-type drop void* ;
 198 M: array-type field-type>c-type type>c-type ;
 199
 200 : field>struct-slot ( field -- slot )
 201     [ name>> ]
 202     [ dup bits>> [ drop uint ] [ type>> field-type>c-type ] if ]
 203     [
 204         [
 205             [ drop ] ! [ writable?>> [ read-only , ] unless ]
 206             [ bits>> [ bits: , , ] when* ] bi
 207         ] V{ } make
 208     ] tri <struct-slot-spec> ;
 209
 210 : def-record-type ( record -- )
 211     dup c-type>> implement-structs get-global member?
 212     [
 213         [ c-type>> create-class-in ]
 214         [ fields>> [ field>struct-slot ] map ] bi
 215         define-struct-class
 216     ] [ c-type>> void def-c-type ] if ;
 217
 218 : def-record ( record -- )
 219     {
 220         [ def-record-type ]
 221         [ constructors>> def-functions ]
 222         [ functions>> def-functions ]
 223         [ [ methods>> ] keep def-methods ]
 224     } cleave ;
 225
 226 : def-union-type ( union -- )
 227     c-type>> void def-c-type ;
 228
 229 : def-union ( union -- )
 230     {
 231         [ def-union-type ]
 232         [ constructors>> def-functions ]
 233         [ functions>> def-functions ]
 234         [ [ methods>> ] keep def-methods ]
 235     } cleave ;
 236
 237 : def-boxed-type ( boxed -- )
 238     c-type>> void def-c-type ;
 239
 240 : signal-name ( signal type -- name )
 241     swap [ c-type>> ] [ name>> ] bi* ":" glue ;
 242
 243 : user-data-parameter ( -- parameter )
 244     parameter new
 245         "user_data" >>name
 246         "in" >>direction
 247         "none" >>transfer-ownership
 248         simple-type new "gpointer" >>name >>type ;
 249
 250 :: def-signal ( signal type -- )
 251     signal {
 252         [ drop current-library get ]
 253         [ return>> return-c-type ]
 254         [ type signal-name ]
 255         [
 256             parameters>> type type>parameter prefix
 257             user-data-parameter suffix parameter-names&types
 258         ]
 259     } cleave make-callback-type define-inline ;
 260
 261 : def-signals ( signals type -- )
 262     [ def-signal ] curry each ;
 263
 264 : def-class-type ( class -- )
 265     c-type>> void def-c-type ;
 266
 267 : def-class ( class -- )
 268     {
 269         [ def-class-type ]
 270         [ constructors>> def-functions ]
 271         [ functions>> def-functions ]
 272         [ [ methods>> ] keep def-methods ]
 273         [ [ signals>> ] keep def-signals ]
 274     } cleave ;
 275
 276 : def-interface-type ( interface -- )
 277     c-type>> void def-c-type ;
 278
 279 : def-interface ( class -- )
 280     {
 281         [ def-interface-type ]
 282         [ functions>> def-functions ]
 283         [ [ methods>> ] keep def-methods ]
 284         [ [ signals>> ] keep def-signals ]
 285     } cleave ;
 286
 287 : defer-enums ( enums -- ) enum-info defer-types ;
 288 : defer-bitfields ( bitfields -- ) bitfield-info defer-types ;
 289 : defer-records ( records -- ) record-info defer-types ;
 290 : defer-unions ( unions -- ) union-info defer-types ;
 291 : defer-boxeds ( boxeds -- ) boxed-info defer-types ;
 292 : defer-callbacks ( callbacks -- ) callback-info defer-types ;
 293 : defer-interfaces ( interfaces -- ) interface-info defer-types ;
 294 : defer-classes ( class -- ) class-info defer-types ;
 295
 296 : def-enums ( enums -- ) [ def-enum-type ] each ;
 297 : def-bitfields ( bitfields -- ) [ def-bitfield-type ] each ;
 298 : def-records ( records -- ) [ def-record ] each ;
 299 : def-unions ( unions -- ) [ def-union ] each ;
 300 : def-boxeds ( boxeds -- ) [ def-boxed-type ] each ;
 301 : def-callbacks ( callbacks -- ) [ def-callback-type ] each ;
 302 : def-interfaces ( interfaces -- ) [ def-interface ] each ;
 303 : def-classes ( classes -- ) [ def-class ] each ;
 304
 305 : def-namespace ( namespace -- )
 306     {
 307         [ symbol-prefixes>> first >upper constant-prefix set ]
 308         [ consts>> def-consts ]
 309
 310         [ enums>> defer-enums ]
 311         [ bitfields>> defer-bitfields ]
 312         [ records>> defer-records ]
 313         [ unions>> defer-unions ]
 314         [ boxeds>> defer-boxeds ]
 315         [ callbacks>> defer-callbacks ]
 316         [ interfaces>> defer-interfaces ]
 317         [ classes>> defer-classes ]
 318
 319         [ aliases>> def-aliases ]
 320
 321         [ enums>> def-enums ]
 322         [ bitfields>> def-bitfields ]
 323         [ records>> def-records ]
 324         [ unions>> def-unions ]
 325         [ boxeds>> def-boxeds ]
 326         [ callbacks>> def-callbacks ]
 327         [ interfaces>> def-interfaces ]
 328         [ classes>> def-classes ]
 329
 330         [ functions>> def-functions ]
 331     } cleave ;
 332
 333 : def-ffi-repository ( repository -- )
 334     namespace>> def-namespace ;
 335