From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Mon, 28 Aug 2017 19:47:11 +0000 (-0700)
Subject: gtk: Add gdk-window-create-similar-surface and -image-surface.
X-Git-Tag: mit-scheme-pucked-9.2.12~78
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=525534bf7cbde8ad496ed18dc1255f409d56f7c2;p=mit-scheme.git

gtk: Add gdk-window-create-similar-surface and -image-surface.
---

diff --git a/src/gtk/Includes/gdkcairo.cdecl b/src/gtk/Includes/gdkcairo.cdecl
index 15e6470fb..0ed19e857 100644
--- a/src/gtk/Includes/gdkcairo.cdecl
+++ b/src/gtk/Includes/gdkcairo.cdecl
@@ -4,6 +4,19 @@ gdk/gdkcairo.h |#
 
 ;(include "pangocairo")
 
+(typedef cairo_content_t
+  (enum _cairo_content
+    (CAIRO_CONTENT_COLOR)
+    (CAIRO_CONTENT_ALPHA)
+    (CAIRO_CONTENT_COLOR_ALPHA))) 
+
+(typedef cairo_format_t
+  (enum _cairo_format
+    (CAIRO_FORMAT_ARGB32)
+    (CAIRO_FORMAT_RGB24)
+    (CAIRO_FORMAT_A8)
+    (CAIRO_FORMAT_A1)))
+
 (extern void gdk_cairo_set_source_pixbuf
 	(cr (* cairo_t))
 	(pixbuf (* (const GdkPixbuf)))
diff --git a/src/gtk/Includes/gdkwindow.cdecl b/src/gtk/Includes/gdkwindow.cdecl
index e5012c1a2..9a4a64996 100644
--- a/src/gtk/Includes/gdkwindow.cdecl
+++ b/src/gtk/Includes/gdkwindow.cdecl
@@ -147,6 +147,9 @@ gdk/gdkwindow.h |#
 	(window (* GdkWindow))
 	(x gint) (y gint) (width gint) (height gint))
 
+(extern gint gdk_window_get_scale_factor
+	(window (* GdkWindow)))
+
 #;(extern (* GdkWindow) gdk_window_get_pointer
 	(window (* GdkWindow))
 	(x (* gint))
@@ -162,6 +165,21 @@ gdk/gdkwindow.h |#
 	(window (* GdkWindow))
 	(cursor (* GdkCursor)))
 
+(extern (* cairo_surface_t)
+	gdk_window_create_similar_surface
+	(window (* GdkWindow))
+	(content cairo_content_t)
+	(width int)
+	(height int))
+
+(extern (* cairo_surface_t)
+	gdk_window_create_similar_image_surface
+	(window (* GdkWindow))
+	(format cairo_format_t)
+	(width int)
+	(height int)
+	(scale int))
+
 (extern void
 	gdk_window_invalidate_rect
 	(window (* GdkWindow))
diff --git a/src/gtk/gdk.scm b/src/gtk/gdk.scm
index 35a575636..3ac76fbe9 100644
--- a/src/gtk/gdk.scm
+++ b/src/gtk/gdk.scm
@@ -27,6 +27,26 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 (define-integrable-operator (guarantee-gdk-window object operator)
   (if (not (and (alien? object) (eq? '|GdkWindow| (alien/ctype object))))
       (error:wrong-type-argument object "a GdkWindow address" operator)))
+
+(define (gdk-window-create-similar-surface window width height)
+  (let ((surface (make-alien '|cairo_surface_t|))
+	(copy (make-alien '|cairo_surface_t|)))
+    (add-glib-cleanup surface (make-cairo-surface-cleanup copy))
+    (C-call "gdk_window_create_similar_surface" copy
+	    window (C-enum "CAIRO_CONTENT_COLOR") width height)
+    (copy-alien-address! surface copy)
+    (check-cairo-surface-status surface)
+    surface))
+
+(define (gdk-window-create-similar-image-surface window width height scale)
+  (let ((surface (make-alien '|cairo_surface_t|))
+	(copy (make-alien '|cairo_surface_t|)))
+    (add-glib-cleanup surface (make-cairo-surface-cleanup copy))
+    (C-call "gdk_window_create_similar_image_surface" copy
+	    window (C-enum "CAIRO_FORMAT_RGB24") width height scale)
+    (copy-alien-address! surface copy)
+    (check-cairo-surface-status surface)
+    surface))
 
 ;;; GdkPixbufLoaders
 
diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg
index 2679efbd4..819348aa8 100644
--- a/src/gtk/gtk.pkg
+++ b/src/gtk/gtk.pkg
@@ -41,12 +41,17 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (files "gdk")
   ;;(depends-on "gtk-const.bin")
   (import (cairo)
-	  make-cairo-cleanup check-cairo-status)
+	  check-cairo-status
+	  check-cairo-surface-status
+	  make-cairo-cleanup
+	  make-cairo-surface-cleanup)
   (import (runtime ffi)
 	  alien/address)
   (import (glib main)
 	  maybe-yield-glib)
   (export (gtk)
+	  gdk-window-create-similar-surface
+	  gdk-window-create-similar-image-surface
 	  <pixbuf-loader> make-pixbuf-loader
 	  load-pixbuf-from-port load-pixbuf-from-file
 	  pixbuf-loader-size-hook set-pixbuf-loader-size-hook!