3 (defvar *lisp-name-package* (find-package :gobject))
4 (defvar *strip-prefix* "")
5 (defvar *lisp-name-exceptions* nil)
6 (defvar *generation-exclusions* nil)
7 (defvar *known-interfaces* (make-hash-table :test 'equal))
9 (defun name->supplied-p (name)
10 (intern (format nil "~A-SUPPLIED-P" (symbol-name name))
13 (defun property->method-arg (property)
14 (destructuring-bind (name accessor-name g-name type readable writable) property
15 (declare (ignore accessor-name g-name type readable writable))
16 `(,name nil ,(name->supplied-p name))))
18 (defun property->arg-push (property)
19 (destructuring-bind (name accessor-name g-name type readable writable) property
20 (declare (ignore accessor-name readable writable))
21 `(when ,(name->supplied-p name)
22 (push ,g-name arg-names)
23 (push ,type arg-types)
24 (push ,name arg-values))))
26 (defun accessor-name (class-name property-name)
27 (intern (format nil "~A-~A" (symbol-name class-name)
28 (lispify-name property-name))
31 (defun property->reader (property)
32 (let ((name (nth 1 property))
33 (prop-name (nth 2 property))
34 (prop-type (nth 3 property)))
35 `(defun ,name (object)
36 (g-object-call-get-property object ,prop-name ,prop-type))))
38 (defun property->writer (property)
39 (let ((name (nth 1 property))
40 (prop-name (nth 2 property))
41 (prop-type (nth 3 property)))
42 `(defun (setf ,name) (new-value object)
43 (g-object-call-set-property object ,prop-name new-value ,prop-type)
46 (defun property->accessors (property export)
47 (append (when (nth 4 property)
48 (list (property->reader property)))
49 (when (nth 5 property)
50 (list (property->writer property)))
52 (list `(export ',(nth 1 property)
53 (find-package ,(package-name (symbol-package (nth 1 property)))))))))
55 (defun interface->lisp-class-name (interface)
58 (string (or (gethash interface *known-interfaces*)
59 (error "Unknown interface ~A" interface)))))
61 (defmacro define-g-object-class (g-type-name name (&optional (superclass 'g-object) (export t)) (&rest interfaces)
63 (let* ((superclass-properties (get superclass 'properties))
64 (combined-properties (append superclass-properties properties)))
66 (defclass ,name (,superclass ,@(mapcar #'interface->lisp-class-name interfaces)) ())
67 (register-object-type ,g-type-name ',name)
69 (list `(export ',name (find-package ,(package-name (symbol-package name))))))
70 (defmethod initialize-instance :before
71 ((object ,name) &key pointer
72 ,@(mapcar #'property->method-arg
74 (unless (or pointer (and (slot-boundp object 'pointer)
75 (not (null-pointer-p (pointer object)))))
76 (let (arg-names arg-values arg-types)
77 ,@(mapcar #'property->arg-push combined-properties)
78 (setf (pointer object)
79 (g-object-call-constructor ,g-type-name
83 (g-object-has-reference object) t))))
85 for property in properties
86 append (property->accessors property export))
88 (eval-when (:compile-toplevel :load-toplevel :execute)
89 (setf (get ',name 'superclass) ',superclass
90 (get ',name 'properties) ',combined-properties)))))
92 (defmacro define-g-interface (g-name name (&optional (export t)) &body properties)
94 (defclass ,name () ())
96 (list `(export ',name (find-package ,(package-name (symbol-package name))))))
98 for property in properties
99 append (property->accessors property export))
100 (eval-when (:compile-toplevel :load-toplevel :execute)
101 (setf (get ',name 'properties) ',properties)
102 (setf (gethash ,g-name *known-interfaces*) ',name))))
104 (defun starts-with (name prefix)
105 (and prefix (> (length name) (length prefix)) (string= (subseq name 0 (length prefix)) prefix)))
107 (defun strip-start (name prefix)
108 (if (starts-with name prefix)
109 (subseq name (length prefix))
112 (defun lispify-name (name)
113 (with-output-to-string (stream)
114 (loop for c across (strip-start name *strip-prefix*)
115 for firstp = t then nil
116 do (when (and (not firstp) (upper-case-p c)) (write-char #\- stream))
117 do (write-char (char-upcase c) stream))))
119 (defun g-name->name (name)
120 (or (second (assoc name *lisp-name-exceptions* :test 'equal))
121 (intern (string-upcase (lispify-name name)) *lisp-name-package*)))
123 (defun property->property-definition (class-name property)
124 (let ((name (g-name->name (g-class-property-definition-name property)))
125 (accessor-name (accessor-name class-name (g-class-property-definition-name property)))
126 (g-name (g-class-property-definition-name property))
127 (type (g-type-name (g-class-property-definition-type property)))
128 (readable (g-class-property-definition-readable property))
129 (writable (and (g-class-property-definition-writable property)
130 (not (g-class-property-definition-constructor-only property)))))
131 `(,name ,accessor-name ,g-name ,type ,readable ,writable)))
133 (defun get-g-class-definition (type)
134 (let* ((g-type (ensure-g-type type))
135 (g-name (g-type-name g-type))
136 (name (g-name->name g-name))
137 (superclass-g-type (g-type-parent g-type))
138 (superclass-name (g-name->name (g-type-name superclass-g-type)))
139 (interfaces (g-type-interfaces g-type))
140 (properties (class-properties g-type))
142 (remove-if-not (lambda (property)
144 (g-class-property-definition-owner-type property)))
146 `(define-g-object-class ,g-name ,name (,superclass-name t) (,@(mapcar #'g-type-name interfaces))
147 ,@(mapcar (lambda (property)
148 (property->property-definition name property))
151 (defun get-g-interface-definition (interface)
152 (let* ((type (ensure-g-type interface))
153 (g-name (g-type-name type))
154 (name (g-name->name g-name))
155 (properties (interface-properties type)))
156 `(define-g-interface ,g-name ,name (t)
157 ,@(mapcar (lambda (property)
158 (property->property-definition name property))
161 (defun get-g-class-definitions-for-root-1 (type)
162 (unless (member (ensure-g-type type) *generation-exclusions* :test '=)
163 (cons (get-g-class-definition type)
165 (mapcar #'get-g-class-definitions-for-root-1
166 (g-type-children type))))))
168 (defun get-g-class-definitions-for-root (type)
169 (setf type (ensure-g-type type))
170 (get-g-class-definitions-for-root-1 type))
172 (defvar *referenced-types*)
174 (defun class-or-interface-properties (type)
175 (setf type (ensure-g-type type))
177 ((= (g-type-fundamental type) +g-type-object+) (class-properties type))
178 ((= (g-type-fundamental type) +g-type-interface+) (interface-properties type))))
180 (defun get-shallow-referenced-types (type)
181 (setf type (ensure-g-type type))
182 (remove-duplicates (sort (loop
183 for property in (class-or-interface-properties type)
184 when (= type (g-class-property-definition-owner-type property))
185 collect (g-class-property-definition-type property))
189 (defun get-referenced-types-1 (type)
190 (setf type (ensure-g-type type))
192 for property-type in (get-shallow-referenced-types type)
193 do (pushnew property-type *referenced-types* :test '=))
195 for type in (g-type-children type)
196 do (get-referenced-types-1 type)))
198 (defun get-referenced-types (root-type)
199 (let (*referenced-types*)
200 (get-referenced-types-1 (ensure-g-type root-type))
203 (defun filter-types-by-prefix (types prefix)
206 (starts-with (g-type-name (ensure-g-type type)) prefix))
209 (defun filter-types-by-fund-type (types fund-type)
210 (setf fund-type (ensure-g-type fund-type))
213 (equal (g-type-fundamental (ensure-g-type type)) fund-type))
216 (defmacro define-g-enum (g-name name (&optional (export t)) &body values)
218 (defcenum ,name ,@values)
219 (register-enum-type ,g-name ',name)
221 (list `(export ',name (find-package ,(package-name (symbol-package name))))))))
223 (defun enum-value->definition (enum-value)
224 (let ((value-name (intern (lispify-name (enum-item-nick enum-value))
225 (find-package :keyword)))
226 (numeric-value (enum-item-value enum-value)))
227 `(,value-name ,numeric-value)))
229 (defun get-g-enum-definition (type)
230 (let* ((g-type (ensure-g-type type))
231 (g-name (g-type-name g-type))
232 (name (g-name->name g-name))
233 (items (get-enum-items g-type)))
234 `(define-g-enum ,g-name ,name (t) ,@(mapcar #'enum-value->definition items))))
236 (defmacro define-g-flags (g-name name (&optional (export t)) &body values)
238 (defbitfield ,name ,@values)
239 (register-enum-type ,g-name ',name)
241 (list `(export ',name (find-package ,(package-name (symbol-package name))))))))
243 (defun flags-value->definition (flags-value)
244 (let ((value-name (intern (lispify-name (flags-item-nick flags-value))
245 (find-package :keyword)))
246 (numeric-value (flags-item-value flags-value)))
247 `(,value-name ,numeric-value)))
249 (defun get-g-flags-definition (type)
250 (let* ((g-type (ensure-g-type type))
251 (g-name (g-type-name g-type))
252 (name (g-name->name g-name))
253 (items (get-flags-items g-type)))
254 `(define-g-flags ,g-name ,name (t) ,@(mapcar #'flags-value->definition items))))
256 (defun generate-types-hierarchy-to-file (file root-type &key include-referenced prefix package exceptions prologue interfaces enums flags objects exclusions)
257 (if (not (streamp file))
258 (with-open-file (stream file :direction :output :if-exists :supersede)
259 (generate-types-hierarchy-to-file stream root-type
262 :exceptions exceptions
264 :include-referenced include-referenced
265 :interfaces interfaces
269 :exclusions exclusions))
270 (let* ((*generation-exclusions* (mapcar #'ensure-g-type exclusions))
271 (*lisp-name-package* (or package *package*))
272 (*package* *lisp-name-package*)
273 (*strip-prefix* (or prefix ""))
274 (*lisp-name-exceptions* exceptions)
275 (*print-case* :downcase)
276 (referenced-types (and include-referenced
277 (filter-types-by-prefix
278 (get-referenced-types root-type)
280 (setf exclusions (mapcar #'ensure-g-type exclusions))
282 (write-string prologue file)
284 (when include-referenced
286 for interface in interfaces
288 for referenced-type in (get-shallow-referenced-types interface)
289 do (pushnew referenced-type referenced-types :test 'equal)))
291 for object in objects
293 for referenced-type in (get-shallow-referenced-types object)
294 do (pushnew referenced-type referenced-types :test 'equal)))
296 for enum-type in (filter-types-by-fund-type
297 referenced-types "GEnum")
298 for def = (get-g-enum-definition enum-type)
299 unless (member (ensure-g-type enum-type) exclusions :test '=)
300 do (format file "~S~%~%" def))
303 for flags-type in (filter-types-by-fund-type
304 referenced-types "GFlags")
305 for def = (get-g-flags-definition flags-type)
306 unless (member (ensure-g-type flags-type) exclusions :test '=)
307 do (format file "~S~%~%" def)))
309 with auto-enums = (and include-referenced
310 (filter-types-by-fund-type
311 referenced-types "GEnum"))
313 for def = (get-g-enum-definition enum)
314 unless (find (ensure-g-type enum) auto-enums :test 'equal)
315 do (format file "~S~%~%" def))
317 with auto-flags = (and include-referenced
318 (filter-types-by-fund-type
319 referenced-types "GFlags"))
320 for flags-type in flags
321 for def = (get-g-flags-definition flags-type)
322 unless (find (ensure-g-type flags-type) auto-flags :test 'equal)
323 do (format file "~S~%~%" def))
325 for interface in interfaces
326 for def = (get-g-interface-definition interface)
327 do (format file "~S~%~%" def))
329 for def in (get-g-class-definitions-for-root root-type)
330 do (format file "~S~%~%" def))
332 for object in objects
333 for def = (get-g-class-definition object)
334 do (format file "~S~%~%" def)))))