Merge branch 'gboxed-gc'

[cl-gtk2.git] / glib / gobject.boxed.lisp

diff --git a/glib/gobject.boxed.lisp b/glib/gobject.boxed.lisp
index 34542b2..e5ba0c5 100644 (file)
--- a/glib/gobject.boxed.lisp
+++ b/glib/gobject.boxed.lisp
@@ -45,6 +45,9 @@
 #+nil(defmethod boxed-free-fn :before (type-info native)
   (format t "(boxed-free-fn ~A ~A)~%" (g-boxed-info-name type-info) native))
 
+(defgeneric has-callback-cleanup (foreign-type))
+(defgeneric cleanup-translated-object-for-callback (foreign-type converted-object native-object))
+
 (defmethod has-callback-cleanup ((type g-boxed-foreign-type))
   t)
 
@@ -230,23 +233,51 @@
   (make-instance 'boxed-opaque-foreign-type :info info :return-p return-p))
 
 (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))))
+  (if (null proxy)
+      (null-pointer)
+      (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-translated-object (native (type boxed-opaque-foreign-type) param)
   (declare (ignore native type param)))
 
+(defvar *gboxed-gc-hooks-lock* (make-recursive-lock "gboxed-gc-hooks-lock"))
+(defvar *gboxed-gc-hooks* nil);;pointers to objects to be freed
+
+(defun activate-gboxed-gc-hooks ()
+  (with-recursive-lock-held (*gboxed-gc-hooks-lock*)
+    (when *gboxed-gc-hooks*
+      (log-for :gc "activating gc hooks for boxeds: ~A~%" *gboxed-gc-hooks*)
+      (loop
+         for (pointer type) in *gboxed-gc-hooks*
+         do (boxed-free-fn type pointer))
+      (setf *gboxed-gc-hooks* nil))))
+
+(defcallback gboxed-idle-gc-hook :boolean ((data :pointer))
+  (declare (ignore data))
+  (activate-gboxed-gc-hooks)
+  nil)
+
+(defun register-gboxed-for-gc (type pointer)
+  (with-recursive-lock-held (*gboxed-gc-hooks-lock*)
+    (let ((locks-were-present (not (null *gboxed-gc-hooks*))))
+      (push (list pointer type) *gboxed-gc-hooks*)
+      (unless locks-were-present
+        (log-for :gc "adding gboxed idle-gc-hook to main loop~%")
+        (g-idle-add (callback gboxed-idle-gc-hook) (null-pointer))))))
+
 (defun make-boxed-free-finalizer (type pointer)
-  (lambda () (boxed-free-fn type pointer)))
+  (lambda () (register-gboxed-for-gc 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))))
+    proxy))
 
 (defmethod cleanup-translated-object-for-callback ((type boxed-opaque-foreign-type) proxy native)
+  (declare (ignore native))
   (tg:cancel-finalization proxy)
   (setf (g-boxed-opaque-pointer proxy) nil))
 
@@ -335,8 +366,7 @@
       (list thing)))
 
 (defun parse-variants (parent variants)
-  (iter (for var-descr in variants)
-        (for (options variant-name . slots) in variants)
+  (iter (for (options variant-name . slots) in variants)
         (for variant =
              (make-var-structure-variant
               :discriminating-values (ensure-list options)
@@ -344,10 +374,10 @@
         (collect variant)))
 
 (defun generated-cstruct-name (symbol)
-  (intern (format nil "~A-CSTRUCT-GENERATED-BY-GOBJECT-BOXED" (symbol-name symbol)) (symbol-package symbol)))
+  (intern (format nil "~A-CSTRUCT" (symbol-name symbol)) (symbol-package symbol)))
 
 (defun generated-cunion-name (symbol)
-  (intern (format nil "~A-CUNION-GENERATED-BY-GOBJECT-BOXED" (symbol-name symbol)) (symbol-package symbol)))
+  (intern (format nil "~A-CUNION" (symbol-name symbol)) (symbol-package symbol)))
 
 (defun generate-cstruct-1 (struct)
   `(defcstruct ,(generated-cstruct-name (cstruct-description-name struct))
@@ -596,3 +626,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))))