From 4c922a8233d9f992fb5d7dccdaa9717dac55af29 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Sat, 6 Feb 2016 11:26:26 -0700 Subject: [PATCH] Add set-rectangle-ink-position./linux-3735fd4-2/bin/mit-scheme --load debug --- src/gtk/fix-layout.scm | 12 ++++++++++++ src/gtk/gtk.pkg | 3 ++- 2 files changed, 14 insertions(+), 1 deletion(-) 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 ) 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? make-rectangle-ink set-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! -- 2.25.1