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
9 gobject-introspection.standard-types
10 prettyprint ascii gobject-introspection.repository locals
11 compiler.units make splitting.monotonic
13 sequences.generalizations words words.constant ;
14 IN: gobject-introspection.ffi
16 SYMBOL: constant-prefix
18 : def-c-type ( c-type-name base-c-type -- )
19 swap (CREATE-C-TYPE) typedef ;
21 : defer-c-type ( c-type-name -- c-type )
22 deferred-type swap (CREATE-C-TYPE) [ typedef ] keep ;
24 ! [ fake-definition ] [ undefined-def define ] bi ;
26 :: defer-types ( types type-info-class -- )
28 [ c-type>> defer-c-type ]
29 [ name>> qualified-name ] bi
30 type-info-class new swap register-type
33 : def-alias-c-type ( base-c-type c-type-name -- c-type )
34 (CREATE-C-TYPE) [ typedef ] keep ;
36 : alias-c-type-name ( alias -- c-type-name )
37 ! <workaround for alises w/o c:type (Atk)
38 [ c-type>> ] [ name>> ] bi or ;
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 ;
47 : def-aliases ( aliases -- )
50 GENERIC: type>c-type ( type -- c-type )
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> ;
62 M: boxed-array-type type>c-type
63 name>> simple-type new swap >>name type>c-type ;
65 M: c-array-type type>c-type
66 element-type>> type>c-type <pointer> ;
68 M: fixed-size-array-type type>c-type
69 [ element-type>> type>c-type ] [ fixed-size>> ] bi 2array ;
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* ;
76 GENERIC: parse-const-value ( str data-type -- value )
78 M: atomic-type parse-const-value
80 { "gint" [ string>number ] }
81 { "gdouble" [ string>number ] }
84 M: utf8-type parse-const-value drop ;
86 : const-value ( const -- value )
87 [ value>> ] [ type>> ] bi parse-const-value ;
89 : const-name ( const -- name )
90 name>> constant-prefix get swap "_" glue ;
92 : def-const ( const -- )
93 [ const-name create-in dup reset-generic ]
94 [ const-value ] bi define-constant ;
96 : def-consts ( consts -- )
99 : define-enum-member ( member -- )
100 [ c-identifier>> create-in dup reset-generic ]
101 [ value>> ] bi define-constant ;
103 : def-enum-type ( enum -- )
104 [ members>> [ define-enum-member ] each ]
105 [ c-type>> int def-c-type ] bi ;
107 : def-bitfield-type ( bitfield -- )
110 GENERIC: parameter-type>c-type ( data-type -- c-type )
112 M: data-type parameter-type>c-type type>c-type ;
113 M: varargs-type parameter-type>c-type drop void* ;
115 : parameter-c-type ( parameter -- c-type )
116 [ type>> parameter-type>c-type ] keep
117 direction>> "in" = [ <pointer> ] unless ;
119 GENERIC: return-type>c-type ( data-type -- c-type )
121 M: data-type return-type>c-type type>c-type ;
122 M: none-type return-type>c-type drop void ;
124 : return-c-type ( return -- c-type )
125 type>> return-type>c-type ;
127 : parameter-name ( parameter -- name )
128 dup type>> varargs-type?
129 [ drop "varargs" ] [ name>> "!incorrect-name!" or ] if ;
131 : error-parameter ( -- parameter )
135 "none" >>transfer-ownership
136 simple-type new "GLib.Error" >>name >>type ;
138 : ?suffix-parameters-with-error ( callable -- parameters )
139 [ parameters>> ] [ throws?>> ] bi
140 [ error-parameter suffix ] when ;
142 : parameter-names&types ( callable -- names types )
143 [ [ parameter-c-type ] map ] [ [ parameter-name ] map ] bi ;
145 : def-function ( function -- )
147 [ return>> return-c-type ]
149 [ drop current-library get ]
150 [ ?suffix-parameters-with-error parameter-names&types ]
151 } cleave make-function define-inline ;
153 : def-functions ( functions -- )
154 [ def-function ] each ;
156 GENERIC: type>data-type ( type -- data-type )
158 M: type type>data-type
159 [ simple-type new ] dip name>> >>name ;
161 : word-started? ( word letter -- ? )
162 [ letter? ] [ LETTER? ] bi* and ; inline
164 : camel-case>underscore-separated ( str -- str' )
165 [ word-started? not ] monotonic-split "_" join >lower ;
167 : type>parameter-name ( type -- name )
168 name>> camel-case>underscore-separated ;
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 ]
177 :: def-method ( method type -- )
179 [ return>> return-c-type ]
181 [ drop current-library get ]
183 ?suffix-parameters-with-error
184 type type>parameter prefix
185 parameter-names&types
187 } cleave make-function define-inline ;
189 : def-methods ( methods type -- )
190 [ def-method ] curry each ;
192 : def-callback-type ( callback -- )
194 [ drop current-library get ]
195 [ return>> return-c-type ]
197 [ ?suffix-parameters-with-error parameter-names&types ]
198 } cleave make-callback-type define-inline ;
200 GENERIC: field-type>c-type ( data-type -- c-type )
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 ;
206 : field>struct-slot ( field -- slot )
208 [ dup bits>> [ drop uint ] [ type>> field-type>c-type ] if ]
211 [ drop ] ! [ writable?>> [ read-only , ] unless ]
212 [ bits>> [ bits: , , ] when* ] bi
214 ] tri <struct-slot-spec> ;
216 : def-record-type ( record -- )
217 dup c-type>> implement-structs get-global member?
219 [ c-type>> create-class-in ]
220 [ fields>> [ field>struct-slot ] map ] bi
222 ] [ c-type>> void def-c-type ] if ;
224 : def-record ( record -- )
227 [ constructors>> def-functions ]
228 [ functions>> def-functions ]
229 [ [ methods>> ] keep def-methods ]
232 : def-union-type ( union -- )
233 c-type>> void def-c-type ;
235 : def-union ( union -- )
238 [ constructors>> def-functions ]
239 [ functions>> def-functions ]
240 [ [ methods>> ] keep def-methods ]
243 : def-boxed-type ( boxed -- )
244 c-type>> void def-c-type ;
246 : signal-name ( signal type -- name )
247 swap [ c-type>> ] [ name>> ] bi* ":" glue ;
249 : user-data-parameter ( -- parameter )
253 "none" >>transfer-ownership
254 simple-type new "gpointer" >>name >>type ;
256 :: def-signal ( signal type -- )
258 [ drop current-library get ]
259 [ return>> return-c-type ]
262 parameters>> type type>parameter prefix
263 user-data-parameter suffix parameter-names&types
265 } cleave make-callback-type define-inline ;
267 : def-signals ( signals type -- )
268 [ def-signal ] curry each ;
270 : def-class-type ( class -- )
271 c-type>> void def-c-type ;
273 : def-class ( class -- )
276 [ constructors>> def-functions ]
277 [ functions>> def-functions ]
278 [ [ methods>> ] keep def-methods ]
279 [ [ signals>> ] keep def-signals ]
282 : def-interface-type ( interface -- )
283 c-type>> void def-c-type ;
285 : def-interface ( class -- )
287 [ def-interface-type ]
288 [ functions>> def-functions ]
289 [ [ methods>> ] keep def-methods ]
290 [ [ signals>> ] keep def-signals ]
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 ;
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 ;
311 : def-namespace ( namespace -- )
313 [ symbol-prefixes>> first >upper constant-prefix set ]
314 [ consts>> def-consts ]
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 ]
325 [ aliases>> def-aliases ]
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 ]
336 [ functions>> def-functions ]
339 : def-ffi-repository ( repository -- )
340 namespace>> def-namespace ;