3 (defun is-object-record (record)
4 (let* ((record-string (string record
))
5 (record-string-len (length record-string
)))
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
)
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|
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 ")
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|
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
)
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|
)))))
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
)
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
)
87 ;; callbacks associated with the records are actually methods
90 (defun parse-enum-members (outs enum
)
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
)
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
)
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
*
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
*
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
))))
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
)
167 (for entry in
(xml-element-children namespace
))
168 (parse-element outs elements entry
))))
170 (defun parse-repository (outs repository elements
)
172 (for namespace in
(s-xml:xml-element-children repository
))
173 (parse-namespace outs namespace elements
)))