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