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))
56 (defclass boxed-cstruct-foreign-type (g-boxed-foreign-type) ())
58 (defmacro define-g-boxed-cstruct (name g-type-name &body slots)
61 ,@(iter (for (name type &key count initarg) in slots)
62 (collect (list name initarg))))
63 (defcstruct ,(generated-cstruct-name name)
64 ,@(iter (for (name type &key count initarg) in slots)
65 (collect `(,name ,type ,@(when count `(:count ,count))))))
66 (eval-when (:compile-toplevel :load-toplevel :execute)
67 (setf (get ',name 'g-boxed-foreign-info)
68 (make-g-boxed-cstruct-wrapper-info :name ',name
70 :cstruct ',(generated-cstruct-name name)
71 :slots ',(iter (for (name type &key initarg) in slots)
73 (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
74 (get ',name 'g-boxed-foreign-info)))))
76 (defmethod make-foreign-type ((info g-boxed-cstruct-wrapper-info) &key return-p)
77 (make-instance 'boxed-cstruct-foreign-type :info info :return-p return-p))
79 (defun memcpy (target source bytes)
80 (iter (for i from 0 below bytes)
81 (setf (mem-aref target :uchar i)
82 (mem-aref source :uchar i))))
84 (defmethod boxed-copy-fn ((info g-boxed-cstruct-wrapper-info) native)
85 (if (g-boxed-info-g-type info)
86 (g-boxed-copy (g-boxed-info-g-type info) native)
87 (let ((copy (foreign-alloc (g-boxed-cstruct-wrapper-info-cstruct info))))
88 (memcpy copy native (foreign-type-size (g-boxed-cstruct-wrapper-info-cstruct info)))
91 (defmethod boxed-free-fn ((info g-boxed-cstruct-wrapper-info) native)
92 (if (g-boxed-info-g-type info)
93 (g-boxed-free (g-boxed-info-g-type info) native)
94 (foreign-free native)))
96 (defmethod translate-to-foreign (proxy (type boxed-cstruct-foreign-type))
99 (let* ((info (g-boxed-foreign-info type))
100 (native-structure-type (g-boxed-cstruct-wrapper-info-cstruct info)))
101 (with-foreign-object (native-structure native-structure-type)
102 (iter (for slot in (g-boxed-cstruct-wrapper-info-slots info))
103 (setf (foreign-slot-value native-structure native-structure-type slot)
104 (slot-value proxy slot)))
105 (values (boxed-copy-fn info native-structure) proxy)))))
107 (defmethod free-translated-object (native-structure (type boxed-cstruct-foreign-type) proxy)
109 (let* ((info (g-boxed-foreign-info type))
110 (native-structure-type (g-boxed-cstruct-wrapper-info-cstruct info)))
111 (iter (for slot in (g-boxed-cstruct-wrapper-info-slots info))
112 (setf (slot-value proxy slot)
113 (foreign-slot-value native-structure native-structure-type slot)))
114 (boxed-free-fn info native-structure))))
116 (defmethod translate-from-foreign (native-structure (type boxed-cstruct-foreign-type))
117 (unless (null-pointer-p native-structure)
118 (let* ((info (g-boxed-foreign-info type))
119 (native-structure-type (g-boxed-cstruct-wrapper-info-cstruct info))
120 (proxy-structure-type (g-boxed-info-name info))
121 (proxy (make-instance proxy-structure-type)))
122 (iter (for slot in (g-boxed-cstruct-wrapper-info-slots info))
123 (setf (slot-value proxy slot)
124 (foreign-slot-value native-structure native-structure-type slot)))
125 (when (g-boxed-foreign-return-p type)
126 (boxed-free-fn info native-structure))
129 (defmethod cleanup-translated-object-for-callback ((type boxed-cstruct-foreign-type) proxy native-structure)
131 (let* ((info (g-boxed-foreign-info type))
132 (native-structure-type (g-boxed-cstruct-wrapper-info-cstruct info)))
133 (iter (for slot in (g-boxed-cstruct-wrapper-info-slots info))
134 (setf (foreign-slot-value native-structure native-structure-type slot)
135 (slot-value proxy slot))))))
137 (eval-when (:compile-toplevel :load-toplevel :execute)
138 (defstruct (g-boxed-opaque-wrapper-info (:include g-boxed-info))
141 (define-foreign-type boxed-opaque-foreign-type (g-boxed-foreign-type) ())
143 (defclass g-boxed-opaque ()
144 ((pointer :initarg :pointer
146 :accessor g-boxed-opaque-pointer)))
148 (defmethod make-foreign-type ((info g-boxed-opaque-wrapper-info) &key return-p)
149 (make-instance 'boxed-opaque-foreign-type :info info :return-p return-p))
151 (defmethod translate-to-foreign (proxy (type boxed-opaque-foreign-type))
152 (prog1 (g-boxed-opaque-pointer proxy)
153 (when (g-boxed-foreign-return-p type)
154 (tg:cancel-finalization proxy)
155 (setf (g-boxed-opaque-pointer proxy) nil))))
157 (defmethod free-translated-object (native (type boxed-opaque-foreign-type) param)
158 (declare (ignore native type param)))
160 (defun make-boxed-free-finalizer (type pointer)
161 (lambda () (boxed-free-fn type pointer)))
163 (defmethod translate-from-foreign (native (foreign-type boxed-opaque-foreign-type))
164 (let* ((type (g-boxed-foreign-info foreign-type))
165 (proxy (make-instance (g-boxed-info-name type) :pointer native)))
166 (tg:finalize proxy (make-boxed-free-finalizer type native))))
168 (defmethod cleanup-translated-object-for-callback ((type boxed-opaque-foreign-type) proxy native)
169 (tg:cancel-finalization proxy)
170 (setf (g-boxed-opaque-pointer proxy) nil))
172 (defmacro define-g-boxed-opaque (name g-type-name &key
173 (alloc (error "Alloc must be specified")))
174 (let ((native-copy (gensym "NATIVE-COPY-"))
175 (instance (gensym "INSTANCE-"))
176 (finalizer (gensym "FINALIZER-")))
177 `(progn (defclass ,name (g-boxed-opaque) ())
178 (defmethod initialize-instance :after ((,instance ,name) &key &allow-other-keys)
179 (unless (g-boxed-opaque-pointer ,instance)
180 (let ((,native-copy ,alloc))
181 (flet ((,finalizer () (boxed-free-fn ,g-type-name ,native-copy)))
182 (setf (g-boxed-opaque-pointer ,instance) ,native-copy)
183 (finalize ,instance (make-boxed-free-finalizer (get ',name 'g-boxed-foreign-info) ,native-copy))))))
184 (eval-when (:compile-toplevel :load-toplevel :execute)
185 (setf (get ',name 'g-boxed-foreign-info)
186 (make-g-boxed-opaque-wrapper-info :name ',name
187 :g-type ,g-type-name)
188 (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
189 (get ',name 'g-boxed-foreign-info))))))
191 (defstruct var-structure
198 (defstruct var-structure-variant
199 discriminating-values
202 (defstruct var-structure-slot
208 (defmethod make-load-form ((object var-structure) &optional env)
209 (make-load-form-saving-slots object :environment env))
211 (defmethod make-load-form ((object var-structure-slot) &optional env)
212 (make-load-form-saving-slots object :environment env))
214 (defmethod make-load-form ((object var-structure-variant) &optional env)
215 (make-load-form-saving-slots object :environment env))
217 (defun var-struct-all-slots (struct)
219 (append (var-struct-all-slots (var-structure-parent struct))
220 (var-structure-slots struct))))
222 (defun all-structures (structure)
223 (append (iter (for variant in (var-structure-variants structure))
224 (appending (all-structures (var-structure-variant-structure variant))))
227 (defun parse-variant-structure-definition (name slots &optional parent)
228 (iter (with result = (make-var-structure :name name
231 :discriminator-slot nil
234 (if (eq :variant (first slot))
236 (when (var-structure-discriminator-slot result)
237 (error "Structure has more than one discriminator slot"))
238 (setf (var-structure-discriminator-slot result) (second slot)
239 (var-structure-variants result) (parse-variants result (nthcdr 2 slot))))
240 (push (parse-slot slot) (var-structure-slots result)))
241 (finally (setf (var-structure-slots result)
242 (reverse (var-structure-slots result)))
245 (defun parse-slot (slot)
246 (destructuring-bind (name type &key count initform) slot
247 (make-var-structure-slot :name name :type type :count count :initform initform)))
249 (defun ensure-list (thing)
254 (defun parse-variants (parent variants)
255 (iter (for var-descr in variants)
256 (for (options variant-name . slots) in variants)
258 (make-var-structure-variant
259 :discriminating-values (ensure-list options)
260 :structure (parse-variant-structure-definition variant-name slots parent)))
263 (defun generated-cstruct-name (symbol)
264 (or (get symbol 'generated-cstruct-name)
265 (setf (get symbol 'generated-cstruct-name) (gensym (format nil "GEN-~A-CSTRUCT-" (symbol-name symbol))))))
267 (defun generated-cunion-name (symbol)
268 (or (get symbol 'generated-cunion-name)
269 (setf (get symbol 'generated-cunion-name) (gensym (format nil "GEN-~A-CUNION-" (symbol-name symbol))))))
271 (defun generate-cstruct-1 (struct)
272 `(defcstruct ,(generated-cstruct-name (var-structure-name struct))
273 ,@(iter (for slot in (var-struct-all-slots struct))
274 (collect `(,(var-structure-slot-name slot) ,(var-structure-slot-type slot)
275 ,@(when (var-structure-slot-count slot)
276 `(:count ,(var-structure-slot-count slot))))))))
278 (defun generate-c-structures (structure)
279 (iter (for str in (all-structures structure))
280 (collect (generate-cstruct-1 str))))
282 (defun generate-union-1 (struct)
283 `(defcunion ,(generated-cunion-name (var-structure-name struct))
284 ,@(iter (for variant in (all-structures struct))
285 (unless (eq struct variant)
286 (collect `(,(var-structure-name variant)
287 ,(generated-cunion-name (var-structure-name variant))))))))
289 (defun generate-unions (struct)
290 (iter (for str in (all-structures struct))
291 (collect (generate-union-1 str))))
293 (defun generate-structure-1 (str)
294 `(defstruct ,(if (var-structure-parent str)
295 `(,(var-structure-name str) (:include ,(var-structure-name (var-structure-parent str))
296 (,(var-structure-discriminator-slot (var-structure-parent str))
297 ,(first (var-structure-variant-discriminating-values
299 (var-structure-variants
300 (var-structure-parent str))
301 :key #'var-structure-variant-structure))))))
302 `,(var-structure-name str))
303 ,@(iter (for slot in (var-structure-slots str))
304 (collect `(,(var-structure-slot-name slot)
305 ,(var-structure-slot-initform slot))))))
307 (defun generate-structures (str)
308 (iter (for variant in (reverse (all-structures str)))
309 (collect (generate-structure-1 variant))))
311 (defun generate-native-type-decision-procedure-1 (str proxy-var)
312 (if (null (var-structure-discriminator-slot str))
313 `(values ',(generated-cstruct-name (var-structure-name str))
314 ',(mapcar #'var-structure-slot-name (var-struct-all-slots str)))
315 `(typecase ,proxy-var
316 ,@(iter (for variant in (var-structure-variants str))
317 (for v-str = (var-structure-variant-structure variant))
318 (collect `(,(var-structure-name v-str)
319 ,(generate-native-type-decision-procedure-1 v-str proxy-var))))
320 (,(var-structure-name str)
321 (values ',(generated-cstruct-name (var-structure-name str))
322 ',(mapcar #'var-structure-slot-name (var-struct-all-slots str)))))))
324 (defun generate-proxy-type-decision-procedure-1 (str native-var)
325 (if (null (var-structure-discriminator-slot str))
326 `(values ',(var-structure-name str)
327 ',(mapcar #'var-structure-slot-name (var-struct-all-slots str))
328 ',(generated-cstruct-name (var-structure-name str)))
329 `(case (foreign-slot-value ,native-var
330 ',(generated-cstruct-name (var-structure-name str))
331 ',(var-structure-discriminator-slot str))
332 ,@(iter (for variant in (var-structure-variants str))
333 (for v-str = (var-structure-variant-structure variant))
334 (collect `(,(var-structure-variant-discriminating-values variant)
335 ,(generate-proxy-type-decision-procedure-1
338 (t (values ',(var-structure-name str)
339 ',(mapcar #'var-structure-slot-name (var-struct-all-slots str))
340 ',(generated-cstruct-name (var-structure-name str)))))))
342 (defun generate-proxy-type-decision-procedure (str)
343 (let ((native (gensym "NATIVE-")))
345 ,(generate-proxy-type-decision-procedure-1 str native))))
347 (defun generate-native-type-decision-procedure (str)
348 (let ((proxy (gensym "PROXY-")))
350 ,(generate-native-type-decision-procedure-1 str proxy))))
352 (defun compile-proxy-type-decision-procedure (str)
353 (compile nil (generate-proxy-type-decision-procedure str)))
355 (defun compile-native-type-decision-procedure (str)
356 (compile nil (generate-native-type-decision-procedure str)))
358 (defstruct (g-boxed-variant-cstruct-info (:include g-boxed-info))
360 native-type-decision-procedure
361 proxy-type-decision-procedure)
363 (defmethod make-load-form ((object g-boxed-variant-cstruct-info) &optional env)
364 (make-load-form-saving-slots object :environment env))
366 (define-foreign-type boxed-variant-cstruct-foreign-type () ())
368 (defmethod make-foreign-type ((info g-boxed-variant-cstruct-info) &key return-p)
369 (make-instance 'boxed-variant-cstruct-foreign-type :info info :return-p return-p))
371 (defmacro define-g-boxed-variant-cstruct (name g-type-name &body slots)
372 (let* ((structure (parse-variant-structure-definition name slots)))
373 `(progn ,@(generate-c-structures structure)
374 ,@(generate-unions structure)
375 ,@(generate-structures structure)
376 (eval-when (:compile-toplevel :load-toplevel :execute)
377 (setf (get ',name 'g-boxed-foreign-info)
378 (make-g-boxed-variant-cstruct-info :name ',name
381 :native-type-decision-procedure
382 ,(generate-native-type-decision-procedure structure)
383 :proxy-type-decision-procedure
384 ,(generate-proxy-type-decision-procedure structure))
385 (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
386 (get ',name 'g-boxed-foreign-info))))))
388 (defun decide-native-type (info proxy)
389 (funcall (g-boxed-variant-cstruct-info-native-type-decision-procedure info) proxy))
391 (defmethod boxed-copy-fn ((info g-boxed-variant-cstruct-info) native)
392 (if (g-boxed-info-g-type info)
393 (g-boxed-copy (g-boxed-info-g-type info) native)
394 (let ((copy (foreign-alloc (generated-cstruct-name (g-boxed-info-name info)))))
395 (memcpy copy native (foreign-type-size (generated-cstruct-name (g-boxed-info-name info))))
398 (defmethod boxed-free-fn ((info g-boxed-variant-cstruct-info) native)
399 (if (g-boxed-info-g-type info)
400 (g-boxed-free (g-boxed-info-g-type info) native)
401 (foreign-free native)))
403 (defmethod translate-to-foreign (proxy (foreign-type boxed-variant-cstruct-foreign-type))
406 (let ((type (g-boxed-foreign-info foreign-type)))
407 (multiple-value-bind (actual-cstruct slots) (decide-native-type type proxy)
408 (with-foreign-object (native-structure (generated-cstruct-name
410 (g-boxed-variant-cstruct-info-root type))))
411 (iter (for slot in slots)
412 (setf (foreign-slot-value native-structure actual-cstruct slot)
413 (slot-value proxy slot)))
414 (values (boxed-copy-fn type native-structure) proxy))))))
416 (defun decide-proxy-type (info native-structure)
417 (funcall (g-boxed-variant-cstruct-info-proxy-type-decision-procedure info) native-structure))
419 (defmethod free-translated-object (native (foreign-type boxed-variant-cstruct-foreign-type) proxy)
421 (let ((type (g-boxed-foreign-info foreign-type)))
422 (multiple-value-bind (actual-struct slots actual-cstruct) (decide-proxy-type type native)
423 (unless (eq (type-of proxy) actual-struct)
425 (error "Expected type of boxed variant structure ~A and actual type ~A do not match"
426 (type-of proxy) actual-struct)
427 (skip-parsing-values () (return-from free-translated-object))))
428 (iter (for slot in slots)
429 (setf (slot-value proxy slot)
430 (foreign-slot-value native actual-cstruct slot)))))))
432 (defmethod translate-from-foreign (native (foreign-type g-boxed-variant-cstruct-info))
433 (unless (null-pointer-p native)
434 (let ((type (g-boxed-foreign-info foreign-type)))
435 (multiple-value-bind (actual-struct slots actual-cstruct) (decide-proxy-type type native)
436 (let ((proxy (make-instance actual-struct)))
437 (iter (for slot in slots)
438 (setf (slot-value proxy slot)
439 (foreign-slot-value native actual-cstruct slot)))
442 (defmethod cleanup-translated-object-for-callback ((foreign-type g-boxed-variant-cstruct-info) proxy native)
444 (let ((type (g-boxed-foreign-info foreign-type)))
445 (multiple-value-bind (actual-cstruct slots) (decide-native-type type proxy)
446 (iter (for slot in slots)
447 (setf (foreign-slot-value native actual-cstruct slot)
448 (slot-value proxy slot)))))))
450 (defgeneric boxed-parse-g-value (gvalue-ptr info))
452 (defgeneric boxed-set-g-value (gvalue-ptr info proxy))
454 (defmethod parse-g-value-for-type (gvalue-ptr (type-numeric (eql +g-type-boxed+)) parse-kind)
455 (declare (ignore parse-kind))
456 (if (g-type= (g-value-type gvalue-ptr) (g-strv-get-type))
457 (convert-from-foreign (g-value-get-boxed gvalue-ptr) '(glib:gstrv :free-from-foreign nil))
458 (let ((boxed-type (get-g-boxed-foreign-info-for-gtype type-numeric)))
459 (boxed-parse-g-value gvalue-ptr boxed-type))))
461 (defmethod set-gvalue-for-type (gvalue-ptr (type-numeric (eql +g-type-boxed+)) value)
462 (if (g-type= (g-value-type gvalue-ptr) (g-strv-get-type))
463 (g-value-set-boxed gvalue-ptr (convert-to-foreign value '(glib:gstrv :free-from-foreign nil)))
464 (let ((boxed-type (get-g-boxed-foreign-info-for-gtype type-numeric)))
465 (boxed-set-g-value gvalue-ptr boxed-type value))))
467 (defmethod boxed-parse-g-value (gvalue-ptr (info g-boxed-cstruct-wrapper-info))
468 (translate-from-foreign (g-value-get-boxed gvalue-ptr) (make-foreign-type info :return-p nil)))
470 (defmethod boxed-set-g-value (gvalue-ptr (info g-boxed-cstruct-wrapper-info) proxy)
471 (g-value-take-boxed gvalue-ptr (translate-to-foreign proxy (make-foreign-type info :return-p nil))))
473 (defmethod boxed-parse-g-value (gvalue-ptr (info g-boxed-variant-cstruct-info))
474 (translate-from-foreign (g-value-get-boxed gvalue-ptr) (make-foreign-type info :return-p nil)))
476 (defmethod boxed-set-g-value (gvalue-ptr (info g-boxed-variant-cstruct-info) proxy)
477 (g-value-take-boxed gvalue-ptr (translate-to-foreign proxy (make-foreign-type info :return-p nil))))
479 (defmethod boxed-parse-g-value (gvalue-ptr (info g-boxed-opaque-wrapper-info))
480 (translate-from-foreign (boxed-copy-fn info (g-value-get-boxed gvalue-ptr)) (make-foreign-type info :return-p nil)))
482 (defmethod boxed-set-g-value (gvalue-ptr (info g-boxed-opaque-wrapper-info) proxy)
483 (g-value-set-boxed gvalue-ptr (translate-to-foreign proxy (make-foreign-type info :return-p nil))))