From: Matt Birkholz Date: Mon, 17 Jan 2011 08:56:12 +0000 (-0700) Subject: Editor-peek-no-hang timeout. Inferior event hooks. X-Git-Tag: 20110609-Gtk-Screen~10 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e5a645d9eac9449b9a7cea172bce1d907fee431f;p=mit-scheme.git 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 300b5faef..294010a03 100644 --- 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 a9beda33e..11e88c55b 100644 --- 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 52e45491f..7813b0a5a 100644 --- 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 b1fbb4e5a..c851b9b6d 100644 --- 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)))))))))) + +(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 0eae0754b..6fed24a61 100644 --- 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 2ec74b293..af24884a2 100644 --- 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 dedc9c9e6..ed67f5cdf 100644 --- 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 3a7820656..f9f39e50f 100644 --- 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 8db5cacc4..b7562c6dc 100644 --- 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 418382c08..5a4cc9ce9 100644 --- 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)