From 967c6e15202c966829f4240e8652fe312ce92497 Mon Sep 17 00:00:00 2001
From: Dmitry Kalyanov <Kalyanov.Dmitry@gmail.com>
Date: Sat, 8 Aug 2009 10:04:40 +0400
Subject: [PATCH] glib: add glib-defcallback macro to be able to work current
 unpatched CFFI

---
 glib/cl-gtk2-glib.asd                         |    1 +
 glib/gobject.cffi-callbacks.lisp              |   26 +++++++++++++++++++++++++
 glib/gobject.foreign-gobject-subclassing.lisp |    2 +-
 3 files changed, 28 insertions(+), 1 deletion(-)
 create mode 100644 glib/gobject.cffi-callbacks.lisp

diff --git a/glib/cl-gtk2-glib.asd b/glib/cl-gtk2-glib.asd
index 1e38003..1425521 100644
--- a/glib/cl-gtk2-glib.asd
+++ b/glib/cl-gtk2-glib.asd
@@ -31,6 +31,7 @@
                (:file "gobject.meta")
                (:file "gobject.generating")
                (:file "gobject.object-defs")
+               (:file "gobject.cffi-callbacks")
                (:file "gobject.foreign-gobject-subclassing")
 
                (:file "gobject.boxed")
diff --git a/glib/gobject.cffi-callbacks.lisp b/glib/gobject.cffi-callbacks.lisp
new file mode 100644
index 0000000..cdf9440
--- /dev/null
+++ b/glib/gobject.cffi-callbacks.lisp
@@ -0,0 +1,26 @@
+(in-package :gobject)
+
+(defun wrap-body-with-boxed-translations (args body)
+  (if (null args)
+      body
+      (let ((arg (first args)))
+        (destructuring-bind (arg-name arg-type) arg
+          (if (and (listp arg-type) (eq 'g-boxed-foreign (first arg-type)))
+              (let ((var (gensym))
+                    (cffi-type (cffi::parse-type arg-type)))
+                `((let ((,var ,arg-name)
+                        (,arg-name (translate-from-foreign ,arg-name ,cffi-type)))
+                    (unwind-protect
+                         (progn ,@(wrap-body-with-boxed-translations (rest args) body))
+                      (cleanup-translated-object-for-callback ,cffi-type ,arg-name ,var)))))
+              (wrap-body-with-boxed-translations (rest args) body))))))
+
+(defmacro glib-defcallback (name-and-options return-type args &body body)
+  (let* ((c-args (iter (for arg in args)
+                       (for (name type) = arg)
+                       (if (and (listp type) (eq 'g-boxed-foreign (first type)))
+                           (collect `(,name :pointer))
+                           (collect arg))))
+         (c-body (wrap-body-with-boxed-translations args body)))
+    `(defcallback ,name-and-options ,return-type ,c-args
+       ,@c-body)))
diff --git a/glib/gobject.foreign-gobject-subclassing.lisp b/glib/gobject.foreign-gobject-subclassing.lisp
index 614082b..09e87a7 100644
--- a/glib/gobject.foreign-gobject-subclassing.lisp
+++ b/glib/gobject.foreign-gobject-subclassing.lisp
@@ -117,7 +117,7 @@
            (make-vtable-description :type-name ,type-name :cstruct-name ',cstruct-name :methods (list ,@(mapcar #'make-load-form (vtable-methods items)))))
      ,@(iter (for method in (vtable-methods items))
              (collect `(defgeneric ,(vtable-method-info-name method) (,@(mapcar #'first (vtable-method-info-args method)))))
-             (collect `(defcallback ,(vtable-method-info-callback-name method) ,(vtable-method-info-return-type method)
+             (collect `(glib-defcallback ,(vtable-method-info-callback-name method) ,(vtable-method-info-return-type method)
                            (,@(vtable-method-info-args method))
                          (restart-case 
                              (,(vtable-method-info-name method) ,@(mapcar #'first (vtable-method-info-args method)))
-- 
1.7.10.4