From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 1 Aug 1993 00:16:08 +0000 (+0000)
Subject: Change KEYBOARD-READ, KEYBOARD-PEEK, and KEYBOARD-PEEK-NO-HANG to
X-Git-Tag: 20090517-FFI~8158
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f6d9a9ec5712a574c2c996b371c30a1439b863fb;p=mit-scheme.git

Change KEYBOARD-READ, KEYBOARD-PEEK, and KEYBOARD-PEEK-NO-HANG to
intercept "update" and "resize" events and to handle them rather than
returning them.  Other events with potentially troublesome actions are
returned as before.  Additionally, several places where input events
were discarded have been fixed -- input events must ALWAYS be handled.
---

diff --git a/v7/src/edwin/comred.scm b/v7/src/edwin/comred.scm
index f84fceb69..23da6f563 100644
--- a/v7/src/edwin/comred.scm
+++ b/v7/src/edwin/comred.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: comred.scm,v 1.97 1993/07/06 20:35:48 cph Exp $
+;;;	$Id: comred.scm,v 1.98 1993/08/01 00:15:49 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
 ;;;
@@ -96,11 +96,12 @@
 (define-structure (input-event
 		   (constructor %make-input-event)
 		   (conc-name input-event/))
+  (type false read-only true)
   (operator false read-only true)
   (operands false read-only true))
 
-(define (make-input-event operator . operands)
-  (%make-input-event operator operands))
+(define (make-input-event type operator . operands)
+  (%make-input-event type operator operands))
 
 (define (apply-input-event input-event)
   (if (not (input-event? input-event))
diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 813589f5b..78a71157f 100644
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: edwin.pkg,v 1.119 1993/07/22 21:06:43 cph Exp $
+$Id: edwin.pkg,v 1.120 1993/08/01 00:15:52 cph Exp $
 
 Copyright (c) 1989-1993 Massachusetts Institute of Technology
 
@@ -419,6 +419,7 @@ MIT in each case. |#
 	  execute-command
 	  execute-command-history-entry
 	  initialize-command-reader!
+	  input-event/type
 	  input-event?
 	  keyboard-keys-read
 	  last-command
diff --git a/v7/src/edwin/input.scm b/v7/src/edwin/input.scm
index 9edf99163..8df6fe0c6 100644
--- a/v7/src/edwin/input.scm
+++ b/v7/src/edwin/input.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/input.scm,v 1.93 1992/02/18 20:47:26 arthur Exp $
+;;;	$Id: input.scm,v 1.94 1993/08/01 00:15:55 cph Exp $
 ;;;
-;;;	Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
+;;;	Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
 ;;;
 ;;;	This material was developed by the Scheme project at the
 ;;;	Massachusetts Institute of Technology, Department of
@@ -181,7 +181,7 @@ B 3BAB8C
       (keyboard-read-1 (editor-peek current-editor))))
 
 (define (keyboard-read)
-  (set! keyboard-keys-read (1+ keyboard-keys-read))
+  (set! keyboard-keys-read (+ keyboard-keys-read 1))
   (if *executing-keyboard-macro?*
       (keyboard-macro-read-key)
       (let ((key (keyboard-read-1 (editor-read current-editor))))
@@ -194,19 +194,36 @@ B 3BAB8C
 	       ((ref-command end-kbd-macro) 1)))
 	key)))
 
+(define (keyboard-read-1 reader)
+  (handle-simple-events (lambda () (keyboard-read-2 reader))))
+
 (define (keyboard-peek-no-hang)
-  ((editor-peek-no-hang current-editor)))
+  (handle-simple-events (editor-peek-no-hang current-editor)))
 
-(define (keyboard-read-char)
-  (let loop ((key (keyboard-read)))
-    (if (char? key)
-	key
-	(loop (keyboard-read)))))
+(define (handle-simple-events thunk)
+  (let loop ()
+    (let ((input (thunk)))
+      (if (and (input-event? input)
+	       (memq (input-event/type input) '(UPDATE SET-SCREEN-SIZE)))
+	  (begin
+	    (apply-input-event input)
+	    (loop))
+	  input))))
 
+(define (keyboard-read-char)
+  (let loop ()
+    (let ((key (keyboard-read)))
+      (if (char? key)
+	  key
+	  (begin
+	    (if (input-event? key)
+		(apply-input-event key))
+	    (loop))))))
+
 (define read-key-timeout/fast 500)
 (define read-key-timeout/slow 2000)
 
-(define (keyboard-read-1 reader)
+(define (keyboard-read-2 reader)
   (remap-alias-key
    (let ((peek-no-hang (editor-peek-no-hang current-editor)))
      (if (not (peek-no-hang))
diff --git a/v7/src/edwin/prompt.scm b/v7/src/edwin/prompt.scm
index fee36d533..e2b846aea 100644
--- a/v7/src/edwin/prompt.scm
+++ b/v7/src/edwin/prompt.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: prompt.scm,v 1.156 1992/11/29 20:22:37 bal Exp $
+;;;	$Id: prompt.scm,v 1.157 1993/08/01 00:15:58 cph Exp $
 ;;;
-;;;	Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
+;;;	Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
 ;;;
 ;;;	This material was developed by the Scheme project at the
 ;;;	Massachusetts Institute of Technology, Department of
@@ -105,9 +105,12 @@
 			(select-window (car typein-saved-windows)))
 		       ((zero? typein-edit-depth)
 			(select-window (other-window)))))))))))
-    (if (eq? value typein-edit-abort-flag)
-	(abort-current-command)
-	value)))
+    (cond ((eq? value typein-edit-abort-flag)
+	   (abort-current-command))
+	  ((and (pair? value) (eq? (car value) typein-edit-abort-flag))
+	   (abort-current-command (cdr value)))
+	  (else
+	   value))))
 
 (define-integrable (within-typein-edit?)
   (not (null? typein-saved-windows)))
@@ -163,6 +166,9 @@
   (set-current-major-mode! mode)
   (command-reader))
 
+(define (abort-typein-edit event)
+  (typein-edit-continuation (cons typein-edit-abort-flag event)))
+
 (define (exit-typein-edit)
   (if (not typein-edit-continuation)
       (error "Not editing typein; can't exit"))
@@ -633,13 +639,12 @@ a repetition of this command will exit."
 	     (let ((input (with-editor-interrupts-disabled keyboard-read)))
 	       (if (and (char? input) (char-ascii? input))
 		   (set-typein-string! (key-name input) true))
-	       input)))))
-    (cond ((and (char? input) (char-ascii? input))
-	   input)
-	  ((input-event? input)
-	   (abort-current-command input))
-	  (else
-	   (editor-error "Not an ASCII character:" input)))))
+	       (if (input-event? input)
+		   (abort-typein-edit input)
+		   input))))))
+    (if (not (and (char? input) (char-ascii? input)))
+	(editor-error "Not an ASCII character:" input))
+    input))
 
 (define (prompt-for-key prompt #!optional comtab)
   (let ((comtab (if (default-object? comtab) (current-comtabs) comtab)))
@@ -649,9 +654,7 @@ a repetition of this command will exit."
 	  (let inner-loop
 	      ((char (with-editor-interrupts-disabled keyboard-read)))
 	    (if (input-event? char)
-		(within-continuation typein-edit-continuation
-		  (lambda ()
-		    (abort-current-command char))))
+		(abort-typein-edit char))
 	    (let ((chars (append! prefix (list char))))
 	      (set-typein-string! (xkey->name chars) true)
 	      (if (prefix-key-list? comtab chars)
@@ -680,6 +683,8 @@ a repetition of this command will exit."
 			  (char-ci=? char #\rubout)))
 		 (set-typein-string! "n" true)
 		 false)
+		((input-event? char)
+		 (abort-typein-edit char))
 		(else
 		 (editor-beep)
 		 (if (not lost?)
@@ -782,29 +787,30 @@ Whilst editing the command, the following commands are available:
 ;;; in unix.scm which deal with .KY files.
 
 (define (prompt-for-password prompt)
-  (prompt-for-typein 
-   prompt false
-   (lambda ()
-     (let loop ((ts ""))
-       (let ((input (keyboard-read)))
-	 (if (and (char? input) (char-ascii? input))
-	     (cond ((char=? input #\Return)
-		    ts)
-		   ((char=? input #\C-g)
-		    (abort-current-command))
-		   ((char=? input #\Rubout)
-		    (let ((ts-len (string-length ts)))
-		      (if (> ts-len 0)
-			  (let ((new-string (string-head ts (-1+ ts-len))))
-			    (set-typein-string!
-			     (make-string (string-length new-string) #\.) true)
-			    (loop new-string))
-			  (loop ts))))
-		   (else
-		    (set-typein-string!
-		     (make-string (1+ (string-length ts)) #\.) true)
-		    (loop (string-append ts (char->string input)))))
-	     (loop ts)))))))
+  (prompt-for-typein prompt false
+    (lambda ()
+      (let loop ((ts ""))
+	(let ((input (keyboard-read)))
+	  (cond ((input-event? input)
+		 (abort-typein-edit input))
+		((not (and (char? input) (char-ascii? input)))
+		 (loop ts))
+		((char=? input #\Return)
+		 ts)
+		((char=? input #\C-g)
+		 (abort-current-command))
+		((char=? input #\Rubout)
+		 (let ((ts-len (string-length ts)))
+		   (if (> ts-len 0)
+		       (let ((new-string (string-head ts (-1+ ts-len))))
+			 (set-typein-string!
+			  (make-string (string-length new-string) #\.) true)
+			 (loop new-string))
+		       (loop ts))))
+		(else
+		 (set-typein-string!
+		  (make-string (1+ (string-length ts)) #\.) true)
+		 (loop (string-append ts (char->string input))))))))))
 
 (define (prompt-for-confirmed-password)
   (let ((password1 (prompt-for-password "Password: ")))
diff --git a/v7/src/edwin/tterm.scm b/v7/src/edwin/tterm.scm
index 000a1c8fa..5024ca1b1 100644
--- a/v7/src/edwin/tterm.scm
+++ b/v7/src/edwin/tterm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: tterm.scm,v 1.20 1993/07/16 19:20:22 gjr Exp $
+$Id: tterm.scm,v 1.21 1993/08/01 00:16:01 cph Exp $
 
 Copyright (c) 1990-1993 Massachusetts Institute of Technology
 
@@ -190,7 +190,7 @@ MIT in each case. |#
 	      (cond ((char? event)
 		     event)
 		    ((process-change-event event)
-		     (make-input-event update-screens! #f))
+		     (make-input-event 'UPDATE update-screens! #f))
 		    (else
 		     (guarantee-result)))))))
       (values
diff --git a/v7/src/edwin/xterm.scm b/v7/src/edwin/xterm.scm
index 76708d3c1..73afb99cc 100644
--- a/v7/src/edwin/xterm.scm
+++ b/v7/src/edwin/xterm.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: xterm.scm,v 1.39 1993/04/28 19:51:10 cph Exp $
+;;;	$Id: xterm.scm,v 1.40 1993/08/01 00:16:08 cph Exp $
 ;;;
 ;;;	Copyright (c) 1989-93 Massachusetts Institute of Technology
 ;;;
@@ -381,7 +381,7 @@
 			    (error "#F returned from blocking read"))
 			   ((not (vector? event))
 			    (if (process-change-event event)
-				(make-input-event update-screens! #f)
+				(make-input-event 'UPDATE update-screens! #f)
 				(loop)))
 			   (else
 			    (or (process-event event) (loop)))))))))
@@ -509,7 +509,8 @@
   (lambda (screen event)
     (set! last-focus-time (vector-ref event 5))
     (let ((xterm (screen-xterm screen)))
-      (make-input-event execute-button-command
+      (make-input-event 'BUTTON
+			execute-button-command
 			screen
 			(make-down-button (vector-ref event 4))
 			(xterm-map-x-coordinate xterm (vector-ref event 2))
@@ -519,7 +520,8 @@
   (lambda (screen event)
     (set! last-focus-time (vector-ref event 5))
     (let ((xterm (screen-xterm screen)))
-      (make-input-event execute-button-command
+      (make-input-event 'BUTTON
+			execute-button-command
 			screen
 			(make-up-button (vector-ref event 4))
 			(xterm-map-x-coordinate xterm (vector-ref event 2))
@@ -535,23 +537,23 @@
 	    (y-size (xterm-map-y-size xterm y-size)))
 	(and (not (and (= x-size (screen-x-size screen))
 		       (= y-size (screen-y-size screen))))
-	     (make-input-event
-	      (lambda (screen x-size y-size)
-		(set-screen-size! screen x-size y-size)
-		(update-screen! screen #t))
-	      screen x-size y-size))))))
+	     (make-input-event 'SET-SCREEN-SIZE
+			       (lambda (screen x-size y-size)
+				 (set-screen-size! screen x-size y-size)
+				 (update-screen! screen #t))
+			       screen x-size y-size))))))
 
 (define-event-handler event-type:focus-in
   (lambda (screen event)
     event
     (and (not (selected-screen? screen))
-	 (make-input-event select-screen screen))))
+	 (make-input-event 'SELECT-SCREEN select-screen screen))))
 
 (define-event-handler event-type:delete-window
   (lambda (screen event)
     event
     (and (not (screen-deleted? screen))
-	 (make-input-event delete-screen! screen))))
+	 (make-input-event 'DELETE-SCREEN delete-screen! screen))))
 
 (define-event-handler event-type:map
   (lambda (screen event)
@@ -559,7 +561,7 @@
     (and (not (screen-deleted? screen))
 	 (begin
 	   (set-screen-visibility! screen 'VISIBLE)
-	   (make-input-event update-screen! screen #t)))))
+	   (make-input-event 'UPDATE update-screen! screen #t)))))
 
 (define-event-handler event-type:unmap
   (lambda (screen event)
@@ -570,7 +572,9 @@
 	   (and (selected-screen? screen)
 		(let ((screen (other-screen screen false)))
 		  (and screen
-		       (make-input-event select-screen screen))))))))
+		       (make-input-event 'SELECT-SCREEN
+					 select-screen
+					 screen))))))))
 
 (define-event-handler event-type:visibility
   (lambda (screen event)
@@ -583,12 +587,12 @@
 	       ((2) (set-screen-visibility! screen 'OBSCURED)))
 	      (and (or (eq? old-visibility 'UNMAPPED)
 		       (eq? old-visibility 'OBSCURED))
-		   (make-input-event update-screen! screen #t)))))))
+		   (make-input-event 'UPDATE update-screen! screen #t)))))))
 
 (define-event-handler event-type:take-focus
   (lambda (screen event)
     (set! last-focus-time (vector-ref event 2))
-    (make-input-event select-screen screen)))
+    (make-input-event 'SELECT-SCREEN select-screen screen)))
 
 (define reading-event?)
 (define signal-interrupts?)