From: Matt Birkholz Date: Tue, 15 Dec 2015 04:49:47 +0000 (-0700) Subject: edwin: Add a timeout parameter to the peek-no-hang input operations. X-Git-Tag: mit-scheme-pucked-9.2.12~376^2~15 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=24ffc20e4e2ee7624c7d6c7142ddc96b9b561ba0;p=mit-scheme.git edwin: Add a timeout parameter to the peek-no-hang input operations. Factor the busy loop out and name it keyboard-peek-busy-no-hang. Use it in the peek-no-hang input operations to implement the timeout. --- diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg index 811069443..9a0a5d576 100644 --- a/src/edwin/edwin.pkg +++ b/src/edwin/edwin.pkg @@ -984,6 +984,8 @@ USA. (parent (edwin screen)) (export (edwin) resize-screen) + (import (edwin keyboard) + keyboard-peek-busy-no-hang) (import (edwin process) register-process-output-events) (import (runtime primitive-io) @@ -1041,6 +1043,8 @@ USA. screen-xterm xterm-screen/set-icon-name xterm-screen/set-name) + (import (edwin keyboard) + keyboard-peek-busy-no-hang) (import (edwin process) register-process-output-events) (initialization (initialize-package!))) @@ -1178,6 +1182,8 @@ USA. swp_nozorder update-window ws_overlappedwindow) + (import (edwin keyboard) + keyboard-peek-busy-no-hang) (export (edwin win-commands) win32-screen/get-client-size win32-screen/get-position @@ -1269,6 +1275,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/input.scm b/src/edwin/input.scm index 772502ad3..8b3a72efc 100644 --- a/src/edwin/input.scm +++ b/src/edwin/input.scm @@ -197,35 +197,69 @@ B 3BAB8C (apply-input-event key)) (loop)))))) -(define (keyboard-peek-no-hang) - (handle-simple-events (editor-peek-no-hang current-editor) #t)) +(define (keyboard-peek-no-hang #!optional timeout) + (let ((milliseconds (if (default-object? timeout) 0 timeout))) + (guarantee-fixnum milliseconds 'keyboard-peek-no-hang) + (handle-simple-events-until + (+ (real-time-clock) milliseconds) + (editor-peek-no-hang current-editor) + #t))) (define (handle-simple-events thunk discard?) (let loop () (let ((input (thunk))) - (if (and (input-event? input) - (let ((type (input-event/type input))) - (or (eq? type 'UPDATE) - (eq? type 'SET-SCREEN-SIZE) - (and (eq? type 'DELETE-SCREEN) - (eq? (input-event/operator input) delete-screen!) - (not (selected-screen? - (car (input-event/operands input)))))))) - (begin - (apply-input-event input) - (if discard? ((editor-read current-editor))) - (loop)) + (if (simple-event-handled? input discard?) + (loop) input)))) + +(define (simple-event-handled? input discard?) + (if (and (input-event? input) + (let ((type (input-event/type input))) + (or (eq? type 'UPDATE) + (eq? type 'SET-SCREEN-SIZE) + (and (eq? type 'DELETE-SCREEN) + (eq? (input-event/operator input) delete-screen!) + (not (selected-screen? + (car (input-event/operands input)))))))) + (begin + (apply-input-event input) + (if discard? ((editor-read current-editor))) + #t) + #f)) + +(define (handle-simple-events-until end-time peek-no-hang discard?) + (let loop () + (let* ((now (real-time-clock)) + (timeout (- end-time now))) + (if (not (positive? timeout)) + #f + (let ((input (peek-no-hang timeout))) + (if (simple-event-handled? input discard?) + (loop) + input)))))) (define read-key-timeout/fast 500) (define read-key-timeout/slow 2000) +(define (keyboard-peek-busy-no-hang peek timeout) + ;; This busy-loop applies the PEEK thunk repeatedly for TIMEOUT + ;; msec. Old display types that only PEEK-no-hang for 0 seconds + ;; must use this. + (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 +270,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 7dacc2a51..a7854c4c5 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/simple.scm b/src/edwin/simple.scm index 4f9604a86..ff75dddba 100644 --- a/src/edwin/simple.scm +++ b/src/edwin/simple.scm @@ -226,12 +226,9 @@ USA. (else (extract-string start end)))))))) (define (sit-for interval) - (let ((time-limit (+ (real-time-clock) interval))) - (let loop () - (if (and (not (keyboard-peek-no-hang)) - (< (real-time-clock) time-limit) - (update-screens! false)) - (loop))))) + (guarantee-fixnum interval 'sit-for) + (update-screens! 'ignore-input) + (keyboard-peek-no-hang interval)) (define sleep-for sleep-current-thread) diff --git a/src/edwin/tterm.scm b/src/edwin/tterm.scm index f57b3dd3b..2016888b3 100644 --- a/src/edwin/tterm.scm +++ b/src/edwin/tterm.scm @@ -334,13 +334,16 @@ USA. (named-lambda (halt-update?) (or (fix:< start end) (read-more?))) - (named-lambda (peek-no-hang) - (let ((event (->event (match-event #f)))) - (if (input-event? event) - (begin - (apply-input-event event) - #f) - event))) + (named-lambda (peek-no-hang timeout) + (keyboard-peek-busy-no-hang + (lambda () + (let ((event (->event (match-event #f)))) + (if (input-event? event) + (begin + (apply-input-event event) + #f) + event))) + timeout)) (named-lambda (peek) (->event (match-event #t))) (named-lambda (read) diff --git a/src/edwin/win32.scm b/src/edwin/win32.scm index f25a2d58b..86dea2b80 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 c6454bc21..490ba7436 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)