display, rather than input ports with standard input operations.
;;; -*-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
(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))
multiple-screens?
available?
make-screen
- make-input-port
+ get-input-operations
with-display-grabbed
with-interrupts-enabled
with-interrupts-disabled)
multiple-screens?
available?
make-screen
- make-input-port
+ get-input-operations
with-display-grabbed
with-interrupts-enabled
with-interrupts-disabled)))
(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))
;;; -*-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
(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))
(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))
#| -*-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
(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
terminal-set-state)
(import (runtime interrupt-handler)
hook/^g-interrupt)
+ (import (runtime transcript)
+ transcript-port)
(initialization (initialize-package!)))
(define-package (edwin window)
clear-message
command-prompt
initialize-typeout!
- keyboard-active?
keyboard-peek-char
keyboard-read-char
message
;;; -*-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
(if (not command-prompt-displayed?)
(clear-current-message!)))))
\f
-(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))
(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
;;; -*-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
;;;
(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))))
;;; -*-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
(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
#| -*-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
(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
;;; -*-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
((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)
;; `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)
;;; -*-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
(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)))
#| -*-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
(tf-teleray description)
(tf-underscore description))))
\f
-(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
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))
(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
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)
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))))))))
\f
(define (insert-lines screen yl yu n)
(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
;;; -*-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
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)
;;; -*-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
;;; package: (edwin window-output-port)
(declare (usual-integrations))
-\f
+
(define (with-output-to-current-point thunk)
(with-output-to-window-point (current-window) thunk))
(with-output-to-port port
(lambda ()
(with-cmdl/output-port (nearest-cmdl) port thunk))))
-
+\f
(define (window-output-port window)
(output-port/copy window-output-port-template window))
(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))))
;;; -*-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
(xterm-clear-rectangle! (screen-xterm screen)
0 (screen-x-size screen) 0 (screen-y-size screen) 0))
\f
-;;;; 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))
-\f
;;;; 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))))))
\f
;;; The values of these flags must be equal to the corresponding event
;;; types in "microcode/x11base.c"
(lambda ()
(select-screen screen))))))
\f
+(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)
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))
projects / mit-scheme.git / commitdiff