From: Chris Hanson Date: Mon, 11 Mar 1991 01:15:02 +0000 (+0000) Subject: Change keyboard input to use special operations defined by the X-Git-Tag: 20090517-FFI~10864 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7f49268bbf0512db4ce17d89fd8522af432dd0f0;p=mit-scheme.git Change keyboard input to use special operations defined by the display, rather than input ports with standard input operations. --- diff --git a/v7/src/edwin/display.scm b/v7/src/edwin/display.scm index 69bf51de1..45fe57d6f 100644 --- a/v7/src/edwin/display.scm +++ b/v7/src/edwin/display.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/display.scm,v 1.3 1990/11/02 03:23:38 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/display.scm,v 1.4 1991/03/11 01:14:06 cph Exp $ ;;; -;;; Copyright (c) 1989, 1990 Massachusetts Institute of Technology +;;; Copyright (c) 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -59,7 +59,7 @@ (multiple-screens? false read-only true) (operation/available? false read-only true) (operation/make-screen false read-only true) - (operation/make-input-port false read-only true) + (operation/get-input-operations false read-only true) (operation/with-display-grabbed false read-only true) (operation/with-interrupts-enabled false read-only true) (operation/with-interrupts-disabled false read-only true)) @@ -68,7 +68,7 @@ multiple-screens? available? make-screen - make-input-port + get-input-operations with-display-grabbed with-interrupts-enabled with-interrupts-disabled) @@ -77,7 +77,7 @@ multiple-screens? available? make-screen - make-input-port + get-input-operations with-display-grabbed with-interrupts-enabled with-interrupts-disabled))) @@ -92,8 +92,8 @@ (define (display-type/make-screen display-type args) (apply (display-type/operation/make-screen display-type) args)) -(define (display-type/make-input-port display-type screen) - ((display-type/operation/make-input-port display-type) screen)) +(define (display-type/get-input-operations display-type screen) + ((display-type/operation/get-input-operations display-type) screen)) (define (display-type/with-display-grabbed display-type thunk) ((display-type/operation/with-display-grabbed display-type) thunk)) diff --git a/v7/src/edwin/edtstr.scm b/v7/src/edwin/edtstr.scm index d92124360..6a7770710 100644 --- a/v7/src/edwin/edtstr.scm +++ b/v7/src/edwin/edtstr.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtstr.scm,v 1.12 1990/11/02 03:23:59 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtstr.scm,v 1.13 1991/03/11 01:14:10 cph Exp $ ;;; -;;; Copyright (c) 1989, 1990 Massachusetts Institute of Technology +;;; Copyright (c) 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -54,7 +54,9 @@ (bufferset false read-only true) (kill-ring false read-only true) (char-history false read-only true) - (input-port false read-only true) + (char-ready? false read-only true) + (peek-char false read-only true) + (read-char false read-only true) (button-event false) (select-time 1)) @@ -63,16 +65,21 @@ (let ((bufferset (make-bufferset initial-buffer)) (screen (display-type/make-screen display-type make-screen-args))) (initialize-screen-root-window! screen bufferset initial-buffer) - (%make-editor name - display-type - (list screen) - screen - bufferset - (make-ring 10) - (make-ring 100) - (display-type/make-input-port display-type screen) - false - 1)))) + (with-values + (lambda () (display-type/get-input-operations display-type screen)) + (lambda (char-ready? peek-char read-char) + (%make-editor name + display-type + (list screen) + screen + bufferset + (make-ring 10) + (make-ring 100) + char-ready? + peek-char + read-char + false + 1)))))) (define-integrable (current-display-type) (editor-display-type current-editor)) diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index 46252206e..43b00b9cb 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.23 1991/02/15 18:13:15 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.24 1991/03/11 01:14:14 cph Exp $ Copyright (c) 1989-91 Massachusetts Institute of Technology @@ -194,7 +194,7 @@ MIT in each case. |# (export (edwin) display-type? display-type/available? - display-type/make-input-port + display-type/get-input-operations display-type/make-screen display-type/multiple-screens? display-type/name @@ -286,6 +286,8 @@ MIT in each case. |# terminal-set-state) (import (runtime interrupt-handler) hook/^g-interrupt) + (import (runtime transcript) + transcript-port) (initialization (initialize-package!))) (define-package (edwin window) @@ -420,7 +422,6 @@ MIT in each case. |# clear-message command-prompt initialize-typeout! - keyboard-active? keyboard-peek-char keyboard-read-char message diff --git a/v7/src/edwin/input.scm b/v7/src/edwin/input.scm index 8146f5689..acf29d5b8 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.86 1990/11/14 15:14:53 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/input.scm,v 1.87 1991/03/11 01:14:20 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -172,19 +172,16 @@ B 3BAB8C (if (not command-prompt-displayed?) (clear-current-message!))))) -(define-integrable (keyboard-active? interval) - (char-ready? (editor-input-port current-editor) interval)) - (define (keyboard-peek-char) (if *executing-keyboard-macro?* (keyboard-macro-peek-char) - (keyboard-read-char-1 input-port/peek-char))) + (keyboard-read-char-1 (editor-peek-char current-editor)))) (define (keyboard-read-char) (set! keyboard-chars-read (1+ keyboard-chars-read)) (if *executing-keyboard-macro?* (keyboard-macro-read-char) - (let ((char (keyboard-read-char-1 input-port/read-char))) + (let ((char (keyboard-read-char-1 (editor-read-char current-editor)))) (set! *auto-save-keystroke-count* (1+ *auto-save-keystroke-count*)) (ring-push! (current-char-history) char) (if *defining-keyboard-macro?* (keyboard-macro-write-char char)) @@ -194,38 +191,44 @@ B 3BAB8C (define read-char-timeout/slow 2000) (define (keyboard-read-char-1 read-char) - ;; Perform redisplay if needed. - (if (not (keyboard-active? 0)) - (begin - (update-screens! false) - (if (let ((interval (ref-variable auto-save-interval)) - (count *auto-save-keystroke-count*)) - (and (positive? interval) - (> count interval) - (> count 20))) - (begin - (do-auto-save) - (set! *auto-save-keystroke-count* 0))))) - ;; Perform the appropriate juggling of the minibuffer message. - (cond ((within-typein-edit?) - (if message-string - (begin - (keyboard-active? read-char-timeout/slow) - (set! message-string false) - (set! message-should-be-erased? false) - (clear-current-message!)))) - ((and (or message-should-be-erased? - (and command-prompt-string - (not command-prompt-displayed?))) - (not (keyboard-active? read-char-timeout/fast))) - (set! message-string false) - (set! message-should-be-erased? false) - (if command-prompt-string - (begin - (set! command-prompt-displayed? true) - (set-current-message! command-prompt-string)) - (clear-current-message!)))) - (let ((char (read-char (editor-input-port current-editor)))) - (if (not (char? char)) - (error "reached EOF in keyboard input port")) - (remap-alias-char char))) \ No newline at end of file + (let ((char-ready? (editor-char-ready? current-editor))) + ;; Perform redisplay if needed. + (if (not (char-ready?)) + (begin + (update-screens! false) + (if (let ((interval (ref-variable auto-save-interval)) + (count *auto-save-keystroke-count*)) + (and (positive? interval) + (> count interval) + (> count 20))) + (begin + (do-auto-save) + (set! *auto-save-keystroke-count* 0))))) + ;; Perform the appropriate juggling of the minibuffer message. + (cond ((within-typein-edit?) + (if message-string + (begin + (let ((t (+ (real-time-clock) read-char-timeout/slow))) + (let loop () + (if (and (not (char-ready?)) + (< (real-time-clock) t)) + (loop)))) + (set! message-string false) + (set! message-should-be-erased? false) + (clear-current-message!)))) + ((and (or message-should-be-erased? + (and command-prompt-string + (not command-prompt-displayed?))) + (let ((t (+ (real-time-clock) read-char-timeout/fast))) + (let loop () + (cond ((char-ready?) false) + ((< (real-time-clock) t) (loop)) + (else true))))) + (set! message-string false) + (set! message-should-be-erased? false) + (if command-prompt-string + (begin + (set! command-prompt-displayed? true) + (set-current-message! command-prompt-string)) + (clear-current-message!))))) + (remap-alias-char (read-char))) \ No newline at end of file diff --git a/v7/src/edwin/iserch.scm b/v7/src/edwin/iserch.scm index 9f5787a85..972d7e838 100644 --- a/v7/src/edwin/iserch.scm +++ b/v7/src/edwin/iserch.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/iserch.scm,v 1.9 1991/02/15 18:13:52 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/iserch.scm,v 1.10 1991/03/11 01:14:24 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; @@ -70,7 +70,7 @@ (if result (execute-char (current-comtabs) result)))))))) (define (isearch-loop state) - (if (not (keyboard-active? 0)) + (if (not ((editor-char-ready? current-editor))) (begin (set-current-point! (search-state-point state)) (message (search-state-message state)))) diff --git a/v7/src/edwin/lspcom.scm b/v7/src/edwin/lspcom.scm index a9beb8fca..4e36010d5 100644 --- a/v7/src/edwin/lspcom.scm +++ b/v7/src/edwin/lspcom.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/lspcom.scm,v 1.150 1989/04/28 22:51:11 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/lspcom.scm,v 1.151 1991/03/11 01:14:28 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -208,8 +208,7 @@ If this would place point off screen, nothing happens." (insert-chars (current-command-char) argument) (if (positive? argument) (let ((point (current-point))) - (if (and (not (mark-left-char-quoted? point)) - (not (keyboard-active? 5))) + (if (not (mark-left-char-quoted? point)) (mark-flash (backward-one-sexp point) 'RIGHT)))))) (define-command lisp-indent-line diff --git a/v7/src/edwin/make.scm b/v7/src/edwin/make.scm index 37d22a428..791bfd884 100644 --- a/v7/src/edwin/make.scm +++ b/v7/src/edwin/make.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.25 1991/02/15 18:13:58 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.26 1991/03/11 01:14:32 cph Exp $ -Copyright (c) 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1989-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -37,4 +37,4 @@ MIT in each case. |# (declare (usual-integrations)) (package/system-loader "edwin" '() 'QUERY) -(add-system! (make-system "Edwin" 3 25 '())) \ No newline at end of file +(add-system! (make-system "Edwin" 3 26 '())) \ No newline at end of file diff --git a/v7/src/edwin/screen.scm b/v7/src/edwin/screen.scm index 21f6df2ef..454684697 100644 --- a/v7/src/edwin/screen.scm +++ b/v7/src/edwin/screen.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/screen.scm,v 1.86 1991/01/15 13:59:08 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/screen.scm,v 1.87 1991/03/11 01:14:38 cph Exp $ ;;; -;;; Copyright (c) 1989, 1990, 1991 Massachusetts Institute of Technology +;;; Copyright (c) 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -533,7 +533,8 @@ ((screen-debug-trace screen) 'screen screen 'update force?)) (let ((current-matrix (screen-current-matrix screen)) (new-matrix (screen-new-matrix screen)) - (y-size (screen-y-size screen))) + (y-size (screen-y-size screen)) + (char-ready? (editor-char-ready? current-editor))) (let ((enable (matrix-enable new-matrix))) (let loop ((y 0)) (cond ((fix:= y y-size) @@ -548,7 +549,7 @@ ;; `terminal-preempt-update?' has side-effects, ;; and it must be run regardless of `force?'. (not force?) - (or (keyboard-active? 0) + (or (char-ready?) (eq? (screen-debug-preemption-y screen) y))) (terminal-move-cursor screen (matrix-cursor-x current-matrix) diff --git a/v7/src/edwin/simple.scm b/v7/src/edwin/simple.scm index bf6d9a01d..2b13c31d9 100644 --- a/v7/src/edwin/simple.scm +++ b/v7/src/edwin/simple.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/simple.scm,v 1.29 1989/04/28 22:53:22 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/simple.scm,v 1.30 1991/03/11 01:14:43 cph Exp $ ;;; -;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology +;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -203,10 +203,15 @@ (else (extract-string start end)))))))) (define (sit-for interval) - (if (not (keyboard-active? 0)) - (begin - (update-screens! false) - (keyboard-active? interval)))) + (let ((time-limit (+ (real-time-clock) interval)) + (char-ready? (editor-char-ready? current-editor))) + (if (not (char-ready?)) + (begin + (update-screens! false) + (let loop () + (if (and (not (char-ready?)) + (< (real-time-clock) time-limit)) + (loop))))))) (define (reposition-window-top mark) (if (not (and mark (set-window-start-mark! (current-window) mark false))) diff --git a/v7/src/edwin/tterm.scm b/v7/src/edwin/tterm.scm index 9d288052b..be64ff021 100644 --- a/v7/src/edwin/tterm.scm +++ b/v7/src/edwin/tterm.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tterm.scm,v 1.3 1991/01/15 20:22:18 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tterm.scm,v 1.4 1991/03/11 01:14:47 cph Exp $ -Copyright (c) 1990, 1991 Massachusetts Institute of Technology +Copyright (c) 1990-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -126,9 +126,44 @@ MIT in each case. |# (tf-teleray description) (tf-underscore description)))) -(define (make-console-input-port screen) - screen ; ignored - console-input-port) +(define-integrable input-buffer-size 16) + +(define (get-console-input-operations screen) + screen ;ignored + (let ((channel (input-port/channel console-input-port)) + (string (make-string input-buffer-size)) + (start input-buffer-size) + (end input-buffer-size)) + (let ((fill-buffer + (lambda (block?) + (let ((eof (lambda () "Reached EOF in keyboard input."))) + (if (fix:= end 0) (eof)) + (if block? + (channel-blocking channel) + (channel-nonblocking channel)) + (let ((n (channel-read channel string 0 input-buffer-size))) + (cond (n + (if (fix:= n 0) (eof)) + (set! start 0) + (set! end n) + (if transcript-port + (write-string (substring string 0 n) + transcript-port))) + (block? (error "Blocking read returned #F."))) + n))))) + (values + (lambda () ;char-ready? + (if (fix:< start end) + true + (fill-buffer false))) + (lambda () ;peek-char + (if (not (fix:< start end)) (fill-buffer true)) + (string-ref string start)) + (lambda () ;read-char + (if (not (fix:< start end)) (fill-buffer true)) + (let ((char (string-ref string start))) + (set! start (fix:+ start 1)) + char)))))) (define (signal-interrupt! interrupt-enables) interrupt-enables ; ignored @@ -162,7 +197,7 @@ MIT in each case. |# false console-available? make-console-screen - make-console-input-port + get-console-input-operations with-console-grabbed with-console-interrupts-enabled with-console-interrupts-disabled)) @@ -219,13 +254,18 @@ MIT in each case. |# (define (channel-state channel) (and channel (channel-type=terminal? channel) - (terminal-get-state channel))) + (cons (channel-blocking? channel) + (terminal-get-state channel)))) (define (set-channel-state! channel state) (if (and channel (channel-type=terminal? channel) state) - (terminal-set-state channel state))) + (begin + (if (car state) + (channel-blocking channel) + (channel-nonblocking channel)) + (terminal-set-state channel (cdr state))))) (define (terminal-operation operation channel) (if (and channel @@ -494,7 +534,7 @@ MIT in each case. |# first-unused-x))) (do ((x (screen-cursor-x screen) (fix:1+ x))) ((fix:= x first-unused-x)) - (output-char screen #\space)) + (output-space screen)) (record-cursor-after-output screen first-unused-x))))))) (define (clear-multi-char screen n) @@ -519,7 +559,7 @@ MIT in each case. |# x-end)))) (do ((x cursor-x (fix:1+ x))) ((fix:= x x-end)) - (output-char screen #\space)) + (output-space screen)) (record-cursor-after-output screen x-end)))))))) (define (insert-lines screen yl yu n) @@ -822,4 +862,7 @@ MIT in each case. |# (define-integrable (output-char screen char) screen - (output-port/write-char console-output-port char)) \ No newline at end of file + (output-port/write-char console-output-port char)) + +(define-integrable (output-space screen) + (output-char screen #\space)) \ No newline at end of file diff --git a/v7/src/edwin/window.scm b/v7/src/edwin/window.scm index 9bb48f471..8e7571cd6 100644 --- a/v7/src/edwin/window.scm +++ b/v7/src/edwin/window.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/window.scm,v 1.152 1990/11/02 03:25:03 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/window.scm,v 1.153 1991/03/11 01:14:53 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -209,10 +209,11 @@ display-style) (update-inferiors! (window-inferiors window) screen x-start y-start xl xu yl yu display-style - (lambda (window screen x-start y-start xl xu yl yu display-style) - (and (or display-style (not (keyboard-active? 0))) - (=> window :update-display! screen x-start y-start xl xu yl yu - display-style))))) + (let ((char-ready? (editor-char-ready? current-editor))) + (lambda (window screen x-start y-start xl xu yl yu display-style) + (and (or display-style (not (char-ready?))) + (=> window :update-display! screen x-start y-start xl xu yl yu + display-style)))))) (define (update-inferiors! inferiors screen x-start y-start xl xu yl yu display-style updater) diff --git a/v7/src/edwin/winout.scm b/v7/src/edwin/winout.scm index 413956d63..aa7061bd5 100644 --- a/v7/src/edwin/winout.scm +++ b/v7/src/edwin/winout.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/winout.scm,v 1.4 1989/08/09 13:18:18 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/winout.scm,v 1.5 1991/03/11 01:14:58 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -46,7 +46,7 @@ ;;; package: (edwin window-output-port) (declare (usual-integrations)) - + (define (with-output-to-current-point thunk) (with-output-to-window-point (current-window) thunk)) @@ -57,7 +57,7 @@ (with-output-to-port port (lambda () (with-cmdl/output-port (nearest-cmdl) port thunk)))) - + (define (window-output-port window) (output-port/copy window-output-port-template window)) @@ -113,10 +113,10 @@ (region-insert-string! point string))))) (define (operation/flush-output port) - ;; Calling `keyboard-active?' gives the screen abstraction a chance - ;; to do refresh if it needs to (e.g. if an X exposure event is - ;; received). - (keyboard-active? 0) + ;; Calling `editor-char-ready?' gives the screen abstraction a + ;; chance to do refresh if it needs to (e.g. if an X exposure event + ;; is received). + ((editor-char-ready? current-editor)) (let ((window (output-port/state port))) (if (window-needs-redisplay? window) (window-direct-update! window false)))) diff --git a/v7/src/edwin/xterm.scm b/v7/src/edwin/xterm.scm index fb5bec4cf..828b5f704 100644 --- a/v7/src/edwin/xterm.scm +++ b/v7/src/edwin/xterm.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.13 1990/11/02 03:25:13 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.14 1991/03/11 01:15:02 cph Exp $ ;;; -;;; Copyright (c) 1989, 1990 Massachusetts Institute of Technology +;;; Copyright (c) 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -222,151 +222,74 @@ (xterm-clear-rectangle! (screen-xterm screen) 0 (screen-x-size screen) 0 (screen-y-size screen) 0)) -;;;; Input Port - -(define (make-xterm-input-port screen) - (input-port/copy xterm-input-port-template - (make-xterm-input-port-state (screen-display screen)))) - -(define-structure (xterm-input-port-state - (constructor make-xterm-input-port-state (display)) - (conc-name xterm-input-port-state/)) - (display false read-only true) - (buffer "") - (index 0) - ;; If we receive a non-keypress event while in a display update, we - ;; stash it here and abort the update. - (pending-event false)) - -(define (operation/char-ready? port interval) - (let ((state (input-port/state port))) - (if (< (xterm-input-port-state/index state) - (string-length (xterm-input-port-state/buffer state))) - true - (xterm-read-chars! state (+ (real-time-clock) interval))))) - -(define (operation/peek-char port) - (let ((state (input-port/state port))) - (let ((buffer (xterm-input-port-state/buffer state)) - (index (xterm-input-port-state/index state))) - (if (< index (string-length buffer)) - (string-ref buffer index) - (let ((buffer (xterm-read-chars! state false))) - (and buffer - (string-ref buffer 0))))))) - -(define (operation/discard-char port) - (let ((state (input-port/state port))) - (set-xterm-input-port-state/index! - state - (1+ (xterm-input-port-state/index state))))) - -(define (operation/read-char port) - (let ((state (input-port/state port))) - (let ((buffer (xterm-input-port-state/buffer state)) - (index (xterm-input-port-state/index state))) - (if (< index (string-length buffer)) - (begin - (set-xterm-input-port-state/index! state (1+ index)) - (string-ref buffer index)) - (let ((buffer (xterm-read-chars! state false))) - (and buffer - (begin - (set-xterm-input-port-state/index! state 1) - (string-ref buffer 0)))))))) - -(define (operation/print-self state port) - (unparse-string state "from display ") - (unparse-object state - (xterm-input-port-state/display (input-port/state port)))) - -(define xterm-input-port-template - (make-input-port `((CHAR-READY? ,operation/char-ready?) - (DISCARD-CHAR ,operation/discard-char) - (PEEK-CHAR ,operation/peek-char) - (PRINT-SELF ,operation/print-self) - (READ-CHAR ,operation/read-char)) - false)) - ;;;; Event Handling -(define (xterm-read-chars! state time-limit) - (let ((display (xterm-input-port-state/display state))) - (letrec - ((loop - (lambda () - (let ((event (x-display-process-events display time-limit))) - (cond ((not event) - false) - ((= (vector-ref event 0) event-type:key-press) - (let ((buffer (vector-ref event 2))) - (set-xterm-input-port-state/buffer! state buffer) - (set-xterm-input-port-state/index! state 0) - (if signal-interrupts? - (let ((^g-index - (string-find-previous-char buffer #\BEL))) - (if ^g-index - (begin - (set-xterm-input-port-state/index! - state (1+ ^g-index)) - (signal-interrupt!))))) - buffer)) - (else - (process-special-event event)))))) - (process-special-event - (lambda (event) - (let ((handler (vector-ref event-handlers (vector-ref event 0))) - (screen (xterm->screen (vector-ref event 1)))) - (if (and handler screen) - (begin - (let ((continuation (screen-in-update? screen))) - (if continuation - (begin - (set-xterm-input-port-state/pending-event! state - event) - (continuation false)))) - (handler screen event)))) - (loop)))) - (let ((event (xterm-input-port-state/pending-event state))) - (if event - (begin - (set-xterm-input-port-state/pending-event! state false) - (process-special-event event)) - (loop)))))) - -(define signal-interrupts?) -(define pending-interrupt?) - -(define (signal-interrupt!) - (editor-beep) - (temporary-message "Quit") - (set! pending-interrupt? false) - (^G-signal)) - -(define (with-editor-interrupts-from-x receiver) - (fluid-let ((signal-interrupts? true) - (pending-interrupt? false)) - (receiver (lambda (thunk) (thunk))))) - -(define (with-x-interrupts-enabled thunk) - (bind-signal-interrupts? true thunk)) - -(define (with-x-interrupts-disabled thunk) - (bind-signal-interrupts? false thunk)) - -(define (bind-signal-interrupts? new-mask thunk) - (let ((old-mask)) - (dynamic-wind (lambda () - (set! old-mask signal-interrupts?) - (set! signal-interrupts? new-mask) - (if (and new-mask pending-interrupt?) - (signal-interrupt!))) - thunk - (lambda () - (set! new-mask signal-interrupts?) - (set! signal-interrupts? old-mask) - (if (and old-mask pending-interrupt?) - (signal-interrupt!)))))) +(define (get-xterm-input-operations screen) + (let ((display (screen-display screen)) + (string false) + (start 0) + (end 0) + (pending-event false)) + (let ((process-events! + (lambda (limit) + (letrec + ((loop + (lambda () + (let ((event (x-display-process-events display limit))) + (cond ((not event) + (if (not limit) + (error "Blocking read returned #F.")) + false) + ((eq? event true) + ;; Handle subprocess output here. + (loop)) + ((= (vector-ref event 0) event-type:key-press) + (set! string (vector-ref event 2)) + (set! start 0) + (set! end (string-length string)) + (if signal-interrupts? + (let ((^g-index + (string-find-previous-char string + #\BEL))) + (if ^g-index + (begin + (set! start (fix:+ ^g-index 1)) + (signal-interrupt!))))) + true) + (else + (process-special-event event)))))) + (process-special-event + (lambda (event) + (let ((handler + (vector-ref event-handlers (vector-ref event 0))) + (screen (xterm->screen (vector-ref event 1)))) + (if (and handler screen) + (begin + (let ((continuation (screen-in-update? screen))) + (if continuation + (begin + (set! pending-event event) + (continuation false)))) + (handler screen event)))) + (loop)))) + (if (not pending-event) + (loop) + (let ((event pending-event)) + (set! pending-event false) + (process-special-event event))))))) + (values + (lambda () ;char-ready? + (if (fix:< start end) + true + (process-events! 0))) + (lambda () ;peek-char + (if (not (fix:< start end)) (process-events! false)) + (string-ref string start)) + (lambda () ;read-char + (if (not (fix:< start end)) (process-events! false)) + (let ((char (string-ref string start))) + (set! start (fix:+ start 1)) + char)))))) ;;; The values of these flags must be equal to the corresponding event ;;; types in "microcode/x11base.c" @@ -426,6 +349,40 @@ (lambda () (select-screen screen)))))) +(define signal-interrupts?) +(define pending-interrupt?) + +(define (signal-interrupt!) + (editor-beep) + (temporary-message "Quit") + (set! pending-interrupt? false) + (^G-signal)) + +(define (with-editor-interrupts-from-x receiver) + (fluid-let ((signal-interrupts? true) + (pending-interrupt? false)) + (receiver (lambda (thunk) (thunk))))) + +(define (with-x-interrupts-enabled thunk) + (bind-signal-interrupts? true thunk)) + +(define (with-x-interrupts-disabled thunk) + (bind-signal-interrupts? false thunk)) + +(define (bind-signal-interrupts? new-mask thunk) + (let ((old-mask)) + (dynamic-wind (lambda () + (set! old-mask signal-interrupts?) + (set! signal-interrupts? new-mask) + (if (and new-mask pending-interrupt?) + (signal-interrupt!))) + thunk + (lambda () + (set! new-mask signal-interrupts?) + (set! signal-interrupts? old-mask) + (if (and old-mask pending-interrupt?) + (signal-interrupt!)))))) + (define x-display-type) (define x-display-data) @@ -444,7 +401,7 @@ true get-x-display make-xterm-screen - make-xterm-input-port + get-xterm-input-operations with-editor-interrupts-from-x with-x-interrupts-enabled with-x-interrupts-disabled))