Some progress on cairo.
[trivial-gtk.git] / gir-parser.lisp
blob19a222b52728b3c0a2dfa63f1e91c419014b5529
1 (in-package :gir)
3 (defun is-object-record (record)
4 (let* ((record-string (string record))
5 (record-string-len (length record-string)))
6 (or
7 (and (> record-string-len 6)
8 (string= "OBJECT" (string-upcase (subseq record-string (- record-string-len 6))))))))
10 (defun parse-function-types (outs method)
11 (iterate
12 (for item in (s-xml:xml-element-children method))
13 (case (s-xml:xml-element-name item)
14 (GIR-CORE::|return-value|
15 (let ((return-type (first (xml-element-children item))))
16 (format outs "~T~A~%" (resolve-type (s-xml:xml-element-attribute return-type 'GIR-C::|type|)))))
17 (GIR-CORE::|parameters|
18 (iterate
19 (for parameter in (s-xml:xml-element-children item))
20 (format outs "( ~A " (s-xml:xml-element-attribute parameter :|name|))
21 (format outs " ~A )~%"
22 (resolve-type (xml-element-attribute (car (s-xml:xml-element-children parameter)) 'GIR-C::|type|))))))))
24 (defun parse-signal-types (outs gsignal)
25 (let ((name (s-xml:xml-element-attribute gsignal :|name|)))
26 (format outs "~%; ----------------- ~A ----------------~%" name)
27 (format outs "(defmacro make-~A-callback (name &rest body) ~%" (lispize name))
28 (format outs "~T(defcallback ,name ")
29 (iterate
30 (for item in (s-xml:xml-element-children gsignal))
31 (when (s-xml::xml-element-p item)
32 (case (s-xml:xml-element-name item)
33 (GIR-CORE::|return-value|
34 (let ((return-type (first (xml-element-children item))))
35 (format outs "~T~A~%" (resolve-type (s-xml:xml-element-attribute return-type 'GIR-C::|type|)))))
36 (GIR-CORE::|parameters|
37 (iterate
38 (for parameter in (s-xml:xml-element-children item))
39 (format outs "( ~A " (s-xml:xml-element-attribute parameter :|name|))
40 (format outs " ~A )~%"
41 (resolve-type (xml-element-attribute (car (s-xml:xml-element-children parameter)) 'GIR-C::|type|))))))))
42 (format outs "))~%")))
46 (defun parse-record (outs record)
47 (let ((c-type (s-xml:xml-element-attribute record 'GIR-C::|type|))
48 (name (s-xml:xml-element-attribute record :|name|)))
49 ;; we punt on object records (I think they are meant to be opaque)
50 (add-type name :struct)
51 (unless (is-object-record name)
52 (format outs "~%; ----------------- ~A ----------------~%" name)
53 (format outs "~%(defcstruct ~A ~%" name)
54 (iterate
55 (for field in (s-xml:xml-element-children record))
56 (when (eql (s-xml:xml-element-name field) 'GIR-CORE::|field|)
57 (format outs "~T(~A ~A)~%"
58 (lispize (s-xml:xml-element-attribute field :|name|))
59 (resolve-type (s-xml:xml-element-attribute field :|value|)))))
60 (format outs ")~%")
61 (iterate
62 (for method in (s-xml:xml-element-children record))
63 (when (eql (s-xml:xml-element-name method) 'GIR-CORE::|callback|)
64 (let ((name (s-xml:xml-element-attribute method :|name|)))
65 (format outs "(defcfun (~S ~A) " name (lispize name))
66 ;; to do -- still need to parse callbacks as methods!
67 (parse-function-types outs method))))
68 (format outs ")~%"))))
71 (defun parse-function (outs function)
72 (let ((c-identifier (s-xml:xml-element-attribute function 'GIR-C::|identifier|))
73 (name (s-xml:xml-element-attribute function :|name|)))
74 (format outs "~%; ----------------- ~A ---------------- " name)
75 (format outs "~%(defcfun (~S ~A) ~%" c-identifier (lispize name))
76 (parse-function-types outs function)
77 (format outs ")~%")))
79 (defun parse-constructor (outs constructor)
80 (let ((c-identifier (s-xml:xml-element-attribute constructor 'GIR-C::|identifier|))
81 (name (s-xml:xml-element-attribute constructor :|name|)))
82 (format outs "~%; ----------------- ~A ---------------- " (lispize c-identifier))
83 (format outs "~%(defcfun (~S ~A) ~%" c-identifier (lispize c-identifier))
84 (parse-function-types outs constructor)
85 (format outs ")~%")))
87 ;; callbacks associated with the records are actually methods
90 (defun parse-enum-members (outs enum)
91 (iterate
92 (for member in (s-xml:xml-element-children enum))
93 (when (eql (s-xml:xml-element-name member) 'GIR-CORE::|member|)
94 (format outs "~T(:~A ~S)~%"
95 (string-upcase (s-xml:xml-element-attribute member :|name|))
96 (parse-integer (s-xml:xml-element-attribute member :|value|))))))
98 (defun parse-enumeration (outs enum)
99 (let ((c-type (s-xml:xml-element-attribute enum 'GIR-C::|type|))
100 (name (s-xml:xml-element-attribute enum :|name|)))
101 (format outs "~%; ----------------- ~A ----------------~%" (lispize c-type))
102 (add-type (string c-type) :unsigned-int)
103 (format outs "(defcenum ~A ~% " name)
104 (parse-enum-members outs enum)
105 (format outs ")~%")))
107 (defun parse-bitfield (outs bitfield)
108 (let ((c-type (s-xml:xml-element-attribute bitfield 'GIR-C::|type|))
109 (name (s-xml:xml-element-attribute bitfield :|name|)))
110 (format outs "~%; ----------------- ~A ----------------~%" (lispize c-type))
111 (format outs "(defcenum ~A ~% " name)
112 (add-type (string c-type) :unsigned-int)
113 (parse-enum-members outs bitfield)
114 (format outs ")~%")))
116 (defun parse-class (outs gclass)
117 (iterate
118 (for method in (s-xml:xml-element-children gclass))
119 (when (s-xml::xml-element-p method)
120 (case (s-xml:xml-element-name method)
121 (GIR-CORE::|constructor| (parse-constructor outs method))
122 (GIR-CORE::|method| (parse-function outs method))
123 (GIR-CORE::|callback| (parse-signal-types outs method))))))
125 (defun parse-boxed (outs boxed)
126 (iterate
127 (for method in (s-xml:xml-element-children boxed))
128 (when (s-xml::xml-element-p method)
129 (case (s-xml:xml-element-name method)
130 (GIR-CORE::|constructor| (parse-constructor outs method))
131 (GIR-CORE::|method| (parse-function outs method))
132 (GIR-CORE::|callback| (parse-signal-types outs method))))))
134 (defun parse-callback (outs callback)
135 (let ((name (s-xml:xml-element-attribute callback :|name|)))
136 (add-type name :pointer)
137 (parse-signal-types outs callback)))
139 (defparameter *gir-top-level-type-elements*
140 ;; first pass --
141 '((GIR-CORE::|bitfield| . parse-bitfield)
142 (GIR-CORE::|enumeration| . parse-enumeration)
143 (GIR-CORE::|record| . parse-record)))
145 (defparameter *gir-top-level-function-elements*
146 ;; second pass
147 '((GIR-CORE::|callback| . parse-callback)
148 (GIR-CORE::|function| . parse-function)
149 (GIR-CORE::|class| . parse-class)
150 (GIR-GLIB::|boxed| . parse-boxed)))
153 (defun parse-element (outs elements entry)
154 (let ((name (s-xml:xml-element-name entry)))
155 (let ((fun (cdr (assoc name elements))))
156 (if fun
157 (funcall fun outs entry)))))
160 (defun parse-namespace (outs namespace elements)
161 (let ((namespace-name
162 (alexandria::make-keyword
163 (string-upcase (s-xml:xml-element-attribute namespace :|name|)))))
164 ;; (format outs "(defpackage ~S (:use :common-lisp :cffi :iterate))~%~%" namespace-name)
165 (format outs "(in-package ~S)~%" namespace-name)
166 (iterate
167 (for entry in (xml-element-children namespace))
168 (parse-element outs elements entry))))
170 (defun parse-repository (outs repository elements)
171 (iterate
172 (for namespace in (s-xml:xml-element-children repository))
173 (parse-namespace outs namespace elements)))