basis/gobject-introspection/ffi/ffi.factor

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