3 (define-foreign-type g-boxed-foreign-type ()
5 :accessor g-boxed-foreign-info
6 :initform (error "info must be specified"))
7 (return-p :initarg :return-p
8 :accessor g-boxed-foreign-return-p
10 (:actual-type :pointer))
12 (eval-when (:compile-toplevel :load-toplevel :execute)
13 (defstruct g-boxed-info
17 (eval-when (:compile-toplevel :load-toplevel :execute)
18 (defun get-g-boxed-foreign-info (name)
19 (get name 'g-boxed-foreign-info)))
21 (defvar *g-type-name->g-boxed-foreign-info* (make-hash-table :test 'equal))
23 (defun get-g-boxed-foreign-info-for-gtype (g-type-designator)
24 (or (gethash (g-type-string g-type-designator) *g-type-name->g-boxed-foreign-info*)
25 (error "Unknown GBoxed type '~A'" (g-type-string g-type-designator))))
27 (defgeneric make-foreign-type (info &key return-p))
29 (define-parse-method g-boxed-foreign (name &rest options)
30 (let ((info (get-g-boxed-foreign-info name)))
31 (assert info nil "Unknown foreign GBoxed type ~A" name)
32 (make-foreign-type info :return-p (member :return options))))
34 (defgeneric boxed-copy-fn (type-info native)
35 (:method (type-info native)
36 (g-boxed-copy (g-boxed-info-g-type type-info) native)))
38 (defmethod boxed-copy-fn :before (type-info native)
39 (format t "(boxed-copy-fn ~A ~A)~%" (g-boxed-info-name type-info) native))
41 (defgeneric boxed-free-fn (type-info native)
42 (:method (type-info native)
43 (g-boxed-free (g-boxed-info-g-type type-info) native)))
45 (defmethod boxed-free-fn :before (type-info native)
46 (format t "(boxed-free-fn ~A ~A)~%" (g-boxed-info-name type-info) native))
48 (defmethod has-callback-cleanup ((type g-boxed-foreign-type))
51 (eval-when (:load-toplevel :compile-toplevel :execute)
52 (defstruct (g-boxed-cstruct-wrapper-info (:include g-boxed-info))
55 (defclass boxed-cstruct-foreign-type (g-boxed-foreign-type) ())
57 (defstruct cstruct-slot-description
63 (defmethod make-load-form ((object cstruct-slot-description) &optional environment)
64 (make-load-form-saving-slots object :environment environment))
66 (defstruct cstruct-description
70 (defmethod make-load-form ((object cstruct-description) &optional environment)
71 (make-load-form-saving-slots object :environment environment))
73 (defun parse-cstruct-slot (slot)
74 (destructuring-bind (name type &key count initform) slot
75 (make-cstruct-slot-description :name name :type type :count count :initform initform)))
77 (defun parse-cstruct-definition (name slots)
78 (make-cstruct-description :name name
79 :slots (mapcar #'parse-cstruct-slot slots)))
81 (defmacro define-g-boxed-cstruct (name g-type-name &body slots)
82 (let ((cstruct-description (parse-cstruct-definition name slots)))
85 ,@(iter (for slot in (cstruct-description-slots cstruct-description))
86 (for name = (cstruct-slot-description-name slot))
87 (for initform = (cstruct-slot-description-initform slot))
88 (collect (list name initform))))
89 (defcstruct ,(generated-cstruct-name name)
90 ,@(iter (for slot in (cstruct-description-slots cstruct-description))
91 (for name = (cstruct-slot-description-name slot))
92 (for type = (cstruct-slot-description-type slot))
93 (for count = (cstruct-slot-description-count slot))
94 (collect `(,name ,type ,@(when count `(:count ,count))))))
95 (defcunion ,(generated-cunion-name name)
96 (,name ,(generated-cstruct-name name)))
97 (eval-when (:compile-toplevel :load-toplevel :execute)
98 (setf (get ',name 'g-boxed-foreign-info)
99 (make-g-boxed-cstruct-wrapper-info :name ',name
101 :cstruct-description ,cstruct-description)
102 (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
103 (get ',name 'g-boxed-foreign-info))))))
105 (defmethod make-foreign-type ((info g-boxed-cstruct-wrapper-info) &key return-p)
106 (make-instance 'boxed-cstruct-foreign-type :info info :return-p return-p))
108 (defun memcpy (target source bytes)
109 (iter (for i from 0 below bytes)
110 (setf (mem-aref target :uchar i)
111 (mem-aref source :uchar i))))
113 (defmethod boxed-copy-fn ((info g-boxed-cstruct-wrapper-info) native)
114 (if (g-boxed-info-g-type info)
115 (g-boxed-copy (g-boxed-info-g-type info) native)
116 (let ((copy (foreign-alloc (generated-cstruct-name (g-boxed-info-name info)))))
117 (memcpy copy native (foreign-type-size (generated-cstruct-name (g-boxed-info-name info))))
120 (defmethod boxed-free-fn ((info g-boxed-cstruct-wrapper-info) native)
121 (if (g-boxed-info-g-type info)
122 (g-boxed-free (g-boxed-info-g-type info) native)
123 (foreign-free native)))
125 (defun copy-slots-to-native (proxy native cstruct-description)
126 (iter (with cstruct-type = (generated-cstruct-name (cstruct-description-name cstruct-description)))
127 (for slot in (cstruct-description-slots cstruct-description))
128 (for slot-name = (cstruct-slot-description-name slot))
130 ((cstruct-slot-description-count slot)
131 (iter (with ptr = (foreign-slot-pointer native cstruct-type slot-name))
132 (with array = (slot-value proxy slot-name))
133 (for i from 0 below (cstruct-slot-description-count slot))
134 (setf (mem-aref ptr (cstruct-slot-description-type slot) i)
137 (setf (foreign-slot-value native cstruct-type slot-name)
138 (slot-value proxy slot-name))))))
140 (defun copy-slots-to-proxy (proxy native cstruct-description)
141 (iter (with cstruct-type = (generated-cstruct-name (cstruct-description-name cstruct-description)))
142 (for slot in (cstruct-description-slots cstruct-description))
143 (for slot-name = (cstruct-slot-description-name slot))
145 ((cstruct-slot-description-count slot)
146 (setf (slot-value proxy slot-name) (make-array (list (cstruct-slot-description-count slot))))
147 (iter (with ptr = (foreign-slot-pointer native cstruct-type slot-name))
148 (with array = (slot-value proxy slot-name))
149 (for i from 0 below (cstruct-slot-description-count slot))
151 (mem-aref ptr (cstruct-slot-description-type slot) i))))
152 (t (setf (slot-value proxy slot-name)
153 (foreign-slot-value native cstruct-type slot-name))))))
155 (defmethod translate-to-foreign (proxy (type boxed-cstruct-foreign-type))
158 (let* ((info (g-boxed-foreign-info type))
159 (native-structure-type (generated-cstruct-name (g-boxed-info-name info))))
160 (with-foreign-object (native-structure native-structure-type)
161 (copy-slots-to-native proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info))
162 (values (boxed-copy-fn info native-structure) proxy)))))
164 (defmethod free-translated-object (native-structure (type boxed-cstruct-foreign-type) proxy)
166 (let ((info (g-boxed-foreign-info type)))
167 (copy-slots-to-proxy proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info))
168 (boxed-free-fn info native-structure))))
170 (defmethod translate-from-foreign (native-structure (type boxed-cstruct-foreign-type))
171 (unless (null-pointer-p native-structure)
172 (let* ((info (g-boxed-foreign-info type))
173 (proxy-structure-type (g-boxed-info-name info))
174 (proxy (make-instance proxy-structure-type)))
175 (copy-slots-to-proxy proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info))
176 (when (g-boxed-foreign-return-p type)
177 (boxed-free-fn info native-structure))
180 (defmethod cleanup-translated-object-for-callback ((type boxed-cstruct-foreign-type) proxy native-structure)
182 (let ((info (g-boxed-foreign-info type)))
183 (copy-slots-to-native proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info)))))
185 (eval-when (:compile-toplevel :load-toplevel :execute)
186 (defstruct (g-boxed-opaque-wrapper-info (:include g-boxed-info))
189 (define-foreign-type boxed-opaque-foreign-type (g-boxed-foreign-type) ())
191 (defclass g-boxed-opaque ()
192 ((pointer :initarg :pointer
194 :accessor g-boxed-opaque-pointer)))
196 (defmethod make-foreign-type ((info g-boxed-opaque-wrapper-info) &key return-p)
197 (make-instance 'boxed-opaque-foreign-type :info info :return-p return-p))
199 (defmethod translate-to-foreign (proxy (type boxed-opaque-foreign-type))
200 (prog1 (g-boxed-opaque-pointer proxy)
201 (when (g-boxed-foreign-return-p type)
202 (tg:cancel-finalization proxy)
203 (setf (g-boxed-opaque-pointer proxy) nil))))
205 (defmethod free-translated-object (native (type boxed-opaque-foreign-type) param)
206 (declare (ignore native type param)))
208 (defun make-boxed-free-finalizer (type pointer)
209 (lambda () (boxed-free-fn type pointer)))
211 (defmethod translate-from-foreign (native (foreign-type boxed-opaque-foreign-type))
212 (let* ((type (g-boxed-foreign-info foreign-type))
213 (proxy (make-instance (g-boxed-info-name type) :pointer native)))
214 (tg:finalize proxy (make-boxed-free-finalizer type native))))
216 (defmethod cleanup-translated-object-for-callback ((type boxed-opaque-foreign-type) proxy native)
217 (tg:cancel-finalization proxy)
218 (setf (g-boxed-opaque-pointer proxy) nil))
220 (defmacro define-g-boxed-opaque (name g-type-name &key
221 (alloc (error "Alloc must be specified")))
222 (let ((native-copy (gensym "NATIVE-COPY-"))
223 (instance (gensym "INSTANCE-"))
224 (finalizer (gensym "FINALIZER-")))
225 `(progn (defclass ,name (g-boxed-opaque) ())
226 (defmethod initialize-instance :after ((,instance ,name) &key &allow-other-keys)
227 (unless (g-boxed-opaque-pointer ,instance)
228 (let ((,native-copy ,alloc))
229 (flet ((,finalizer () (boxed-free-fn ,g-type-name ,native-copy)))
230 (setf (g-boxed-opaque-pointer ,instance) ,native-copy)
231 (finalize ,instance (make-boxed-free-finalizer (get ',name 'g-boxed-foreign-info) ,native-copy))))))
232 (eval-when (:compile-toplevel :load-toplevel :execute)
233 (setf (get ',name 'g-boxed-foreign-info)
234 (make-g-boxed-opaque-wrapper-info :name ',name
235 :g-type ,g-type-name)
236 (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
237 (get ',name 'g-boxed-foreign-info))))))
239 (defstruct var-structure
245 resulting-cstruct-description)
247 (defstruct var-structure-variant
248 discriminating-values
251 (defmethod make-load-form ((object var-structure) &optional env)
252 (make-load-form-saving-slots object :environment env))
254 (defmethod make-load-form ((object var-structure-variant) &optional env)
255 (make-load-form-saving-slots object :environment env))
257 (defun var-struct-all-slots (struct)
259 (append (var-struct-all-slots (var-structure-parent struct))
260 (var-structure-slots struct))))
262 (defun all-structures (structure)
263 (append (iter (for variant in (var-structure-variants structure))
264 (appending (all-structures (var-structure-variant-structure variant))))
267 (defun parse-variant-structure-definition (name slots &optional parent)
268 (iter (with result = (make-var-structure :name name
271 :discriminator-slot nil
274 (if (eq :variant (first slot))
276 (when (var-structure-discriminator-slot result)
277 (error "Structure has more than one discriminator slot"))
278 (setf (var-structure-discriminator-slot result) (second slot)
279 (var-structure-variants result) (parse-variants result (nthcdr 2 slot))))
280 (push (parse-cstruct-slot slot) (var-structure-slots result)))
281 (finally (setf (var-structure-slots result)
282 (reverse (var-structure-slots result)))
284 (set-variant-result-structure result))
287 (defun set-variant-result-structure (var-structure)
288 (setf (var-structure-resulting-cstruct-description var-structure)
289 (make-cstruct-description
291 (var-structure-name var-structure)
294 (when (var-structure-parent var-structure)
295 (cstruct-description-slots (var-structure-resulting-cstruct-description (var-structure-parent var-structure))))
296 (var-structure-slots var-structure))))
297 (iter (for variant in (var-structure-variants var-structure))
298 (for child-var-structure = (var-structure-variant-structure variant))
299 (set-variant-result-structure child-var-structure)))
301 (defun ensure-list (thing)
306 (defun parse-variants (parent variants)
307 (iter (for var-descr in variants)
308 (for (options variant-name . slots) in variants)
310 (make-var-structure-variant
311 :discriminating-values (ensure-list options)
312 :structure (parse-variant-structure-definition variant-name slots parent)))
315 (defpackage :gobject.boxed.generated-names)
317 (defun generated-cstruct-name (symbol)
318 (or (get symbol 'generated-cstruct-name)
319 (setf (get symbol 'generated-cstruct-name) (gentemp (format nil "CSTRUCT-~A" (symbol-name symbol)) (find-package :gobject.boxed.generated-names)))))
321 (defun generated-cunion-name (symbol)
322 (or (get symbol 'generated-cunion-name)
323 (setf (get symbol 'generated-cunion-name) (gentemp (format nil "CUNION-~A" (symbol-name symbol)) (find-package :gobject.boxed.generated-names)))))
325 (defun generate-cstruct-1 (struct)
326 `(defcstruct ,(generated-cstruct-name (cstruct-description-name struct))
327 ,@(iter (for slot in (cstruct-description-slots struct))
328 (collect `(,(cstruct-slot-description-name slot) ,(cstruct-slot-description-type slot)
329 ,@(when (cstruct-slot-description-count slot)
330 `(:count ,(cstruct-slot-description-count slot))))))))
332 (defun generate-c-structures (structure)
333 (iter (for str in (all-structures structure))
334 (for cstruct = (var-structure-resulting-cstruct-description str))
335 (collect (generate-cstruct-1 cstruct))))
337 (defun generate-variant-union (struct)
338 `(defcunion ,(generated-cunion-name (var-structure-name struct))
339 ,@(iter (for str in (all-structures struct))
340 (collect `(,(var-structure-name str)
341 ,(generated-cstruct-name (var-structure-name str)))))))
343 (defun generate-structure-1 (str)
344 `(defstruct ,(if (var-structure-parent str)
345 `(,(var-structure-name str) (:include ,(var-structure-name (var-structure-parent str))
346 (,(var-structure-discriminator-slot (var-structure-parent str))
347 ,(first (var-structure-variant-discriminating-values
349 (var-structure-variants
350 (var-structure-parent str))
351 :key #'var-structure-variant-structure))))))
352 `,(var-structure-name str))
353 ,@(iter (for slot in (var-structure-slots str))
354 (collect `(,(cstruct-slot-description-name slot)
355 ,(cstruct-slot-description-initform slot))))))
357 (defun generate-structures (str)
358 (iter (for variant in (reverse (all-structures str)))
359 (collect (generate-structure-1 variant))))
361 (defun generate-native-type-decision-procedure-1 (str proxy-var)
362 (if (null (var-structure-discriminator-slot str))
363 `(values ',(var-structure-resulting-cstruct-description str))
364 `(typecase ,proxy-var
365 ,@(iter (for variant in (var-structure-variants str))
366 (for v-str = (var-structure-variant-structure variant))
367 (collect `(,(var-structure-name v-str)
368 ,(generate-native-type-decision-procedure-1 v-str proxy-var))))
369 (,(var-structure-name str)
370 (values ',(var-structure-resulting-cstruct-description str))))))
372 (defun generate-proxy-type-decision-procedure-1 (str native-var)
373 (if (null (var-structure-discriminator-slot str))
374 `(values ',(var-structure-name str)
375 ',(var-structure-resulting-cstruct-description str))
376 `(case (foreign-slot-value ,native-var
377 ',(generated-cstruct-name (var-structure-name str))
378 ',(var-structure-discriminator-slot str))
379 ,@(iter (for variant in (var-structure-variants str))
380 (for v-str = (var-structure-variant-structure variant))
381 (collect `(,(var-structure-variant-discriminating-values variant)
382 ,(generate-proxy-type-decision-procedure-1
385 (t (values ',(var-structure-name str)
386 ',(var-structure-resulting-cstruct-description str))))))
388 (defun generate-proxy-type-decision-procedure (str)
389 (let ((native (gensym "NATIVE-")))
391 ,(generate-proxy-type-decision-procedure-1 str native))))
393 (defun generate-native-type-decision-procedure (str)
394 (let ((proxy (gensym "PROXY-")))
396 ,(generate-native-type-decision-procedure-1 str proxy))))
398 (defun compile-proxy-type-decision-procedure (str)
399 (compile nil (generate-proxy-type-decision-procedure str)))
401 (defun compile-native-type-decision-procedure (str)
402 (compile nil (generate-native-type-decision-procedure str)))
404 (defstruct (g-boxed-variant-cstruct-info (:include g-boxed-info))
406 native-type-decision-procedure
407 proxy-type-decision-procedure)
409 (defmethod make-load-form ((object g-boxed-variant-cstruct-info) &optional env)
410 (make-load-form-saving-slots object :environment env))
412 (define-foreign-type boxed-variant-cstruct-foreign-type (g-boxed-foreign-type) ())
414 (defmethod make-foreign-type ((info g-boxed-variant-cstruct-info) &key return-p)
415 (make-instance 'boxed-variant-cstruct-foreign-type :info info :return-p return-p))
417 (defmacro define-g-boxed-variant-cstruct (name g-type-name &body slots)
418 (let* ((structure (parse-variant-structure-definition name slots)))
419 `(progn ,@(generate-c-structures structure)
420 ,(generate-variant-union structure)
421 ,@(generate-structures structure)
422 (eval-when (:compile-toplevel :load-toplevel :execute)
423 (setf (get ',name 'g-boxed-foreign-info)
424 (make-g-boxed-variant-cstruct-info :name ',name
427 :native-type-decision-procedure
428 ,(generate-native-type-decision-procedure structure)
429 :proxy-type-decision-procedure
430 ,(generate-proxy-type-decision-procedure structure))
431 (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
432 (get ',name 'g-boxed-foreign-info))))))
434 (defun decide-native-type (info proxy)
435 (funcall (g-boxed-variant-cstruct-info-native-type-decision-procedure info) proxy))
437 (defmethod boxed-copy-fn ((info g-boxed-variant-cstruct-info) native)
438 (if (g-boxed-info-g-type info)
439 (g-boxed-copy (g-boxed-info-g-type info) native)
440 (let ((copy (foreign-alloc (generated-cunion-name (g-boxed-info-name info)))))
441 (memcpy copy native (foreign-type-size (generated-cunion-name (g-boxed-info-name info))))
444 (defmethod boxed-free-fn ((info g-boxed-variant-cstruct-info) native)
445 (if (g-boxed-info-g-type info)
446 (g-boxed-free (g-boxed-info-g-type info) native)
447 (foreign-free native)))
449 (defmethod translate-to-foreign (proxy (foreign-type boxed-variant-cstruct-foreign-type))
452 (let* ((type (g-boxed-foreign-info foreign-type))
453 (cstruct-description (decide-native-type type proxy)))
454 (with-foreign-object (native-structure (generated-cstruct-name
456 (g-boxed-variant-cstruct-info-root type))))
457 (copy-slots-to-native proxy native-structure cstruct-description)
458 (values (boxed-copy-fn type native-structure) proxy)))))
460 (defun decide-proxy-type (info native-structure)
461 (funcall (g-boxed-variant-cstruct-info-proxy-type-decision-procedure info) native-structure))
463 (defmethod free-translated-object (native (foreign-type boxed-variant-cstruct-foreign-type) proxy)
465 (let ((type (g-boxed-foreign-info foreign-type)))
466 (multiple-value-bind (actual-struct cstruct-description) (decide-proxy-type type native)
467 (unless (eq (type-of proxy) actual-struct)
469 (error "Expected type of boxed variant structure ~A and actual type ~A do not match"
470 (type-of proxy) actual-struct)
471 (skip-parsing-values () (return-from free-translated-object))))
472 (copy-slots-to-proxy proxy native cstruct-description)
473 (boxed-free-fn type native)))))
475 (defmethod translate-from-foreign (native (foreign-type boxed-variant-cstruct-foreign-type))
476 (unless (null-pointer-p native)
477 (let ((type (g-boxed-foreign-info foreign-type)))
478 (multiple-value-bind (actual-struct cstruct-description) (decide-proxy-type type native)
479 (let ((proxy (make-instance actual-struct)))
480 (copy-slots-to-proxy proxy native cstruct-description)
481 (when (g-boxed-foreign-return-p foreign-type)
482 (boxed-free-fn type native))
485 (defmethod cleanup-translated-object-for-callback ((foreign-type boxed-variant-cstruct-foreign-type) proxy native)
487 (let ((type (g-boxed-foreign-info foreign-type)))
488 (let ((cstruct-description (decide-native-type type proxy)))
489 (copy-slots-to-native proxy native cstruct-description)))))
491 (defgeneric boxed-parse-g-value (gvalue-ptr info))
493 (defgeneric boxed-set-g-value (gvalue-ptr info proxy))
495 (defmethod parse-g-value-for-type (gvalue-ptr (type-numeric (eql +g-type-boxed+)) parse-kind)
496 (declare (ignore parse-kind))
497 (if (g-type= (g-value-type gvalue-ptr) (g-strv-get-type))
498 (convert-from-foreign (g-value-get-boxed gvalue-ptr) '(glib:gstrv :free-from-foreign nil))
499 (let ((boxed-type (get-g-boxed-foreign-info-for-gtype type-numeric)))
500 (boxed-parse-g-value gvalue-ptr boxed-type))))
502 (defmethod set-gvalue-for-type (gvalue-ptr (type-numeric (eql +g-type-boxed+)) value)
503 (if (g-type= (g-value-type gvalue-ptr) (g-strv-get-type))
504 (g-value-set-boxed gvalue-ptr (convert-to-foreign value '(glib:gstrv :free-from-foreign nil)))
505 (let ((boxed-type (get-g-boxed-foreign-info-for-gtype type-numeric)))
506 (boxed-set-g-value gvalue-ptr boxed-type value))))
508 (defmethod boxed-parse-g-value (gvalue-ptr (info g-boxed-cstruct-wrapper-info))
509 (translate-from-foreign (g-value-get-boxed gvalue-ptr) (make-foreign-type info :return-p nil)))
511 (defmethod boxed-set-g-value (gvalue-ptr (info g-boxed-cstruct-wrapper-info) proxy)
512 (g-value-take-boxed gvalue-ptr (translate-to-foreign proxy (make-foreign-type info :return-p nil))))
514 (defmethod boxed-parse-g-value (gvalue-ptr (info g-boxed-variant-cstruct-info))
515 (translate-from-foreign (g-value-get-boxed gvalue-ptr) (make-foreign-type info :return-p nil)))
517 (defmethod boxed-set-g-value (gvalue-ptr (info g-boxed-variant-cstruct-info) proxy)
518 (g-value-take-boxed gvalue-ptr (translate-to-foreign proxy (make-foreign-type info :return-p nil))))
520 (defmethod boxed-parse-g-value (gvalue-ptr (info g-boxed-opaque-wrapper-info))
521 (translate-from-foreign (boxed-copy-fn info (g-value-get-boxed gvalue-ptr)) (make-foreign-type info :return-p nil)))
523 (defmethod boxed-set-g-value (gvalue-ptr (info g-boxed-opaque-wrapper-info) proxy)
524 (g-value-set-boxed gvalue-ptr (translate-to-foreign proxy (make-foreign-type info :return-p nil))))