;;; -*-Scheme-*-
;;;
-;;; $Id: comred.scm,v 1.97 1993/07/06 20:35:48 cph Exp $
+;;; $Id: comred.scm,v 1.98 1993/08/01 00:15:49 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
;;;
(define-structure (input-event
(constructor %make-input-event)
(conc-name input-event/))
+ (type false read-only true)
(operator false read-only true)
(operands false read-only true))
-(define (make-input-event operator . operands)
- (%make-input-event operator operands))
+(define (make-input-event type operator . operands)
+ (%make-input-event type operator operands))
(define (apply-input-event input-event)
(if (not (input-event? input-event))
#| -*-Scheme-*-
-$Id: edwin.pkg,v 1.119 1993/07/22 21:06:43 cph Exp $
+$Id: edwin.pkg,v 1.120 1993/08/01 00:15:52 cph Exp $
Copyright (c) 1989-1993 Massachusetts Institute of Technology
execute-command
execute-command-history-entry
initialize-command-reader!
+ input-event/type
input-event?
keyboard-keys-read
last-command
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/input.scm,v 1.93 1992/02/18 20:47:26 arthur Exp $
+;;; $Id: input.scm,v 1.94 1993/08/01 00:15:55 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(keyboard-read-1 (editor-peek current-editor))))
(define (keyboard-read)
- (set! keyboard-keys-read (1+ keyboard-keys-read))
+ (set! keyboard-keys-read (+ keyboard-keys-read 1))
(if *executing-keyboard-macro?*
(keyboard-macro-read-key)
(let ((key (keyboard-read-1 (editor-read current-editor))))
((ref-command end-kbd-macro) 1)))
key)))
+(define (keyboard-read-1 reader)
+ (handle-simple-events (lambda () (keyboard-read-2 reader))))
+
(define (keyboard-peek-no-hang)
- ((editor-peek-no-hang current-editor)))
+ (handle-simple-events (editor-peek-no-hang current-editor)))
-(define (keyboard-read-char)
- (let loop ((key (keyboard-read)))
- (if (char? key)
- key
- (loop (keyboard-read)))))
+(define (handle-simple-events thunk)
+ (let loop ()
+ (let ((input (thunk)))
+ (if (and (input-event? input)
+ (memq (input-event/type input) '(UPDATE SET-SCREEN-SIZE)))
+ (begin
+ (apply-input-event input)
+ (loop))
+ input))))
+(define (keyboard-read-char)
+ (let loop ()
+ (let ((key (keyboard-read)))
+ (if (char? key)
+ key
+ (begin
+ (if (input-event? key)
+ (apply-input-event key))
+ (loop))))))
+\f
(define read-key-timeout/fast 500)
(define read-key-timeout/slow 2000)
-(define (keyboard-read-1 reader)
+(define (keyboard-read-2 reader)
(remap-alias-key
(let ((peek-no-hang (editor-peek-no-hang current-editor)))
(if (not (peek-no-hang))
;;; -*-Scheme-*-
;;;
-;;; $Id: prompt.scm,v 1.156 1992/11/29 20:22:37 bal Exp $
+;;; $Id: prompt.scm,v 1.157 1993/08/01 00:15:58 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(select-window (car typein-saved-windows)))
((zero? typein-edit-depth)
(select-window (other-window)))))))))))
- (if (eq? value typein-edit-abort-flag)
- (abort-current-command)
- value)))
+ (cond ((eq? value typein-edit-abort-flag)
+ (abort-current-command))
+ ((and (pair? value) (eq? (car value) typein-edit-abort-flag))
+ (abort-current-command (cdr value)))
+ (else
+ value))))
(define-integrable (within-typein-edit?)
(not (null? typein-saved-windows)))
(set-current-major-mode! mode)
(command-reader))
+(define (abort-typein-edit event)
+ (typein-edit-continuation (cons typein-edit-abort-flag event)))
+
(define (exit-typein-edit)
(if (not typein-edit-continuation)
(error "Not editing typein; can't exit"))
(let ((input (with-editor-interrupts-disabled keyboard-read)))
(if (and (char? input) (char-ascii? input))
(set-typein-string! (key-name input) true))
- input)))))
- (cond ((and (char? input) (char-ascii? input))
- input)
- ((input-event? input)
- (abort-current-command input))
- (else
- (editor-error "Not an ASCII character:" input)))))
+ (if (input-event? input)
+ (abort-typein-edit input)
+ input))))))
+ (if (not (and (char? input) (char-ascii? input)))
+ (editor-error "Not an ASCII character:" input))
+ input))
(define (prompt-for-key prompt #!optional comtab)
(let ((comtab (if (default-object? comtab) (current-comtabs) comtab)))
(let inner-loop
((char (with-editor-interrupts-disabled keyboard-read)))
(if (input-event? char)
- (within-continuation typein-edit-continuation
- (lambda ()
- (abort-current-command char))))
+ (abort-typein-edit char))
(let ((chars (append! prefix (list char))))
(set-typein-string! (xkey->name chars) true)
(if (prefix-key-list? comtab chars)
(char-ci=? char #\rubout)))
(set-typein-string! "n" true)
false)
+ ((input-event? char)
+ (abort-typein-edit char))
(else
(editor-beep)
(if (not lost?)
;;; in unix.scm which deal with .KY files.
(define (prompt-for-password prompt)
- (prompt-for-typein
- prompt false
- (lambda ()
- (let loop ((ts ""))
- (let ((input (keyboard-read)))
- (if (and (char? input) (char-ascii? input))
- (cond ((char=? input #\Return)
- ts)
- ((char=? input #\C-g)
- (abort-current-command))
- ((char=? input #\Rubout)
- (let ((ts-len (string-length ts)))
- (if (> ts-len 0)
- (let ((new-string (string-head ts (-1+ ts-len))))
- (set-typein-string!
- (make-string (string-length new-string) #\.) true)
- (loop new-string))
- (loop ts))))
- (else
- (set-typein-string!
- (make-string (1+ (string-length ts)) #\.) true)
- (loop (string-append ts (char->string input)))))
- (loop ts)))))))
+ (prompt-for-typein prompt false
+ (lambda ()
+ (let loop ((ts ""))
+ (let ((input (keyboard-read)))
+ (cond ((input-event? input)
+ (abort-typein-edit input))
+ ((not (and (char? input) (char-ascii? input)))
+ (loop ts))
+ ((char=? input #\Return)
+ ts)
+ ((char=? input #\C-g)
+ (abort-current-command))
+ ((char=? input #\Rubout)
+ (let ((ts-len (string-length ts)))
+ (if (> ts-len 0)
+ (let ((new-string (string-head ts (-1+ ts-len))))
+ (set-typein-string!
+ (make-string (string-length new-string) #\.) true)
+ (loop new-string))
+ (loop ts))))
+ (else
+ (set-typein-string!
+ (make-string (1+ (string-length ts)) #\.) true)
+ (loop (string-append ts (char->string input))))))))))
(define (prompt-for-confirmed-password)
(let ((password1 (prompt-for-password "Password: ")))
#| -*-Scheme-*-
-$Id: tterm.scm,v 1.20 1993/07/16 19:20:22 gjr Exp $
+$Id: tterm.scm,v 1.21 1993/08/01 00:16:01 cph Exp $
Copyright (c) 1990-1993 Massachusetts Institute of Technology
(cond ((char? event)
event)
((process-change-event event)
- (make-input-event update-screens! #f))
+ (make-input-event 'UPDATE update-screens! #f))
(else
(guarantee-result)))))))
(values
;;; -*-Scheme-*-
;;;
-;;; $Id: xterm.scm,v 1.39 1993/04/28 19:51:10 cph Exp $
+;;; $Id: xterm.scm,v 1.40 1993/08/01 00:16:08 cph Exp $
;;;
;;; Copyright (c) 1989-93 Massachusetts Institute of Technology
;;;
(error "#F returned from blocking read"))
((not (vector? event))
(if (process-change-event event)
- (make-input-event update-screens! #f)
+ (make-input-event 'UPDATE update-screens! #f)
(loop)))
(else
(or (process-event event) (loop)))))))))
(lambda (screen event)
(set! last-focus-time (vector-ref event 5))
(let ((xterm (screen-xterm screen)))
- (make-input-event execute-button-command
+ (make-input-event 'BUTTON
+ execute-button-command
screen
(make-down-button (vector-ref event 4))
(xterm-map-x-coordinate xterm (vector-ref event 2))
(lambda (screen event)
(set! last-focus-time (vector-ref event 5))
(let ((xterm (screen-xterm screen)))
- (make-input-event execute-button-command
+ (make-input-event 'BUTTON
+ execute-button-command
screen
(make-up-button (vector-ref event 4))
(xterm-map-x-coordinate xterm (vector-ref event 2))
(y-size (xterm-map-y-size xterm y-size)))
(and (not (and (= x-size (screen-x-size screen))
(= y-size (screen-y-size screen))))
- (make-input-event
- (lambda (screen x-size y-size)
- (set-screen-size! screen x-size y-size)
- (update-screen! screen #t))
- screen x-size y-size))))))
+ (make-input-event 'SET-SCREEN-SIZE
+ (lambda (screen x-size y-size)
+ (set-screen-size! screen x-size y-size)
+ (update-screen! screen #t))
+ screen x-size y-size))))))
(define-event-handler event-type:focus-in
(lambda (screen event)
event
(and (not (selected-screen? screen))
- (make-input-event select-screen screen))))
+ (make-input-event 'SELECT-SCREEN select-screen screen))))
(define-event-handler event-type:delete-window
(lambda (screen event)
event
(and (not (screen-deleted? screen))
- (make-input-event delete-screen! screen))))
+ (make-input-event 'DELETE-SCREEN delete-screen! screen))))
(define-event-handler event-type:map
(lambda (screen event)
(and (not (screen-deleted? screen))
(begin
(set-screen-visibility! screen 'VISIBLE)
- (make-input-event update-screen! screen #t)))))
+ (make-input-event 'UPDATE update-screen! screen #t)))))
(define-event-handler event-type:unmap
(lambda (screen event)
(and (selected-screen? screen)
(let ((screen (other-screen screen false)))
(and screen
- (make-input-event select-screen screen))))))))
+ (make-input-event 'SELECT-SCREEN
+ select-screen
+ screen))))))))
(define-event-handler event-type:visibility
(lambda (screen event)
((2) (set-screen-visibility! screen 'OBSCURED)))
(and (or (eq? old-visibility 'UNMAPPED)
(eq? old-visibility 'OBSCURED))
- (make-input-event update-screen! screen #t)))))))
+ (make-input-event 'UPDATE update-screen! screen #t)))))))
(define-event-handler event-type:take-focus
(lambda (screen event)
(set! last-focus-time (vector-ref event 2))
- (make-input-event select-screen screen)))
+ (make-input-event 'SELECT-SCREEN select-screen screen)))
\f
(define reading-event?)
(define signal-interrupts?)
projects / mit-scheme.git / commitdiff