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 #+nil(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 #+nil(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
64 (defstruct (cstruct-inline-slot-description (:include cstruct-slot-description))
67 (defmethod make-load-form ((object cstruct-slot-description) &optional environment)
68 (make-load-form-saving-slots object :environment environment))
70 (defmethod make-load-form ((object cstruct-inline-slot-description) &optional environment)
71 (make-load-form-saving-slots object :environment environment))
73 (defstruct cstruct-description
77 (defmethod make-load-form ((object cstruct-description) &optional environment)
78 (make-load-form-saving-slots object :environment environment))
80 (defun parse-cstruct-slot (slot)
81 (destructuring-bind (name type &key count initform inline) slot
83 (make-cstruct-inline-slot-description :name name :type (generated-cunion-name type)
84 :count count :initform initform :inline-p inline
85 :boxed-type-name type)
86 (make-cstruct-inline-slot-description :name name :type type
87 :count count :initform initform :inline-p inline))))
89 (defun parse-cstruct-definition (name slots)
90 (make-cstruct-description :name name
91 :slots (mapcar #'parse-cstruct-slot slots)))
93 (defmacro define-g-boxed-cstruct (name g-type-name &body slots)
94 (let ((cstruct-description (parse-cstruct-definition name slots)))
97 ,@(iter (for slot in (cstruct-description-slots cstruct-description))
98 (for name = (cstruct-slot-description-name slot))
99 (for initform = (cstruct-slot-description-initform slot))
100 (collect (list name initform))))
101 (defcstruct ,(generated-cstruct-name name)
102 ,@(iter (for slot in (cstruct-description-slots cstruct-description))
103 (for name = (cstruct-slot-description-name slot))
104 (for type = (cstruct-slot-description-type slot))
105 (for count = (cstruct-slot-description-count slot))
106 (collect `(,name ,type ,@(when count `(:count ,count))))))
107 (defcunion ,(generated-cunion-name name)
108 (,name ,(generated-cstruct-name name)))
109 (eval-when (:compile-toplevel :load-toplevel :execute)
110 (setf (get ',name 'g-boxed-foreign-info)
111 (make-g-boxed-cstruct-wrapper-info :name ',name
113 :cstruct-description ,cstruct-description)
114 (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
115 (get ',name 'g-boxed-foreign-info)
116 (get ',name 'structure-constructor)
117 ',(intern (format nil "MAKE-~A" (symbol-name name)) (symbol-package name)))))))
119 (defmethod make-foreign-type ((info g-boxed-cstruct-wrapper-info) &key return-p)
120 (make-instance 'boxed-cstruct-foreign-type :info info :return-p return-p))
122 (defun memcpy (target source bytes)
123 (iter (for i from 0 below bytes)
124 (setf (mem-aref target :uchar i)
125 (mem-aref source :uchar i))))
127 (defmethod boxed-copy-fn ((info g-boxed-cstruct-wrapper-info) native)
128 (if (g-boxed-info-g-type info)
129 (g-boxed-copy (g-boxed-info-g-type info) native)
130 (let ((copy (foreign-alloc (generated-cstruct-name (g-boxed-info-name info)))))
131 (memcpy copy native (foreign-type-size (generated-cstruct-name (g-boxed-info-name info))))
134 (defmethod boxed-free-fn ((info g-boxed-cstruct-wrapper-info) native)
135 (if (g-boxed-info-g-type info)
136 (g-boxed-free (g-boxed-info-g-type info) native)
137 (foreign-free native)))
139 (defun copy-slots-to-native (proxy native cstruct-description)
140 (iter (with cstruct-type = (generated-cstruct-name (cstruct-description-name cstruct-description)))
141 (for slot in (cstruct-description-slots cstruct-description))
142 (for slot-name = (cstruct-slot-description-name slot))
144 ((cstruct-slot-description-count slot)
145 (iter (with ptr = (foreign-slot-pointer native cstruct-type slot-name))
146 (with array = (slot-value proxy slot-name))
147 (for i from 0 below (cstruct-slot-description-count slot))
148 (setf (mem-aref ptr (cstruct-slot-description-type slot) i)
150 ((cstruct-slot-description-inline-p slot)
151 (let ((info (get-g-boxed-foreign-info (cstruct-inline-slot-description-boxed-type-name slot))))
152 (copy-slots-to-native (slot-value proxy slot-name)
153 (foreign-slot-pointer native cstruct-type slot-name)
154 (g-boxed-cstruct-wrapper-info-cstruct-description info))))
156 (setf (foreign-slot-value native cstruct-type slot-name)
157 (slot-value proxy slot-name))))))
159 (defun create-structure (structure-name)
160 (let ((constructor (get structure-name 'structure-constructor)))
161 (assert constructor nil "Don't know how to create structure of type ~A" structure-name)
162 (funcall constructor)))
164 (defun copy-slots-to-proxy (proxy native cstruct-description)
165 (iter (with cstruct-type = (generated-cstruct-name (cstruct-description-name cstruct-description)))
166 (for slot in (cstruct-description-slots cstruct-description))
167 (for slot-name = (cstruct-slot-description-name slot))
169 ((cstruct-slot-description-count slot)
170 (setf (slot-value proxy slot-name) (make-array (list (cstruct-slot-description-count slot))))
171 (iter (with ptr = (foreign-slot-pointer native cstruct-type slot-name))
172 (with array = (slot-value proxy slot-name))
173 (for i from 0 below (cstruct-slot-description-count slot))
175 (mem-aref ptr (cstruct-slot-description-type slot) i))))
176 ((cstruct-slot-description-inline-p slot)
177 (let ((info (get-g-boxed-foreign-info (cstruct-inline-slot-description-boxed-type-name slot))))
178 (setf (slot-value proxy slot-name) (create-structure (cstruct-inline-slot-description-boxed-type-name slot)))
179 (copy-slots-to-proxy (slot-value proxy slot-name)
180 (foreign-slot-pointer native cstruct-type slot-name)
181 (g-boxed-cstruct-wrapper-info-cstruct-description info))))
182 (t (setf (slot-value proxy slot-name)
183 (foreign-slot-value native cstruct-type slot-name))))))
185 (defmethod translate-to-foreign (proxy (type boxed-cstruct-foreign-type))
188 (let* ((info (g-boxed-foreign-info type))
189 (native-structure-type (generated-cstruct-name (g-boxed-info-name info))))
190 (with-foreign-object (native-structure native-structure-type)
191 (copy-slots-to-native proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info))
192 (values (boxed-copy-fn info native-structure) proxy)))))
194 (defmethod free-translated-object (native-structure (type boxed-cstruct-foreign-type) proxy)
196 (let ((info (g-boxed-foreign-info type)))
197 (copy-slots-to-proxy proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info))
198 (boxed-free-fn info native-structure))))
200 (defmethod translate-from-foreign (native-structure (type boxed-cstruct-foreign-type))
201 (unless (null-pointer-p native-structure)
202 (let* ((info (g-boxed-foreign-info type))
203 (proxy-structure-type (g-boxed-info-name info))
204 (proxy (create-structure proxy-structure-type)))
205 (copy-slots-to-proxy proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info))
206 (when (g-boxed-foreign-return-p type)
207 (boxed-free-fn info native-structure))
210 (defmethod cleanup-translated-object-for-callback ((type boxed-cstruct-foreign-type) proxy native-structure)
212 (let ((info (g-boxed-foreign-info type)))
213 (copy-slots-to-native proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info)))))
215 (eval-when (:compile-toplevel :load-toplevel :execute)
216 (defstruct (g-boxed-opaque-wrapper-info (:include g-boxed-info))
219 (define-foreign-type boxed-opaque-foreign-type (g-boxed-foreign-type) ())
221 (defclass g-boxed-opaque ()
222 ((pointer :initarg :pointer
224 :accessor g-boxed-opaque-pointer)))
226 (defmethod pointer ((object g-boxed-opaque))
227 (g-boxed-opaque-pointer object))
229 (defmethod make-foreign-type ((info g-boxed-opaque-wrapper-info) &key return-p)
230 (make-instance 'boxed-opaque-foreign-type :info info :return-p return-p))
232 (defmethod translate-to-foreign (proxy (type boxed-opaque-foreign-type))
233 (prog1 (g-boxed-opaque-pointer proxy)
234 (when (g-boxed-foreign-return-p type)
235 (tg:cancel-finalization proxy)
236 (setf (g-boxed-opaque-pointer proxy) nil))))
238 (defmethod free-translated-object (native (type boxed-opaque-foreign-type) param)
239 (declare (ignore native type param)))
241 (defun make-boxed-free-finalizer (type pointer)
242 (lambda () (boxed-free-fn type pointer)))
244 (defmethod translate-from-foreign (native (foreign-type boxed-opaque-foreign-type))
245 (let* ((type (g-boxed-foreign-info foreign-type))
246 (proxy (make-instance (g-boxed-info-name type) :pointer native)))
247 (tg:finalize proxy (make-boxed-free-finalizer type native))))
249 (defmethod cleanup-translated-object-for-callback ((type boxed-opaque-foreign-type) proxy native)
250 (tg:cancel-finalization proxy)
251 (setf (g-boxed-opaque-pointer proxy) nil))
253 (defmacro define-g-boxed-opaque (name g-type-name &key
254 (alloc (error "Alloc must be specified")))
255 (let ((native-copy (gensym "NATIVE-COPY-"))
256 (instance (gensym "INSTANCE-")))
257 `(progn (defclass ,name (g-boxed-opaque) ())
258 (defmethod initialize-instance :after ((,instance ,name) &key &allow-other-keys)
259 (unless (g-boxed-opaque-pointer ,instance)
260 (let ((,native-copy ,alloc))
261 (setf (g-boxed-opaque-pointer ,instance) ,native-copy)
262 (finalize ,instance (make-boxed-free-finalizer (get ',name 'g-boxed-foreign-info) ,native-copy)))))
263 (eval-when (:compile-toplevel :load-toplevel :execute)
264 (setf (get ',name 'g-boxed-foreign-info)
265 (make-g-boxed-opaque-wrapper-info :name ',name
266 :g-type ,g-type-name)
267 (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
268 (get ',name 'g-boxed-foreign-info))))))
270 (defstruct var-structure
276 resulting-cstruct-description)
278 (defstruct var-structure-variant
279 discriminating-values
282 (defmethod make-load-form ((object var-structure) &optional env)
283 (make-load-form-saving-slots object :environment env))
285 (defmethod make-load-form ((object var-structure-variant) &optional env)
286 (make-load-form-saving-slots object :environment env))
288 (defun var-struct-all-slots (struct)
290 (append (var-struct-all-slots (var-structure-parent struct))
291 (var-structure-slots struct))))
293 (defun all-structures (structure)
294 (append (iter (for variant in (var-structure-variants structure))
295 (appending (all-structures (var-structure-variant-structure variant))))
298 (defun parse-variant-structure-definition (name slots &optional parent)
299 (iter (with result = (make-var-structure :name name
302 :discriminator-slot nil
305 (if (eq :variant (first slot))
307 (when (var-structure-discriminator-slot result)
308 (error "Structure has more than one discriminator slot"))
309 (setf (var-structure-discriminator-slot result) (second slot)
310 (var-structure-variants result) (parse-variants result (nthcdr 2 slot))))
311 (push (parse-cstruct-slot slot) (var-structure-slots result)))
312 (finally (setf (var-structure-slots result)
313 (reverse (var-structure-slots result)))
315 (set-variant-result-structure result))
318 (defun set-variant-result-structure (var-structure)
319 (setf (var-structure-resulting-cstruct-description var-structure)
320 (make-cstruct-description
322 (var-structure-name var-structure)
325 (when (var-structure-parent var-structure)
326 (cstruct-description-slots (var-structure-resulting-cstruct-description (var-structure-parent var-structure))))
327 (var-structure-slots var-structure))))
328 (iter (for variant in (var-structure-variants var-structure))
329 (for child-var-structure = (var-structure-variant-structure variant))
330 (set-variant-result-structure child-var-structure)))
332 (defun ensure-list (thing)
337 (defun parse-variants (parent variants)
338 (iter (for var-descr in variants)
339 (for (options variant-name . slots) in variants)
341 (make-var-structure-variant
342 :discriminating-values (ensure-list options)
343 :structure (parse-variant-structure-definition variant-name slots parent)))
346 (defun generated-cstruct-name (symbol)
347 (intern (format nil "~A-CSTRUCT-GENERATED-BY-GOBJECT-BOXED" (symbol-name symbol)) (symbol-package symbol)))
349 (defun generated-cunion-name (symbol)
350 (intern (format nil "~A-CUNION-GENERATED-BY-GOBJECT-BOXED" (symbol-name symbol)) (symbol-package symbol)))
352 (defun generate-cstruct-1 (struct)
353 `(defcstruct ,(generated-cstruct-name (cstruct-description-name struct))
354 ,@(iter (for slot in (cstruct-description-slots struct))
355 (collect `(,(cstruct-slot-description-name slot) ,(cstruct-slot-description-type slot)
356 ,@(when (cstruct-slot-description-count slot)
357 `(:count ,(cstruct-slot-description-count slot))))))))
359 (defun generate-c-structures (structure)
360 (iter (for str in (all-structures structure))
361 (for cstruct = (var-structure-resulting-cstruct-description str))
362 (collect (generate-cstruct-1 cstruct))))
364 (defun generate-variant-union (struct)
365 `(defcunion ,(generated-cunion-name (var-structure-name struct))
366 ,@(iter (for str in (all-structures struct))
367 (collect `(,(var-structure-name str)
368 ,(generated-cstruct-name (var-structure-name str)))))))
370 (defun generate-structure-1 (str)
371 (let ((name (var-structure-name str)))
373 (defstruct ,(if (var-structure-parent str)
374 `(,(var-structure-name str) (:include ,(var-structure-name (var-structure-parent str))
375 (,(var-structure-discriminator-slot (var-structure-parent str))
376 ,(first (var-structure-variant-discriminating-values
378 (var-structure-variants
379 (var-structure-parent str))
380 :key #'var-structure-variant-structure))))))
381 `,(var-structure-name str))
382 ,@(iter (for slot in (var-structure-slots str))
383 (collect `(,(cstruct-slot-description-name slot)
384 ,(cstruct-slot-description-initform slot)))))
385 (setf (get ',name 'structure-constructor)
386 ',(intern (format nil "MAKE-~A" (symbol-name name)) (symbol-package name))))))
388 (defun generate-structures (str)
389 (iter (for variant in (reverse (all-structures str)))
390 (collect (generate-structure-1 variant))))
392 (defun generate-native-type-decision-procedure-1 (str proxy-var)
393 (if (null (var-structure-discriminator-slot str))
394 `(values ',(var-structure-resulting-cstruct-description str))
395 `(typecase ,proxy-var
396 ,@(iter (for variant in (var-structure-variants str))
397 (for v-str = (var-structure-variant-structure variant))
398 (collect `(,(var-structure-name v-str)
399 ,(generate-native-type-decision-procedure-1 v-str proxy-var))))
400 (,(var-structure-name str)
401 (values ',(var-structure-resulting-cstruct-description str))))))
403 (defun generate-proxy-type-decision-procedure-1 (str native-var)
404 (if (null (var-structure-discriminator-slot str))
405 `(values ',(var-structure-name str)
406 ',(var-structure-resulting-cstruct-description str))
407 `(case (foreign-slot-value ,native-var
408 ',(generated-cstruct-name (var-structure-name str))
409 ',(var-structure-discriminator-slot str))
410 ,@(iter (for variant in (var-structure-variants str))
411 (for v-str = (var-structure-variant-structure variant))
412 (collect `(,(var-structure-variant-discriminating-values variant)
413 ,(generate-proxy-type-decision-procedure-1
416 (t (values ',(var-structure-name str)
417 ',(var-structure-resulting-cstruct-description str))))))
419 (defun generate-proxy-type-decision-procedure (str)
420 (let ((native (gensym "NATIVE-")))
422 (declare (ignorable ,native))
423 ,(generate-proxy-type-decision-procedure-1 str native))))
425 (defun generate-native-type-decision-procedure (str)
426 (let ((proxy (gensym "PROXY-")))
428 (declare (ignorable ,proxy))
429 ,(generate-native-type-decision-procedure-1 str proxy))))
431 (defun compile-proxy-type-decision-procedure (str)
432 (compile nil (generate-proxy-type-decision-procedure str)))
434 (defun compile-native-type-decision-procedure (str)
435 (compile nil (generate-native-type-decision-procedure str)))
437 (defstruct (g-boxed-variant-cstruct-info (:include g-boxed-info))
439 native-type-decision-procedure
440 proxy-type-decision-procedure)
442 (defmethod make-load-form ((object g-boxed-variant-cstruct-info) &optional env)
443 (make-load-form-saving-slots object :environment env))
445 (define-foreign-type boxed-variant-cstruct-foreign-type (g-boxed-foreign-type) ())
447 (defmethod make-foreign-type ((info g-boxed-variant-cstruct-info) &key return-p)
448 (make-instance 'boxed-variant-cstruct-foreign-type :info info :return-p return-p))
450 (defmacro define-g-boxed-variant-cstruct (name g-type-name &body slots)
451 (let* ((structure (parse-variant-structure-definition name slots)))
452 `(progn ,@(generate-c-structures structure)
453 ,(generate-variant-union structure)
454 ,@(generate-structures structure)
455 (eval-when (:compile-toplevel :load-toplevel :execute)
456 (setf (get ',name 'g-boxed-foreign-info)
457 (make-g-boxed-variant-cstruct-info :name ',name
460 :native-type-decision-procedure
461 ,(generate-native-type-decision-procedure structure)
462 :proxy-type-decision-procedure
463 ,(generate-proxy-type-decision-procedure structure))
464 (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
465 (get ',name 'g-boxed-foreign-info))))))
467 (defun decide-native-type (info proxy)
468 (funcall (g-boxed-variant-cstruct-info-native-type-decision-procedure info) proxy))
470 (defmethod boxed-copy-fn ((info g-boxed-variant-cstruct-info) native)
471 (if (g-boxed-info-g-type info)
472 (g-boxed-copy (g-boxed-info-g-type info) native)
473 (let ((copy (foreign-alloc (generated-cunion-name (g-boxed-info-name info)))))
474 (memcpy copy native (foreign-type-size (generated-cunion-name (g-boxed-info-name info))))
477 (defmethod boxed-free-fn ((info g-boxed-variant-cstruct-info) native)
478 (if (g-boxed-info-g-type info)
479 (g-boxed-free (g-boxed-info-g-type info) native)
480 (foreign-free native)))
482 (defmethod translate-to-foreign (proxy (foreign-type boxed-variant-cstruct-foreign-type))
485 (let* ((type (g-boxed-foreign-info foreign-type))
486 (cstruct-description (decide-native-type type proxy)))
487 (with-foreign-object (native-structure (generated-cunion-name
489 (g-boxed-variant-cstruct-info-root type))))
490 (copy-slots-to-native proxy native-structure cstruct-description)
491 (values (boxed-copy-fn type native-structure) proxy)))))
493 (defun decide-proxy-type (info native-structure)
494 (funcall (g-boxed-variant-cstruct-info-proxy-type-decision-procedure info) native-structure))
496 (defmethod free-translated-object (native (foreign-type boxed-variant-cstruct-foreign-type) proxy)
498 (let ((type (g-boxed-foreign-info foreign-type)))
499 (multiple-value-bind (actual-struct cstruct-description) (decide-proxy-type type native)
500 (unless (eq (type-of proxy) actual-struct)
502 (error "Expected type of boxed variant structure ~A and actual type ~A do not match"
503 (type-of proxy) actual-struct)
504 (skip-parsing-values () (return-from free-translated-object))))
505 (copy-slots-to-proxy proxy native cstruct-description)
506 (boxed-free-fn type native)))))
508 (defmethod translate-from-foreign (native (foreign-type boxed-variant-cstruct-foreign-type))
509 (unless (null-pointer-p native)
510 (let ((type (g-boxed-foreign-info foreign-type)))
511 (multiple-value-bind (actual-struct cstruct-description) (decide-proxy-type type native)
512 (let ((proxy (create-structure actual-struct)))
513 (copy-slots-to-proxy proxy native cstruct-description)
514 (when (g-boxed-foreign-return-p foreign-type)
515 (boxed-free-fn type native))
518 (defmethod cleanup-translated-object-for-callback ((foreign-type boxed-variant-cstruct-foreign-type) proxy native)
520 (let ((type (g-boxed-foreign-info foreign-type)))
521 (let ((cstruct-description (decide-native-type type proxy)))
522 (copy-slots-to-native proxy native cstruct-description)))))
524 (defgeneric boxed-parse-g-value (gvalue-ptr info))
526 (defgeneric boxed-set-g-value (gvalue-ptr info proxy))
528 (defmethod parse-g-value-for-type (gvalue-ptr (type-numeric (eql +g-type-boxed+)) parse-kind)
529 (declare (ignore parse-kind))
530 (if (g-type= (g-value-type gvalue-ptr) (g-strv-get-type))
531 (convert-from-foreign (g-value-get-boxed gvalue-ptr) '(glib:gstrv :free-from-foreign nil))
532 (let ((boxed-type (get-g-boxed-foreign-info-for-gtype (g-value-type gvalue-ptr))))
533 (boxed-parse-g-value gvalue-ptr boxed-type))))
535 (defmethod set-gvalue-for-type (gvalue-ptr (type-numeric (eql +g-type-boxed+)) value)
536 (if (g-type= (g-value-type gvalue-ptr) (g-strv-get-type))
537 (g-value-set-boxed gvalue-ptr (convert-to-foreign value '(glib:gstrv :free-from-foreign nil)))
538 (let ((boxed-type (get-g-boxed-foreign-info-for-gtype (g-value-type gvalue-ptr))))
539 (boxed-set-g-value gvalue-ptr boxed-type value))))
541 (defmethod boxed-parse-g-value (gvalue-ptr (info g-boxed-cstruct-wrapper-info))
542 (translate-from-foreign (g-value-get-boxed gvalue-ptr) (make-foreign-type info :return-p nil)))
544 (defmethod boxed-set-g-value (gvalue-ptr (info g-boxed-cstruct-wrapper-info) proxy)
545 (g-value-take-boxed gvalue-ptr (translate-to-foreign proxy (make-foreign-type info :return-p nil))))
547 (defmethod boxed-parse-g-value (gvalue-ptr (info g-boxed-variant-cstruct-info))
548 (translate-from-foreign (g-value-get-boxed gvalue-ptr) (make-foreign-type info :return-p nil)))
550 (defmethod boxed-set-g-value (gvalue-ptr (info g-boxed-variant-cstruct-info) proxy)
551 (g-value-take-boxed gvalue-ptr (translate-to-foreign proxy (make-foreign-type info :return-p nil))))
553 (defmethod boxed-parse-g-value (gvalue-ptr (info g-boxed-opaque-wrapper-info))
554 (translate-from-foreign (boxed-copy-fn info (g-value-get-boxed gvalue-ptr)) (make-foreign-type info :return-p nil)))
556 (defmethod boxed-set-g-value (gvalue-ptr (info g-boxed-opaque-wrapper-info) proxy)
557 (g-value-set-boxed gvalue-ptr (translate-to-foreign proxy (make-foreign-type info :return-p nil))))
559 (defun boxed-related-symbols (name)
560 (let ((info (get-g-boxed-foreign-info name)))
562 (g-boxed-cstruct-wrapper-info
564 (intern (format nil "MAKE-~A" (symbol-name name)))
565 (intern (format nil "COPY-~A" (symbol-name name))))
566 (iter (for slot in (cstruct-description-slots (g-boxed-cstruct-wrapper-info-cstruct-description info)))
567 (for slot-name = (cstruct-slot-description-name slot))
568 (collect (intern (format nil "~A-~A" (symbol-name name) (symbol-name slot-name)))))))
569 (g-boxed-opaque-wrapper-info
571 (g-boxed-variant-cstruct-info
573 (iter (for var-struct in (all-structures (g-boxed-variant-cstruct-info-root info)))
574 (for s-name = (var-structure-name var-struct))
575 (for cstruct-description = (var-structure-resulting-cstruct-description var-struct))
576 (appending (append (list s-name)
577 (list (intern (format nil "MAKE-~A" (symbol-name s-name)))
578 (intern (format nil "COPY-~A" (symbol-name s-name))))
579 (iter (for slot in (cstruct-description-slots cstruct-description))
580 (for slot-name = (cstruct-slot-description-name slot))
581 (collect (intern (format nil "~A-~A" (symbol-name s-name)
582 (symbol-name slot-name)))))))))))))
584 (defmacro define-boxed-opaque-accessor (boxed-name accessor-name &key type reader writer)
587 `(progn ,@(when reader
588 (list (etypecase reader
589 (symbol `(defun ,accessor-name (,var)
590 (funcall ,reader ,var)))
591 (string `(defcfun (,accessor-name ,reader) ,type
592 (,var (g-boxed-foreign ,boxed-name)))))))
594 (list (etypecase reader
595 (symbol `(defun (setf ,accessor-name) (,n-var ,var)
596 (funcall ,reader ,n-var ,var)))
597 (string `(defun (setf ,accessor-name) (,n-var ,var)
598 (foreign-funcall ,writer (g-boxed-foreign ,boxed-name) ,var ,type ,n-var :void)))))))))