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 (gtype-name (gtype g-type-designator)) *g-type-name->g-boxed-foreign-info*)
25 (error "Unknown GBoxed type '~A'" (gtype-name (gtype 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 (defgeneric has-callback-cleanup (foreign-type))
49 (defgeneric cleanup-translated-object-for-callback (foreign-type converted-object native-object))
51 (defmethod has-callback-cleanup ((type g-boxed-foreign-type))
54 (eval-when (:load-toplevel :compile-toplevel :execute)
55 (defstruct (g-boxed-cstruct-wrapper-info (:include g-boxed-info))
58 (defclass boxed-cstruct-foreign-type (g-boxed-foreign-type) ())
60 (defstruct cstruct-slot-description
67 (defstruct (cstruct-inline-slot-description (:include cstruct-slot-description))
70 (defmethod make-load-form ((object cstruct-slot-description) &optional environment)
71 (make-load-form-saving-slots object :environment environment))
73 (defmethod make-load-form ((object cstruct-inline-slot-description) &optional environment)
74 (make-load-form-saving-slots object :environment environment))
76 (defstruct cstruct-description
80 (defmethod make-load-form ((object cstruct-description) &optional environment)
81 (make-load-form-saving-slots object :environment environment))
83 (defun parse-cstruct-slot (slot)
84 (destructuring-bind (name type &key count initform inline) slot
86 (make-cstruct-inline-slot-description :name name :type (generated-cunion-name type)
87 :count count :initform initform :inline-p inline
88 :boxed-type-name type)
89 (make-cstruct-inline-slot-description :name name :type type
90 :count count :initform initform :inline-p inline))))
92 (defun parse-cstruct-definition (name slots)
93 (make-cstruct-description :name name
94 :slots (mapcar #'parse-cstruct-slot slots)))
96 (defmacro define-g-boxed-cstruct (name g-type-name &body slots)
97 (let ((cstruct-description (parse-cstruct-definition name slots))
98 (cstruct-name (generated-cstruct-name name))
99 (cunion-name (generated-cunion-name name)))
102 ,@(iter (for slot in (cstruct-description-slots cstruct-description))
103 (for name = (cstruct-slot-description-name slot))
104 (for initform = (cstruct-slot-description-initform slot))
105 (collect (list name initform))))
106 (defcstruct ,cstruct-name
107 ,@(iter (for slot in (cstruct-description-slots cstruct-description))
108 (for name = (cstruct-slot-description-name slot))
109 (for type = (cstruct-slot-description-type slot))
110 (for count = (cstruct-slot-description-count slot))
111 (collect `(,name ,type ,@(when count `(:count ,count))))))
112 (defctype ,cstruct-name (:struct ,cstruct-name))
113 (defcunion ,cunion-name
114 (,name ,cstruct-name))
115 (defctype ,cunion-name (:union ,cunion-name))
116 (eval-when (:compile-toplevel :load-toplevel :execute)
117 (setf (get ',name 'g-boxed-foreign-info)
118 (make-g-boxed-cstruct-wrapper-info :name ',name
120 :cstruct-description ,cstruct-description)
121 (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
122 (get ',name 'g-boxed-foreign-info)
123 (get ',name 'structure-constructor)
124 ',(intern (format nil "MAKE-~A" (symbol-name name)) (symbol-package name)))))))
126 (defmethod make-foreign-type ((info g-boxed-cstruct-wrapper-info) &key return-p)
127 (make-instance 'boxed-cstruct-foreign-type :info info :return-p return-p))
129 (defun memcpy (target source bytes)
130 (iter (for i from 0 below bytes)
131 (setf (mem-aref target :uchar i)
132 (mem-aref source :uchar i))))
134 (defmethod boxed-copy-fn ((info g-boxed-cstruct-wrapper-info) native)
135 (if (g-boxed-info-g-type info)
136 (g-boxed-copy (g-boxed-info-g-type info) native)
137 (let ((copy (foreign-alloc (generated-cstruct-name (g-boxed-info-name info)))))
138 (memcpy copy native (foreign-type-size (generated-cstruct-name (g-boxed-info-name info))))
141 (defmethod boxed-free-fn ((info g-boxed-cstruct-wrapper-info) native)
142 (if (g-boxed-info-g-type info)
143 (g-boxed-free (g-boxed-info-g-type info) native)
144 (foreign-free native)))
146 (defun copy-slots-to-native (proxy native cstruct-description)
147 (iter (with cstruct-type = (generated-cstruct-name (cstruct-description-name cstruct-description)))
148 (for slot in (cstruct-description-slots cstruct-description))
149 (for slot-name = (cstruct-slot-description-name slot))
151 ((cstruct-slot-description-count slot)
152 (iter (with ptr = (foreign-slot-pointer native cstruct-type slot-name))
153 (with array = (slot-value proxy slot-name))
154 (for i from 0 below (cstruct-slot-description-count slot))
155 (setf (mem-aref ptr (cstruct-slot-description-type slot) i)
157 ((cstruct-slot-description-inline-p slot)
158 (let ((info (get-g-boxed-foreign-info (cstruct-inline-slot-description-boxed-type-name slot))))
159 (copy-slots-to-native (slot-value proxy slot-name)
160 (foreign-slot-pointer native cstruct-type slot-name)
161 (g-boxed-cstruct-wrapper-info-cstruct-description info))))
163 (setf (foreign-slot-value native cstruct-type slot-name)
164 (slot-value proxy slot-name))))))
166 (defun create-structure (structure-name)
167 (let ((constructor (get structure-name 'structure-constructor)))
168 (assert constructor nil "Don't know how to create structure of type ~A" structure-name)
169 (funcall constructor)))
171 (defun copy-slots-to-proxy (proxy native cstruct-description)
172 (iter (with cstruct-type = (generated-cstruct-name (cstruct-description-name cstruct-description)))
173 (for slot in (cstruct-description-slots cstruct-description))
174 (for slot-name = (cstruct-slot-description-name slot))
176 ((cstruct-slot-description-count slot)
177 (setf (slot-value proxy slot-name) (make-array (list (cstruct-slot-description-count slot))))
178 (iter (with ptr = (foreign-slot-pointer native cstruct-type slot-name))
179 (with array = (slot-value proxy slot-name))
180 (for i from 0 below (cstruct-slot-description-count slot))
182 (mem-aref ptr (cstruct-slot-description-type slot) i))))
183 ((cstruct-slot-description-inline-p slot)
184 (let ((info (get-g-boxed-foreign-info (cstruct-inline-slot-description-boxed-type-name slot))))
185 (setf (slot-value proxy slot-name) (create-structure (cstruct-inline-slot-description-boxed-type-name slot)))
186 (copy-slots-to-proxy (slot-value proxy slot-name)
187 (foreign-slot-pointer native cstruct-type slot-name)
188 (g-boxed-cstruct-wrapper-info-cstruct-description info))))
189 (t (setf (slot-value proxy slot-name)
190 (foreign-slot-value native cstruct-type slot-name))))))
192 (defmethod translate-to-foreign (proxy (type boxed-cstruct-foreign-type))
195 (let* ((info (g-boxed-foreign-info type))
196 (native-structure-type (generated-cstruct-name (g-boxed-info-name info))))
197 (with-foreign-object (native-structure native-structure-type)
198 (copy-slots-to-native proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info))
199 (values (boxed-copy-fn info native-structure) proxy)))))
201 (defmethod free-translated-object (native-structure (type boxed-cstruct-foreign-type) proxy)
203 (let ((info (g-boxed-foreign-info type)))
204 (copy-slots-to-proxy proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info))
205 (boxed-free-fn info native-structure))))
207 (defmethod translate-from-foreign (native-structure (type boxed-cstruct-foreign-type))
208 (unless (null-pointer-p native-structure)
209 (let* ((info (g-boxed-foreign-info type))
210 (proxy-structure-type (g-boxed-info-name info))
211 (proxy (create-structure proxy-structure-type)))
212 (copy-slots-to-proxy proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info))
213 (when (g-boxed-foreign-return-p type)
214 (boxed-free-fn info native-structure))
217 (defmethod cleanup-translated-object-for-callback ((type boxed-cstruct-foreign-type) proxy native-structure)
219 (let ((info (g-boxed-foreign-info type)))
220 (copy-slots-to-native proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info)))))
222 (eval-when (:compile-toplevel :load-toplevel :execute)
223 (defstruct (g-boxed-opaque-wrapper-info (:include g-boxed-info))
226 (define-foreign-type boxed-opaque-foreign-type (g-boxed-foreign-type) ())
228 (defclass g-boxed-opaque ()
229 ((pointer :initarg :pointer
231 :accessor g-boxed-opaque-pointer)))
233 (defmethod pointer ((object g-boxed-opaque))
234 (g-boxed-opaque-pointer object))
236 (defmethod make-foreign-type ((info g-boxed-opaque-wrapper-info) &key return-p)
237 (make-instance 'boxed-opaque-foreign-type :info info :return-p return-p))
239 (defmethod translate-to-foreign (proxy (type boxed-opaque-foreign-type))
242 (prog1 (g-boxed-opaque-pointer proxy)
243 (when (g-boxed-foreign-return-p type)
244 (tg:cancel-finalization proxy)
245 (setf (g-boxed-opaque-pointer proxy) nil)))))
247 (defmethod free-translated-object (native (type boxed-opaque-foreign-type) param)
248 (declare (ignore native type param)))
250 (defvar *gboxed-gc-hooks-lock* (make-recursive-lock "gboxed-gc-hooks-lock"))
251 (defvar *gboxed-gc-hooks* nil);;pointers to objects to be freed
253 (defun activate-gboxed-gc-hooks ()
254 (with-recursive-lock-held (*gboxed-gc-hooks-lock*)
255 (when *gboxed-gc-hooks*
256 (log-for :gc "activating gc hooks for boxeds: ~A~%" *gboxed-gc-hooks*)
258 for (pointer type) in *gboxed-gc-hooks*
259 do (boxed-free-fn type pointer))
260 (setf *gboxed-gc-hooks* nil))))
262 (defcallback gboxed-idle-gc-hook :boolean ((data :pointer))
263 (declare (ignore data))
264 (activate-gboxed-gc-hooks)
267 (defun register-gboxed-for-gc (type pointer)
268 (with-recursive-lock-held (*gboxed-gc-hooks-lock*)
269 (let ((locks-were-present (not (null *gboxed-gc-hooks*))))
270 (push (list pointer type) *gboxed-gc-hooks*)
271 (unless locks-were-present
272 (log-for :gc "adding gboxed idle-gc-hook to main loop~%")
273 (g-idle-add (callback gboxed-idle-gc-hook) (null-pointer))))))
275 (defun make-boxed-free-finalizer (type pointer)
276 (lambda () (register-gboxed-for-gc type pointer)))
278 (defmethod translate-from-foreign (native (foreign-type boxed-opaque-foreign-type))
279 (let* ((type (g-boxed-foreign-info foreign-type))
280 (proxy (make-instance (g-boxed-info-name type) :pointer native)))
283 (defmethod cleanup-translated-object-for-callback ((type boxed-opaque-foreign-type) proxy native)
284 (declare (ignore native))
285 (tg:cancel-finalization proxy)
286 (setf (g-boxed-opaque-pointer proxy) nil))
288 (defmacro define-g-boxed-opaque (name g-type-name &key
289 (alloc (error "Alloc must be specified")))
290 (let ((native-copy (gensym "NATIVE-COPY-"))
291 (instance (gensym "INSTANCE-")))
292 `(progn (defclass ,name (g-boxed-opaque) ())
293 (defmethod initialize-instance :after ((,instance ,name) &key &allow-other-keys)
294 (unless (g-boxed-opaque-pointer ,instance)
295 (let ((,native-copy ,alloc))
296 (setf (g-boxed-opaque-pointer ,instance) ,native-copy)
297 (finalize ,instance (make-boxed-free-finalizer (get ',name 'g-boxed-foreign-info) ,native-copy)))))
298 (eval-when (:compile-toplevel :load-toplevel :execute)
299 (setf (get ',name 'g-boxed-foreign-info)
300 (make-g-boxed-opaque-wrapper-info :name ',name
301 :g-type ,g-type-name)
302 (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
303 (get ',name 'g-boxed-foreign-info))))))
305 (defstruct var-structure
311 resulting-cstruct-description)
313 (defstruct var-structure-variant
314 discriminating-values
317 (defmethod make-load-form ((object var-structure) &optional env)
318 (make-load-form-saving-slots object :environment env))
320 (defmethod make-load-form ((object var-structure-variant) &optional env)
321 (make-load-form-saving-slots object :environment env))
323 (defun var-struct-all-slots (struct)
325 (append (var-struct-all-slots (var-structure-parent struct))
326 (var-structure-slots struct))))
328 (defun all-structures (structure)
329 (append (iter (for variant in (var-structure-variants structure))
330 (appending (all-structures (var-structure-variant-structure variant))))
333 (defun parse-variant-structure-definition (name slots &optional parent)
334 (iter (with result = (make-var-structure :name name
337 :discriminator-slot nil
340 (if (eq :variant (first slot))
342 (when (var-structure-discriminator-slot result)
343 (error "Structure has more than one discriminator slot"))
344 (setf (var-structure-discriminator-slot result) (second slot)
345 (var-structure-variants result) (parse-variants result (nthcdr 2 slot))))
346 (push (parse-cstruct-slot slot) (var-structure-slots result)))
347 (finally (setf (var-structure-slots result)
348 (reverse (var-structure-slots result)))
350 (set-variant-result-structure result))
353 (defun set-variant-result-structure (var-structure)
354 (setf (var-structure-resulting-cstruct-description var-structure)
355 (make-cstruct-description
357 (var-structure-name var-structure)
360 (when (var-structure-parent var-structure)
361 (cstruct-description-slots (var-structure-resulting-cstruct-description (var-structure-parent var-structure))))
362 (var-structure-slots var-structure))))
363 (iter (for variant in (var-structure-variants var-structure))
364 (for child-var-structure = (var-structure-variant-structure variant))
365 (set-variant-result-structure child-var-structure)))
367 (defun ensure-list (thing)
372 (defun parse-variants (parent variants)
373 (iter (for (options variant-name . slots) in variants)
375 (make-var-structure-variant
376 :discriminating-values (ensure-list options)
377 :structure (parse-variant-structure-definition variant-name slots parent)))
380 (defun generated-cstruct-name (symbol)
381 (intern (format nil "~A-CSTRUCT" (symbol-name symbol)) (symbol-package symbol)))
383 (defun generated-cunion-name (symbol)
384 (intern (format nil "~A-CUNION" (symbol-name symbol)) (symbol-package symbol)))
386 (defun generate-cstruct-1 (struct)
387 (let ((cstruct-name (generated-cstruct-name (cstruct-description-name struct))))
388 `((defcstruct ,cstruct-name
389 ,@(iter (for slot in (cstruct-description-slots struct))
390 (collect `(,(cstruct-slot-description-name slot) ,(cstruct-slot-description-type slot)
391 ,@(when (cstruct-slot-description-count slot)
392 `(:count ,(cstruct-slot-description-count slot)))))))
393 (defctype ,cstruct-name (:struct ,cstruct-name)))))
395 (defun generate-c-structures (structure)
396 (iter (for str in (all-structures structure))
397 (for cstruct = (var-structure-resulting-cstruct-description str))
398 (nconcing (generate-cstruct-1 cstruct))))
400 (defun generate-variant-union (struct)
401 (let ((cunion-name (generated-cunion-name (var-structure-name struct))))
402 `((defcunion ,cunion-name
403 ,@(iter (for str in (all-structures struct))
404 (collect `(,(var-structure-name str)
405 ,(generated-cstruct-name (var-structure-name str))))))
406 (defctype ,cunion-name (:union ,cunion-name)))))
408 (defun generate-structure-1 (str)
409 (let ((name (var-structure-name str)))
411 (defstruct ,(if (var-structure-parent str)
412 `(,(var-structure-name str) (:include ,(var-structure-name (var-structure-parent str))
413 (,(var-structure-discriminator-slot (var-structure-parent str))
414 ,(first (var-structure-variant-discriminating-values
416 (var-structure-variants
417 (var-structure-parent str))
418 :key #'var-structure-variant-structure))))))
419 `,(var-structure-name str))
420 ,@(iter (for slot in (var-structure-slots str))
421 (collect `(,(cstruct-slot-description-name slot)
422 ,(cstruct-slot-description-initform slot)))))
423 (setf (get ',name 'structure-constructor)
424 ',(intern (format nil "MAKE-~A" (symbol-name name)) (symbol-package name))))))
426 (defun generate-structures (str)
427 (iter (for variant in (reverse (all-structures str)))
428 (collect (generate-structure-1 variant))))
430 (defun generate-native-type-decision-procedure-1 (str proxy-var)
431 (if (null (var-structure-discriminator-slot str))
432 `(values ',(var-structure-resulting-cstruct-description str))
433 `(typecase ,proxy-var
434 ,@(iter (for variant in (var-structure-variants str))
435 (for v-str = (var-structure-variant-structure variant))
436 (collect `(,(var-structure-name v-str)
437 ,(generate-native-type-decision-procedure-1 v-str proxy-var))))
438 (,(var-structure-name str)
439 (values ',(var-structure-resulting-cstruct-description str))))))
441 (defun generate-proxy-type-decision-procedure-1 (str native-var)
442 (if (null (var-structure-discriminator-slot str))
443 `(values ',(var-structure-name str)
444 ',(var-structure-resulting-cstruct-description str))
445 `(case (foreign-slot-value ,native-var
446 ',(generated-cstruct-name (var-structure-name str))
447 ',(var-structure-discriminator-slot str))
448 ,@(iter (for variant in (var-structure-variants str))
449 (for v-str = (var-structure-variant-structure variant))
450 (collect `(,(var-structure-variant-discriminating-values variant)
451 ,(generate-proxy-type-decision-procedure-1
454 (t (values ',(var-structure-name str)
455 ',(var-structure-resulting-cstruct-description str))))))
457 (defun generate-proxy-type-decision-procedure (str)
458 (let ((native (gensym "NATIVE-")))
460 (declare (ignorable ,native))
461 ,(generate-proxy-type-decision-procedure-1 str native))))
463 (defun generate-native-type-decision-procedure (str)
464 (let ((proxy (gensym "PROXY-")))
466 (declare (ignorable ,proxy))
467 ,(generate-native-type-decision-procedure-1 str proxy))))
469 (defun compile-proxy-type-decision-procedure (str)
470 (compile nil (generate-proxy-type-decision-procedure str)))
472 (defun compile-native-type-decision-procedure (str)
473 (compile nil (generate-native-type-decision-procedure str)))
475 (defstruct (g-boxed-variant-cstruct-info (:include g-boxed-info))
477 native-type-decision-procedure
478 proxy-type-decision-procedure)
480 (defmethod make-load-form ((object g-boxed-variant-cstruct-info) &optional env)
481 (make-load-form-saving-slots object :environment env))
483 (define-foreign-type boxed-variant-cstruct-foreign-type (g-boxed-foreign-type) ())
485 (defmethod make-foreign-type ((info g-boxed-variant-cstruct-info) &key return-p)
486 (make-instance 'boxed-variant-cstruct-foreign-type :info info :return-p return-p))
488 (defmacro define-g-boxed-variant-cstruct (name g-type-name &body slots)
489 (let* ((structure (parse-variant-structure-definition name slots)))
490 `(progn ,@(generate-c-structures structure)
491 ,@(generate-variant-union structure)
492 ,@(generate-structures structure)
493 (eval-when (:compile-toplevel :load-toplevel :execute)
494 (setf (get ',name 'g-boxed-foreign-info)
495 (make-g-boxed-variant-cstruct-info :name ',name
498 :native-type-decision-procedure
499 ,(generate-native-type-decision-procedure structure)
500 :proxy-type-decision-procedure
501 ,(generate-proxy-type-decision-procedure structure))
502 (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
503 (get ',name 'g-boxed-foreign-info))))))
505 (defun decide-native-type (info proxy)
506 (funcall (g-boxed-variant-cstruct-info-native-type-decision-procedure info) proxy))
508 (defmethod boxed-copy-fn ((info g-boxed-variant-cstruct-info) native)
509 (if (g-boxed-info-g-type info)
510 (g-boxed-copy (g-boxed-info-g-type info) native)
511 (let ((copy (foreign-alloc (generated-cunion-name (g-boxed-info-name info)))))
512 (memcpy copy native (foreign-type-size (generated-cunion-name (g-boxed-info-name info))))
515 (defmethod boxed-free-fn ((info g-boxed-variant-cstruct-info) native)
516 (if (g-boxed-info-g-type info)
517 (g-boxed-free (g-boxed-info-g-type info) native)
518 (foreign-free native)))
520 (defmethod translate-to-foreign (proxy (foreign-type boxed-variant-cstruct-foreign-type))
523 (let* ((type (g-boxed-foreign-info foreign-type))
524 (cstruct-description (decide-native-type type proxy)))
525 (with-foreign-object (native-structure (generated-cunion-name
527 (g-boxed-variant-cstruct-info-root type))))
528 (copy-slots-to-native proxy native-structure cstruct-description)
529 (values (boxed-copy-fn type native-structure) proxy)))))
531 (defun decide-proxy-type (info native-structure)
532 (funcall (g-boxed-variant-cstruct-info-proxy-type-decision-procedure info) native-structure))
534 (defmethod free-translated-object (native (foreign-type boxed-variant-cstruct-foreign-type) proxy)
536 (let ((type (g-boxed-foreign-info foreign-type)))
537 (multiple-value-bind (actual-struct cstruct-description) (decide-proxy-type type native)
538 (unless (eq (type-of proxy) actual-struct)
540 (error "Expected type of boxed variant structure ~A and actual type ~A do not match"
541 (type-of proxy) actual-struct)
542 (skip-parsing-values () (return-from free-translated-object))))
543 (copy-slots-to-proxy proxy native cstruct-description)
544 (boxed-free-fn type native)))))
546 (defmethod translate-from-foreign (native (foreign-type boxed-variant-cstruct-foreign-type))
547 (unless (null-pointer-p native)
548 (let ((type (g-boxed-foreign-info foreign-type)))
549 (multiple-value-bind (actual-struct cstruct-description) (decide-proxy-type type native)
550 (let ((proxy (create-structure actual-struct)))
551 (copy-slots-to-proxy proxy native cstruct-description)
552 (when (g-boxed-foreign-return-p foreign-type)
553 (boxed-free-fn type native))
556 (defmethod cleanup-translated-object-for-callback ((foreign-type boxed-variant-cstruct-foreign-type) proxy native)
558 (let ((type (g-boxed-foreign-info foreign-type)))
559 (let ((cstruct-description (decide-native-type type proxy)))
560 (copy-slots-to-native proxy native cstruct-description)))))
562 (defgeneric boxed-parse-g-value (gvalue-ptr info))
564 (defgeneric boxed-set-g-value (gvalue-ptr info proxy))
566 (defmethod parse-g-value-for-type (gvalue-ptr (type-numeric (eql (gtype +g-type-boxed+))) parse-kind)
567 (declare (ignore parse-kind))
568 (if (g-type= (g-value-type gvalue-ptr) (g-strv-get-type))
569 (convert-from-foreign (g-value-get-boxed gvalue-ptr) '(glib:gstrv :free-from-foreign nil))
570 (let ((boxed-type (get-g-boxed-foreign-info-for-gtype (g-value-type gvalue-ptr))))
571 (boxed-parse-g-value gvalue-ptr boxed-type))))
573 (defmethod set-gvalue-for-type (gvalue-ptr (type-numeric (eql (gtype +g-type-boxed+))) value)
574 (if (g-type= (g-value-type gvalue-ptr) (g-strv-get-type))
575 (g-value-set-boxed gvalue-ptr (convert-to-foreign value '(glib:gstrv :free-from-foreign nil)))
576 (let ((boxed-type (get-g-boxed-foreign-info-for-gtype (g-value-type gvalue-ptr))))
577 (boxed-set-g-value gvalue-ptr boxed-type value))))
579 (defmethod boxed-parse-g-value (gvalue-ptr (info g-boxed-cstruct-wrapper-info))
580 (translate-from-foreign (g-value-get-boxed gvalue-ptr) (make-foreign-type info :return-p nil)))
582 (defmethod boxed-set-g-value (gvalue-ptr (info g-boxed-cstruct-wrapper-info) proxy)
583 (g-value-take-boxed gvalue-ptr (translate-to-foreign proxy (make-foreign-type info :return-p nil))))
585 (defmethod boxed-parse-g-value (gvalue-ptr (info g-boxed-variant-cstruct-info))
586 (translate-from-foreign (g-value-get-boxed gvalue-ptr) (make-foreign-type info :return-p nil)))
588 (defmethod boxed-set-g-value (gvalue-ptr (info g-boxed-variant-cstruct-info) proxy)
589 (g-value-take-boxed gvalue-ptr (translate-to-foreign proxy (make-foreign-type info :return-p nil))))
591 (defmethod boxed-parse-g-value (gvalue-ptr (info g-boxed-opaque-wrapper-info))
592 (translate-from-foreign (boxed-copy-fn info (g-value-get-boxed gvalue-ptr)) (make-foreign-type info :return-p nil)))
594 (defmethod boxed-set-g-value (gvalue-ptr (info g-boxed-opaque-wrapper-info) proxy)
595 (g-value-set-boxed gvalue-ptr (translate-to-foreign proxy (make-foreign-type info :return-p nil))))
597 (defun boxed-related-symbols (name)
598 (let ((info (get-g-boxed-foreign-info name)))
600 (g-boxed-cstruct-wrapper-info
602 (intern (format nil "MAKE-~A" (symbol-name name)))
603 (intern (format nil "COPY-~A" (symbol-name name))))
604 (iter (for slot in (cstruct-description-slots (g-boxed-cstruct-wrapper-info-cstruct-description info)))
605 (for slot-name = (cstruct-slot-description-name slot))
606 (collect (intern (format nil "~A-~A" (symbol-name name) (symbol-name slot-name)))))))
607 (g-boxed-opaque-wrapper-info
609 (g-boxed-variant-cstruct-info
611 (iter (for var-struct in (all-structures (g-boxed-variant-cstruct-info-root info)))
612 (for s-name = (var-structure-name var-struct))
613 (for cstruct-description = (var-structure-resulting-cstruct-description var-struct))
614 (appending (append (list s-name)
615 (list (intern (format nil "MAKE-~A" (symbol-name s-name)))
616 (intern (format nil "COPY-~A" (symbol-name s-name))))
617 (iter (for slot in (cstruct-description-slots cstruct-description))
618 (for slot-name = (cstruct-slot-description-name slot))
619 (collect (intern (format nil "~A-~A" (symbol-name s-name)
620 (symbol-name slot-name)))))))))))))
622 (defmacro define-boxed-opaque-accessor (boxed-name accessor-name &key type reader writer)
625 `(progn ,@(when reader
626 (list (etypecase reader
627 (symbol `(defun ,accessor-name (,var)
628 (funcall ,reader ,var)))
629 (string `(defcfun (,accessor-name ,reader) ,type
630 (,var (g-boxed-foreign ,boxed-name)))))))
632 (list (etypecase reader
633 (symbol `(defun (setf ,accessor-name) (,n-var ,var)
634 (funcall ,reader ,n-var ,var)))
635 (string `(defun (setf ,accessor-name) (,n-var ,var)
636 (foreign-funcall ,writer (g-boxed-foreign ,boxed-name) ,var ,type ,n-var :void)))))))))
638 (defun copy-boxed-slots-to-foreign (structure native-ptr &optional (type (and structure (type-of structure))))
640 (copy-slots-to-native
643 (g-boxed-cstruct-wrapper-info-cstruct-description (get-g-boxed-foreign-info type)))))
645 (define-compiler-macro copy-boxed-slots-to-foreign (&whole whole structure native-ptr &optional type)
648 (let* ((type-r (eval type))
649 (f-i (get-g-boxed-foreign-info type-r)))
651 (warn "Unknown foreign GBoxed type ~S" type-r)
652 (return-from copy-boxed-slots-to-foreign whole))
653 (unless (typep f-i 'g-boxed-cstruct-wrapper-info)
654 (warn "Foreign GBoxed type ~S is not a C structure wrapper" type-r)
655 (return-from copy-boxed-slots-to-foreign whole))
657 (copy-slots-to-native
660 (load-time-value (g-boxed-cstruct-wrapper-info-cstruct-description (get-g-boxed-foreign-info ',type-r))))))
663 (defmacro with-foreign-boxed-array ((n-var array-var type values-seq) &body body)
664 (let ((values-seq-1 (gensym "VALUES-SEQ-"))
665 (cstruct (generated-cstruct-name type))
668 `(let* ((,values-seq-1 ,values-seq)
669 (,n-var (length ,values-seq-1)))
670 (with-foreign-object (,array-var ',cstruct ,n-var)
672 (map nil (lambda (,x)
673 (copy-boxed-slots-to-foreign
675 (inc-pointer ,array-var (* ,i (foreign-type-size ',cstruct)))