From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Wed, 18 Jan 2017 20:35:05 +0000 (-0700)
Subject: gtk-screen: Handle button presses.
X-Git-Tag: mit-scheme-pucked-9.2.12~241
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=70bd4c91e2cb3f566438c044f088391730dd09c3;p=mit-scheme.git

gtk-screen: Handle button presses.
---

diff --git a/src/gtk-screen/gtk-screen.pkg b/src/gtk-screen/gtk-screen.pkg
index 8fa01ef7e..e14b3bdc3 100644
--- a/src/gtk-screen/gtk-screen.pkg
+++ b/src/gtk-screen/gtk-screen.pkg
@@ -57,7 +57,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	  register-process-output-events)
   (import (edwin window)
 	  editor-frame-root-window
-	  window-inferiors find-inferior window-next
+	  window-inferiors find-inferior window-next window-superior
 	  combination? combination-vertical? combination-child
 	  (%window-x-size window-x-size)
 	  (%window-y-size window-y-size)
diff --git a/src/gtk-screen/gtk-screen.scm b/src/gtk-screen/gtk-screen.scm
index c0aee12c6..0c5ba8b9a 100644
--- a/src/gtk-screen/gtk-screen.scm
+++ b/src/gtk-screen/gtk-screen.scm
@@ -760,6 +760,43 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	(if k
 	    (queue! (make-special-key k char-bits))
 	    #t))))
+
+(define (button-down-handler widget type button modifiers x y)
+  (declare (ignore type))
+  (%trace "; Button down: "button" "modifiers" "x" "y" "widget"\n")
+  (queue-input-event (edwin-widget-screen widget)
+		     (make-input-event
+		      'BUTTON
+		      execute-gtk-button-command
+		      widget button modifiers x y))
+  #t)
+
+(define (execute-gtk-button-command widget button modifiers x y)
+  (let ((screen (edwin-widget-screen widget))
+	(frame (text-widget-buffer-frame widget)))
+    (let ((inferior (find-inferior (window-inferiors (window-superior frame))
+				   frame)))
+      (%trace "; button inferior "inferior"\n")
+      (execute-button-command
+       screen
+       (make-down-button (fix:-1+ button) (modifiers->char-bits modifiers))
+       (fix:+ (inferior-x-start inferior)
+	      (fix:quotient x
+			    (gtk-screen-char-width screen)))
+       (fix:+ (inferior-y-start inferior)
+	      (fix:quotient y
+			    (fix:+ (gtk-screen-line-height screen)
+				   (gtk-screen-line-spacing screen))))))))
+
+(define (modifiers->char-bits modifiers)
+  (reduce bitwise-ior 0 (map (lambda (modifier)
+			       (case modifier
+				 ((META) char-bit:meta)
+				 ((CONTROL) char-bit:control)
+				 ((SUPER) char-bit:super)
+				 ((HYPER) char-bit:hyper)
+				 (else 0)))
+			     modifiers)))
 
 ;;; Initialization
 
@@ -1136,6 +1173,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (set-fix-widget-focus-change-handler! widget focus-change-handler)
   (set-fix-widget-visibility-notify-handler! widget visibility-notify-handler)
   (set-fix-widget-key-press-handler! widget key-press-handler)
+  (set-fix-widget-button-handler! widget 'PRESS button-down-handler)
   widget)
 
 (define-method gtk-widget-destroy-callback ((widget <text-widget>))