Loading on win32 systems tested
[trivial-gtk.git] / gir-parser.lisp
bloba48641b89a8c5d4c375d3f5e78759b1be069d1ea
1 (in-package :gir)
3 (defun named-xml-element-child (element name)
4 (find-if #'(lambda (x)
5 (and (s-xml::xml-element-p x)
6 (equal (s-xml::xml-element-name x) name)))
7 (s-xml::xml-element-children element)))
9 (defun is-field-element-p (element)
10 (equal (s-xml:xml-element-name element) 'GIR-CORE::|field|))
12 (defun is-callback-element-p (element)
13 (equal (s-xml:xml-element-name element) 'GIR-CORE::|callback|))
15 (defun is-object-record (record)
16 (let* ((record-string (string record))
17 (record-string-len (length record-string)))
18 (or
19 (and (> record-string-len 6)
20 (string= "OBJECT" (string-upcase (subseq record-string (- record-string-len 6))))))))
22 (defun parse-function-types (outs method)
23 (let ((return-value
24 (named-xml-element-child method 'GIR-CORE:|return-value|))
25 (parameters
26 (named-xml-element-child method 'GIR-CORE:|parameters|)))
27 (let ((return-type (first (xml-element-children return-value))))
28 (format outs " ~A~%" (resolve-type (s-xml:xml-element-attribute return-type 'GIR-C::|type|))))
29 (when (s-xml::xml-element-p parameters)
30 (iterate
31 (for parameter in (s-xml:xml-element-children parameters))
32 (format outs "~&~T( ~A " (s-xml:xml-element-attribute parameter :|name|))
33 (format outs " ~A )"
34 (resolve-type (xml-element-attribute (car (s-xml:xml-element-children parameter)) 'GIR-C::|type|)))))))
36 (defun parse-signal-types (outs gsignal)
37 (let ((name (s-xml:xml-element-attribute gsignal :|name|)))
38 (format outs "~%; ----------------- ~A ----------------~%" name)
39 (format outs "(defmacro make-~A (name &rest body) ~%" (lispize name))
40 (format outs "~T(defcallback ,name ")
41 (let ((return-value (named-xml-element-child gsignal 'GIR-CORE::|return-value|)))
42 (let ((return-type (first (xml-element-children return-value))))
43 (format outs "~&~T~A" (resolve-type (s-xml:xml-element-attribute return-type 'GIR-C::|type|))))
44 (format outs "~T( ")
45 (iterate
46 (for item in (s-xml:xml-element-children gsignal))
47 (when (s-xml::xml-element-p item)
48 (case (s-xml:xml-element-name item)
49 (GIR-CORE::|parameters|
50 (iterate
51 (for parameter in (s-xml:xml-element-children item))
52 (format outs "( ~A " (s-xml:xml-element-attribute parameter :|name|))
53 (format outs " ~A ) "
54 (resolve-type (xml-element-attribute (car (s-xml:xml-element-children parameter)) 'GIR-C::|type|))))))))
55 (format outs ")"))
56 (format outs "~%~T,@body))~%")))
60 (defun parse-record (outs record)
61 (let ((c-type (s-xml:xml-element-attribute record 'GIR-C::|type|))
62 (name (s-xml:xml-element-attribute record :|name|)))
63 ;; we punt on object records (I think they are meant to be opaque)
64 (add-type name :struct)
65 ;; if the struct is actually an object type, we aren't interested (they are supposed to be opaque!?)
66 (unless (is-object-record name)
67 (let
68 ((fields (remove-if-not #'is-field-element-p (s-xml::xml-element-children record)))
69 (callbacks (remove-if-not #'is-callback-element-p (s-xml::xml-element-children record))))
70 (format outs "~%; ----------------- ~A ----------------~%" name)
71 (when (or (not (zerop (length fields))) (not (zerop (length callbacks))))
72 (format outs "~%; ----------------- ~A : fields ----------------~%" name)
73 (when (not (zerop (length fields)))
74 (format outs "~%(defcstruct ~A ~%" name)
75 (iterate
76 (for field in fields)
77 (format outs "~&~T(~A ~A)"
78 (lispize (s-xml:xml-element-attribute field :|name|))
79 (resolve-type (s-xml:xml-element-attribute
80 (named-xml-element-child field 'GIR-CORE:|type|)
81 'GIR-C::|type|))))
82 (format outs ")~%"))
83 (when (not (zerop (length callbacks)))
84 (format outs "~%; ----------------- ~A : methods ----------------~%" name)
85 (iterate
86 (for method in callbacks)
87 (let ((name (s-xml:xml-element-attribute method :|name|)))
88 (format outs "(defcfun (~S ~A) " name (lispize name))
89 (parse-function-types outs method)
90 (format outs ")~%~%")))))))))
94 (defun parse-function (outs function)
95 (let ((c-identifier (s-xml:xml-element-attribute function 'GIR-C::|identifier|))
96 (name (s-xml:xml-element-attribute function :|name|)))
97 (format outs "~%; ----------------- Function: ~A ---------------- " name)
98 (format outs "~%(defcfun (~S ~A)" c-identifier (lispize name))
99 (parse-function-types outs function)
100 (format outs ")~%")))
102 (defun parse-constructor (outs constructor)
103 (let ((c-identifier (s-xml:xml-element-attribute constructor 'GIR-C::|identifier|))
104 (name (s-xml:xml-element-attribute constructor :|name|)))
105 (format outs "~%; ----------------- Constructor: ~A ---------------- " (lispize c-identifier))
106 (format outs "~%(defcfun (~S ~A) " c-identifier (lispize c-identifier))
107 (parse-function-types outs constructor)
108 (format outs ")~%")))
110 ;; callbacks associated with the records are actually methods
113 (defun parse-enum-members (outs enum)
114 (iterate
115 (for member in (s-xml:xml-element-children enum))
116 (when (eql (s-xml:xml-element-name member) 'GIR-CORE::|member|)
117 (format outs "~&~T(:~A ~S)"
118 (string-upcase (s-xml:xml-element-attribute member :|name|))
119 (parse-integer (s-xml:xml-element-attribute member :|value|))))))
121 (defun parse-enumeration (outs enum)
122 (let ((c-type (s-xml:xml-element-attribute enum 'GIR-C::|type|))
123 (name (s-xml:xml-element-attribute enum :|name|)))
124 (format outs "~%; ----------------- Enumeration: ~A ----------------~%" (lispize c-type))
125 (add-type (string c-type) :unsigned-int)
126 (format outs "(defcenum ~A " name)
127 (parse-enum-members outs enum)
128 (format outs ")~%")))
130 (defun parse-bitfield (outs bitfield)
131 (let ((c-type (s-xml:xml-element-attribute bitfield 'GIR-C::|type|))
132 (name (s-xml:xml-element-attribute bitfield :|name|)))
133 (format outs "~%; ----------------- ~A ----------------~%" (lispize c-type))
134 (format outs "(defcenum ~A " name)
135 (add-type (string c-type) :unsigned-int)
136 (parse-enum-members outs bitfield)
137 (format outs ")~%")))
139 (defun parse-class (outs gclass)
140 (iterate
141 (for method in (s-xml:xml-element-children gclass))
142 (when (s-xml::xml-element-p method)
143 (case (s-xml:xml-element-name method)
144 (GIR-CORE::|constructor| (parse-constructor outs method))
145 (GIR-CORE::|method| (parse-function outs method))
146 (GIR-CORE::|callback| (parse-signal-types outs method))))))
148 (defun parse-boxed (outs boxed)
149 (iterate
150 (for method in (s-xml:xml-element-children boxed))
151 (when (s-xml::xml-element-p method)
152 (case (s-xml:xml-element-name method)
153 (GIR-CORE::|constructor| (parse-constructor outs method))
154 (GIR-CORE::|method| (parse-function outs method))
155 (GIR-CORE::|callback| (parse-signal-types outs method))))))
157 (defun parse-callback (outs callback)
158 (let ((name (s-xml:xml-element-attribute callback :|name|)))
159 (add-type name :pointer)
160 (parse-signal-types outs callback)))
162 (defparameter *gir-top-level-type-elements*
163 ;; first pass --
164 '((GIR-CORE::|bitfield| . parse-bitfield)
165 (GIR-CORE::|enumeration| . parse-enumeration)
166 (GIR-CORE::|record| . parse-record)))
168 (defparameter *gir-top-level-function-elements*
169 ;; second pass
170 '((GIR-CORE::|callback| . parse-callback)
171 (GIR-CORE::|function| . parse-function)
172 (GIR-CORE::|class| . parse-class)
173 (GIR-GLIB::|boxed| . parse-boxed)))
176 (defun parse-element (outs elements entry)
177 (let ((name (s-xml:xml-element-name entry)))
178 (let ((fun (cdr (assoc name elements))))
179 (if fun
180 (funcall fun outs entry)))))
183 (defun parse-namespace (outs namespace elements)
184 (let ((namespace-name
185 (alexandria::make-keyword
186 (string-upcase (s-xml:xml-element-attribute namespace :|name|)))))
187 ;; (format outs "(defpackage ~S (:use :common-lisp :cffi :iterate))~%~%" namespace-name)
188 (format outs "(in-package ~S)~%" namespace-name)
189 (iterate
190 (for entry in (xml-element-children namespace))
191 (parse-element outs elements entry))))
193 (defun parse-repository (outs repository elements)
194 (iterate
195 (for namespace in (s-xml:xml-element-children repository))
196 (parse-namespace outs namespace elements)))