X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=glib%2Fgobject.boxed.lisp;h=34542b2bb2828a562359f3fabde4f4f8ab0e9c4d;hb=eee03aae86b30336ec34b468624e07adf2592b5e;hp=d74f8fbd4014df24b8d6931be43915f946a75dc3;hpb=1210ea93e088328d8f6cd8d91c57427c688f11c5;p=cl-gtk2.git

diff --git a/glib/gobject.boxed.lisp b/glib/gobject.boxed.lisp
index d74f8fb..34542b2 100644
--- a/glib/gobject.boxed.lisp
+++ b/glib/gobject.boxed.lisp
@@ -4,15 +4,9 @@
   ((info :initarg :info
          :accessor g-boxed-foreign-info
          :initform (error "info must be specified"))
-   (free-from-foreign :initarg :free-from-foreign
-                      :initform nil
-                      :accessor g-boxed-foreign-free-from-foreign)
-   (free-to-foreign :initarg :free-to-foreign
-                    :initform nil
-                    :accessor g-boxed-foreign-free-to-foreign)
-   (for-callback :initarg :for-callback
-                 :initform nil
-                 :accessor g-boxed-foreign-for-callback))
+   (return-p :initarg :return-p
+             :accessor g-boxed-foreign-return-p
+             :initform nil))
   (:actual-type :pointer))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
@@ -30,190 +24,242 @@
   (or (gethash (g-type-string g-type-designator) *g-type-name->g-boxed-foreign-info*)
       (error "Unknown GBoxed type '~A'" (g-type-string g-type-designator))))
 
-(define-parse-method g-boxed-foreign (name &key free-from-foreign free-to-foreign for-callback)
+(defgeneric make-foreign-type (info &key return-p))
+
+(define-parse-method g-boxed-foreign (name &rest options)
   (let ((info (get-g-boxed-foreign-info name)))
     (assert info nil "Unknown foreign GBoxed type ~A" name)
-    (make-instance 'g-boxed-foreign-type
-                   :info info
-                   :free-from-foreign free-from-foreign
-                   :free-to-foreign free-to-foreign
-                   :for-callback for-callback)))
+    (make-foreign-type info :return-p (member :return options))))
+
+(defgeneric boxed-copy-fn (type-info native)
+  (:method (type-info native)
+    (g-boxed-copy (g-boxed-info-g-type type-info) native)))
+
+#+nil(defmethod boxed-copy-fn :before (type-info native)
+  (format t "(boxed-copy-fn ~A ~A)~%" (g-boxed-info-name type-info) native))
+
+(defgeneric boxed-free-fn (type-info native)
+  (:method (type-info native)
+    (g-boxed-free (g-boxed-info-g-type type-info) native)))
+
+#+nil(defmethod boxed-free-fn :before (type-info native)
+  (format t "(boxed-free-fn ~A ~A)~%" (g-boxed-info-name type-info) native))
+
+(defmethod has-callback-cleanup ((type g-boxed-foreign-type))
+  t)
 
 (eval-when (:load-toplevel :compile-toplevel :execute)
   (defstruct (g-boxed-cstruct-wrapper-info (:include g-boxed-info))
-    cstruct
-    slots))
+    cstruct-description))
+
+(defclass boxed-cstruct-foreign-type (g-boxed-foreign-type) ())
+
+(defstruct cstruct-slot-description
+  name
+  type
+  count
+  initform
+  inline-p)
+
+(defstruct (cstruct-inline-slot-description (:include cstruct-slot-description))
+  boxed-type-name)
+
+(defmethod make-load-form ((object cstruct-slot-description) &optional environment)
+  (make-load-form-saving-slots object :environment environment))
+
+(defmethod make-load-form ((object cstruct-inline-slot-description) &optional environment)
+  (make-load-form-saving-slots object :environment environment))
+
+(defstruct cstruct-description
+  name
+  slots)
+
+(defmethod make-load-form ((object cstruct-description) &optional environment)
+  (make-load-form-saving-slots object :environment environment))
+
+(defun parse-cstruct-slot (slot)
+  (destructuring-bind (name type &key count initform inline) slot
+    (if inline
+        (make-cstruct-inline-slot-description :name name :type (generated-cunion-name type)
+                                       :count count :initform initform :inline-p inline
+                                       :boxed-type-name type)
+        (make-cstruct-inline-slot-description :name name :type type
+                                              :count count :initform initform :inline-p inline))))
+
+(defun parse-cstruct-definition (name slots)
+  (make-cstruct-description :name name
+                            :slots (mapcar #'parse-cstruct-slot slots)))
 
 (defmacro define-g-boxed-cstruct (name g-type-name &body slots)
-  `(progn
-     (defstruct ,name
-       ,@(iter (for (name type &key initarg) in slots)
-               (collect (list name initarg))))
-     (defcstruct ,(generated-cstruct-name name)
-       ,@(iter (for (name type &key initarg) in slots)
-               (collect `(,name ,type))))
-     (eval-when (:compile-toplevel :load-toplevel :execute)
-       (setf (get ',name 'g-boxed-foreign-info)
-             (make-g-boxed-cstruct-wrapper-info :name ',name
-                                                :g-type ,g-type-name
-                                                :cstruct ',(generated-cstruct-name name)
-                                                :slots ',(iter (for (name type &key initarg) in slots)
-                                                               (collect name)))
-             (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
-             (get ',name 'g-boxed-foreign-info)))))
-
-(defgeneric create-temporary-native (type proxy)
-  (:documentation "Creates a native structure (or passes a pointer to copy contained in PROXY)
-that contains the same data that the PROXY contains and returns a pointer to it.
-
-This call is always paired by call to FREE-TEMPORARY-NATIVE and calls may be nested."))
-
-(defgeneric free-temporary-native (type proxy native-ptr)
-  (:documentation "Frees the native structure that was previously created
-by CREATE-TEMPORARY-NATIVE for the same PROXY.
-
-Also reads data from native structure pointer to by NATIVE-PTR
-and sets the PROXY to contain the same data.
-
-This call is always paired by call to CREATE-TEMPORARY-NATIVE and calls may be nested."))
-
-(defgeneric create-proxy-for-native (type native-ptr)
-  (:documentation "Creates a proxy that is initialized by data contained in native
-structured pointed to by NATIVE-PTR.
-
-Created proxy should not be linked to NATIVE-PTR and should have
-indefinite lifetime (until garbage collector collects it). Specifically,
-if proxy need a pointer to native structure, it should make a copy of
-a structure.
-
-If proxy requires finalization, finalizers should be added."))
-
-(defgeneric create-reference-proxy (type native-ptr)
-  (:documentation "Creates a reference proxy for a native structure pointed to by NATIVE-PTR.
-
-Reference proxy's lifetime is bound to duration of a callback. When the
-callback returns the reference proxy is declared invalid and operations on it are errors.
-
-This call is always paired by call to FREE-REFERENCE-PROXY and calls will not nest."))
-
-(defgeneric free-reference-proxy (type proxy native-ptr)
-  (:documentation "Frees a reference proxy PROXY previously created by call to
-CREATE-REFERENCE-PROXY. This call should ensure that all changes on PROXY are
-reflected in native structure pointed to by NATIVE-PTR.
-
-After a call to FREE-REFERENCE-PROXY, PROXY is declared invalid and using it is an error,
-operations on it should signal erros.
-
-This call is always paired by call to CREATE-REFERENCE-PROXY."))
-
-(defmethod create-temporary-native ((type g-boxed-cstruct-wrapper-info) proxy)
-  (format t "create-temporary-native~%")
-  (let* ((native-structure-type (g-boxed-cstruct-wrapper-info-cstruct type))
-         (native-structure (foreign-alloc native-structure-type)))
-    (iter (for slot in (g-boxed-cstruct-wrapper-info-slots type))
-          (setf (foreign-slot-value native-structure native-structure-type slot)
-                (slot-value proxy slot)))
-    native-structure))
-
-(defmethod free-temporary-native ((type g-boxed-cstruct-wrapper-info) proxy native-structure)
-  (format t "free-temporary-native~%")
-  (let ((native-structure-type (g-boxed-cstruct-wrapper-info-cstruct type)))
-    (iter (for slot in (g-boxed-cstruct-wrapper-info-slots type))
-          (setf (slot-value proxy slot)
-                (foreign-slot-value native-structure native-structure-type slot))))
-  (foreign-free native-structure))
-
-(defmethod create-proxy-for-native ((type g-boxed-cstruct-wrapper-info) native-structure)
-  (format t "create-proxy-for-native~%")
-  (let* ((native-structure-type (g-boxed-cstruct-wrapper-info-cstruct type))
-         (proxy (make-instance (g-boxed-info-name type))))
-    (iter (for slot in (g-boxed-cstruct-wrapper-info-slots type))
-          (setf (slot-value proxy slot)
-                (foreign-slot-value native-structure native-structure-type slot)))
-    proxy))
-
-(defmethod create-reference-proxy ((type g-boxed-cstruct-wrapper-info) native-structure)
-  (format t "create-reference-proxy~%")
-  (create-proxy-for-native type native-structure))
-
-(defmethod free-reference-proxy ((type g-boxed-cstruct-wrapper-info) proxy native-structure)
-  (format t "free-reference-proxy~%")
-  (let ((native-structure-type (g-boxed-cstruct-wrapper-info-cstruct type)))
-    (iter (for slot in (g-boxed-cstruct-wrapper-info-slots type))
-          (setf (foreign-slot-value native-structure native-structure-type slot)
-                (slot-value proxy slot)))))
-
-(defmethod translate-to-foreign (proxy (type g-boxed-foreign-type))
-  (if proxy
-      (let* ((info (g-boxed-foreign-info type)))
-        (values (create-temporary-native info proxy) proxy))
-      (null-pointer)))
-
-(defmethod free-translated-object (native-structure (type g-boxed-foreign-type) proxy)
+  (let ((cstruct-description (parse-cstruct-definition name slots)))
+    `(progn
+       (defstruct ,name
+         ,@(iter (for slot in (cstruct-description-slots cstruct-description))
+                 (for name = (cstruct-slot-description-name slot))
+                 (for initform = (cstruct-slot-description-initform slot))
+                 (collect (list name initform))))
+       (defcstruct ,(generated-cstruct-name name)
+         ,@(iter (for slot in (cstruct-description-slots cstruct-description))
+                 (for name = (cstruct-slot-description-name slot))
+                 (for type = (cstruct-slot-description-type slot))
+                 (for count = (cstruct-slot-description-count slot))
+                 (collect `(,name ,type ,@(when count `(:count ,count))))))
+       (defcunion ,(generated-cunion-name name)
+         (,name ,(generated-cstruct-name name)))
+       (eval-when (:compile-toplevel :load-toplevel :execute)
+         (setf (get ',name 'g-boxed-foreign-info)
+               (make-g-boxed-cstruct-wrapper-info :name ',name
+                                                  :g-type ,g-type-name
+                                                  :cstruct-description ,cstruct-description)
+               (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
+               (get ',name 'g-boxed-foreign-info)
+               (get ',name 'structure-constructor)
+               ',(intern (format nil "MAKE-~A" (symbol-name name)) (symbol-package name)))))))
+
+(defmethod make-foreign-type ((info g-boxed-cstruct-wrapper-info) &key return-p)
+  (make-instance 'boxed-cstruct-foreign-type :info info :return-p return-p))
+
+(defun memcpy (target source bytes)
+  (iter (for i from 0 below bytes)
+        (setf (mem-aref target :uchar i)
+              (mem-aref source :uchar i))))
+
+(defmethod boxed-copy-fn ((info g-boxed-cstruct-wrapper-info) native)
+  (if (g-boxed-info-g-type info)
+      (g-boxed-copy (g-boxed-info-g-type info) native)
+      (let ((copy (foreign-alloc (generated-cstruct-name (g-boxed-info-name info)))))
+        (memcpy copy native (foreign-type-size (generated-cstruct-name (g-boxed-info-name info))))
+        copy)))
+
+(defmethod boxed-free-fn ((info g-boxed-cstruct-wrapper-info) native)
+  (if (g-boxed-info-g-type info)
+      (g-boxed-free (g-boxed-info-g-type info) native)
+      (foreign-free native)))
+
+(defun copy-slots-to-native (proxy native cstruct-description)
+  (iter (with cstruct-type = (generated-cstruct-name (cstruct-description-name cstruct-description)))
+        (for slot in (cstruct-description-slots cstruct-description))
+        (for slot-name = (cstruct-slot-description-name slot))
+        (cond
+          ((cstruct-slot-description-count slot)
+           (iter (with ptr = (foreign-slot-pointer native cstruct-type slot-name))
+                 (with array = (slot-value proxy slot-name))
+                 (for i from 0 below (cstruct-slot-description-count slot))
+                 (setf (mem-aref ptr (cstruct-slot-description-type slot) i)
+                       (aref array i))))
+          ((cstruct-slot-description-inline-p slot)
+           (let ((info (get-g-boxed-foreign-info (cstruct-inline-slot-description-boxed-type-name slot))))
+             (copy-slots-to-native (slot-value proxy slot-name)
+                                   (foreign-slot-pointer native cstruct-type slot-name)
+                                   (g-boxed-cstruct-wrapper-info-cstruct-description info))))
+          (t
+           (setf (foreign-slot-value native cstruct-type slot-name)
+                 (slot-value proxy slot-name))))))
+
+(defun create-structure (structure-name)
+  (let ((constructor (get structure-name 'structure-constructor)))
+    (assert constructor nil "Don't know how to create structure of type ~A" structure-name)
+    (funcall constructor)))
+
+(defun copy-slots-to-proxy (proxy native cstruct-description)
+  (iter (with cstruct-type = (generated-cstruct-name (cstruct-description-name cstruct-description)))
+        (for slot in (cstruct-description-slots cstruct-description))
+        (for slot-name = (cstruct-slot-description-name slot))
+        (cond
+          ((cstruct-slot-description-count slot)
+           (setf (slot-value proxy slot-name) (make-array (list (cstruct-slot-description-count slot))))
+           (iter (with ptr = (foreign-slot-pointer native cstruct-type slot-name))
+                 (with array = (slot-value proxy slot-name))
+                 (for i from 0 below (cstruct-slot-description-count slot))
+                 (setf (aref array i)
+                       (mem-aref ptr (cstruct-slot-description-type slot) i))))
+          ((cstruct-slot-description-inline-p slot)
+           (let ((info (get-g-boxed-foreign-info (cstruct-inline-slot-description-boxed-type-name slot))))
+             (setf (slot-value proxy slot-name) (create-structure (cstruct-inline-slot-description-boxed-type-name slot)))
+             (copy-slots-to-proxy (slot-value proxy slot-name)
+                                  (foreign-slot-pointer native cstruct-type slot-name)
+                                  (g-boxed-cstruct-wrapper-info-cstruct-description info))))
+          (t (setf (slot-value proxy slot-name)
+                   (foreign-slot-value native cstruct-type slot-name))))))
+
+(defmethod translate-to-foreign (proxy (type boxed-cstruct-foreign-type))
+  (if (null proxy)
+      (null-pointer)
+      (let* ((info (g-boxed-foreign-info type))
+             (native-structure-type (generated-cstruct-name (g-boxed-info-name info))))
+        (with-foreign-object (native-structure native-structure-type)
+          (copy-slots-to-native proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info))
+          (values (boxed-copy-fn info native-structure) proxy)))))
+
+(defmethod free-translated-object (native-structure (type boxed-cstruct-foreign-type) proxy)
   (when proxy
-    (free-temporary-native (g-boxed-foreign-info type) proxy native-structure)))
+    (let ((info (g-boxed-foreign-info type)))
+      (copy-slots-to-proxy proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info))
+      (boxed-free-fn info native-structure))))
 
-(defmethod translate-from-foreign (native-structure (type g-boxed-foreign-type))
-  (unless (null-pointer-p native-structure)
-    (let* ((info (g-boxed-foreign-info type)))
-      (cond
-        ((g-boxed-foreign-for-callback type)
-         (create-reference-proxy info native-structure))
-        ((or (g-boxed-foreign-free-to-foreign type)
-             (g-boxed-foreign-free-from-foreign type))
-         (error "Feature not yet handled"))
-        (t (create-proxy-for-native info native-structure))))))
-
-(defmethod cleanup-translated-object-for-callback ((type g-boxed-foreign-type) proxy native-structure)
+(defmethod translate-from-foreign (native-structure (type boxed-cstruct-foreign-type))
   (unless (null-pointer-p native-structure)
-    (free-reference-proxy (g-boxed-foreign-info type) proxy native-structure)))
+    (let* ((info (g-boxed-foreign-info type))
+           (proxy-structure-type (g-boxed-info-name info))
+           (proxy (create-structure proxy-structure-type)))
+      (copy-slots-to-proxy proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info))
+      (when (g-boxed-foreign-return-p type)
+        (boxed-free-fn info native-structure))
+      proxy)))
 
-(defmethod has-callback-cleanup ((type g-boxed-foreign-type))
-  t)
+(defmethod cleanup-translated-object-for-callback ((type boxed-cstruct-foreign-type) proxy native-structure)
+  (when proxy
+    (let ((info (g-boxed-foreign-info type)))
+      (copy-slots-to-native proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info)))))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defstruct (g-boxed-opaque-wrapper-info (:include g-boxed-info))
     alloc free))
 
+(define-foreign-type boxed-opaque-foreign-type (g-boxed-foreign-type) ())
+
 (defclass g-boxed-opaque ()
   ((pointer :initarg :pointer
             :initform nil
             :accessor g-boxed-opaque-pointer)))
 
-(defmethod create-temporary-native ((type g-boxed-opaque-wrapper-info) proxy)
-  (declare (ignore type))
-  (g-boxed-opaque-pointer proxy))
+(defmethod pointer ((object g-boxed-opaque))
+  (g-boxed-opaque-pointer object))
 
-(defmethod free-temporary-native ((type g-boxed-opaque-wrapper-info) proxy native-structure)
-  (declare (ignore type proxy native-structure)))
+(defmethod make-foreign-type ((info g-boxed-opaque-wrapper-info) &key return-p)
+  (make-instance 'boxed-opaque-foreign-type :info info :return-p return-p))
 
-(defmethod create-reference-proxy ((type g-boxed-opaque-wrapper-info) native-structure)
-  (make-instance (g-boxed-info-g-type type) :pointer native-structure))
+(defmethod translate-to-foreign (proxy (type boxed-opaque-foreign-type))
+  (prog1 (g-boxed-opaque-pointer proxy)
+    (when (g-boxed-foreign-return-p type)
+      (tg:cancel-finalization proxy)
+      (setf (g-boxed-opaque-pointer proxy) nil))))
 
-(defmethod free-reference-proxy ((type g-boxed-opaque-wrapper-info) proxy native-structure)
-  (declare (ignore type native-structure))
-  (setf (g-boxed-opaque-pointer proxy) nil))
+(defmethod free-translated-object (native (type boxed-opaque-foreign-type) param)
+  (declare (ignore native type param)))
 
-(defmethod create-proxy-for-native ((type g-boxed-opaque-wrapper-info) native-structure)
-  (let* ((g-type (g-boxed-info-g-type type))
-         (native-copy (g-boxed-copy g-type native-structure)))
-    (flet ((finalizer () (g-boxed-free g-type native-copy)))
-      (let ((proxy (make-instance (g-boxed-opaque-wrapper-info-g-type type) :pointer native-copy)))
-        (tg:finalize proxy #'finalizer)
-        proxy))))
+(defun make-boxed-free-finalizer (type pointer)
+  (lambda () (boxed-free-fn type pointer)))
+
+(defmethod translate-from-foreign (native (foreign-type boxed-opaque-foreign-type))
+  (let* ((type (g-boxed-foreign-info foreign-type))
+         (proxy (make-instance (g-boxed-info-name type) :pointer native)))
+    (tg:finalize proxy (make-boxed-free-finalizer type native))))
+
+(defmethod cleanup-translated-object-for-callback ((type boxed-opaque-foreign-type) proxy native)
+  (tg:cancel-finalization proxy)
+  (setf (g-boxed-opaque-pointer proxy) nil))
 
 (defmacro define-g-boxed-opaque (name g-type-name &key
                                  (alloc (error "Alloc must be specified")))
   (let ((native-copy (gensym "NATIVE-COPY-"))
-        (instance (gensym "INSTANCE-"))
-        (finalizer (gensym "FINALIZER-")))
+        (instance (gensym "INSTANCE-")))
     `(progn (defclass ,name (g-boxed-opaque) ())
             (defmethod initialize-instance :after ((,instance ,name) &key &allow-other-keys)
               (unless (g-boxed-opaque-pointer ,instance)
                 (let ((,native-copy ,alloc))
-                  (flet ((,finalizer () (g-boxed-free ,g-type-name ,native-copy)))
-                    (setf (g-boxed-opaque-pointer ,instance) ,native-copy)
-                    (finalize ,instance #',finalizer)))))
+                  (setf (g-boxed-opaque-pointer ,instance) ,native-copy)
+                  (finalize ,instance (make-boxed-free-finalizer (get ',name 'g-boxed-foreign-info) ,native-copy)))))
             (eval-when (:compile-toplevel :load-toplevel :execute)
               (setf (get ',name 'g-boxed-foreign-info)
                     (make-g-boxed-opaque-wrapper-info :name ',name
@@ -226,24 +272,16 @@ This call is always paired by call to CREATE-REFERENCE-PROXY."))
   parent
   slots
   discriminator-slot
-  variants)
+  variants
+  resulting-cstruct-description)
 
 (defstruct var-structure-variant
   discriminating-values
   structure)
 
-(defstruct var-structure-slot
-  name
-  type
-  initform
-  count)
-
 (defmethod make-load-form ((object var-structure) &optional env)
   (make-load-form-saving-slots object :environment env))
 
-(defmethod make-load-form ((object var-structure-slot) &optional env)
-  (make-load-form-saving-slots object :environment env))
-
 (defmethod make-load-form ((object var-structure-variant) &optional env)
   (make-load-form-saving-slots object :environment env))
 
@@ -270,14 +308,26 @@ This call is always paired by call to CREATE-REFERENCE-PROXY."))
                 (error "Structure has more than one discriminator slot"))
               (setf (var-structure-discriminator-slot result) (second slot)
                     (var-structure-variants result) (parse-variants result (nthcdr 2 slot))))
-            (push (parse-slot slot) (var-structure-slots result)))
+            (push (parse-cstruct-slot slot) (var-structure-slots result)))
         (finally (setf (var-structure-slots result)
                        (reverse (var-structure-slots result)))
+                 (unless parent
+                   (set-variant-result-structure result))
                  (return result))))
 
-(defun parse-slot (slot)
-  (destructuring-bind (name type &key count initform) slot
-    (make-var-structure-slot :name name :type type :count count :initform initform)))
+(defun set-variant-result-structure (var-structure)
+  (setf (var-structure-resulting-cstruct-description var-structure)
+        (make-cstruct-description
+         :name
+         (var-structure-name var-structure)
+         :slots
+         (append
+          (when (var-structure-parent var-structure)
+            (cstruct-description-slots (var-structure-resulting-cstruct-description (var-structure-parent var-structure))))
+          (var-structure-slots var-structure))))
+  (iter (for variant in (var-structure-variants var-structure))
+        (for child-var-structure = (var-structure-variant-structure variant))
+        (set-variant-result-structure child-var-structure)))
 
 (defun ensure-list (thing)
   (if (listp thing)
@@ -294,48 +344,46 @@ This call is always paired by call to CREATE-REFERENCE-PROXY."))
         (collect variant)))
 
 (defun generated-cstruct-name (symbol)
-  (or (get symbol 'generated-cstruct-name)
-      (setf (get symbol 'generated-cstruct-name) (gensym (format nil "GEN-~A-CSTRUCT-" (symbol-name symbol))))))
+  (intern (format nil "~A-CSTRUCT-GENERATED-BY-GOBJECT-BOXED" (symbol-name symbol)) (symbol-package symbol)))
 
 (defun generated-cunion-name (symbol)
-  (or (get symbol 'generated-cunion-name)
-      (setf (get symbol 'generated-cunion-name) (gensym (format nil "GEN-~A-CUNION-" (symbol-name symbol))))))
+  (intern (format nil "~A-CUNION-GENERATED-BY-GOBJECT-BOXED" (symbol-name symbol)) (symbol-package symbol)))
 
 (defun generate-cstruct-1 (struct)
-  `(defcstruct ,(generated-cstruct-name (var-structure-name struct))
-     ,@(iter (for slot in (var-struct-all-slots struct))
-             (collect `(,(var-structure-slot-name slot) ,(var-structure-slot-type slot)
-                         ,@(when (var-structure-slot-count slot)
-                                 (list `(:count ,(var-structure-slot-count slot)))))))))
+  `(defcstruct ,(generated-cstruct-name (cstruct-description-name struct))
+     ,@(iter (for slot in (cstruct-description-slots struct))
+             (collect `(,(cstruct-slot-description-name slot) ,(cstruct-slot-description-type slot)
+                         ,@(when (cstruct-slot-description-count slot)
+                                 `(:count ,(cstruct-slot-description-count slot))))))))
 
 (defun generate-c-structures (structure)
   (iter (for str in (all-structures structure))
-        (collect (generate-cstruct-1 str))))
+        (for cstruct = (var-structure-resulting-cstruct-description str))
+        (collect (generate-cstruct-1 cstruct))))
 
-(defun generate-union-1 (struct)
+(defun generate-variant-union (struct)
   `(defcunion ,(generated-cunion-name (var-structure-name struct))
-     ,@(iter (for variant in (all-structures struct))
-             (unless (eq struct variant)
-               (collect `(,(var-structure-name variant)
-                           ,(generated-cunion-name (var-structure-name variant))))))))
-
-(defun generate-unions (struct)
-  (iter (for str in (all-structures struct))
-        (collect (generate-union-1 str))))
+     ,@(iter (for str in (all-structures struct))
+             (collect `(,(var-structure-name str)
+                         ,(generated-cstruct-name (var-structure-name str)))))))
 
 (defun generate-structure-1 (str)
-  `(defstruct ,(if (var-structure-parent str)
-                   `(,(var-structure-name str) (:include ,(var-structure-name (var-structure-parent str))
-                                                         (,(var-structure-discriminator-slot (var-structure-parent str))
-                                                           ,(first (var-structure-variant-discriminating-values
-                                                                    (find str
-                                                                          (var-structure-variants
-                                                                           (var-structure-parent str))
-                                                                          :key #'var-structure-variant-structure))))))
-                   `,(var-structure-name str))
-     ,@(iter (for slot in (var-structure-slots str))
-             (collect `(,(var-structure-slot-name slot)
-                         ,(var-structure-slot-initform slot))))))
+  (let ((name (var-structure-name str)))
+    `(progn
+       (defstruct ,(if (var-structure-parent str)
+                       `(,(var-structure-name str) (:include ,(var-structure-name (var-structure-parent str))
+                                                             (,(var-structure-discriminator-slot (var-structure-parent str))
+                                                               ,(first (var-structure-variant-discriminating-values
+                                                                        (find str
+                                                                              (var-structure-variants
+                                                                               (var-structure-parent str))
+                                                                              :key #'var-structure-variant-structure))))))
+                       `,(var-structure-name str))
+         ,@(iter (for slot in (var-structure-slots str))
+                 (collect `(,(cstruct-slot-description-name slot)
+                             ,(cstruct-slot-description-initform slot)))))
+       (setf (get ',name 'structure-constructor)
+             ',(intern (format nil "MAKE-~A" (symbol-name name)) (symbol-package name))))))
 
 (defun generate-structures (str)
   (iter (for variant in (reverse (all-structures str)))
@@ -343,22 +391,19 @@ This call is always paired by call to CREATE-REFERENCE-PROXY."))
 
 (defun generate-native-type-decision-procedure-1 (str proxy-var)
   (if (null (var-structure-discriminator-slot str))
-      `(values ',(generated-cstruct-name (var-structure-name str))
-               ',(mapcar #'var-structure-slot-name (var-struct-all-slots str)))
+      `(values ',(var-structure-resulting-cstruct-description str))
       `(typecase ,proxy-var
          ,@(iter (for variant in (var-structure-variants str))
                  (for v-str = (var-structure-variant-structure variant))
                  (collect `(,(var-structure-name v-str)
                              ,(generate-native-type-decision-procedure-1 v-str proxy-var))))
          (,(var-structure-name str)
-          (values ',(generated-cstruct-name (var-structure-name str))
-                  ',(mapcar #'var-structure-slot-name (var-struct-all-slots str)))))))
+          (values ',(var-structure-resulting-cstruct-description str))))))
 
 (defun generate-proxy-type-decision-procedure-1 (str native-var)
   (if (null (var-structure-discriminator-slot str))
       `(values ',(var-structure-name str)
-               ',(mapcar #'var-structure-slot-name (var-struct-all-slots str))
-               ',(generated-cstruct-name (var-structure-name str)))
+               ',(var-structure-resulting-cstruct-description str))
       `(case (foreign-slot-value ,native-var
                                  ',(generated-cstruct-name (var-structure-name str))
                                  ',(var-structure-discriminator-slot str))
@@ -369,17 +414,18 @@ This call is always paired by call to CREATE-REFERENCE-PROXY."))
                                v-str
                                native-var))))
          (t (values ',(var-structure-name str)
-                    ',(mapcar #'var-structure-slot-name (var-struct-all-slots str))
-                    ',(generated-cstruct-name (var-structure-name str)))))))
+                    ',(var-structure-resulting-cstruct-description str))))))
 
 (defun generate-proxy-type-decision-procedure (str)
   (let ((native (gensym "NATIVE-")))
     `(lambda (,native)
+       (declare (ignorable ,native))
        ,(generate-proxy-type-decision-procedure-1 str native))))
 
 (defun generate-native-type-decision-procedure (str)
   (let ((proxy (gensym "PROXY-")))
     `(lambda (,proxy)
+       (declare (ignorable ,proxy))
        ,(generate-native-type-decision-procedure-1 str proxy))))
 
 (defun compile-proxy-type-decision-procedure (str)
@@ -396,10 +442,15 @@ This call is always paired by call to CREATE-REFERENCE-PROXY."))
 (defmethod make-load-form ((object g-boxed-variant-cstruct-info) &optional env)
   (make-load-form-saving-slots object :environment env))
 
+(define-foreign-type boxed-variant-cstruct-foreign-type (g-boxed-foreign-type) ())
+
+(defmethod make-foreign-type ((info g-boxed-variant-cstruct-info) &key return-p)
+  (make-instance 'boxed-variant-cstruct-foreign-type :info info :return-p return-p))
+
 (defmacro define-g-boxed-variant-cstruct (name g-type-name &body slots)
   (let* ((structure (parse-variant-structure-definition name slots)))
     `(progn ,@(generate-c-structures structure)
-            ,@(generate-unions structure)
+            ,(generate-variant-union structure)
             ,@(generate-structures structure)
             (eval-when (:compile-toplevel :load-toplevel :execute)
               (setf (get ',name 'g-boxed-foreign-info)
@@ -416,59 +467,132 @@ This call is always paired by call to CREATE-REFERENCE-PROXY."))
 (defun decide-native-type (info proxy)
   (funcall (g-boxed-variant-cstruct-info-native-type-decision-procedure info) proxy))
 
-(defmethod create-temporary-native ((type g-boxed-variant-cstruct-info) proxy)
-  (multiple-value-bind (actual-cstruct slots) (decide-native-type type proxy)
-    (let ((native-structure (foreign-alloc
-                             (generated-cstruct-name
-                              (var-structure-name
-                               (g-boxed-variant-cstruct-info-root type))))))
-      (iter (for slot in slots)
-            (setf (foreign-slot-value native-structure actual-cstruct slot)
-                  (slot-value proxy slot)))
-      native-structure)))
+(defmethod boxed-copy-fn ((info g-boxed-variant-cstruct-info) native)
+  (if (g-boxed-info-g-type info)
+      (g-boxed-copy (g-boxed-info-g-type info) native)
+      (let ((copy (foreign-alloc (generated-cunion-name (g-boxed-info-name info)))))
+        (memcpy copy native (foreign-type-size (generated-cunion-name (g-boxed-info-name info))))
+        copy)))
+
+(defmethod boxed-free-fn ((info g-boxed-variant-cstruct-info) native)
+  (if (g-boxed-info-g-type info)
+      (g-boxed-free (g-boxed-info-g-type info) native)
+      (foreign-free native)))
+
+(defmethod translate-to-foreign (proxy (foreign-type boxed-variant-cstruct-foreign-type))
+  (if (null proxy)
+      (null-pointer)
+      (let* ((type (g-boxed-foreign-info foreign-type))
+             (cstruct-description (decide-native-type type proxy)))
+        (with-foreign-object (native-structure (generated-cunion-name
+                                                (var-structure-name
+                                                 (g-boxed-variant-cstruct-info-root type))))
+          (copy-slots-to-native proxy native-structure cstruct-description)
+          (values (boxed-copy-fn type native-structure) proxy)))))
 
 (defun decide-proxy-type (info native-structure)
   (funcall (g-boxed-variant-cstruct-info-proxy-type-decision-procedure info) native-structure))
 
-(defmethod free-temporary-native ((type g-boxed-variant-cstruct-info) proxy native-ptr)
-  (multiple-value-bind (actual-struct slots actual-cstruct) (decide-proxy-type type native-ptr)
-    (unless (eq (type-of proxy) actual-struct)
-      (restart-case
-          (error "Expected type of boxed variant structure ~A and actual type ~A do not match"
-                 (type-of proxy) actual-struct)
-        (skip-parsing-values () (return-from free-temporary-native))))
-    (iter (for slot in slots)
-          (setf (slot-value proxy slot)
-                (foreign-slot-value native-ptr actual-cstruct slot)))))
-
-(defmethod create-proxy-for-native ((type g-boxed-variant-cstruct-info) native-ptr)
-  (multiple-value-bind (actual-struct slots actual-cstruct) (decide-proxy-type type native-ptr)
-    (let ((proxy (make-instance actual-struct)))
-      (iter (for slot in slots)
-            (setf (slot-value proxy slot)
-                  (foreign-slot-value native-ptr actual-cstruct slot)))
-      proxy)))
+(defmethod free-translated-object (native (foreign-type boxed-variant-cstruct-foreign-type) proxy)
+  (when proxy
+    (let ((type (g-boxed-foreign-info foreign-type)))
+      (multiple-value-bind (actual-struct cstruct-description) (decide-proxy-type type native)
+        (unless (eq (type-of proxy) actual-struct)
+          (restart-case
+              (error "Expected type of boxed variant structure ~A and actual type ~A do not match"
+                     (type-of proxy) actual-struct)
+            (skip-parsing-values () (return-from free-translated-object))))
+        (copy-slots-to-proxy proxy native cstruct-description)
+        (boxed-free-fn type native)))))
+
+(defmethod translate-from-foreign (native (foreign-type boxed-variant-cstruct-foreign-type))
+  (unless (null-pointer-p native)
+    (let ((type (g-boxed-foreign-info foreign-type)))
+      (multiple-value-bind (actual-struct cstruct-description) (decide-proxy-type type native)
+        (let ((proxy (create-structure actual-struct)))
+          (copy-slots-to-proxy proxy native cstruct-description)
+          (when (g-boxed-foreign-return-p foreign-type)
+            (boxed-free-fn type native))
+          proxy)))))
+
+(defmethod cleanup-translated-object-for-callback ((foreign-type boxed-variant-cstruct-foreign-type) proxy native)
+  (when proxy
+    (let ((type (g-boxed-foreign-info foreign-type)))
+      (let ((cstruct-description (decide-native-type type proxy)))
+        (copy-slots-to-native proxy native cstruct-description)))))
 
-(defmethod create-reference-proxy ((type g-boxed-variant-cstruct-info) native-ptr)
-  (create-proxy-for-native type native-ptr))
+(defgeneric boxed-parse-g-value (gvalue-ptr info))
 
-(defmethod free-reference-proxy ((type g-boxed-variant-cstruct-info) proxy native-ptr)
-  (multiple-value-bind (actual-cstruct slots) (decide-native-type type proxy)
-    (iter (for slot in slots)
-          (setf (foreign-slot-value native-ptr actual-cstruct slot)
-                (slot-value proxy slot)))))
+(defgeneric boxed-set-g-value (gvalue-ptr info proxy))
 
 (defmethod parse-g-value-for-type (gvalue-ptr (type-numeric (eql +g-type-boxed+)) parse-kind)
   (declare (ignore parse-kind))
   (if (g-type= (g-value-type gvalue-ptr) (g-strv-get-type))
       (convert-from-foreign (g-value-get-boxed gvalue-ptr) '(glib:gstrv :free-from-foreign nil))
-      (let ((boxed-type (get-g-boxed-foreign-info-for-gtype type-numeric)))
-        (create-proxy-for-native boxed-type (g-value-get-boxed gvalue-ptr)))))
+      (let ((boxed-type (get-g-boxed-foreign-info-for-gtype (g-value-type gvalue-ptr))))
+        (boxed-parse-g-value gvalue-ptr boxed-type))))
 
 (defmethod set-gvalue-for-type (gvalue-ptr (type-numeric (eql +g-type-boxed+)) value)
   (if (g-type= (g-value-type gvalue-ptr) (g-strv-get-type))
       (g-value-set-boxed gvalue-ptr (convert-to-foreign value '(glib:gstrv :free-from-foreign nil)))
-      (let* ((boxed-type (get-g-boxed-foreign-info-for-gtype type-numeric))
-             (native (create-temporary-native boxed-type value)))
-        (g-value-take-boxed gvalue-ptr (g-boxed-copy type-numeric native))
-        (free-temporary-native boxed-type value native))))
+      (let ((boxed-type (get-g-boxed-foreign-info-for-gtype (g-value-type gvalue-ptr))))
+        (boxed-set-g-value gvalue-ptr boxed-type value))))
+
+(defmethod boxed-parse-g-value (gvalue-ptr (info g-boxed-cstruct-wrapper-info))
+  (translate-from-foreign (g-value-get-boxed gvalue-ptr) (make-foreign-type info :return-p nil)))
+
+(defmethod boxed-set-g-value (gvalue-ptr (info g-boxed-cstruct-wrapper-info) proxy)
+  (g-value-take-boxed gvalue-ptr (translate-to-foreign proxy (make-foreign-type info :return-p nil))))
+
+(defmethod boxed-parse-g-value (gvalue-ptr (info g-boxed-variant-cstruct-info))
+  (translate-from-foreign (g-value-get-boxed gvalue-ptr) (make-foreign-type info :return-p nil)))
+
+(defmethod boxed-set-g-value (gvalue-ptr (info g-boxed-variant-cstruct-info) proxy)
+  (g-value-take-boxed gvalue-ptr (translate-to-foreign proxy (make-foreign-type info :return-p nil))))
+
+(defmethod boxed-parse-g-value (gvalue-ptr (info g-boxed-opaque-wrapper-info))
+  (translate-from-foreign (boxed-copy-fn info (g-value-get-boxed gvalue-ptr)) (make-foreign-type info :return-p nil)))
+
+(defmethod boxed-set-g-value (gvalue-ptr (info g-boxed-opaque-wrapper-info) proxy)
+  (g-value-set-boxed gvalue-ptr (translate-to-foreign proxy (make-foreign-type info :return-p nil))))
+
+(defun boxed-related-symbols (name)
+  (let ((info (get-g-boxed-foreign-info name)))
+    (etypecase info
+      (g-boxed-cstruct-wrapper-info
+       (append (list name
+                     (intern (format nil "MAKE-~A" (symbol-name name)))
+                     (intern (format nil "COPY-~A" (symbol-name name))))
+               (iter (for slot in (cstruct-description-slots (g-boxed-cstruct-wrapper-info-cstruct-description info)))
+                     (for slot-name = (cstruct-slot-description-name slot))
+                     (collect (intern (format nil "~A-~A" (symbol-name name) (symbol-name slot-name)))))))
+      (g-boxed-opaque-wrapper-info
+       (list name))
+      (g-boxed-variant-cstruct-info
+       (append (list name)
+               (iter (for var-struct in (all-structures (g-boxed-variant-cstruct-info-root info)))
+                     (for s-name = (var-structure-name var-struct))
+                     (for cstruct-description = (var-structure-resulting-cstruct-description var-struct))
+                     (appending (append (list s-name)
+                                        (list (intern (format nil "MAKE-~A" (symbol-name s-name)))
+                                              (intern (format nil "COPY-~A" (symbol-name s-name))))
+                                        (iter (for slot in (cstruct-description-slots cstruct-description))
+                                              (for slot-name = (cstruct-slot-description-name slot))
+                                              (collect (intern (format nil "~A-~A" (symbol-name s-name)
+                                                                       (symbol-name slot-name)))))))))))))
+
+(defmacro define-boxed-opaque-accessor (boxed-name accessor-name &key type reader writer)
+  (let ((var (gensym))
+        (n-var (gensym)))
+    `(progn ,@(when reader
+                    (list (etypecase reader
+                            (symbol `(defun ,accessor-name (,var)
+                                       (funcall ,reader ,var)))
+                            (string `(defcfun (,accessor-name ,reader) ,type
+                                       (,var (g-boxed-foreign ,boxed-name)))))))
+            ,@(when writer
+                    (list (etypecase reader
+                            (symbol `(defun (setf ,accessor-name) (,n-var ,var)
+                                       (funcall ,reader ,n-var ,var)))
+                            (string `(defun (setf ,accessor-name) (,n-var ,var)
+                                       (foreign-funcall ,writer (g-boxed-foreign ,boxed-name) ,var ,type ,n-var :void)))))))))