From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Sun, 7 Apr 2013 21:13:35 +0000 (-0700)
Subject: gtk: Add gtk-graphics/make.
X-Git-Tag: mit-scheme-pucked-9.2.12~519
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f309315b10897f99b449b3527902bb94e92d5876;p=mit-scheme.git

gtk: Add gtk-graphics/make.
---

diff --git a/src/gtk/gtk-graphics.scm b/src/gtk/gtk-graphics.scm
index ff08b1ccf..0f0197869 100644
--- a/src/gtk/gtk-graphics.scm
+++ b/src/gtk/gtk-graphics.scm
@@ -94,6 +94,12 @@ USA.
 	  (gtk-widget-show-all window)
 	  (make-device graphics)))))
 
+(define (gtk-graphics/make width height)
+  (guarantee-positive-fixnum width 'gtk-graphics/open)
+  (guarantee-positive-fixnum height 'gtk-graphics/open)
+  (%make-graphics-device gtk-graphics-device-type
+			 (make-gtk-graphics width height)))
+
 (define (toplevel graphics)
   (let ((widgets (fix-drawing-widgets (fix-ink-drawing graphics))))
     (if (null? (cdr widgets))
diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg
index bea8ed114..d319d68bc 100644
--- a/src/gtk/gtk.pkg
+++ b/src/gtk/gtk.pkg
@@ -406,14 +406,18 @@ USA.
   (import (gtk fix-layout)
 	  fix-ink-extent fix-rect-height fix-rect-width
 	  ->color set-surface-ink-surface! drawing-damage)
+  (import (runtime graphics)
+	  %make-graphics-device)
   (export ()
+	  gtk-graphics-device-type
 	  gtk-graphics/set-background-color
 	  gtk-graphics/set-foreground-color
 	  gtk-graphics/draw-line
 	  gtk-graphics/draw-text
 	  gtk-graphics/draw-circle
 	  gtk-graphics/fill-polygon-list
-	  gtk-graphics/flush))
+	  gtk-graphics/flush
+	  gtk-graphics/make))
 
 (define-package (gtk swat)
   (parent (gtk))