glib/gobject.boxed.lisp

   1 (in-package :gobject)
   2
   3 (define-foreign-type g-boxed-foreign-type ()
   4   ((info :initarg :info
   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
   9              :initform nil))
  10   (:actual-type :pointer))
  11
  12 (eval-when (:compile-toplevel :load-toplevel :execute)
  13   (defstruct g-boxed-info
  14     name
  15     g-type))
  16
  17 (eval-when (:compile-toplevel :load-toplevel :execute)
  18   (defun get-g-boxed-foreign-info (name)
  19     (get name 'g-boxed-foreign-info)))
  20
  21 (defvar *g-type-name->g-boxed-foreign-info* (make-hash-table :test 'equal))
  22
  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))))
  26
  27 (defgeneric make-foreign-type (info &key return-p))
  28
  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))))
  33
  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)))
  37
  38 (defmethod boxed-copy-fn :before (type-info native)
  39   (format t "(boxed-copy-fn ~A ~A)~%" (g-boxed-info-name type-info) native))
  40
  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)))
  44
  45 (defmethod boxed-free-fn :before (type-info native)
  46   (format t "(boxed-free-fn ~A ~A)~%" (g-boxed-info-name type-info) native))
  47
  48 (defmethod has-callback-cleanup ((type g-boxed-foreign-type))
  49   t)
  50
  51 (eval-when (:load-toplevel :compile-toplevel :execute)
  52   (defstruct (g-boxed-cstruct-wrapper-info (:include g-boxed-info))
  53     cstruct-description))
  54
  55 (defclass boxed-cstruct-foreign-type (g-boxed-foreign-type) ())
  56
  57 (defstruct cstruct-slot-description
  58   name
  59   type
  60   count
  61   initform
  62   inline-p)
  63
  64 (defstruct (cstruct-inline-slot-description (:include cstruct-slot-description))
  65   boxed-type-name)
  66
  67 (defmethod make-load-form ((object cstruct-slot-description) &optional environment)
  68   (make-load-form-saving-slots object :environment environment))
  69
  70 (defmethod make-load-form ((object cstruct-inline-slot-description) &optional environment)
  71   (make-load-form-saving-slots object :environment environment))
  72
  73 (defstruct cstruct-description
  74   name
  75   slots)
  76
  77 (defmethod make-load-form ((object cstruct-description) &optional environment)
  78   (make-load-form-saving-slots object :environment environment))
  79
  80 (defun parse-cstruct-slot (slot)
  81   (destructuring-bind (name type &key count initform inline) slot
  82     (if inline
  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))))
  88
  89 (defun parse-cstruct-definition (name slots)
  90   (make-cstruct-description :name name
  91                             :slots (mapcar #'parse-cstruct-slot slots)))
  92
  93 (defmacro define-g-boxed-cstruct (name g-type-name &body slots)
  94   (let ((cstruct-description (parse-cstruct-definition name slots)))
  95     `(progn
  96        (defstruct ,name
  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
 112                                                   :g-type ,g-type-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
 117 (defmethod make-foreign-type ((info g-boxed-cstruct-wrapper-info) &key return-p)
 118   (make-instance 'boxed-cstruct-foreign-type :info info :return-p return-p))
 119
 120 (defun memcpy (target source bytes)
 121   (iter (for i from 0 below bytes)
 122         (setf (mem-aref target :uchar i)
 123               (mem-aref source :uchar i))))
 124
 125 (defmethod boxed-copy-fn ((info g-boxed-cstruct-wrapper-info) native)
 126   (if (g-boxed-info-g-type info)
 127       (g-boxed-copy (g-boxed-info-g-type info) native)
 128       (let ((copy (foreign-alloc (generated-cstruct-name (g-boxed-info-name info)))))
 129         (memcpy copy native (foreign-type-size (generated-cstruct-name (g-boxed-info-name info))))
 130         copy)))
 131
 132 (defmethod boxed-free-fn ((info g-boxed-cstruct-wrapper-info) native)
 133   (if (g-boxed-info-g-type info)
 134       (g-boxed-free (g-boxed-info-g-type info) native)
 135       (foreign-free native)))
 136
 137 (defun copy-slots-to-native (proxy native cstruct-description)
 138   (iter (with cstruct-type = (generated-cstruct-name (cstruct-description-name cstruct-description)))
 139         (for slot in (cstruct-description-slots cstruct-description))
 140         (for slot-name = (cstruct-slot-description-name slot))
 141         (cond
 142           ((cstruct-slot-description-count slot)
 143            (iter (with ptr = (foreign-slot-pointer native cstruct-type slot-name))
 144                  (with array = (slot-value proxy slot-name))
 145                  (for i from 0 below (cstruct-slot-description-count slot))
 146                  (setf (mem-aref ptr (cstruct-slot-description-type slot) i)
 147                        (aref array i))))
 148           ((cstruct-slot-description-inline-p slot)
 149            (let ((info (get-g-boxed-foreign-info (cstruct-inline-slot-description-boxed-type-name slot))))
 150              (copy-slots-to-native (slot-value proxy slot-name)
 151                                    (foreign-slot-pointer native cstruct-type slot-name)
 152                                    (g-boxed-cstruct-wrapper-info-cstruct-description info))))
 153           (t
 154            (setf (foreign-slot-value native cstruct-type slot-name)
 155                  (slot-value proxy slot-name))))))
 156
 157 (defun copy-slots-to-proxy (proxy native cstruct-description)
 158   (iter (with cstruct-type = (generated-cstruct-name (cstruct-description-name cstruct-description)))
 159         (for slot in (cstruct-description-slots cstruct-description))
 160         (for slot-name = (cstruct-slot-description-name slot))
 161         (cond
 162           ((cstruct-slot-description-count slot)
 163            (setf (slot-value proxy slot-name) (make-array (list (cstruct-slot-description-count slot))))
 164            (iter (with ptr = (foreign-slot-pointer native cstruct-type slot-name))
 165                  (with array = (slot-value proxy slot-name))
 166                  (for i from 0 below (cstruct-slot-description-count slot))
 167                  (setf (aref array i)
 168                        (mem-aref ptr (cstruct-slot-description-type slot) i))))
 169           ((cstruct-slot-description-inline-p slot)
 170            (let ((info (get-g-boxed-foreign-info (cstruct-inline-slot-description-boxed-type-name slot))))
 171              (setf (slot-value proxy slot-name) (make-instance (cstruct-inline-slot-description-boxed-type-name slot)))
 172              (copy-slots-to-proxy (slot-value proxy slot-name)
 173                                   (foreign-slot-pointer native cstruct-type slot-name)
 174                                   (g-boxed-cstruct-wrapper-info-cstruct-description info))))
 175           (t (setf (slot-value proxy slot-name)
 176                    (foreign-slot-value native cstruct-type slot-name))))))
 177
 178 (defmethod translate-to-foreign (proxy (type boxed-cstruct-foreign-type))
 179   (if (null proxy)
 180       (null-pointer)
 181       (let* ((info (g-boxed-foreign-info type))
 182              (native-structure-type (generated-cstruct-name (g-boxed-info-name info))))
 183         (with-foreign-object (native-structure native-structure-type)
 184           (copy-slots-to-native proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info))
 185           (values (boxed-copy-fn info native-structure) proxy)))))
 186
 187 (defmethod free-translated-object (native-structure (type boxed-cstruct-foreign-type) proxy)
 188   (when proxy
 189     (let ((info (g-boxed-foreign-info type)))
 190       (copy-slots-to-proxy proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info))
 191       (boxed-free-fn info native-structure))))
 192
 193 (defmethod translate-from-foreign (native-structure (type boxed-cstruct-foreign-type))
 194   (unless (null-pointer-p native-structure)
 195     (let* ((info (g-boxed-foreign-info type))
 196            (proxy-structure-type (g-boxed-info-name info))
 197            (proxy (make-instance proxy-structure-type)))
 198       (copy-slots-to-proxy proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info))
 199       (when (g-boxed-foreign-return-p type)
 200         (boxed-free-fn info native-structure))
 201       proxy)))
 202
 203 (defmethod cleanup-translated-object-for-callback ((type boxed-cstruct-foreign-type) proxy native-structure)
 204   (when proxy
 205     (let ((info (g-boxed-foreign-info type)))
 206       (copy-slots-to-native proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info)))))
 207
 208 (eval-when (:compile-toplevel :load-toplevel :execute)
 209   (defstruct (g-boxed-opaque-wrapper-info (:include g-boxed-info))
 210     alloc free))
 211
 212 (define-foreign-type boxed-opaque-foreign-type (g-boxed-foreign-type) ())
 213
 214 (defclass g-boxed-opaque ()
 215   ((pointer :initarg :pointer
 216             :initform nil
 217             :accessor g-boxed-opaque-pointer)))
 218
 219 (defmethod pointer ((object g-boxed-opaque))
 220   (g-boxed-opaque-pointer object))
 221
 222 (defmethod make-foreign-type ((info g-boxed-opaque-wrapper-info) &key return-p)
 223   (make-instance 'boxed-opaque-foreign-type :info info :return-p return-p))
 224
 225 (defmethod translate-to-foreign (proxy (type boxed-opaque-foreign-type))
 226   (prog1 (g-boxed-opaque-pointer proxy)
 227     (when (g-boxed-foreign-return-p type)
 228       (tg:cancel-finalization proxy)
 229       (setf (g-boxed-opaque-pointer proxy) nil))))
 230
 231 (defmethod free-translated-object (native (type boxed-opaque-foreign-type) param)
 232   (declare (ignore native type param)))
 233
 234 (defun make-boxed-free-finalizer (type pointer)
 235   (lambda () (boxed-free-fn type pointer)))
 236
 237 (defmethod translate-from-foreign (native (foreign-type boxed-opaque-foreign-type))
 238   (let* ((type (g-boxed-foreign-info foreign-type))
 239          (proxy (make-instance (g-boxed-info-name type) :pointer native)))
 240     (tg:finalize proxy (make-boxed-free-finalizer type native))))
 241
 242 (defmethod cleanup-translated-object-for-callback ((type boxed-opaque-foreign-type) proxy native)
 243   (tg:cancel-finalization proxy)
 244   (setf (g-boxed-opaque-pointer proxy) nil))
 245
 246 (defmacro define-g-boxed-opaque (name g-type-name &key
 247                                  (alloc (error "Alloc must be specified")))
 248   (let ((native-copy (gensym "NATIVE-COPY-"))
 249         (instance (gensym "INSTANCE-")))
 250     `(progn (defclass ,name (g-boxed-opaque) ())
 251             (defmethod initialize-instance :after ((,instance ,name) &key &allow-other-keys)
 252               (unless (g-boxed-opaque-pointer ,instance)
 253                 (let ((,native-copy ,alloc))
 254                   (setf (g-boxed-opaque-pointer ,instance) ,native-copy)
 255                   (finalize ,instance (make-boxed-free-finalizer (get ',name 'g-boxed-foreign-info) ,native-copy)))))
 256             (eval-when (:compile-toplevel :load-toplevel :execute)
 257               (setf (get ',name 'g-boxed-foreign-info)
 258                     (make-g-boxed-opaque-wrapper-info :name ',name
 259                                                       :g-type ,g-type-name)
 260                     (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
 261                     (get ',name 'g-boxed-foreign-info))))))
 262
 263 (defstruct var-structure
 264   name
 265   parent
 266   slots
 267   discriminator-slot
 268   variants
 269   resulting-cstruct-description)
 270
 271 (defstruct var-structure-variant
 272   discriminating-values
 273   structure)
 274
 275 (defmethod make-load-form ((object var-structure) &optional env)
 276   (make-load-form-saving-slots object :environment env))
 277
 278 (defmethod make-load-form ((object var-structure-variant) &optional env)
 279   (make-load-form-saving-slots object :environment env))
 280
 281 (defun var-struct-all-slots (struct)
 282   (when struct
 283     (append (var-struct-all-slots (var-structure-parent struct))
 284             (var-structure-slots struct))))
 285
 286 (defun all-structures (structure)
 287   (append (iter (for variant in (var-structure-variants structure))
 288                 (appending (all-structures (var-structure-variant-structure variant))))
 289           (list structure)))
 290
 291 (defun parse-variant-structure-definition (name slots &optional parent)
 292   (iter (with result = (make-var-structure :name name
 293                                            :parent parent
 294                                            :slots nil
 295                                            :discriminator-slot nil
 296                                            :variants nil))
 297         (for slot in slots)
 298         (if (eq :variant (first slot))
 299             (progn
 300               (when (var-structure-discriminator-slot result)
 301                 (error "Structure has more than one discriminator slot"))
 302               (setf (var-structure-discriminator-slot result) (second slot)
 303                     (var-structure-variants result) (parse-variants result (nthcdr 2 slot))))
 304             (push (parse-cstruct-slot slot) (var-structure-slots result)))
 305         (finally (setf (var-structure-slots result)
 306                        (reverse (var-structure-slots result)))
 307                  (unless parent
 308                    (set-variant-result-structure result))
 309                  (return result))))
 310
 311 (defun set-variant-result-structure (var-structure)
 312   (setf (var-structure-resulting-cstruct-description var-structure)
 313         (make-cstruct-description
 314          :name
 315          (var-structure-name var-structure)
 316          :slots
 317          (append
 318           (when (var-structure-parent var-structure)
 319             (cstruct-description-slots (var-structure-resulting-cstruct-description (var-structure-parent var-structure))))
 320           (var-structure-slots var-structure))))
 321   (iter (for variant in (var-structure-variants var-structure))
 322         (for child-var-structure = (var-structure-variant-structure variant))
 323         (set-variant-result-structure child-var-structure)))
 324
 325 (defun ensure-list (thing)
 326   (if (listp thing)
 327       thing
 328       (list thing)))
 329
 330 (defun parse-variants (parent variants)
 331   (iter (for var-descr in variants)
 332         (for (options variant-name . slots) in variants)
 333         (for variant =
 334              (make-var-structure-variant
 335               :discriminating-values (ensure-list options)
 336               :structure (parse-variant-structure-definition variant-name slots parent)))
 337         (collect variant)))
 338
 339 (defpackage :gobject.boxed.generated-names)
 340
 341 (defun generated-cstruct-name (symbol)
 342   (or (get symbol 'generated-cstruct-name)
 343       (setf (get symbol 'generated-cstruct-name) (gentemp (format nil "CSTRUCT-~A" (symbol-name symbol)) (find-package :gobject.boxed.generated-names)))))
 344
 345 (defun generated-cunion-name (symbol)
 346   (or (get symbol 'generated-cunion-name)
 347       (setf (get symbol 'generated-cunion-name) (gentemp (format nil "CUNION-~A" (symbol-name symbol)) (find-package :gobject.boxed.generated-names)))))
 348
 349 (defun generated-fn-name (symbol)
 350   (or (get symbol 'generated-fn-name)
 351       (setf (get symbol 'generated-fn-name) (gentemp (format nil "FN~A" (symbol-name symbol)) (find-package :gobject.boxed.generated-names)))))
 352
 353 (defun generate-cstruct-1 (struct)
 354   `(defcstruct ,(generated-cstruct-name (cstruct-description-name struct))
 355      ,@(iter (for slot in (cstruct-description-slots struct))
 356              (collect `(,(cstruct-slot-description-name slot) ,(cstruct-slot-description-type slot)
 357                          ,@(when (cstruct-slot-description-count slot)
 358                                  `(:count ,(cstruct-slot-description-count slot))))))))
 359
 360 (defun generate-c-structures (structure)
 361   (iter (for str in (all-structures structure))
 362         (for cstruct = (var-structure-resulting-cstruct-description str))
 363         (collect (generate-cstruct-1 cstruct))))
 364
 365 (defun generate-variant-union (struct)
 366   `(defcunion ,(generated-cunion-name (var-structure-name struct))
 367      ,@(iter (for str in (all-structures struct))
 368              (collect `(,(var-structure-name str)
 369                          ,(generated-cstruct-name (var-structure-name str)))))))
 370
 371 (defun generate-structure-1 (str)
 372   `(defstruct ,(if (var-structure-parent str)
 373                    `(,(var-structure-name str) (:include ,(var-structure-name (var-structure-parent str))
 374                                                          (,(var-structure-discriminator-slot (var-structure-parent str))
 375                                                            ,(first (var-structure-variant-discriminating-values
 376                                                                     (find str
 377                                                                           (var-structure-variants
 378                                                                            (var-structure-parent str))
 379                                                                           :key #'var-structure-variant-structure))))))
 380                    `,(var-structure-name str))
 381      ,@(iter (for slot in (var-structure-slots str))
 382              (collect `(,(cstruct-slot-description-name slot)
 383                          ,(cstruct-slot-description-initform slot))))))
 384
 385 (defun generate-structures (str)
 386   (iter (for variant in (reverse (all-structures str)))
 387         (collect (generate-structure-1 variant))))
 388
 389 (defun generate-native-type-decision-procedure-1 (str proxy-var)
 390   (if (null (var-structure-discriminator-slot str))
 391       `(values ',(var-structure-resulting-cstruct-description str))
 392       `(typecase ,proxy-var
 393          ,@(iter (for variant in (var-structure-variants str))
 394                  (for v-str = (var-structure-variant-structure variant))
 395                  (collect `(,(var-structure-name v-str)
 396                              ,(generate-native-type-decision-procedure-1 v-str proxy-var))))
 397          (,(var-structure-name str)
 398           (values ',(var-structure-resulting-cstruct-description str))))))
 399
 400 (defun generate-proxy-type-decision-procedure-1 (str native-var)
 401   (if (null (var-structure-discriminator-slot str))
 402       `(values ',(var-structure-name str)
 403                ',(var-structure-resulting-cstruct-description str))
 404       `(case (foreign-slot-value ,native-var
 405                                  ',(generated-cstruct-name (var-structure-name str))
 406                                  ',(var-structure-discriminator-slot str))
 407          ,@(iter (for variant in (var-structure-variants str))
 408                  (for v-str = (var-structure-variant-structure variant))
 409                  (collect `(,(var-structure-variant-discriminating-values variant)
 410                              ,(generate-proxy-type-decision-procedure-1
 411                                v-str
 412                                native-var))))
 413          (t (values ',(var-structure-name str)
 414                     ',(var-structure-resulting-cstruct-description str))))))
 415
 416 (defun generate-proxy-type-decision-procedure (str)
 417   (let ((native (gensym "NATIVE-")))
 418     `(lambda (,native)
 419        (declare (ignorable ,native))
 420        ,(generate-proxy-type-decision-procedure-1 str native))))
 421
 422 (defun generate-native-type-decision-procedure (str)
 423   (let ((proxy (gensym "PROXY-")))
 424     `(lambda (,proxy)
 425        (declare (ignorable ,proxy))
 426        ,(generate-native-type-decision-procedure-1 str proxy))))
 427
 428 (defun compile-proxy-type-decision-procedure (str)
 429   (compile nil (generate-proxy-type-decision-procedure str)))
 430
 431 (defun compile-native-type-decision-procedure (str)
 432   (compile nil (generate-native-type-decision-procedure str)))
 433
 434 (defstruct (g-boxed-variant-cstruct-info (:include g-boxed-info))
 435   root
 436   native-type-decision-procedure
 437   proxy-type-decision-procedure)
 438
 439 (defmethod make-load-form ((object g-boxed-variant-cstruct-info) &optional env)
 440   (make-load-form-saving-slots object :environment env))
 441
 442 (define-foreign-type boxed-variant-cstruct-foreign-type (g-boxed-foreign-type) ())
 443
 444 (defmethod make-foreign-type ((info g-boxed-variant-cstruct-info) &key return-p)
 445   (make-instance 'boxed-variant-cstruct-foreign-type :info info :return-p return-p))
 446
 447 (defmacro define-g-boxed-variant-cstruct (name g-type-name &body slots)
 448   (let* ((structure (parse-variant-structure-definition name slots)))
 449     `(progn ,@(generate-c-structures structure)
 450             ,(generate-variant-union structure)
 451             ,@(generate-structures structure)
 452             (eval-when (:compile-toplevel :load-toplevel :execute)
 453               (setf (get ',name 'g-boxed-foreign-info)
 454                     (make-g-boxed-variant-cstruct-info :name ',name
 455                                                        :g-type ,g-type-name
 456                                                        :root ,structure
 457                                                        :native-type-decision-procedure
 458                                                        ,(generate-native-type-decision-procedure structure)
 459                                                        :proxy-type-decision-procedure
 460                                                        ,(generate-proxy-type-decision-procedure structure))
 461                     (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
 462                     (get ',name 'g-boxed-foreign-info))))))
 463
 464 (defun decide-native-type (info proxy)
 465   (funcall (g-boxed-variant-cstruct-info-native-type-decision-procedure info) proxy))
 466
 467 (defmethod boxed-copy-fn ((info g-boxed-variant-cstruct-info) native)
 468   (if (g-boxed-info-g-type info)
 469       (g-boxed-copy (g-boxed-info-g-type info) native)
 470       (let ((copy (foreign-alloc (generated-cunion-name (g-boxed-info-name info)))))
 471         (memcpy copy native (foreign-type-size (generated-cunion-name (g-boxed-info-name info))))
 472         copy)))
 473
 474 (defmethod boxed-free-fn ((info g-boxed-variant-cstruct-info) native)
 475   (if (g-boxed-info-g-type info)
 476       (g-boxed-free (g-boxed-info-g-type info) native)
 477       (foreign-free native)))
 478
 479 (defmethod translate-to-foreign (proxy (foreign-type boxed-variant-cstruct-foreign-type))
 480   (if (null proxy)
 481       (null-pointer)
 482       (let* ((type (g-boxed-foreign-info foreign-type))
 483              (cstruct-description (decide-native-type type proxy)))
 484         (with-foreign-object (native-structure (generated-cunion-name
 485                                                 (var-structure-name
 486                                                  (g-boxed-variant-cstruct-info-root type))))
 487           (copy-slots-to-native proxy native-structure cstruct-description)
 488           (values (boxed-copy-fn type native-structure) proxy)))))
 489
 490 (defun decide-proxy-type (info native-structure)
 491   (funcall (g-boxed-variant-cstruct-info-proxy-type-decision-procedure info) native-structure))
 492
 493 (defmethod free-translated-object (native (foreign-type boxed-variant-cstruct-foreign-type) proxy)
 494   (when proxy
 495     (let ((type (g-boxed-foreign-info foreign-type)))
 496       (multiple-value-bind (actual-struct cstruct-description) (decide-proxy-type type native)
 497         (unless (eq (type-of proxy) actual-struct)
 498           (restart-case
 499               (error "Expected type of boxed variant structure ~A and actual type ~A do not match"
 500                      (type-of proxy) actual-struct)
 501             (skip-parsing-values () (return-from free-translated-object))))
 502         (copy-slots-to-proxy proxy native cstruct-description)
 503         (boxed-free-fn type native)))))
 504
 505 (defmethod translate-from-foreign (native (foreign-type boxed-variant-cstruct-foreign-type))
 506   (unless (null-pointer-p native)
 507     (let ((type (g-boxed-foreign-info foreign-type)))
 508       (multiple-value-bind (actual-struct cstruct-description) (decide-proxy-type type native)
 509         (let ((proxy (make-instance actual-struct)))
 510           (copy-slots-to-proxy proxy native cstruct-description)
 511           (when (g-boxed-foreign-return-p foreign-type)
 512             (boxed-free-fn type native))
 513           proxy)))))
 514
 515 (defmethod cleanup-translated-object-for-callback ((foreign-type boxed-variant-cstruct-foreign-type) proxy native)
 516   (when proxy
 517     (let ((type (g-boxed-foreign-info foreign-type)))
 518       (let ((cstruct-description (decide-native-type type proxy)))
 519         (copy-slots-to-native proxy native cstruct-description)))))
 520
 521 (defgeneric boxed-parse-g-value (gvalue-ptr info))
 522
 523 (defgeneric boxed-set-g-value (gvalue-ptr info proxy))
 524
 525 (defmethod parse-g-value-for-type (gvalue-ptr (type-numeric (eql +g-type-boxed+)) parse-kind)
 526   (declare (ignore parse-kind))
 527   (if (g-type= (g-value-type gvalue-ptr) (g-strv-get-type))
 528       (convert-from-foreign (g-value-get-boxed gvalue-ptr) '(glib:gstrv :free-from-foreign nil))
 529       (let ((boxed-type (get-g-boxed-foreign-info-for-gtype (g-value-type gvalue-ptr))))
 530         (boxed-parse-g-value gvalue-ptr boxed-type))))
 531
 532 (defmethod set-gvalue-for-type (gvalue-ptr (type-numeric (eql +g-type-boxed+)) value)
 533   (if (g-type= (g-value-type gvalue-ptr) (g-strv-get-type))
 534       (g-value-set-boxed gvalue-ptr (convert-to-foreign value '(glib:gstrv :free-from-foreign nil)))
 535       (let ((boxed-type (get-g-boxed-foreign-info-for-gtype (g-value-type gvalue-ptr))))
 536         (boxed-set-g-value gvalue-ptr boxed-type value))))
 537
 538 (defmethod boxed-parse-g-value (gvalue-ptr (info g-boxed-cstruct-wrapper-info))
 539   (translate-from-foreign (g-value-get-boxed gvalue-ptr) (make-foreign-type info :return-p nil)))
 540
 541 (defmethod boxed-set-g-value (gvalue-ptr (info g-boxed-cstruct-wrapper-info) proxy)
 542   (g-value-take-boxed gvalue-ptr (translate-to-foreign proxy (make-foreign-type info :return-p nil))))
 543
 544 (defmethod boxed-parse-g-value (gvalue-ptr (info g-boxed-variant-cstruct-info))
 545   (translate-from-foreign (g-value-get-boxed gvalue-ptr) (make-foreign-type info :return-p nil)))
 546
 547 (defmethod boxed-set-g-value (gvalue-ptr (info g-boxed-variant-cstruct-info) proxy)
 548   (g-value-take-boxed gvalue-ptr (translate-to-foreign proxy (make-foreign-type info :return-p nil))))
 549
 550 (defmethod boxed-parse-g-value (gvalue-ptr (info g-boxed-opaque-wrapper-info))
 551   (translate-from-foreign (boxed-copy-fn info (g-value-get-boxed gvalue-ptr)) (make-foreign-type info :return-p nil)))
 552
 553 (defmethod boxed-set-g-value (gvalue-ptr (info g-boxed-opaque-wrapper-info) proxy)
 554   (g-value-set-boxed gvalue-ptr (translate-to-foreign proxy (make-foreign-type info :return-p nil))))
 555
 556 (defun boxed-related-symbols (name)
 557   (let ((info (get-g-boxed-foreign-info name)))
 558     (etypecase info
 559       (g-boxed-cstruct-wrapper-info
 560        (append (list name
 561                      (intern (format nil "MAKE-~A" (symbol-name name)))
 562                      (intern (format nil "COPY-~A" (symbol-name name))))
 563                (iter (for slot in (cstruct-description-slots (g-boxed-cstruct-wrapper-info-cstruct-description info)))
 564                      (for slot-name = (cstruct-slot-description-name slot))
 565                      (collect (intern (format nil "~A-~A" (symbol-name name) (symbol-name slot-name)))))))
 566       (g-boxed-opaque-wrapper-info
 567        (list name))
 568       (g-boxed-variant-cstruct-info
 569        (append (list name)
 570                (iter (for var-struct in (all-structures (g-boxed-variant-cstruct-info-root info)))
 571                      (for s-name = (var-structure-name var-struct))
 572                      (for cstruct-description = (var-structure-resulting-cstruct-description var-struct))
 573                      (appending (append (list (intern (format nil "MAKE-~A" (symbol-name s-name)))
 574                                               (intern (format nil "COPY-~A" (symbol-name s-name))))
 575                                         (iter (for slot in (cstruct-description-slots cstruct-description))
 576                                               (for slot-name = (cstruct-slot-description-name slot))
 577                                               (collect (intern (format nil "~A-~A" (symbol-name s-name)
 578                                                                        (symbol-name slot-name)))))))))))))
 579
 580 (defmacro define-boxed-opaque-accessor (boxed-name accessor-name &key type reader writer)
 581   (let ((var (gensym))
 582         (n-var (gensym)))
 583     `(progn ,@(when reader
 584                     (list (etypecase reader
 585                             (symbol `(defun ,accessor-name (,var)
 586                                        (funcall ,reader ,var)))
 587                             (string `(defcfun (,accessor-name ,reader) ,type
 588                                        (,var (g-boxed-foreign ,boxed-name)))))))
 589             ,@(when writer
 590                     (list (etypecase reader
 591                             (symbol `(defun (setf ,accessor-name) (,n-var ,var)
 592                                        (funcall ,reader ,n-var ,var)))
 593                             (string `(defun (setf ,accessor-name) (,n-var ,var)
 594                                        (foreign-funcall ,writer (g-boxed-foreign ,boxed-name) ,var ,type ,n-var :void)))))))))