1 ! Copyright (C) 2010 Anton Gorenko.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors ascii combinators gobject-introspection.common
4 gobject-introspection.repository kernel literals math.parser
5 sequences splitting xml.data xml.traversal ;
6 IN: gobject-introspection.loader
8 : xml>simple-type ( xml -- type )
9 [ simple-type new ] dip {
10 [ "name" attr >>name ]
13 [ xml>simple-type ] map f like >>element-types
17 : xml>varargs-type ( xml -- type )
18 drop varargs-type new ;
20 : xml>array-type ( xml -- type )
21 [ array-type new ] dip {
22 [ "name" attr >>name ]
23 [ "zero-terminated" attr "0" = not >>zero-terminated? ]
24 [ "length" attr string>number >>length ]
25 [ "fixed-size" attr string>number >>fixed-size ]
26 [ "type" tag-named xml>simple-type >>element-type ]
29 : xml>inner-callback-type ( xml -- type )
30 [ inner-callback-type new ] dip {
31 [ "name" attr >>name ]
34 : xml>type ( xml -- type )
36 { "type" [ xml>simple-type ] }
37 { "array"[ xml>array-type ] }
38 { "callback" [ xml>inner-callback-type ] }
39 { "varargs" [ xml>varargs-type ] }
43 $[ { "array" "type" "callback" "varargs" } [ <null-name> ] map ]
45 : child-type-tag ( xml -- type-tag )
47 type-tags [ swap tag-named? ] with any?
50 : xml>alias ( xml -- alias )
52 [ "name" attr >>name ]
53 [ "type" attr >>c-type ]
54 [ child-type-tag xml>type >>type ]
57 : xml>const ( xml -- const )
59 [ "name" attr >>name ]
60 [ "value" attr >>value ]
61 [ child-type-tag xml>type >>type ]
64 : load-type ( type xml -- type )
66 [ "name" attr >>name ]
67 [ [ "type" attr ] [ "type-name" attr ] bi or >>c-type ]
68 [ "get-type" attr >>get-type ]
71 : xml>member ( xml -- member )
72 [ enum-member new ] dip {
73 [ "name" attr >>name ]
74 [ "identifier" attr >>c-identifier ]
75 [ "value" attr string>number >>value ]
78 : xml>enum ( xml -- enum )
81 [ "member" tags-named [ xml>member ] map >>members ]
84 : load-parameter ( param xml -- param )
85 [ child-type-tag xml>type >>type ]
86 [ "transfer-ownership" attr >>transfer-ownership ] bi ;
88 : xml>parameter ( xml -- parameter )
89 [ parameter new ] dip {
90 [ "name" attr >>name ]
91 [ "direction" attr dup "in" ? >>direction ]
92 [ "allow-none" attr "1" = >>allow-none? ]
93 [ child-type-tag xml>type >>type ]
94 [ "transfer-ownership" attr >>transfer-ownership ]
97 : xml>return ( xml -- return )
99 [ child-type-tag xml>type >>type ]
100 [ "transfer-ownership" attr >>transfer-ownership ]
103 : load-callable ( callable xml -- callable )
104 [ "return-value" tag-named xml>return >>return ]
106 "parameters" tag-named "parameter" tags-named
107 [ xml>parameter ] map >>parameters
110 : xml>function ( xml -- function )
111 [ function new ] dip {
112 [ "name" attr >>name ]
113 [ "identifier" attr >>identifier ]
115 [ "throws" attr "1" = >>throws? ]
118 : load-functions ( xml tag-name -- functions )
119 tags-named [ xml>function ] map ;
121 : xml>field ( xml -- field )
123 [ "name" attr >>name ]
124 [ "writable" attr "1" = >>writable? ]
125 [ "bits" attr string>number >>bits ]
126 [ child-type-tag xml>type >>type ]
129 : xml>record ( xml -- record )
133 over c-type>> implement-struct?
134 [ "field" tags-named [ xml>field ] map >>fields ]
137 [ "constructor" load-functions >>constructors ]
138 [ "method" load-functions >>methods ]
139 [ "function" load-functions >>functions ]
140 [ "disguised" attr "1" = >>disguised? ]
141 [ "is-gtype-struct-for" attr >>struct-for ]
144 : xml>union ( xml -- union )
147 [ "field" tags-named [ xml>field ] map >>fields ]
148 [ "constructor" load-functions >>constructors ]
149 [ "method" load-functions >>methods ]
150 [ "function" load-functions >>functions ]
153 : xml>callback ( xml -- callback )
154 [ callback new ] dip {
157 [ "throws" attr "1" = >>throws? ]
160 : xml>signal ( xml -- signal )
162 [ "name" attr >>name ]
166 : xml>property ( xml -- property )
167 [ property new ] dip {
168 [ "name" attr >>name ]
169 [ "writable" attr "1" = >>writable? ]
170 [ "readable" attr "0" = not >>readable? ]
171 [ "construct" attr "1" = >>construct? ]
172 [ "construct-only" attr "1" = >>construct-only? ]
173 [ child-type-tag xml>type >>type ]
176 : xml>class ( xml -- class )
179 [ "abstract" attr "1" = >>abstract? ]
180 [ "parent" attr >>parent ]
181 [ "type-struct" attr >>type-struct ]
182 [ "constructor" load-functions >>constructors ]
183 [ "method" load-functions >>methods ]
184 [ "function" load-functions >>functions ]
185 [ "signal" tags-named [ xml>signal ] map >>signals ]
188 : xml>interface ( xml -- interface )
189 [ interface new ] dip {
191 [ "method" load-functions >>methods ]
192 [ "function" load-functions >>functions ]
193 [ "signal" tags-named [ xml>signal ] map >>signals ]
196 : xml>boxed ( xml -- boxed )
200 : fix-conts ( namespace -- )
201 [ symbol-prefixes>> first >upper "_" append ] [ consts>> ] bi
202 [ [ name>> append ] keep c-identifier<< ] with each ;
204 : postprocess-namespace ( namespace -- )
207 : xml>namespace ( xml -- namespace )
208 [ namespace new ] dip {
209 [ "name" attr >>name ]
210 [ "identifier-prefixes" attr "," split >>identifier-prefixes ]
211 [ "symbol-prefixes" attr "," split >>symbol-prefixes ]
212 [ "alias" tags-named [ xml>alias ] map >>aliases ]
213 [ "constant" tags-named [ xml>const ] map >>consts ]
214 [ "enumeration" tags-named [ xml>enum ] map >>enums ]
215 [ "bitfield" tags-named [ xml>enum ] map >>bitfields ]
216 [ "record" tags-named [ xml>record ] map >>records ]
217 [ "union" tags-named [ xml>union ] map >>unions ]
218 [ "boxed" tags-named [ xml>boxed ] map >>boxeds ]
219 [ "callback" tags-named [ xml>callback ] map >>callbacks ]
220 [ "class" tags-named [ xml>class ] map >>classes ]
221 [ "interface" tags-named [ xml>interface ] map >>interfaces ]
222 [ "function" load-functions >>functions ]
223 } cleave [ postprocess-namespace ] keep ;
225 : xml>repository ( xml -- repository )
226 [ repository new ] dip
227 "namespace" tag-named xml>namespace >>namespace ;