3 (define-foreign-type g-boxed-foreign-type ()
5 :accessor g-boxed-foreign-info
6 :initform (error "info must be specified"))
7 (free-from-foreign :initarg :free-from-foreign
9 :accessor g-boxed-foreign-free-from-foreign)
10 (free-to-foreign :initarg :free-to-foreign
12 :accessor g-boxed-foreign-free-to-foreign)
13 (for-callback :initarg :for-callback
15 :accessor g-boxed-foreign-for-callback))
16 (:actual-type :pointer))
18 (eval-when (:compile-toplevel :load-toplevel :execute)
19 (defstruct g-boxed-info
23 (eval-when (:compile-toplevel :load-toplevel :execute)
24 (defun get-g-boxed-foreign-info (name)
25 (get name 'g-boxed-foreign-info)))
27 (defvar *g-type-name->g-boxed-foreign-info* (make-hash-table :test 'equal))
29 (defun get-g-boxed-foreign-info-for-gtype (g-type-designator)
30 (or (gethash (g-type-string g-type-designator) *g-type-name->g-boxed-foreign-info*)
31 (error "Unknown GBoxed type '~A'" (g-type-string g-type-designator))))
33 (define-parse-method g-boxed-foreign (name &key free-from-foreign free-to-foreign for-callback)
34 (let ((info (get-g-boxed-foreign-info name)))
35 (assert info nil "Unknown foreign GBoxed type ~A" name)
36 (make-instance 'g-boxed-foreign-type
38 :free-from-foreign free-from-foreign
39 :free-to-foreign free-to-foreign
40 :for-callback for-callback)))
42 (eval-when (:load-toplevel :compile-toplevel :execute)
43 (defstruct (g-boxed-cstruct-wrapper-info (:include g-boxed-info))
47 (defmacro define-g-boxed-cstruct (name g-type-name &body slots)
50 ,@(iter (for (name type &key initarg) in slots)
51 (collect (list name initarg))))
52 (defcstruct ,(generated-cstruct-name name)
53 ,@(iter (for (name type &key initarg) in slots)
54 (collect `(,name ,type))))
55 (eval-when (:compile-toplevel :load-toplevel :execute)
56 (setf (get ',name 'g-boxed-foreign-info)
57 (make-g-boxed-cstruct-wrapper-info :name ',name
59 :cstruct ',(generated-cstruct-name name)
60 :slots ',(iter (for (name type &key initarg) in slots)
62 (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
63 (get ',name 'g-boxed-foreign-info)))))
65 (defgeneric create-temporary-native (type proxy)
66 (:documentation "Creates a native structure (or passes a pointer to copy contained in PROXY)
67 that contains the same data that the PROXY contains and returns a pointer to it.
69 This call is always paired by call to FREE-TEMPORARY-NATIVE and calls may be nested."))
71 (defgeneric free-temporary-native (type proxy native-ptr)
72 (:documentation "Frees the native structure that was previously created
73 by CREATE-TEMPORARY-NATIVE for the same PROXY.
75 Also reads data from native structure pointer to by NATIVE-PTR
76 and sets the PROXY to contain the same data.
78 This call is always paired by call to CREATE-TEMPORARY-NATIVE and calls may be nested."))
80 (defgeneric create-proxy-for-native (type native-ptr)
81 (:documentation "Creates a proxy that is initialized by data contained in native
82 structured pointed to by NATIVE-PTR.
84 Created proxy should not be linked to NATIVE-PTR and should have
85 indefinite lifetime (until garbage collector collects it). Specifically,
86 if proxy need a pointer to native structure, it should make a copy of
89 If proxy requires finalization, finalizers should be added."))
91 (defgeneric create-reference-proxy (type native-ptr)
92 (:documentation "Creates a reference proxy for a native structure pointed to by NATIVE-PTR.
94 Reference proxy's lifetime is bound to duration of a callback. When the
95 callback returns the reference proxy is declared invalid and operations on it are errors.
97 This call is always paired by call to FREE-REFERENCE-PROXY and calls will not nest."))
99 (defgeneric free-reference-proxy (type proxy native-ptr)
100 (:documentation "Frees a reference proxy PROXY previously created by call to
101 CREATE-REFERENCE-PROXY. This call should ensure that all changes on PROXY are
102 reflected in native structure pointed to by NATIVE-PTR.
104 After a call to FREE-REFERENCE-PROXY, PROXY is declared invalid and using it is an error,
105 operations on it should signal erros.
107 This call is always paired by call to CREATE-REFERENCE-PROXY."))
109 (defmethod create-temporary-native ((type g-boxed-cstruct-wrapper-info) proxy)
110 (format t "create-temporary-native~%")
111 (let* ((native-structure-type (g-boxed-cstruct-wrapper-info-cstruct type))
112 (native-structure (foreign-alloc native-structure-type)))
113 (iter (for slot in (g-boxed-cstruct-wrapper-info-slots type))
114 (setf (foreign-slot-value native-structure native-structure-type slot)
115 (slot-value proxy slot)))
118 (defmethod free-temporary-native ((type g-boxed-cstruct-wrapper-info) proxy native-structure)
119 (format t "free-temporary-native~%")
120 (let ((native-structure-type (g-boxed-cstruct-wrapper-info-cstruct type)))
121 (iter (for slot in (g-boxed-cstruct-wrapper-info-slots type))
122 (setf (slot-value proxy slot)
123 (foreign-slot-value native-structure native-structure-type slot))))
124 (foreign-free native-structure))
126 (defmethod create-proxy-for-native ((type g-boxed-cstruct-wrapper-info) native-structure)
127 (format t "create-proxy-for-native~%")
128 (let* ((native-structure-type (g-boxed-cstruct-wrapper-info-cstruct type))
129 (proxy (make-instance (g-boxed-info-name type))))
130 (iter (for slot in (g-boxed-cstruct-wrapper-info-slots type))
131 (setf (slot-value proxy slot)
132 (foreign-slot-value native-structure native-structure-type slot)))
135 (defmethod create-reference-proxy ((type g-boxed-cstruct-wrapper-info) native-structure)
136 (format t "create-reference-proxy~%")
137 (create-proxy-for-native type native-structure))
139 (defmethod free-reference-proxy ((type g-boxed-cstruct-wrapper-info) proxy native-structure)
140 (format t "free-reference-proxy~%")
141 (let ((native-structure-type (g-boxed-cstruct-wrapper-info-cstruct type)))
142 (iter (for slot in (g-boxed-cstruct-wrapper-info-slots type))
143 (setf (foreign-slot-value native-structure native-structure-type slot)
144 (slot-value proxy slot)))))
146 (defmethod translate-to-foreign (proxy (type g-boxed-foreign-type))
148 (let* ((info (g-boxed-foreign-info type)))
149 (values (create-temporary-native info proxy) proxy))
152 (defmethod free-translated-object (native-structure (type g-boxed-foreign-type) proxy)
154 (free-temporary-native (g-boxed-foreign-info type) proxy native-structure)))
156 (defmethod translate-from-foreign (native-structure (type g-boxed-foreign-type))
157 (unless (null-pointer-p native-structure)
158 (let* ((info (g-boxed-foreign-info type)))
160 ((g-boxed-foreign-for-callback type)
161 (create-reference-proxy info native-structure))
162 ((or (g-boxed-foreign-free-to-foreign type)
163 (g-boxed-foreign-free-from-foreign type))
164 (error "Feature not yet handled"))
165 (t (create-proxy-for-native info native-structure))))))
167 (defmethod cleanup-translated-object-for-callback ((type g-boxed-foreign-type) proxy native-structure)
168 (unless (null-pointer-p native-structure)
169 (free-reference-proxy (g-boxed-foreign-info type) proxy native-structure)))
171 (defmethod has-callback-cleanup ((type g-boxed-foreign-type))
174 (eval-when (:compile-toplevel :load-toplevel :execute)
175 (defstruct (g-boxed-opaque-wrapper-info (:include g-boxed-info))
178 (defclass g-boxed-opaque ()
179 ((pointer :initarg :pointer
181 :accessor g-boxed-opaque-pointer)))
183 (defmethod create-temporary-native ((type g-boxed-opaque-wrapper-info) proxy)
184 (declare (ignore type))
185 (g-boxed-opaque-pointer proxy))
187 (defmethod free-temporary-native ((type g-boxed-opaque-wrapper-info) proxy native-structure)
188 (declare (ignore type proxy native-structure)))
190 (defmethod create-reference-proxy ((type g-boxed-opaque-wrapper-info) native-structure)
191 (make-instance (g-boxed-info-g-type type) :pointer native-structure))
193 (defmethod free-reference-proxy ((type g-boxed-opaque-wrapper-info) proxy native-structure)
194 (declare (ignore type native-structure))
195 (setf (g-boxed-opaque-pointer proxy) nil))
197 (defmethod create-proxy-for-native ((type g-boxed-opaque-wrapper-info) native-structure)
198 (let* ((g-type (g-boxed-info-g-type type))
199 (native-copy (g-boxed-copy g-type native-structure)))
200 (flet ((finalizer () (g-boxed-free g-type native-copy)))
201 (let ((proxy (make-instance (g-boxed-opaque-wrapper-info-g-type type) :pointer native-copy)))
202 (tg:finalize proxy #'finalizer)
205 (defmacro define-g-boxed-opaque (name g-type-name &key
206 (alloc (error "Alloc must be specified")))
207 (let ((native-copy (gensym "NATIVE-COPY-"))
208 (instance (gensym "INSTANCE-"))
209 (finalizer (gensym "FINALIZER-")))
210 `(progn (defclass ,name (g-boxed-opaque) ())
211 (defmethod initialize-instance :after ((,instance ,name) &key &allow-other-keys)
212 (unless (g-boxed-opaque-pointer ,instance)
213 (let ((,native-copy ,alloc))
214 (flet ((,finalizer () (g-boxed-free ,g-type-name ,native-copy)))
215 (setf (g-boxed-opaque-pointer ,instance) ,native-copy)
216 (finalize ,instance #',finalizer)))))
217 (eval-when (:compile-toplevel :load-toplevel :execute)
218 (setf (get ',name 'g-boxed-foreign-info)
219 (make-g-boxed-opaque-wrapper-info :name ',name
220 :g-type ,g-type-name)
221 (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
222 (get ',name 'g-boxed-foreign-info))))))
224 (defstruct var-structure
231 (defstruct var-structure-variant
232 discriminating-values
235 (defstruct var-structure-slot
241 (defmethod make-load-form ((object var-structure) &optional env)
242 (make-load-form-saving-slots object :environment env))
244 (defmethod make-load-form ((object var-structure-slot) &optional env)
245 (make-load-form-saving-slots object :environment env))
247 (defmethod make-load-form ((object var-structure-variant) &optional env)
248 (make-load-form-saving-slots object :environment env))
250 (defun var-struct-all-slots (struct)
252 (append (var-struct-all-slots (var-structure-parent struct))
253 (var-structure-slots struct))))
255 (defun all-structures (structure)
256 (append (iter (for variant in (var-structure-variants structure))
257 (appending (all-structures (var-structure-variant-structure variant))))
260 (defun parse-variant-structure-definition (name slots &optional parent)
261 (iter (with result = (make-var-structure :name name
264 :discriminator-slot nil
267 (if (eq :variant (first slot))
269 (when (var-structure-discriminator-slot result)
270 (error "Structure has more than one discriminator slot"))
271 (setf (var-structure-discriminator-slot result) (second slot)
272 (var-structure-variants result) (parse-variants result (nthcdr 2 slot))))
273 (push (parse-slot slot) (var-structure-slots result)))
274 (finally (setf (var-structure-slots result)
275 (reverse (var-structure-slots result)))
278 (defun parse-slot (slot)
279 (destructuring-bind (name type &key count initform) slot
280 (make-var-structure-slot :name name :type type :count count :initform initform)))
282 (defun ensure-list (thing)
287 (defun parse-variants (parent variants)
288 (iter (for var-descr in variants)
289 (for (options variant-name . slots) in variants)
291 (make-var-structure-variant
292 :discriminating-values (ensure-list options)
293 :structure (parse-variant-structure-definition variant-name slots parent)))
296 (defun generated-cstruct-name (symbol)
297 (or (get symbol 'generated-cstruct-name)
298 (setf (get symbol 'generated-cstruct-name) (gensym (format nil "GEN-~A-CSTRUCT-" (symbol-name symbol))))))
300 (defun generated-cunion-name (symbol)
301 (or (get symbol 'generated-cunion-name)
302 (setf (get symbol 'generated-cunion-name) (gensym (format nil "GEN-~A-CUNION-" (symbol-name symbol))))))
304 (defun generate-cstruct-1 (struct)
305 `(defcstruct ,(generated-cstruct-name (var-structure-name struct))
306 ,@(iter (for slot in (var-struct-all-slots struct))
307 (collect `(,(var-structure-slot-name slot) ,(var-structure-slot-type slot)
308 ,@(when (var-structure-slot-count slot)
309 (list `(:count ,(var-structure-slot-count slot)))))))))
311 (defun generate-c-structures (structure)
312 (iter (for str in (all-structures structure))
313 (collect (generate-cstruct-1 str))))
315 (defun generate-union-1 (struct)
316 `(defcunion ,(generated-cunion-name (var-structure-name struct))
317 ,@(iter (for variant in (all-structures struct))
318 (unless (eq struct variant)
319 (collect `(,(var-structure-name variant)
320 ,(generated-cunion-name (var-structure-name variant))))))))
322 (defun generate-unions (struct)
323 (iter (for str in (all-structures struct))
324 (collect (generate-union-1 str))))
326 (defun generate-structure-1 (str)
327 `(defstruct ,(if (var-structure-parent str)
328 `(,(var-structure-name str) (:include ,(var-structure-name (var-structure-parent str))
329 (,(var-structure-discriminator-slot (var-structure-parent str))
330 ,(first (var-structure-variant-discriminating-values
332 (var-structure-variants
333 (var-structure-parent str))
334 :key #'var-structure-variant-structure))))))
335 `,(var-structure-name str))
336 ,@(iter (for slot in (var-structure-slots str))
337 (collect `(,(var-structure-slot-name slot)
338 ,(var-structure-slot-initform slot))))))
340 (defun generate-structures (str)
341 (iter (for variant in (reverse (all-structures str)))
342 (collect (generate-structure-1 variant))))
344 (defun generate-native-type-decision-procedure-1 (str proxy-var)
345 (if (null (var-structure-discriminator-slot str))
346 `(values ',(generated-cstruct-name (var-structure-name str))
347 ',(mapcar #'var-structure-slot-name (var-struct-all-slots str)))
348 `(typecase ,proxy-var
349 ,@(iter (for variant in (var-structure-variants str))
350 (for v-str = (var-structure-variant-structure variant))
351 (collect `(,(var-structure-name v-str)
352 ,(generate-native-type-decision-procedure-1 v-str proxy-var))))
353 (,(var-structure-name str)
354 (values ',(generated-cstruct-name (var-structure-name str))
355 ',(mapcar #'var-structure-slot-name (var-struct-all-slots str)))))))
357 (defun generate-proxy-type-decision-procedure-1 (str native-var)
358 (if (null (var-structure-discriminator-slot str))
359 `(values ',(var-structure-name str)
360 ',(mapcar #'var-structure-slot-name (var-struct-all-slots str))
361 ',(generated-cstruct-name (var-structure-name str)))
362 `(case (foreign-slot-value ,native-var
363 ',(generated-cstruct-name (var-structure-name str))
364 ',(var-structure-discriminator-slot str))
365 ,@(iter (for variant in (var-structure-variants str))
366 (for v-str = (var-structure-variant-structure variant))
367 (collect `(,(var-structure-variant-discriminating-values variant)
368 ,(generate-proxy-type-decision-procedure-1
371 (t (values ',(var-structure-name str)
372 ',(mapcar #'var-structure-slot-name (var-struct-all-slots str))
373 ',(generated-cstruct-name (var-structure-name str)))))))
375 (defun generate-proxy-type-decision-procedure (str)
376 (let ((native (gensym "NATIVE-")))
378 ,(generate-proxy-type-decision-procedure-1 str native))))
380 (defun generate-native-type-decision-procedure (str)
381 (let ((proxy (gensym "PROXY-")))
383 ,(generate-native-type-decision-procedure-1 str proxy))))
385 (defun compile-proxy-type-decision-procedure (str)
386 (compile nil (generate-proxy-type-decision-procedure str)))
388 (defun compile-native-type-decision-procedure (str)
389 (compile nil (generate-native-type-decision-procedure str)))
391 (defstruct (g-boxed-variant-cstruct-info (:include g-boxed-info))
393 native-type-decision-procedure
394 proxy-type-decision-procedure)
396 (defmethod make-load-form ((object g-boxed-variant-cstruct-info) &optional env)
397 (make-load-form-saving-slots object :environment env))
399 (defmacro define-g-boxed-variant-cstruct (name g-type-name &body slots)
400 (let* ((structure (parse-variant-structure-definition name slots)))
401 `(progn ,@(generate-c-structures structure)
402 ,@(generate-unions structure)
403 ,@(generate-structures structure)
404 (eval-when (:compile-toplevel :load-toplevel :execute)
405 (setf (get ',name 'g-boxed-foreign-info)
406 (make-g-boxed-variant-cstruct-info :name ',name
409 :native-type-decision-procedure
410 ,(generate-native-type-decision-procedure structure)
411 :proxy-type-decision-procedure
412 ,(generate-proxy-type-decision-procedure structure))
413 (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
414 (get ',name 'g-boxed-foreign-info))))))
416 (defun decide-native-type (info proxy)
417 (funcall (g-boxed-variant-cstruct-info-native-type-decision-procedure info) proxy))
419 (defmethod create-temporary-native ((type g-boxed-variant-cstruct-info) proxy)
420 (multiple-value-bind (actual-cstruct slots) (decide-native-type type proxy)
421 (let ((native-structure (foreign-alloc
422 (generated-cstruct-name
424 (g-boxed-variant-cstruct-info-root type))))))
425 (iter (for slot in slots)
426 (setf (foreign-slot-value native-structure actual-cstruct slot)
427 (slot-value proxy slot)))
430 (defun decide-proxy-type (info native-structure)
431 (funcall (g-boxed-variant-cstruct-info-proxy-type-decision-procedure info) native-structure))
433 (defmethod free-temporary-native ((type g-boxed-variant-cstruct-info) proxy native-ptr)
434 (multiple-value-bind (actual-struct slots actual-cstruct) (decide-proxy-type type native-ptr)
435 (unless (eq (type-of proxy) actual-struct)
437 (error "Expected type of boxed variant structure ~A and actual type ~A do not match"
438 (type-of proxy) actual-struct)
439 (skip-parsing-values () (return-from free-temporary-native))))
440 (iter (for slot in slots)
441 (setf (slot-value proxy slot)
442 (foreign-slot-value native-ptr actual-cstruct slot)))))
444 (defmethod create-proxy-for-native ((type g-boxed-variant-cstruct-info) native-ptr)
445 (multiple-value-bind (actual-struct slots actual-cstruct) (decide-proxy-type type native-ptr)
446 (let ((proxy (make-instance actual-struct)))
447 (iter (for slot in slots)
448 (setf (slot-value proxy slot)
449 (foreign-slot-value native-ptr actual-cstruct slot)))
452 (defmethod create-reference-proxy ((type g-boxed-variant-cstruct-info) native-ptr)
453 (create-proxy-for-native type native-ptr))
455 (defmethod free-reference-proxy ((type g-boxed-variant-cstruct-info) proxy native-ptr)
456 (multiple-value-bind (actual-cstruct slots) (decide-native-type type proxy)
457 (iter (for slot in slots)
458 (setf (foreign-slot-value native-ptr actual-cstruct slot)
459 (slot-value proxy slot)))))
461 (defmethod parse-g-value-for-type (gvalue-ptr (type-numeric (eql +g-type-boxed+)) parse-kind)
462 (declare (ignore parse-kind))
463 (if (g-type= (g-value-type gvalue-ptr) (g-strv-get-type))
464 (convert-from-foreign (g-value-get-boxed gvalue-ptr) '(glib:gstrv :free-from-foreign nil))
465 (let ((boxed-type (get-g-boxed-foreign-info-for-gtype type-numeric)))
466 (create-proxy-for-native boxed-type (g-value-get-boxed gvalue-ptr)))))
468 (defmethod set-gvalue-for-type (gvalue-ptr (type-numeric (eql +g-type-boxed+)) value)
469 (if (g-type= (g-value-type gvalue-ptr) (g-strv-get-type))
470 (g-value-set-boxed gvalue-ptr (convert-to-foreign value '(glib:gstrv :free-from-foreign nil)))
471 (let* ((boxed-type (get-g-boxed-foreign-info-for-gtype type-numeric))
472 (native (create-temporary-native boxed-type value)))
473 (g-value-take-boxed gvalue-ptr (g-boxed-copy type-numeric native))
474 (free-temporary-native boxed-type value native))))