From dfc259e2a677889025d94fd7f5d38b120c573053 Mon Sep 17 00:00:00 2001
From: Dmitry Kalyanov <Kalyanov.Dmitry@gmail.com>
Date: Sun, 8 Nov 2009 15:09:18 +0300
Subject: [PATCH] Add gobject:copy-boxed-slots-to-foreign and
 gobject:with-boxed-foreign-array

---
 doc/gobject.ref.texi      |   61 +++++++++++++++++++++++++++++++++++++++++++++
 glib/gobject.boxed.lisp   |   43 ++++++++++++++++++++++++++++++++
 glib/gobject.package.lisp |    4 ++-
 3 files changed, 107 insertions(+), 1 deletion(-)

diff --git a/doc/gobject.ref.texi b/doc/gobject.ref.texi
index a14ccfd..df7e0c7 100644
--- a/doc/gobject.ref.texi
+++ b/doc/gobject.ref.texi
@@ -1782,6 +1782,8 @@ Example:
 * define-boxed-opaque-accessor::
 * boxed-related-symbols::
 * GBoxed foreign type::
+* copy-boxed-slots-to-foreign::
+* with-boxed-foreign-array::
 @end menu
 
 GObject manual defines this type in the following way:
@@ -2138,6 +2140,65 @@ Examples of usage:
   (limit (g-boxed-foreign text-iter)))
 @end lisp
 
+
+@node copy-boxed-slots-to-foreign
+@section copy-boxed-slots-to-foreign
+
+@Function copy-boxed-slots-to-foreign
+@lisp
+(copy-boxed-slots-to-foreign structure native-ptr &optional (type (and structure (type-of structure))))
+@end lisp
+
+@table @var
+@item @var{structure}
+A Lisp structure corresponding to some GBoxed type
+@item @var{native-ptr}
+A foreign pointer
+@item @code{type}
+Name of the GBoxed type. It is optional but may be included for optimization purposes
+@end table
+
+Copies the contents of @var{structure} to C structure pointed to by @var{native-ptr}. @var{type} is used to determine which slots and which cstruct definition should be used.
+
+Examples:
+@lisp
+(cffi:with-foreign-object (point-ptr 'gdk::point-cstruct)
+  (gobject:copy-boxed-slots-to-foreign (gdk:make-point :x 10 :y 10) point-ptr 'gdk:point))
+@end lisp
+
+@node with-boxed-foreign-array
+@section with-boxed-foreign-array
+
+@Macro with-boxed-foreign-array
+@lisp
+(with-foreign-boxed-array (n-var array-var type values-seq) &body body)
+@end lisp
+
+@table @var
+@item @var{n-var}
+A variable that will contain the count of items in @var{values-seq}
+@item @var{array-var}
+A variable that will contain the pointer to array of C structures
+@item @var{type}
+A symbol that specifies the type of GBoxed structure
+@item @var{values-seq}
+An expression that returns the sequence of structures (list or array)
+@end table
+
+Evaluates the @var{body} within the scope and extent of foreign array that contains copies of structures that are returned by @var{values-seq}. Binds @var{n-var} to the length of @var{values-seq}, @var{array-var} to the pointer to array of structures.
+
+Examples:
+@lisp
+(defcfun gdk-region-polygon (g-boxed-foreign region :return)
+  (points :pointer)
+  (n-points :int)
+  (fill-rule gdk-fill-rule))
+
+(defun region-from-polygon (points fill-rule)
+  (with-foreign-boxed-array (n pts point points)
+    (gdk-region-polygon pts n fill-rule)))
+@end lisp
+
 @node Generating type definitions by introspection
 @chapter Generating type definitions by introspection
 @menu
diff --git a/glib/gobject.boxed.lisp b/glib/gobject.boxed.lisp
index 1234abd..983d0ff 100644
--- a/glib/gobject.boxed.lisp
+++ b/glib/gobject.boxed.lisp
@@ -599,3 +599,46 @@
                                        (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)))))))))
+
+(defun copy-boxed-slots-to-foreign (structure native-ptr &optional (type (and structure (type-of structure))))
+  (when structure
+    (copy-slots-to-native
+     structure
+     native-ptr
+     (g-boxed-cstruct-wrapper-info-cstruct-description (get-g-boxed-foreign-info type)))))
+
+(define-compiler-macro copy-boxed-slots-to-foreign (&whole whole structure native-ptr &optional type)
+  (if (and type
+           (constantp type))
+      (let* ((type-r (eval type))
+             (f-i (get-g-boxed-foreign-info type-r)))
+        (unless f-i
+          (warn "Unknown foreign GBoxed type ~S" type-r)
+          (return-from copy-boxed-slots-to-foreign whole))
+        (unless (typep f-i 'g-boxed-cstruct-wrapper-info)
+          (warn "Foreign GBoxed type ~S is not a C structure wrapper" type-r)
+          (return-from copy-boxed-slots-to-foreign whole))
+        `(when ,structure
+           (copy-slots-to-native
+            ,structure
+            ,native-ptr
+            (load-time-value (g-boxed-cstruct-wrapper-info-cstruct-description (get-g-boxed-foreign-info ',type-r))))))
+      whole))
+
+(defmacro with-foreign-boxed-array ((n-var array-var type values-seq) &body body)
+  (let ((values-seq-1 (gensym "VALUES-SEQ-"))
+        (cstruct (generated-cstruct-name type))
+        (x (gensym "X-"))
+        (i (gensym "I-")))
+    `(let* ((,values-seq-1 ,values-seq)
+            (,n-var (length ,values-seq-1)))
+       (with-foreign-object (,array-var ',cstruct ,n-var)
+         (let ((,i 0))
+           (map nil (lambda (,x)
+                      (copy-boxed-slots-to-foreign
+                       ,x
+                       (inc-pointer ,array-var (* ,i (foreign-type-size ',cstruct)))
+                       ',type)
+                      (incf ,i))
+                ,values-seq-1))
+         ,@body))))
diff --git a/glib/gobject.package.lisp b/glib/gobject.package.lisp
index cad6804..fc9eb7d 100644
--- a/glib/gobject.package.lisp
+++ b/glib/gobject.package.lisp
@@ -193,7 +193,9 @@
            #:delete-handler-from-object
            #:disconnect-signal
            #:define-cb-methods
-           #:create-fn-ref)
+           #:create-fn-ref
+           #:copy-boxed-slots-to-foreign
+           #:with-foreign-boxed-array)
   (:documentation
    "CL-GTK2-GOBJECT is a binding to GObject type system.
 For information on GObject, see its @a[http://library.gnome.org/devel/gobject/stable/]{documentation}.
-- 
1.7.10.4