From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Sat, 6 Feb 2016 18:26:26 +0000 (-0700)
Subject: Add set-rectangle-ink-position./linux-3735fd4-2/bin/mit-scheme --load debug
X-Git-Tag: mit-scheme-pucked-9.2.12~367
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4c922a8233d9f992fb5d7dccdaa9717dac55af29;p=mit-scheme.git

Add set-rectangle-ink-position./linux-3735fd4-2/bin/mit-scheme --load debug
---

diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm
index 107c6f6bb..e6b6d4405 100644
--- a/src/gtk/fix-layout.scm
+++ b/src/gtk/fix-layout.scm
@@ -1172,6 +1172,18 @@ USA.
 	     (set-fix-rect! rect x y width height)
 	     (recache-rectangle-extent! ink)))))))
 
+(define (set-rectangle-ink-position! ink x y)
+  (guarantee-fixnum x 'set-rectangle-ink-position!)
+  (guarantee-fixnum y 'set-rectangle-ink-position!)
+  (without-interrupts
+   (lambda ()
+     (let ((rect (rectangle-ink-rect ink)))
+       (if (not (and (fix:= x (fix-rect-x rect))
+		     (fix:= y (fix-rect-y rect))))
+	   (begin
+	     (set-fix-rect-position! rect x y)
+	     (recache-rectangle-extent! ink)))))))
+
 (define-method fix-ink-move! ((ink <rectangle-ink>) dx dy)
   (without-interrupts
    (lambda ()
diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg
index c9c1d504c..12f64fef0 100644
--- a/src/gtk/gtk.pkg
+++ b/src/gtk/gtk.pkg
@@ -210,7 +210,8 @@ USA.
 	  line-ink-dash-color set-line-ink-dash-color!
 	  line-ink-dashes set-line-ink-dashes!
 
-	  <rectangle-ink> rectangle-ink? make-rectangle-ink set-rectangle-ink!
+	  <rectangle-ink> rectangle-ink? make-rectangle-ink
+	  set-rectangle-ink! set-rectangle-ink-position!
 	  rectangle-ink-color set-rectangle-ink-color!
 	  rectangle-ink-width set-rectangle-ink-width!
 	  rectangle-ink-fill-color set-rectangle-ink-fill-color!