Editor-peek-no-hang timeout. Inferior event hooks.

Moved the busy-wait loop in keyboard-read-1 into each editor-peek-no-
hang method.  The gtk-screen method can then provide a version that
blocks for the specified timeout.

Added hooks to be called when inferior threads and processes are ready
with input events.

* src/edwin/bufwin.scm: Moved generalization of buffer-window/redraw!
into %clear-window-incremental-redisplay-state! -- the only part not
useful to a gtk-screen.  Genericized it by doing nothing for gtk
screens.

* src/edwin/editor.scm (hook/signal-inferior-thread-output!): Added
this hook so that gtk-screen can get inferior threads to signal the
editor thread with an event other than #f.  The tty screens' innermost
editor mainloops test the inferior-thread-changes? flag and return an
input event; they just need a wake-up.  The gtk-screen substitutes a
procedure that directly queues the input event and thus wakes the
editor thread.

* src/edwin/image.scm (group-line-image!, substring-line-image!): New,
for parsing and imaging lines in one step.

* src/edwin/: edwin.pkg, input.scm (keyboard-peek-busy-no-hang): New.
The common, busy-waiting implementation of peek-no-hang, used in the
various tty screens.

(keyboard-peek-no-hang): The editor-peek-no-hang method now requires a
timeout argument.

(keyboard-read-1): Eliminate the wait loop.  Rely on the editor-peek-
no-hang methods.

* src/edwin/: os2term.scm, tterm.scm, win32.scm, xterm.scm: Use
keyboard-peek-busy-no-hang to implement a timeout argument for the
original editor-peek-no-hang method.

* src/edwin/process.scm (register-process-input): Call the new
hook/inferior-process-output whenever an inferior process goes on the
process-input-queue.  Gtk-screen uses this to queue an input event for
the editor thread, so that it will accept the (all!) inferior process
output.

diff --git a/src/edwin/bufwin.scm b/src/edwin/bufwin.scm
index 300b5faef9d4a5fc4a673aff161a823eea335fb4..294010a030db9eb42085a25f41f8031f22548e67 100644 (file)
--- a/src/edwin/bufwin.scm
+++ b/src/edwin/bufwin.scm
@@ -789,10 +789,6 @@ USA.
 (define (buffer-window/redraw! window)
   (if (%window-debug-trace window)
       ((%window-debug-trace window) 'window window 'force-redraw!))
-  (if (tty-screen? (%window-saved-screen window))
-      (tty-screen/buffer-window/redraw! window)))
-
-(define (tty-screen/buffer-window/redraw! window)
   (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
     (%set-window-force-redraw?! window #t)
     (%recache-window-buffer-local-variables! window)
@@ -827,6 +823,10 @@ USA.
   (%clear-window-incremental-redisplay-state! window))
 
 (define (%clear-window-incremental-redisplay-state! window)
+  (if (tty-screen? (%window-saved-screen window))
+      (%%clear-window-incremental-redisplay-state! window)))
+
+(define (%%clear-window-incremental-redisplay-state! window)
   (if (%window-start-outline window)
       (begin
        (deallocate-outlines! window

diff --git a/src/edwin/editor.scm b/src/edwin/editor.scm
index a9beda33e97698e331c0dfebf0265cc6fc9c46fb..11e88c55b5d63f53b0899c28c3960358e5b8975f 100644 (file)
--- a/src/edwin/editor.scm
+++ b/src/edwin/editor.scm
@@ -605,7 +605,12 @@ TRANSCRIPT    messages appear in transcript buffer, if it is enabled;
   (if (not inferior-thread-changes?)
       (begin
        (set! inferior-thread-changes? #t)
-       (signal-thread-event editor-thread #f))))
+       (hook/signal-inferior-thread-output!))))
+
+(define (signal-inferior-thread-output!)
+  (signal-thread-event editor-thread #f))
+
+(define hook/signal-inferior-thread-output! signal-inferior-thread-output!)
 
 (define (accept-thread-output)
   (with-interrupt-mask interrupt-mask/gc-ok

diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg
index 52e45491f9340b23b8bac7e8128e6e8ef75b63b6..7813b0a5a5c1c3aa1c0cc0880eab2a5e79b3da4c 100644 (file)
--- a/src/edwin/edwin.pkg
+++ b/src/edwin/edwin.pkg
@@ -990,6 +990,8 @@ USA.
     (parent (edwin screen))
     (export (edwin)
            resize-screen)
+    (import (edwin keyboard)
+           keyboard-peek-busy-no-hang)
     (import (runtime primitive-io)
            channel-type=terminal?
            have-select?
@@ -1043,6 +1045,8 @@ USA.
            screen-xterm
            xterm-screen/set-icon-name
            xterm-screen/set-name)
+    (import (edwin keyboard)
+           keyboard-peek-busy-no-hang)
     (initialization (initialize-package!)))
 
   (define-package (edwin x-keys)
@@ -1269,6 +1273,8 @@ USA.
            screen-char-height
            screen-pel-width
            screen-pel-height)
+    (import (edwin keyboard)
+           keyboard-peek-busy-no-hang)
     (import (runtime os2-window-primitives)
            button-event-type:down
            button-event/flags

diff --git a/src/edwin/image.scm b/src/edwin/image.scm
index b1fbb4e5abd6c1a5708da0f73ad6deda1edc62d1..c851b9b6db4e46833f5a99f591d28f0ad4b41046 100644 (file)
--- a/src/edwin/image.scm
+++ b/src/edwin/image.scm
@@ -404,4 +404,88 @@ USA.
                  (begin
                    (string-set! image image-index (string-ref picture i))
                    (loop (fix:+ i 1) (fix:+ image-index 1))))))))))
+\f
+(define (group-line-image! group start end
+                          image image-start image-end
+                          tab-width column-offset char-image-strings
+                          receiver)
+  ;; Like GROUP-IMAGE!, but stops at a line ending.  RECEIVER will be
+  ;; called with the index of the next newline character, or END.
+  (let ((text       (group-text group))
+       (gap-start  (group-gap-start group))
+       (gap-end    (group-gap-end group))
+       (gap-length (group-gap-length group)))
+    (cond ((fix:<= end gap-start)
+          (substring-line-image! text start end
+                                 image image-start image-end
+                                 tab-width column-offset char-image-strings
+                                 receiver))
+         ((fix:<= gap-start start)
+          (substring-line-image! text
+                                 (fix:+ start gap-length)
+                                 (fix:+ end gap-length)
+                                 image image-start image-end
+                                 tab-width column-offset char-image-strings
+                                 (lambda (text-index image-index)
+                                   (receiver (fix:- text-index gap-length) image-index))))
+         (else
+          (substring-line-image!
+           text start gap-start
+           image image-start image-end
+           tab-width column-offset char-image-strings
+           (lambda (text-index image-index)
+             (cond ((fix:< text-index gap-start)
+                    (receiver text-index image-index))
+                   ((and (fix:< start text-index)
+                         (char=? #\newline
+                                 (xstring-ref text (fix:-1+ text-index))))
+                    (receiver text-index image-index))
+                   ((fix:= image-index image-end)
+                    (receiver text-index image-index))
+                   (else
+                    (substring-line-image!
+                     text gap-end (fix:+ end gap-length)
+                     image image-index image-end
+                     tab-width column-offset char-image-strings
+                     (lambda (text-index image-index)
+                       (receiver (fix:- text-index gap-length)
+                                 image-index)))))))))))
 
+(define (substring-line-image! string string-start string-end
+                              image image-start image-end
+                              tab-width column-offset char-image-strings
+                              receiver)
+  (let loop ((string-index string-start) (image-index image-start))
+    (if (or (fix:= image-index image-end)
+           (fix:= string-index string-end))
+       (receiver string-index image-index)
+       (let ((char (xstring-ref string string-index)))
+         (cond ((char=? char #\newline)
+                (receiver (fix:1+ string-index) image-index))
+               ((and (char=? char #\tab) tab-width)
+                (let* ((n (fix:- tab-width
+                                 (fix:remainder (fix:+ column-offset
+                                                       image-index)
+                                                tab-width)))
+                       (end (fix:+ image-index n))
+                       (min-end (if (fix:< end image-end) end image-end)))
+                  (do ((image-index image-index (fix:+ image-index 1)))
+                      ((fix:= image-index min-end)
+                       (if (fix:<= end image-end)
+                           (loop (fix:1+ string-index) end)
+                           (receiver string-index image-end)))
+                    (string-set! image image-index #\space))))
+               (else
+                (let* ((image-string (vector-ref char-image-strings
+                                                 (char->integer char)))
+                       (image-len    (string-length image-string))
+                       (end (fix:+ image-index image-len))
+                       (min-end (if (fix:< end image-end) end image-end)))
+                  (do ((image-index image-index (fix:1+ image-index))
+                       (i 0 (fix:1+ i)))
+                      ((fix:= image-index min-end)
+                       (if (fix:<= end image-end)
+                           (loop (fix:1+ string-index) end)
+                           (receiver string-index image-index)))
+                    (string-set! image image-index
+                                 (string-ref image-string i))))))))))

diff --git a/src/edwin/input.scm b/src/edwin/input.scm
index 0eae0754b4e8f63235fa72b148fdf1afe3ec0b4d..6fed24a61a8c27f64136e5050ceb492c0aa6b188 100644 (file)
--- a/src/edwin/input.scm
+++ b/src/edwin/input.scm
@@ -198,7 +198,8 @@ B 3BAB8C
            (loop))))))
 
 (define (keyboard-peek-no-hang)
-  (handle-simple-events (editor-peek-no-hang current-editor) #t))
+  (handle-simple-events (lambda () ((editor-peek-no-hang current-editor) 0))
+                       #t))
 
 (define (handle-simple-events thunk discard?)
   (let loop ()
@@ -220,12 +221,23 @@ B 3BAB8C
 (define read-key-timeout/fast 500)
 (define read-key-timeout/slow 2000)
 
+(define (keyboard-peek-busy-no-hang peek timeout)
+  ;; For screens that can only PEEK-no-hang for 0 seconds.
+  (let* ((start (real-time-clock))
+        (end (+ start timeout)))
+    (let loop ()
+      (or (peek)
+         (let ((now (real-time-clock)))
+           (if (< now end)
+               (loop)
+               #f))))))
+
 (define (keyboard-read-1 reader discard?)
   (remap-alias-key
    (handle-simple-events
     (lambda ()
       (let ((peek-no-hang (editor-peek-no-hang current-editor)))
-       (if (not (peek-no-hang))
+       (if (not (peek-no-hang 0))
            (begin
              (if (let ((interval (ref-variable auto-save-interval))
                        (count auto-save-keystroke-count))
@@ -236,31 +248,24 @@ B 3BAB8C
                    (do-auto-save)
                    (set! auto-save-keystroke-count 0)))
              (update-screens! #f)))
-       (let ((wait
-              (lambda (timeout)
-                (let ((t (+ (real-time-clock) timeout)))
-                  (let loop ()
-                    (cond ((peek-no-hang) #f)
-                          ((>= (real-time-clock) t) #t)
-                          (else (loop))))))))
-         ;; Perform the appropriate juggling of the minibuffer message.
-         (cond ((within-typein-edit?)
-                (if message-string
-                    (begin
-                      (wait read-key-timeout/slow)
-                      (set! message-string #f)
-                      (set! message-should-be-erased? #f)
-                      (clear-current-message!))))
-               ((and (or message-should-be-erased?
-                         (and command-prompt-string
-                              (not command-prompt-displayed?)))
-                     (wait read-key-timeout/fast))
-                (set! message-string #f)
-                (set! message-should-be-erased? #f)
-                (if command-prompt-string
-                    (begin
-                      (set! command-prompt-displayed? #t)
-                      (set-current-message! command-prompt-string))
-                    (clear-current-message!)))))
+       ;; Perform the appropriate juggling of the minibuffer message.
+       (cond ((within-typein-edit?)
+              (if message-string
+                  (begin
+                    (peek-no-hang read-key-timeout/slow)
+                    (set! message-string #f)
+                    (set! message-should-be-erased? #f)
+                    (clear-current-message!))))
+             ((and (or message-should-be-erased?
+                       (and command-prompt-string
+                            (not command-prompt-displayed?)))
+                   (not (peek-no-hang read-key-timeout/fast)))
+              (set! message-string #f)
+              (set! message-should-be-erased? #f)
+              (if command-prompt-string
+                  (begin
+                    (set! command-prompt-displayed? #t)
+                    (set-current-message! command-prompt-string))
+                  (clear-current-message!))))
        (reader)))
     discard?)))
\ No newline at end of file

diff --git a/src/edwin/os2term.scm b/src/edwin/os2term.scm
index 2ec74b293f6bebe2138664a3438b0c476eb23b53..af24884a299dd803f59d1d2dd1ea4517ab78e444 100644 (file)
--- a/src/edwin/os2term.scm
+++ b/src/edwin/os2term.scm
@@ -641,9 +641,12 @@ USA.
       (setup-pending 'IN-UPDATE)
       pending)
 
-    (define (peek-no-hang)
-      (setup-pending #f)
-      pending)
+    (define (peek-no-hang timeout)
+      (keyboard-peek-busy-no-hang
+       (lambda ()
+        (setup-pending #f)
+        pending)
+       timeout))
 
     (define (peek)
       (setup-pending #t)

diff --git a/src/edwin/process.scm b/src/edwin/process.scm
index dedc9c9e6f60e7dc5120f642fd97338d2ed90543..ed67f5cdf3b7d72120098fac2d121b8e7b5222e0 100644 (file)
--- a/src/edwin/process.scm
+++ b/src/edwin/process.scm
@@ -231,7 +231,10 @@ Initialized from the SHELL environment variable."
              (if (null? (cdr queue))
                  (set-car! queue tail)
                  (set-cdr! (cdr queue) tail))
-             (set-cdr! queue tail))))))))
+             (set-cdr! queue tail))))
+      (if hook/inferior-process-output (hook/inferior-process-output))))))
+
+(define hook/inferior-process-output #f)
 
 (define (process-output-available?)
   (not (null? (car process-input-queue))))

diff --git a/src/edwin/tterm.scm b/src/edwin/tterm.scm
index 3a78206563d211a106f86bf4108189f689c5534d..f9f39e50f1d8cb64db198362154b018ff62e7b1f 100644 (file)
--- a/src/edwin/tterm.scm
+++ b/src/edwin/tterm.scm
@@ -281,14 +281,17 @@ USA.
        (lambda ()                      ;halt-update?
         (or (fix:< start end)
             (read-char #f)))
-       (lambda ()                      ;peek-no-hang
-        (or (parse-key)
-            (let ((event (read-event #f)))
-              (if (fix:fixnum? event)
-                  (begin
-                    (process-change-event event)
-                    #f)
-                  event))))
+       (lambda (timeout)               ;peek-no-hang
+        (keyboard-peek-busy-no-hang
+         (lambda ()
+           (or (parse-key)
+               (let ((event (read-event #f)))
+                 (if (fix:fixnum? event)
+                     (begin
+                       (process-change-event event)
+                       #f)
+                     event))))
+         timeout))
        (lambda ()                      ;peek
         (or (parse-key)
             (guarantee-result)))

diff --git a/src/edwin/win32.scm b/src/edwin/win32.scm
index 8db5cacc4d2cbec4983a36aa21949c8b328903f9..b7562c6dcac883fa7d7ab9f5eb270076e3cc7499 100644 (file)
--- a/src/edwin/win32.scm
+++ b/src/edwin/win32.scm
@@ -386,9 +386,12 @@ USA.
       (values (lambda ()               ;halt-update?
                (or pending-result
                    (probe 'IN-UPDATE)))
-             (lambda ()                ;peek-no-hang
-               (or pending-result
-                   (probe #f)))
+             (lambda (timeout)         ;peek-no-hang
+               (keyboard-peek-busy-no-hang
+                (lambda ()
+                  (or pending-result
+                      (probe #f)))
+                timeout))
              (lambda ()                ;peek
                (or pending-result
                    (let ((result (get-next-event #t)))

diff --git a/src/edwin/xterm.scm b/src/edwin/xterm.scm
index 418382c088f5831383940f0cba68f6f9fa6f3f9c..5a4cc9ce99951b178c17d02f4731c0d450e6c2e3 100644 (file)
--- a/src/edwin/xterm.scm
+++ b/src/edwin/xterm.scm
@@ -472,10 +472,14 @@ USA.
               (or pending-result
                   (fix:< start end)
                   (probe 'IN-UPDATE)))
-            (lambda ()                 ;peek-no-hang
-              (or pending-result
-                  (fix:< start end)
-                  (probe #f)))
+            (lambda (timeout)          ;peek-no-hang
+              (keyboard-peek-busy-no-hang
+               (lambda ()
+                 (or pending-result
+                     (and (fix:< start end)
+                          (string-ref string start))
+                     (probe #f)))
+               timeout))
             (lambda ()                 ;peek
               (or pending-result
                   (if (fix:< start end)