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