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
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
10 : def-c-type ( c-type-name base-c-type -- )
11 swap (CREATE-C-TYPE) typedef ;
13 : defer-c-type ( c-type-name -- c-type )
14 deferred-type swap (CREATE-C-TYPE) [ typedef ] keep ;
16 ! [ fake-definition ] [ undefined-def define ] bi ;
18 :: defer-types ( types type-info-class -- )
20 [ c-type>> defer-c-type ]
21 [ name>> qualified-name ] bi
22 type-info-class new swap register-type
25 : def-alias-c-type ( base-c-type c-type-name -- c-type )
26 (CREATE-C-TYPE) [ typedef ] keep ;
28 : alias-c-type-name ( alias -- c-type-name )
29 ! <workaround for aliases w/o c:type (Atk)
30 [ c-type>> ] [ name>> ] bi or ;
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 ;
39 : def-aliases ( aliases -- )
42 GENERIC: type>c-type ( type -- c-type )
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> ;
54 M: boxed-array-type type>c-type
55 name>> simple-type new swap >>name type>c-type ;
57 M: c-array-type type>c-type
58 element-type>> type>c-type <pointer> ;
60 M: fixed-size-array-type type>c-type
61 [ element-type>> type>c-type ] [ fixed-size>> ] bi 2array ;
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* ;
68 GENERIC: parse-const-value ( str data-type -- value )
70 : number-type? ( name -- ? )
80 M: atomic-type parse-const-value
82 { [ dup number-type? ] [ drop string>number ] }
83 { [ dup "gboolean" = ] [ drop "true" = ] }
86 M: utf8-type parse-const-value drop ;
88 : const-value ( const -- value )
89 [ value>> ] [ type>> ] bi parse-const-value ;
91 : def-const ( const -- )
92 [ c-identifier>> create-function ] [ const-value ] bi
95 : def-consts ( consts -- )
98 : define-enum-member ( member -- )
99 [ c-identifier>> create-function ] [ value>> ] bi
102 : def-enum-type ( enum -- )
103 [ members>> [ define-enum-member ] each ]
104 [ c-type>> int def-c-type ] bi ;
106 : def-bitfield-type ( bitfield -- )
109 GENERIC: parameter-type>c-type ( data-type -- c-type )
111 M: data-type parameter-type>c-type type>c-type ;
112 M: varargs-type parameter-type>c-type drop void* ;
114 : parameter-c-type ( parameter -- c-type )
115 [ type>> parameter-type>c-type ] keep
116 direction>> "in" = [ <pointer> ] unless ;
118 GENERIC: return-type>c-type ( data-type -- c-type )
120 M: data-type return-type>c-type type>c-type ;
121 M: none-type return-type>c-type drop void ;
123 : return-c-type ( return -- c-type )
124 type>> return-type>c-type ;
126 : parameter-name ( parameter -- name )
127 dup type>> varargs-type?
128 [ drop "varargs" ] [ name>> "!incorrect-name!" or ] if ;
130 : error-parameter ( -- parameter )
134 "none" >>transfer-ownership
135 simple-type new "GLib.Error" >>name >>type ;
137 : ?suffix-parameters-with-error ( callable -- parameters )
138 [ parameters>> ] [ throws?>> ] bi
139 [ error-parameter suffix ] when ;
141 : parameter-names&types ( callable -- names types )
142 [ [ parameter-c-type ] map ] [ [ parameter-name ] map ] bi ;
144 : def-function ( function -- )
146 [ return>> return-c-type ]
148 [ drop current-library get ]
149 [ ?suffix-parameters-with-error parameter-names&types ]
150 } cleave make-function define-inline ;
152 : def-functions ( functions -- )
153 [ def-function ] each ;
155 GENERIC: type>data-type ( type -- data-type )
157 M: type type>data-type
158 [ simple-type new ] dip name>> >>name ;
160 : word-started? ( word letter -- ? )
161 [ letter? ] [ LETTER? ] bi* and ; inline
163 : camel-case>underscore-separated ( str -- str' )
164 [ word-started? not ] monotonic-split "_" join >lower ;
166 : type>parameter-name ( type -- name )
167 name>> camel-case>underscore-separated ;
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 ]
176 :: def-method ( method type -- )
178 [ return>> return-c-type ]
180 [ drop current-library get ]
182 ?suffix-parameters-with-error
183 type type>parameter prefix
184 parameter-names&types
186 } cleave make-function define-inline ;
188 : def-methods ( methods type -- )
189 [ def-method ] curry each ;
191 : def-callback-type ( callback -- )
193 [ return>> return-c-type ]
195 [ drop current-library get ]
196 [ ?suffix-parameters-with-error parameter-names&types ]
197 } cleave make-callback-type define-inline ;
199 GENERIC: field-type>c-type ( data-type -- c-type )
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 ;
205 : field>struct-slot ( field -- slot )
207 [ dup bits>> [ drop uint ] [ type>> field-type>c-type ] if ]
210 [ drop ] ! [ writable?>> [ read-only , ] unless ]
211 [ bits>> [ bits: , , ] when* ] bi
213 ] tri <struct-slot-spec> ;
215 : def-record-type ( record -- )
218 [ c-type>> create-class-in ]
219 [ fields>> [ field>struct-slot ] map ] bi
221 ] [ c-type>> void def-c-type ] if ;
223 : def-record ( record -- )
226 [ constructors>> def-functions ]
227 [ functions>> def-functions ]
228 [ [ methods>> ] keep def-methods ]
231 : def-union-type ( union -- )
232 c-type>> void def-c-type ;
234 : private-record? ( record -- ? )
237 [ name>> "Class" tail? ]
238 [ name>> "Private" tail? ]
239 [ name>> "Iface" tail? ]
242 : def-union ( union -- )
245 [ constructors>> def-functions ]
246 [ functions>> def-functions ]
247 [ [ methods>> ] keep def-methods ]
250 : find-existing-boxed-type ( boxed -- type/f )
252 dup [ c-type? ] [ "c-type" word-prop ] bi or
256 : def-boxed-type ( boxed -- )
257 c-type>> void def-c-type ;
259 : signal-name ( signal type -- name )
260 swap [ c-type>> ] [ name>> ] bi* ":" glue ;
262 : user-data-parameter ( -- parameter )
266 "none" >>transfer-ownership
267 simple-type new "gpointer" >>name >>type ;
269 :: def-signal ( signal type -- )
271 [ return>> return-c-type ]
273 [ drop current-library get ]
275 parameters>> type type>parameter prefix
276 user-data-parameter suffix parameter-names&types
278 } cleave make-callback-type define-inline ;
280 : def-signals ( signals type -- )
281 [ def-signal ] curry each ;
283 : def-class-type ( class -- )
284 c-type>> void def-c-type ;
286 : def-class ( class -- )
289 [ constructors>> def-functions ]
290 [ functions>> def-functions ]
291 [ [ methods>> ] keep def-methods ]
292 [ [ signals>> ] keep def-signals ]
295 : def-interface-type ( interface -- )
296 c-type>> void def-c-type ;
298 : def-interface ( class -- )
300 [ def-interface-type ]
301 [ functions>> def-functions ]
302 [ [ methods>> ] keep def-methods ]
303 [ [ signals>> ] keep def-signals ]
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 ;
313 : defer-boxeds ( boxeds -- )
316 dup find-existing-boxed-type
317 [ ] [ c-type>> defer-c-type ] ?if
319 [ name>> qualified-name ] bi
320 boxed-info new swap register-type
323 : defer-records ( records -- )
324 [ private-record? ] partition
325 [ begin-private record-info defer-types end-private ]
326 [ record-info defer-types ] bi* ;
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 ;
335 : def-boxeds ( boxeds -- )
336 [ find-existing-boxed-type ] reject
337 [ def-boxed-type ] each ;
339 : def-records ( records -- )
340 [ private-record? ] partition
341 [ begin-private [ def-record ] each end-private ]
342 [ [ def-record ] each ] bi* ;
344 : def-namespace ( namespace -- )
346 [ consts>> def-consts ]
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 ]
357 [ aliases>> def-aliases ]
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 ]
368 [ functions>> def-functions ]
371 : def-ffi-repository ( repository -- )
372 namespace>> def-namespace ;