3 (defvar *lisp-name-package
* nil
4 "For internal use (used by class definitions generator). Specifies the package in which symbols are interned.")
5 (defvar *strip-prefix
* "")
6 (defvar *lisp-name-exceptions
* nil
)
7 (defvar *generation-exclusions
* nil
)
8 (defvar *known-interfaces
* (make-hash-table :test
'equal
))
9 (defvar *additional-properties
* nil
)
10 (defvar *generated-types
* nil
)
12 (defun name->supplied-p
(name)
13 (make-symbol (format nil
"~A-SUPPLIED-P" (symbol-name name
))))
15 (defstruct property name accessor-name readable writable
)
17 (defstruct (gobject-property (:include property
)) gname type
)
19 (defstruct (cffi-property (:include property
)) type reader writer
)
21 (defmethod make-load-form ((object gobject-property
) &optional env
)
22 (declare (ignore env
))
23 `(make-gobject-property :name
',(property-name object
)
24 :accessor-name
',(property-accessor-name object
)
25 :readable
',(property-readable object
)
26 :writable
',(property-writable object
)
27 :gname
',(gobject-property-gname object
)
28 :type
',(gobject-property-type object
)))
30 (defmethod make-load-form ((object cffi-property
) &optional env
)
31 (declare (ignore env
))
32 `(make-cffi-property :name
',(property-name object
)
33 :accessor-name
',(property-accessor-name object
)
34 :readable
',(property-readable object
)
35 :writable
',(property-writable object
)
36 :type
',(cffi-property-type object
)
37 :reader
',(cffi-property-reader object
)
38 :writer
',(cffi-property-writer object
)))
40 (defun parse-gobject-property (spec)
41 (destructuring-bind (name accessor-name gname type readable writable
) spec
42 (make-gobject-property :name name
43 :accessor-name accessor-name
49 (defun parse-cffi-property (spec)
50 (destructuring-bind (name accessor-name type reader writer
) spec
51 (make-cffi-property :name name
52 :accessor-name accessor-name
56 :readable
(not (null reader
))
57 :writable
(not (null writer
)))))
59 (defun parse-property (spec)
61 ((eq (first spec
) :cffi
) (parse-cffi-property (rest spec
)))
62 (t (parse-gobject-property spec
))))
64 (defun property->method-arg
(property)
65 (when (or (gobject-property-p property
)
66 (and (cffi-property-p property
)
67 (property-writable property
)))
68 (let ((name (property-name property
)))
69 `(,name nil
,(name->supplied-p name
)))))
71 (defun gobject-property->arg-push
(property)
72 (assert (typep property
'gobject-property
))
73 (with-slots (name type gname
) property
74 `(when ,(name->supplied-p name
)
75 (push ,gname arg-names
)
76 (push ,type arg-types
)
77 (push ,name arg-values
))))
79 (defun cffi-property->initarg
(property)
80 (assert (typep property
'cffi-property
))
81 (when (property-writable property
)
82 (with-slots (accessor-name name type writer
) property
83 `(when ,(name->supplied-p name
)
84 (setf (,accessor-name object
) ,name
)))))
86 (defun accessor-name (class-name property-name
)
87 (intern (format nil
"~A-~A" (symbol-name class-name
)
88 (lispify-name property-name
))
91 (defgeneric property-
>reader
(class property
))
92 (defgeneric property-
>writer
(class property
))
94 (defmethod property->reader
(class (property gobject-property
))
95 (with-slots (accessor-name type gname
) property
96 `(defmethod ,accessor-name
((object ,class
))
97 (g-object-call-get-property object
,gname
,type
))))
99 (defmethod property->reader
(class (property cffi-property
))
100 (with-slots (accessor-name type reader
) property
102 (string `(defmethod ,accessor-name
((object ,class
))
103 (foreign-funcall ,reader g-object object
,type
)))
104 (symbol `(defmethod ,accessor-name
((object ,class
))
105 (funcall ',reader object
))))))
107 (defmethod property->writer
(class (property gobject-property
))
108 (with-slots (accessor-name type gname
) property
109 `(defmethod (setf ,accessor-name
) (new-value (object ,class
))
110 (g-object-call-set-property object
,gname new-value
,type
)
113 (defmethod property->writer
(class (property cffi-property
))
114 (with-slots (accessor-name type writer
) property
116 (string `(defmethod (setf ,accessor-name
) (new-value (object ,class
))
117 (foreign-funcall ,writer g-object object
,type new-value
:void
)
119 (symbol `(defmethod (setf ,accessor-name
) (new-value (object ,class
))
120 (funcall ',writer object new-value
)
123 (defun property->accessors
(class property export
)
124 (append (when (property-readable property
)
125 (list (property->reader class property
)))
126 (when (property-writable property
)
127 (list (property->writer class property
)))
129 (list `(export ',(property-accessor-name property
)
130 (find-package ,(package-name (symbol-package (property-accessor-name property
)))))))))
132 (defun interface->lisp-class-name
(interface)
135 (string (or (gethash interface
*known-interfaces
*)
136 (error "Unknown interface ~A" interface
)))))
138 (defun type-initializer-call (type-initializer)
139 (etypecase type-initializer
140 (string `(if (foreign-symbol-pointer ,type-initializer
)
141 (foreign-funcall ,type-initializer g-type
)
142 (warn "Type initializer '~A' is not available" ,type-initializer
)))
143 (symbol `(funcall ',type-initializer
))))
145 (defun meta-property->slot
(class-name property
)
146 `(,(property-name property
)
147 :allocation
,(if (gobject-property-p property
) :gobject-property
:gobject-fn
)
148 :g-property-type
,(if (gobject-property-p property
) (gobject-property-type property
) (cffi-property-type property
))
149 :accessor
,(intern (format nil
"~A-~A" (symbol-name class-name
) (property-name property
)) (symbol-package class-name
))
150 ,@(when (if (gobject-property-p property
)
152 (not (null (cffi-property-writer property
))))
154 ,(intern (string-upcase (property-name property
)) (find-package :keyword
))))
155 ,@(if (gobject-property-p property
)
156 `(:g-property-name
,(gobject-property-gname property
))
157 `(:g-getter
,(cffi-property-reader property
)
158 :g-setter
,(cffi-property-writer property
)))))
160 (defmacro define-g-object-class
(g-type-name name
161 (&key
(superclass 'g-object
)
166 (setf properties
(mapcar #'parse-property properties
))
168 (defclass ,name
(,superclass
,@(mapcar #'interface-
>lisp-class-name interfaces
))
169 (,@(mapcar (lambda (property) (meta-property->slot name property
)) properties
))
170 (:metaclass gobject-class
)
171 (:g-type-name .
,g-type-name
)
172 ,@(when type-initializer
173 (list `(:g-type-initializer .
,type-initializer
))))
175 (cons `(export ',name
(find-package ,(package-name (symbol-package name
))))
176 (mapcar (lambda (property)
177 `(export ',(intern (format nil
"~A-~A" (symbol-name name
) (property-name property
)) (symbol-package name
))
178 (find-package ,(package-name (symbol-package name
)))))
181 (defmacro define-g-interface
(g-type-name name
(&key
(export t
) type-initializer
) &body properties
)
182 (setf properties
(mapcar #'parse-property properties
))
185 (,@(mapcar (lambda (property) (meta-property->slot name property
)) properties
))
186 (:metaclass gobject-class
)
187 (:g-type-name .
,g-type-name
)
189 ,@(when type-initializer
190 (list `(:g-type-initializer .
,type-initializer
))))
192 (cons `(export ',name
(find-package ,(package-name (symbol-package name
))))
193 (mapcar (lambda (property)
194 `(export ',(intern (format nil
"~A-~A" (symbol-name name
) (property-name property
)) (symbol-package name
))
195 (find-package ,(package-name (symbol-package name
)))))
197 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
198 (setf (gethash ,g-type-name
*known-interfaces
*) ',name
))))
200 (defun starts-with (name prefix
)
201 (and prefix
(> (length name
) (length prefix
)) (string= (subseq name
0 (length prefix
)) prefix
)))
203 (defun strip-start (name prefix
)
204 (if (starts-with name prefix
)
205 (subseq name
(length prefix
))
208 (defun lispify-name (name)
209 (with-output-to-string (stream)
210 (loop for c across
(strip-start name
*strip-prefix
*)
211 for firstp
= t then nil
212 do
(when (and (not firstp
) (upper-case-p c
)) (write-char #\- stream
))
213 do
(write-char (char-upcase c
) stream
))))
215 (defun g-name->name
(name)
216 (or (second (assoc name
*lisp-name-exceptions
* :test
'equal
))
217 (intern (string-upcase (lispify-name name
)) *lisp-name-package
*)))
219 (defun property->property-definition
(class-name property
)
220 (let ((name (g-name->name
(g-class-property-definition-name property
)))
221 (accessor-name (accessor-name class-name
(g-class-property-definition-name property
)))
222 (g-name (g-class-property-definition-name property
))
223 (type (g-type-name (g-class-property-definition-type property
)))
224 (readable (g-class-property-definition-readable property
))
225 (writable (and (g-class-property-definition-writable property
)
226 (not (g-class-property-definition-constructor-only property
)))))
227 `(,name
,accessor-name
,g-name
,type
,readable
,writable
)))
229 (defun probable-type-init-name (type-name)
230 (with-output-to-string (stream)
231 (iter (for c in-string type-name
)
232 (for prev-c previous c
)
233 (when (and (not (first-iteration-p))
235 (not (upper-case-p prev-c
))
236 (not (char= prev-c
#\_
)))
237 (write-char #\_ stream
))
238 (write-char (char-downcase c
) stream
))
239 (write-string "_get_type" stream
)))
241 (defun get-g-class-definition (type &optional lisp-name-package
)
242 (when (and (stringp type
) (zerop (g-type-numeric type
)))
243 (let ((type-init-name (probable-type-init-name type
)))
244 (when (foreign-symbol-pointer type-init-name
)
245 (foreign-funcall-pointer (foreign-symbol-pointer type-init-name
) () :int
))))
246 (when *generated-types
*
247 (setf (gethash (g-type-string type
) *generated-types
*) t
))
248 (let* ((*lisp-name-package
* (or lisp-name-package
*lisp-name-package
* *package
*))
249 (g-type (ensure-g-type type
))
250 (g-name (g-type-name g-type
))
251 (name (g-name->name g-name
))
252 (superclass-g-type (g-type-parent g-type
))
253 (superclass-name (g-name->name
(g-type-name superclass-g-type
)))
254 (interfaces (g-type-interfaces g-type
))
255 (properties (class-properties g-type
))
256 (type-init-name (probable-type-init-name g-name
))
258 (sort (copy-list (remove g-type properties
:key
#'g-class-property-definition-owner-type
:test-not
#'g-type
=))
259 #'string
< :key
#'g-class-property-definition-name
)))
260 `(define-g-object-class ,g-name
,name
261 (:superclass
,superclass-name
263 :interfaces
(,@(sort (mapcar #'g-type-name interfaces
) 'string
<))
264 ,@(when (and (foreign-symbol-pointer type-init-name
)
265 (not (null-pointer-p (foreign-symbol-pointer type-init-name
))))
266 `(:type-initializer
,type-init-name
)))
267 (,@(mapcar (lambda (property)
268 (property->property-definition name property
))
270 ,@(cdr (find g-name
*additional-properties
* :key
'car
:test
'string
=))))))
272 (defun get-g-interface-definition (interface &optional lisp-name-package
)
273 (when (and (stringp interface
) (zerop (g-type-numeric interface
)))
274 (let ((type-init-name (probable-type-init-name interface
)))
275 (when (foreign-symbol-pointer type-init-name
)
276 (foreign-funcall-pointer (foreign-symbol-pointer type-init-name
) () :int
))))
277 (when *generated-types
*
278 (setf (gethash (g-type-string interface
) *generated-types
*) t
))
279 (let* ((*lisp-name-package
* (or lisp-name-package
*lisp-name-package
* *package
*))
280 (type (ensure-g-type interface
))
281 (g-name (g-type-name type
))
282 (name (g-name->name g-name
))
283 (properties (sort (copy-list (interface-properties type
))
284 #'string
< :key
#'g-class-property-definition-name
))
285 (probable-type-initializer (probable-type-init-name g-name
)))
286 `(define-g-interface ,g-name
,name
288 ,@(when (foreign-symbol-pointer probable-type-initializer
)
289 `(:type-initializer
,probable-type-initializer
)))
290 ,@(append (mapcar (lambda (property)
291 (property->property-definition name property
))
293 (cdr (find g-name
*additional-properties
* :key
'car
:test
'string
=))))))
295 (defun get-g-class-definitions-for-root-1 (type)
296 (unless (member type
*generation-exclusions
* :test
'g-type
=)
297 (iter (when (first-iteration-p)
298 (unless (and *generated-types
*
299 (gethash (g-type-string type
) *generated-types
*))
300 (appending (list (get-g-class-definition type
)))))
301 (for child-type in
(sort (copy-list (g-type-children type
)) #'string
< :key
#'g-type-string
))
302 (appending (get-g-class-definitions-for-root-1 child-type
)))))
304 (defun get-g-class-definitions-for-root (type)
305 (setf type
(ensure-g-type type
))
306 (get-g-class-definitions-for-root-1 type
))
308 (defvar *referenced-types
*)
310 (defun class-or-interface-properties (type)
311 (setf type
(ensure-g-type type
))
313 ((g-type= (g-type-fundamental type
) +g-type-object
+) (class-properties type
))
314 ((g-type= (g-type-fundamental type
) +g-type-interface
+) (interface-properties type
))))
316 (defun get-shallow-referenced-types (type)
317 (setf type
(ensure-g-type type
))
318 (remove-duplicates (sort (loop
319 for property in
(class-or-interface-properties type
)
320 when
(g-type= type
(g-class-property-definition-owner-type property
))
321 collect
(g-class-property-definition-type property
))
323 :key
#'g-type-string
)
326 (defun get-referenced-types-1 (type)
327 (setf type
(ensure-g-type type
))
329 for property-type in
(sort (copy-list (get-shallow-referenced-types type
)) #'string
> :key
#'g-type-string
)
330 do
(pushnew property-type
*referenced-types
* :test
'g-type
=))
332 for type in
(sort (copy-list (g-type-children type
)) #'string
< :key
#'g-type-string
)
333 do
(get-referenced-types-1 type
)))
335 (defun get-referenced-types (root-type)
336 (let (*referenced-types
*)
337 (get-referenced-types-1 (ensure-g-type root-type
))
340 (defun filter-types-by-prefix (types prefix
)
343 (starts-with (g-type-name (ensure-g-type type
)) prefix
))
346 (defun filter-types-by-fund-type (types fund-type
)
347 (setf fund-type
(ensure-g-type fund-type
))
350 (equal (g-type-fundamental (ensure-g-type type
)) fund-type
))
353 (defmacro define-g-enum
(g-name name
(&key
(export t
) type-initializer
) &body values
)
354 "Defines a GEnum type for enumeration. Generates corresponding CFFI definition.
358 \(define-g-enum \"GdkGrabStatus\" grab-status () :success :already-grabbed :invalid-time :not-viewable :frozen)
359 \(define-g-enum \"GdkExtensionMode\" gdk-extension-mode (:export t :type-initializer \"gdk_extension_mode_get_type\")
360 (:none 0) (:all 1) (:cursor 2))
362 @arg[g-name]{a string. Specifies the GEnum name}
363 @arg[name]{a symbol. Names the enumeration type.}
364 @arg[export]{a boolean. If true, @code{name} will be exported.}
365 @arg[type-initializer]{a @code{NIL} or a string or a function designator.
367 If non-@code{NIL}, specifies the function that initializes the type: string specifies a C function that returns the GType value and function designator specifies the Lisp function.}
368 @arg[values]{values for enum. Each value is a keyword or a list @code{(keyword integer-value)}. @code{keyword} corresponds to Lisp value of enumeration, and @code{integer-value} is an C integer for enumeration item. If @code{integer-value} is not specified, it is generated automatically (see CFFI manual)}"
370 (defcenum ,name
,@values
)
371 (register-enum-type ,g-name
',name
)
373 (list `(export ',name
(find-package ,(package-name (symbol-package name
))))))
374 ,@(when type-initializer
375 (list `(at-init () ,(type-initializer-call type-initializer
))))))
377 (defun enum-value->definition
(enum-value)
378 (let ((value-name (intern (lispify-name (enum-item-nick enum-value
))
379 (find-package :keyword
)))
380 (numeric-value (enum-item-value enum-value
)))
381 `(,value-name
,numeric-value
)))
383 (defun get-g-enum-definition (type &optional lisp-name-package
)
384 (when (and (stringp type
) (zerop (g-type-numeric type
)))
385 (let ((type-init-name (probable-type-init-name type
)))
386 (when (foreign-symbol-pointer type-init-name
)
387 (foreign-funcall-pointer (foreign-symbol-pointer type-init-name
) () :int
))))
388 (when *generated-types
*
389 (setf (gethash (g-type-string type
) *generated-types
*) t
))
390 (let* ((*lisp-name-package
* (or lisp-name-package
*lisp-name-package
* *package
*))
391 (g-type (ensure-g-type type
))
392 (g-name (g-type-name g-type
))
393 (name (g-name->name g-name
))
394 (items (get-enum-items g-type
))
395 (probable-type-initializer (probable-type-init-name g-name
)))
396 `(define-g-enum ,g-name
,name
398 ,@(when (foreign-symbol-pointer probable-type-initializer
)
399 (list :type-initializer
400 probable-type-initializer
)))
401 ,@(mapcar #'enum-value-
>definition items
))))
403 (defmacro define-g-flags
(g-name name
(&key
(export t
) type-initializer
) &body values
)
404 "Defines a GFlags type for enumeration that can combine its values. Generates corresponding CFFI definition. Values of this type are lists of keywords that are combined.
408 \(define-g-flags \"GdkWindowState\" window-state ()
410 (:iconified 2) (:maximized 4) (:sticky 8) (:fullscreen 16)
411 (:above 32) (:below 64))
413 @arg[g-name]{a string. Specifies the GEnum name}
414 @arg[name]{a symbol. Names the enumeration type.}
415 @arg[export]{a boolean. If true, @code{name} will be exported.}
416 @arg[type-initializer]{a @code{NIL} or a string or a function designator.
418 If non-@code{NIL}, specifies the function that initializes the type: string specifies a C function that returns the GType value and function designator specifies the Lisp function.}
419 @arg[values]{values for flags. Each value is a keyword or a list @code{(keyword integer-value)}. @code{keyword} corresponds to Lisp value of a flag, and @code{integer-value} is an C integer for flag. If @code{integer-value} is not specified, it is generated automatically (see CFFI manual)}"
421 (defbitfield ,name
,@values
)
422 (register-flags-type ,g-name
',name
)
424 (list `(export ',name
(find-package ,(package-name (symbol-package name
))))))
425 ,@(when type-initializer
426 (list `(at-init () ,(type-initializer-call type-initializer
))))))
428 (defun flags-value->definition
(flags-value)
429 (let ((value-name (intern (lispify-name (flags-item-nick flags-value
))
430 (find-package :keyword
)))
431 (numeric-value (flags-item-value flags-value
)))
432 `(,value-name
,numeric-value
)))
434 (defun get-g-flags-definition (type &optional lisp-name-package
)
435 (when (and (stringp type
) (zerop (g-type-numeric type
)))
436 (let ((type-init-name (probable-type-init-name type
)))
437 (when (foreign-symbol-pointer type-init-name
)
438 (foreign-funcall-pointer (foreign-symbol-pointer type-init-name
) () :int
))))
439 (when *generated-types
*
440 (setf (gethash (g-type-string type
) *generated-types
*) t
))
441 (let* ((*lisp-name-package
* (or lisp-name-package
*lisp-name-package
* *package
*))
442 (g-type (ensure-g-type type
))
443 (g-name (g-type-name g-type
))
444 (name (g-name->name g-name
))
445 (items (get-flags-items g-type
))
446 (probable-type-initializer (probable-type-init-name g-name
)))
447 `(define-g-flags ,g-name
,name
449 ,@(when (foreign-symbol-pointer probable-type-initializer
)
450 (list :type-initializer
451 probable-type-initializer
)))
452 ,@(mapcar #'flags-value-
>definition items
))))
454 (defun generate-types-hierarchy-to-file (file root-type
&key include-referenced prefix package exceptions prologue interfaces enums flags objects exclusions additional-properties
)
455 (if (not (streamp file
))
456 (with-open-file (stream file
:direction
:output
:if-exists
:supersede
)
457 (generate-types-hierarchy-to-file stream root-type
460 :exceptions exceptions
462 :include-referenced include-referenced
463 :interfaces interfaces
467 :exclusions exclusions
468 :additional-properties additional-properties
))
469 (let* ((*generation-exclusions
* (mapcar #'ensure-g-type exclusions
))
470 (*lisp-name-package
* (or package
*package
*))
471 (*package
* *lisp-name-package
*)
472 (*strip-prefix
* (or prefix
""))
473 (*lisp-name-exceptions
* exceptions
)
474 (*print-case
* :downcase
)
475 (*additional-properties
* additional-properties
)
476 (*generated-types
* (make-hash-table :test
'equalp
))
477 (referenced-types (and include-referenced
478 (filter-types-by-prefix
479 (get-referenced-types root-type
)
481 (setf exclusions
(mapcar #'ensure-g-type exclusions
))
483 (write-string prologue file
)
485 (when include-referenced
487 for interface in interfaces
489 for referenced-type in
(get-shallow-referenced-types interface
)
490 do
(pushnew referenced-type referenced-types
:test
'g-type
=)))
492 for object in objects
494 for referenced-type in
(get-shallow-referenced-types object
)
495 do
(pushnew referenced-type referenced-types
:test
'g-type
=)))
497 for enum-type in
(filter-types-by-fund-type
498 referenced-types
"GEnum")
499 for def
= (get-g-enum-definition enum-type
)
500 unless
(member enum-type exclusions
:test
'g-type
=)
501 do
(format file
"~S~%~%" def
))
504 for flags-type in
(filter-types-by-fund-type
505 referenced-types
"GFlags")
506 for def
= (get-g-flags-definition flags-type
)
507 unless
(member flags-type exclusions
:test
'g-type
=)
508 do
(format file
"~S~%~%" def
)))
510 with auto-enums
= (and include-referenced
511 (filter-types-by-fund-type
512 referenced-types
"GEnum"))
514 for def
= (get-g-enum-definition enum
)
515 unless
(find enum auto-enums
:test
'g-type
=)
516 do
(format file
"~S~%~%" def
))
518 with auto-flags
= (and include-referenced
519 (filter-types-by-fund-type
520 referenced-types
"GFlags"))
521 for flags-type in flags
522 for def
= (get-g-flags-definition flags-type
)
523 unless
(find flags-type auto-flags
:test
'g-type
=)
524 do
(format file
"~S~%~%" def
))
526 for interface in interfaces
527 for def
= (get-g-interface-definition interface
)
528 do
(format file
"~S~%~%" def
))
530 for def in
(get-g-class-definitions-for-root root-type
)
531 do
(format file
"~S~%~%" def
))
532 (iter (for object in objects
)
533 (unless (gethash (g-type-string object
) *generated-types
*)
534 (for def
= (get-g-class-definition object
))
535 (format file
"~S~%~%" def
))))))