;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.121 1992/02/10 15:31:50 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.122 1992/02/17 22:06:10 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
(define (read-quoted-char prompt-string)
(let ((read-ascii-char
(lambda ()
- (let ((key (with-editor-interrupts-disabled keyboard-read)))
- (or (and (char? key)
- (char-ascii? key))
- (editor-error "Not an ASCII character" (key-name key)))
- (set-command-prompt!
- (string-append (command-prompt) (key-name key)))
- key))))
+ (let ((input (with-editor-interrupts-disabled keyboard-read)))
+ (if (input-event? input)
+ (abort-current-command input)
+ (begin
+ (if (not (and (char? input) (char-ascii? input)))
+ (editor-error "Can't quote non-ASCII char:" input))
+ (set-command-prompt!
+ (string-append (command-prompt) (key-name input)))
+ input))))))
(let ((read-digit
(lambda ()
(or (char->digit (read-ascii-char) 8)
()
(lambda ()
(set-command-prompt-prefix!)
- (let ((prefix-key (current-command-key)))
- (dispatch-on-key
- (current-comtabs)
- ((if (pair? prefix-key) append cons)
- prefix-key
- (list (with-editor-interrupts-disabled keyboard-read)))))))
+ (let ((input (with-editor-interrupts-disabled keyboard-read)))
+ (if (input-event? input)
+ (apply-input-event input)
+ (dispatch-on-key (current-comtabs)
+ (let ((prefix-key (current-command-key)))
+ ((if (pair? prefix-key) append cons)
+ prefix-key
+ (list input))))))))
(define (set-command-prompt-prefix!)
(set-command-prompt!
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.91 1992/02/04 04:01:50 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.92 1992/02/17 22:08:30 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
(define keyboard-keys-read) ;# of keys read from keyboard
(define command-history)
(define command-history-limit 30)
-(define command-reader-reset-thunk)
-(define command-reader-reset-continuation)
(define command-reader-override-queue)
(define (initialize-command-reader!)
(set! keyboard-keys-read 0)
(set! command-history (make-circular-list command-history-limit false))
- (set! command-reader-reset-thunk false)
(set! command-reader-override-queue (make-queue))
unspecific)
(let loop ((initialization initialization))
(with-keyboard-macro-disabled
(lambda ()
- (call-with-protected-continuation
- (lambda (continuation)
- (fluid-let ((command-reader-reset-continuation continuation))
- (unwind-protect
- false
- (lambda ()
- (intercept-^G-interrupts (lambda () unspecific)
- (lambda ()
- (command-reader initialization))))
- (lambda ()
- (let ((thunk command-reader-reset-thunk))
- (if thunk
- (begin
- (set! command-reader-reset-thunk false)
- (thunk)))))))))))
+ (intercept-^G-interrupts (lambda () unspecific)
+ (lambda ()
+ (command-reader initialization)))))
(loop false)))
-(define (command-reader/reset-and-execute thunk)
- (set! command-reader-reset-thunk thunk)
- (command-reader-reset-continuation false))
-
(define (override-next-command! override)
(enqueue! command-reader-override-queue override))
-\f
-(define (command-reader #!optional initialization)
- (define (command-reader-loop)
- (let ((value (with-command-variables start-next-command)))
- (if (not (eq? value 'ABORT))
- (value)))
- (command-reader-loop))
- (define (with-command-variables start-next-command)
- (call-with-protected-continuation
- (lambda (continuation)
- (fluid-let ((*command-continuation* continuation)
- (*command-key* false)
- (*command* false)
- (*next-argument* false)
- (*next-message* false))
- (bind-condition-handler (list condition-type:editor-error)
- editor-error-handler
- start-next-command)))))
+(define (abort-current-command #!optional input)
+ (keyboard-macro-disable)
+ (if (or (default-object? input) (not input))
+ (*command-continuation* 'ABORT)
+ (within-continuation *command-continuation*
+ (lambda ()
+ (cond ((input-event? input)
+ (apply-input-event input))
+ ((command? input)
+ (execute-command input))
+ (else
+ (execute-key (current-comtabs) input)))
+ 'ABORT))))
+
+(define-structure (input-event
+ (constructor %make-input-event)
+ (conc-name input-event/))
+ (operator false read-only true)
+ (operands false read-only true))
- (define (start-next-command)
- (reset-command-state!)
- (if (queue-empty? command-reader-override-queue)
- (let ((key (with-editor-interrupts-disabled keyboard-read)))
- (set! *command-key* key)
- (clear-message)
- (set-command-prompt!
- (if (not (command-argument))
- (key-name key)
- (string-append-separated (command-argument-prompt)
- (key-name key))))
- (let ((window (current-window)))
- (%dispatch-on-command window
- (comtab-entry (buffer-comtabs
- (window-buffer window))
- key)
- false)))
- ((dequeue! command-reader-override-queue)))
- (start-next-command))
+(define (make-input-event operator . operands)
+ (%make-input-event operator operands))
+(define (apply-input-event input-event)
+ (if (not (input-event? input-event))
+ (error:wrong-type-argument input-event "input event" apply-input-event))
+ (clear-message)
+ (reset-command-state!)
+ (apply (input-event/operator input-event)
+ (input-event/operands input-event)))
+\f
+(define (command-reader #!optional initialization)
(fluid-let ((*last-command* false)
+ (*command* false)
(*command-argument*)
+ (*next-argument* false)
(*command-message*)
- (*non-undo-count* 0))
- (if (and (not (default-object? initialization)) initialization)
- (with-command-variables
- (lambda ()
- (reset-command-state!)
- (initialization))))
- (command-reader-loop)))
+ (*next-message* false)
+ (*non-undo-count* 0)
+ (*command-key* false)
+ (*command-continuation*))
+ (bind-condition-handler (list condition-type:editor-error)
+ editor-error-handler
+ (lambda ()
+ (if (and (not (default-object? initialization)) initialization)
+ (call-with-current-continuation
+ (lambda (continuation)
+ (set! *command-continuation* continuation)
+ (reset-command-state!)
+ (initialization))))
+ (do () (false)
+ (call-with-current-continuation
+ (lambda (continuation)
+ (set! *command-continuation* continuation)
+ (do () (false)
+ (reset-command-state!)
+ (if (queue-empty? command-reader-override-queue)
+ (let ((input
+ (with-editor-interrupts-disabled keyboard-read)))
+ (if (input-event? input)
+ (apply-input-event input)
+ (begin
+ (set! *command-key* input)
+ (clear-message)
+ (set-command-prompt!
+ (if (not (command-argument))
+ (key-name input)
+ (string-append-separated
+ (command-argument-prompt)
+ (key-name input))))
+ (let ((window (current-window)))
+ (%dispatch-on-command
+ window
+ (comtab-entry (buffer-comtabs
+ (window-buffer window))
+ input)
+ false)))))
+ ((dequeue! command-reader-override-queue)))))))))))
(define (reset-command-state!)
(set! *last-command* *command*)
(if *defining-keyboard-macro?*
(keyboard-macro-finalize-keys)))
\f
-(define (abort-current-command #!optional value)
- (keyboard-macro-disable)
- (*command-continuation* (if (default-object? value) 'ABORT value)))
-
(define-integrable (current-command-key)
*command-key*)
(reset-command-state!)
(%dispatch-on-command (current-window) command false))
+(define (execute-button-command screen button x y)
+ (send (screen-root-window screen) ':button-event! button x y))
+
(define (read-and-dispatch-on-key)
(dispatch-on-key (current-comtabs)
(with-editor-interrupts-disabled keyboard-read)))
(define (dispatch-on-key comtab key)
- (set! *command-key* key)
- (set-command-prompt!
- (string-append-separated (command-argument-prompt) (xkey->name key)))
- (%dispatch-on-command (current-window) (comtab-entry comtab key) false))
+ (if (input-event? key)
+ (apply-input-event key)
+ (begin
+ (set! *command-key* key)
+ (set-command-prompt!
+ (string-append-separated (command-argument-prompt) (xkey->name key)))
+ (%dispatch-on-command (current-window)
+ (comtab-entry comtab key)
+ false))))
(define (dispatch-on-command command #!optional record?)
(%dispatch-on-command (current-window)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/curren.scm,v 1.98 1992/02/12 23:52:51 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/curren.scm,v 1.99 1992/02/17 22:08:43 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
(define (delete-screen! screen)
(without-interrupts
(lambda ()
- (if (selected-screen? screen)
- (select-screen
- (or (other-screen screen false)
- (other-screen screen true)
- (error "Can't delete only screen:" screen))))
- (screen-discard! screen)
- (set-editor-screens! current-editor
- (delq! screen
- (editor-screens current-editor))))))
+ (let ((other (other-screen screen true)))
+ (if other
+ (begin
+ (if (selected-screen? screen)
+ (select-screen (or (other-screen screen false) other)))
+ (screen-discard! screen)
+ (set-editor-screens! current-editor
+ (delq! screen
+ (editor-screens current-editor))))
+ (save-buffers-kill-edwin))))))
(define (select-screen screen)
(without-interrupts
(define (with-selected-buffer buffer thunk)
(let ((old-buffer))
- (unwind-protect (lambda ()
- (let ((window (current-window)))
- (set! old-buffer (window-buffer window))
- (if (buffer-alive? buffer)
- (set-window-buffer! window buffer true)))
- (set! buffer)
- unspecific)
- thunk
- (lambda ()
+ (dynamic-wind (lambda ()
+ (let ((window (current-window)))
+ (set! old-buffer (window-buffer window))
+ (if (buffer-alive? buffer)
+ (set-window-buffer! window buffer true)))
+ (set! buffer)
+ unspecific)
+ thunk
+ (lambda ()
+ (let ((window (current-window)))
+ (set! buffer (window-buffer window))
(if (buffer-alive? old-buffer)
- (set-window-buffer! (current-window)
- old-buffer
- true))))))
+ (set-window-buffer! window old-buffer true)))
+ (set! old-buffer)
+ unspecific))))
(define (current-process)
(let ((process (get-buffer-process (current-buffer))))
(define (with-current-point point thunk)
(let ((old-point))
- (unwind-protect (lambda ()
- (let ((window (current-window)))
- (set! old-point (window-point window))
- (set-window-point! window point))
- (set! point)
- unspecific)
- thunk
- (lambda ()
- (set-window-point! (current-window) old-point)))))
+ (dynamic-wind (lambda ()
+ (let ((window (current-window)))
+ (set! old-point (window-point window))
+ (set-window-point! window point))
+ (set! point)
+ unspecific)
+ thunk
+ (lambda ()
+ (let ((window (current-window)))
+ (set! point (window-point window))
+ (set-window-point! window old-point))
+ (set! old-point)
+ unspecific))))
(define (current-column)
(mark-column (current-point)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.76 1992/02/12 06:40:22 arthur Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.77 1992/02/17 22:09:04 cph Exp $
Copyright (c) 1989-92 Massachusetts Institute of Technology
"pasmod"
"tximod"
"manual" ; man page display
- "print") ; printer output
+ "print" ; printer output
+ "notify") ; mode line notifications
(parent ())
(import (runtime rep)
hook/repl-eval)
(parent (edwin))
(export (edwin)
abort-current-command
+ apply-input-event
auto-argument-mode?
command-argument
command-history-list
command-message-receive
command-reader
- command-reader/reset-and-execute
current-command
current-command-key
dispatch-on-key
dispatch-on-command
+ execute-button-command
execute-key
execute-command
execute-command-history-entry
initialize-command-reader!
+ input-event?
keyboard-keys-read
last-command
last-command-key
+ make-input-event
override-next-command!
read-and-dispatch-on-key
set-command-argument!
set-command-message!
set-current-command!
- top-level-command-reader)
- (export (edwin inferior-repl)
- command-reader-reset-continuation))
+ top-level-command-reader))
(define-package (edwin keyboard)
(files "input")
initialize-typeout!
keyboard-read
keyboard-peek
+ keyboard-peek-no-hang
keyboard-read-char
message
message-args->string
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/input.scm,v 1.91 1992/02/04 04:03:08 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/input.scm,v 1.92 1992/02/17 22:09:14 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
(define (keyboard-peek)
(if *executing-keyboard-macro?*
(keyboard-macro-peek-key)
- (keyboard-read-1 (editor-peek-char current-editor))))
+ (keyboard-read-1 (editor-peek current-editor))))
(define (keyboard-read)
(set! keyboard-keys-read (1+ keyboard-keys-read))
(if *executing-keyboard-macro?*
(keyboard-macro-read-key)
- (let ((key (keyboard-read-1 (editor-read-char current-editor))))
+ (let ((key (keyboard-read-1 (editor-read current-editor))))
(set! auto-save-keystroke-count (fix:+ auto-save-keystroke-count 1))
(ring-push! (current-char-history) key)
(if *defining-keyboard-macro?* (keyboard-macro-write-key key))
key)))
+(define (keyboard-peek-no-hang)
+ ((editor-peek-no-hang current-editor)))
+
(define (keyboard-read-char)
(let loop ((key (keyboard-read)))
(if (char? key)
(define read-key-timeout/fast 500)
(define read-key-timeout/slow 2000)
-(define (keyboard-read-1 read-key)
+(define (keyboard-read-1 reader)
(remap-alias-key
- (let ((char-ready? (editor-char-ready? current-editor)))
- (if (not (char-ready?))
+ (let ((peek-no-hang (editor-peek-no-hang current-editor)))
+ (if (not (peek-no-hang))
(begin
- (update-screens! false)
(if (let ((interval (ref-variable auto-save-interval))
(count auto-save-keystroke-count))
(and (fix:> count 20)
(> count interval)))
(begin
(do-auto-save)
- (set! auto-save-keystroke-count 0)))))
+ (set! auto-save-keystroke-count 0)))
+ (update-screens! false)))
(let ((wait
(lambda (timeout)
(let ((t (+ (real-time-clock) timeout)))
(let loop ()
- (cond ((char-ready?) false)
+ (cond ((peek-no-hang) false)
((>= (real-time-clock) t) true)
(else (loop))))))))
;; Perform the appropriate juggling of the minibuffer message.
(set! command-prompt-displayed? true)
(set-current-message! command-prompt-string))
(clear-current-message!)))))
- (read-key))))
\ No newline at end of file
+ (reader))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/iserch.scm,v 1.16 1992/02/04 04:03:19 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/iserch.scm,v 1.17 1992/02/17 22:09:23 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
(let ((point (window-point window))
(y-point (window-point-y window)))
(let ((result
- (unwind-protect
- false
+ (dynamic-wind
+ (lambda () unspecific)
(lambda ()
(with-editor-interrupts-disabled
(lambda ()
(if result (execute-key (current-comtabs) result))))))))
(define (isearch-loop state)
- (if (not ((editor-char-ready? current-editor)))
+ (if (not (keyboard-peek-no-hang))
(begin
(set-current-point! (search-state-point state))
(message (search-state-message state))))
- (let ((char (keyboard-read-char)))
+ (let ((char (keyboard-read)))
(let ((test-for
(lambda (char*)
(char=? char (remap-alias-key char*)))))
- (cond ((test-for (ref-variable search-quote-char))
- (isearch-append-char
- state
- (prompt-for-typein
- (string-append (search-state-message state) "^Q")
- false
- keyboard-read-char)))
+ (cond ((not (char? char))
+ (isearch-exit state)
+ char)
+ ((test-for (ref-variable search-quote-char))
+ (let ((char
+ (prompt-for-typein
+ (string-append (search-state-message state) "^Q")
+ false
+ keyboard-read)))
+ (if (char? char)
+ (isearch-append-char state char)
+ (begin
+ (isearch-exit state)
+ char))))
((test-for (ref-variable search-exit-char))
(if (string-null? (search-state-text state))
(nonincremental-search (search-state-forward? state)
(isearch-append-char state char))))))
\f
(define (nonincremental-search forward? regexp?)
- (cond ((let ((key (remap-alias-key (ref-variable search-yank-word-char))))
- (and (char? key)
- (char=?
- key
- (prompt-for-typein
- (if regexp?
- (prompt-for-string/prompt
- (if forward? "RE search" "RE search backward")
- (write-to-string (ref-variable search-last-regexp)))
- (prompt-for-string/prompt
- (if forward? "Search" "Search backward")
- (write-to-string (ref-variable search-last-string))))
- false
- (lambda () (keyboard-peek))))))
- (if forward?
- (ref-command-object word-search-forward)
- (ref-command-object word-search-backward)))
- (regexp?
- (if forward?
- (ref-command-object re-search-forward)
- (ref-command-object re-search-backward)))
- (else
- (if forward?
- (ref-command-object search-forward)
- (ref-command-object search-backward)))))
+ (let ((yank-word (remap-alias-key (ref-variable search-yank-word-char)))
+ (not-word-search
+ (lambda ()
+ (if regexp?
+ (if forward?
+ (ref-command-object re-search-forward)
+ (ref-command-object re-search-backward))
+ (if forward?
+ (ref-command-object search-forward)
+ (ref-command-object search-backward))))))
+ (if (char? yank-word)
+ (let ((char
+ (prompt-for-typein
+ (if regexp?
+ (prompt-for-string/prompt
+ (if forward? "RE search" "RE search backward")
+ (write-to-string (ref-variable search-last-regexp)))
+ (prompt-for-string/prompt
+ (if forward? "Search" "Search backward")
+ (write-to-string (ref-variable search-last-string))))
+ false
+ keyboard-peek)))
+ (cond ((not (char? char))
+ char)
+ ((char=? yank-word char)
+ (if forward?
+ (ref-command-object word-search-forward)
+ (ref-command-object word-search-backward)))
+ (else
+ (not-word-search))))
+ (not-word-search))))
(define (isearch-append-char state char)
(isearch-append-string state (string char)))
initial-point))))))
(define (perform-search forward? regexp? text start)
- (call-with-protected-continuation
+ (call-with-current-continuation
(lambda (continuation)
(bind-condition-handler (list condition-type:re-compile-pattern)
(lambda (condition)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/kmacro.scm,v 1.36 1992/02/04 04:03:23 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/kmacro.scm,v 1.37 1992/02/17 22:09:31 cph Exp $
;;;
;;; Copyright (c) 1985, 1989-92 Massachusetts Institute of Technology
;;;
(define (with-keyboard-macro-disabled thunk)
(fluid-let ((*executing-keyboard-macro?* false)
(*defining-keyboard-macro?* false))
- (unwind-protect keyboard-macro-event
- thunk
- keyboard-macro-event)))
+ (dynamic-wind keyboard-macro-event
+ thunk
+ keyboard-macro-event)))
(define (keyboard-macro-disable)
(set! *defining-keyboard-macro?* false)
(*keyboard-macro-continuation*))
(define (loop n)
(set! *keyboard-macro-position* *macro)
- (if (call-with-protected-continuation
+ (if (call-with-current-continuation
(lambda (c)
(set! *keyboard-macro-continuation* c)
(command-reader)))
(lambda ()
(set-command-prompt!
"Proceed with macro? (Space, DEL, C-d, C-r or C-l)")
- (keyboard-read-char)))))
+ (keyboard-read)))))
(let ((test-for
(lambda (char*)
(char=? char (remap-alias-key char*)))))
- (cond ((test-for #\space)
+ (cond ((input-event? char)
+ (abort-current-command char))
+ ((not (char? char))
+ (editor-beep)
+ (loop))
+ ((test-for #\space)
unspecific)
((test-for #\rubout)
(*keyboard-macro-continuation* true))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/prompt.scm,v 1.152 1992/02/04 04:03:38 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/prompt.scm,v 1.153 1992/02/17 22:09:37 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
(define (within-typein-edit thunk)
(let ((value
- (call-with-protected-continuation
+ (call-with-current-continuation
(lambda (continuation)
(fluid-let ((typein-edit-continuation continuation)
(typein-edit-depth (1+ typein-edit-depth))
(typein-saved-windows
(cons (current-window)
typein-saved-windows)))
- (unwind-protect
- false
+ (dynamic-wind
+ (lambda () unspecific)
(lambda ()
(let ((window (typein-window)))
(select-window window)
(define (temporary-typein-message string)
(let ((point) (start) (end))
- (unwind-protect (lambda ()
- (set! point (current-point))
- (set! end (buffer-end (current-buffer)))
- (set! start (mark-right-inserting end))
- unspecific)
- (lambda ()
- (insert-string string start)
- (set-current-point! start)
- (sit-for 2000))
- (lambda ()
- (delete-string start end)
- (set-current-point! point)))))
+ (dynamic-wind (lambda ()
+ (set! point (current-point))
+ (set! end (buffer-end (current-buffer)))
+ (set! start (mark-right-inserting end))
+ unspecific)
+ (lambda ()
+ (insert-string string start)
+ (set-current-point! start)
+ (sit-for 2000))
+ (lambda ()
+ (delete-string start end)
+ (set-current-point! point)))))
\f
;;;; Character Prompts
(define (prompt-for-char prompt)
- (with-editor-interrupts-disabled
- (lambda ()
- (prompt-for-typein (string-append prompt ": ") false
- (lambda ()
- (let ((key (keyboard-read)))
- (if (not (and (char? key)
- (char-ascii? key)))
- (editor-error "Not an ASCII character" key))
- (set-typein-string! (key-name key) true)
- key))))))
+ (let ((input
+ (prompt-for-typein (string-append prompt ": ") false
+ (lambda ()
+ (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)))))
(define (prompt-for-key prompt #!optional comtab)
(let ((comtab (if (default-object? comtab) (current-comtabs) comtab)))
(prompt-for-typein (string-append prompt ": ") false
(lambda ()
- (with-editor-interrupts-disabled
- (lambda ()
- (let outer-loop ((prefix '()))
- (let inner-loop ((char (keyboard-read)))
- (let ((chars (append! prefix (list char))))
- (set-typein-string! (xkey->name chars) true)
- (if (prefix-key-list? comtab chars)
- (outer-loop chars)
- (let ((command (comtab-entry comtab chars)))
- (if (memq command extension-commands)
- (inner-loop
- (fluid-let ((execute-extended-keys? false))
- (dispatch-on-command command)))
- chars))))))))))))
+ (let outer-loop ((prefix '()))
+ (let inner-loop
+ ((char (with-editor-interrupts-disabled keyboard-read)))
+ (if (input-event? char)
+ (within-continuation typein-edit-continuation
+ (lambda ()
+ (abort-current-command char))))
+ (let ((chars (append! prefix (list char))))
+ (set-typein-string! (xkey->name chars) true)
+ (if (prefix-key-list? comtab chars)
+ (outer-loop chars)
+ (let ((command (comtab-entry comtab chars)))
+ (if (memq command extension-commands)
+ (inner-loop
+ (fluid-let ((execute-extended-keys? false))
+ (dispatch-on-command command)))
+ chars))))))))))
\f
;;;; Confirmation Prompts
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/simple.scm,v 1.40 1991/11/26 07:58:17 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/simple.scm,v 1.41 1992/02/17 22:09:45 cph Exp $
;;;
-;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology
+;;; Copyright (c) 1985, 1989-92 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(cond (*executing-keyboard-macro?* unspecific)
((not mark) (editor-beep))
((window-mark-visible? (current-window) mark)
- (if (not ((editor-char-ready? current-editor)))
+ (if (not (keyboard-peek-no-hang))
(with-current-point mark
(lambda ()
(sit-for 500)))))
(else (extract-string start end))))))))
(define (sit-for interval)
- (let ((time-limit (+ (real-time-clock) interval))
- (char-ready? (editor-char-ready? current-editor)))
- (if (not (char-ready?))
+ (let ((time-limit (+ (real-time-clock) interval)))
+ (if (not (keyboard-peek-no-hang))
(begin
(update-screens! false)
(let loop ()
- (if (and (not (char-ready?))
+ (if (and (not (keyboard-peek-no-hang))
(< (real-time-clock) time-limit))
(loop)))))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tterm.scm,v 1.11 1992/02/12 12:06:31 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tterm.scm,v 1.12 1992/02/17 22:09:51 cph Exp $
Copyright (c) 1990-92 Massachusetts Institute of Technology
(if transcript-port
(output-port/write-substring
transcript-port string 0 n))
- true)
+ (string-ref string 0))
((or (fix:= n event:process-output)
(fix:= n event:process-status))
(maybe-process-changes n))
(or pending-event
(fix:< start end)
(fill-buffer 'NO-PROCESSING)))
- (lambda () ;char-ready?
+ (lambda () ;peek-no-hang
(if pending-event (process-pending-event))
(or (fix:< start end)
(fill-buffer 'NONBLOCKING)))
- (lambda () ;peek-char
+ (lambda () ;peek
(if pending-event (process-pending-event))
(if (not (fix:< start end)) (fill-buffer 'BLOCKING))
(string-ref string start))
- (lambda () ;read-char
+ (lambda () ;read
(if pending-event (process-pending-event))
(if (not (fix:< start end)) (fill-buffer 'BLOCKING))
(let ((char (string-ref string start)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.27 1992/02/11 19:01:23 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.28 1992/02/17 22:09:58 cph Exp $
;;;
;;; Copyright (c) 1989-92 Massachusetts Institute of Technology
;;;
(loop (cdr screens))))))
\f
(define (xterm-screen/wrap-update! screen thunk)
- (unwind-protect
+ (dynamic-wind
(lambda ()
(xterm-enable-cursor (screen-xterm screen) false))
thunk
(define (get-xterm-input-operations)
(let ((display x-display-data)
(queue x-display-events)
- (pending-key false)
+ (pending-result false)
(string false)
(start 0)
(end 0)
(set! end (string-length string))
(set! start end)
(cond ((fix:= end 0)
- (set! pending-key
- (x-make-special-key (vector-ref event 4)
- (vector-ref event 3)))
- true)
+ (x-make-special-key (vector-ref event 4)
+ (vector-ref event 3)))
((fix:= end 1)
(let ((char
(if (or (fix:= (vector-ref event 3) 0)
(fix:andc (vector-ref event 3) 2)))))
(if (and signal-interrupts? (char=? char #\BEL))
(begin
- (set! pending-key false)
(signal-interrupt!)
false)
- (begin
- (set! pending-key char)
- true))))
+ char)))
(else
- (set! start 0)
- (set! pending-key false)
- (if signal-interrupts?
- (let ((i (string-find-previous-char string #\BEL)))
- (if i
- (begin
- (set! start (fix:+ i 1))
- (signal-interrupt!)
- (fix:< start end))
- true))
- true))))))
- (let ((read-until-key
+ (let ((i
+ (and signal-interrupts?
+ (string-find-previous-char string #\BEL))))
+ (if i
+ (begin
+ (set! start (fix:+ i 1))
+ (signal-interrupt!)
+ (and (fix:< start end)
+ (let ((result (string-ref string start)))
+ (set! start (fix:+ start 1))
+ result)))
+ (begin
+ (set! start 1)
+ (string-ref string 0)))))))))
+ (let ((read-until-result
(lambda (time-limit)
(let loop ()
(let ((event (get-next-event time-limit)))
((fix:= event-type:key-press (vector-ref event 0))
(or (process-key-press-event event) (loop)))
(else
- (process-special-event event)
- (loop))))))))
+ (or (process-special-event event) (loop)))))))))
(values
(lambda () ;halt-update?
- (or pending-key
+ (or pending-result
(fix:< start end)
pending-event
- (let ((event (get-next-event 0)))
+ (let ((event (read-event queue display 0)))
(if event (set! pending-event event))
event)))
- (lambda () ;char-ready?
- (or pending-key
+ (lambda () ;peek-no-hang
+ (or pending-result
(fix:< start end)
- (read-until-key 0)))
- (letrec ((peek-char
- (lambda ()
- (or pending-key
- (if (fix:< start end)
- (string-ref string start)
- (begin
- (read-until-key false)
- (peek-char)))))))
- peek-char)
- (letrec ((read-char
- (lambda ()
- (cond (pending-key
- => (lambda (key)
- (set! pending-key false)
- key))
- ((fix:< start end)
- (let ((char (string-ref string start)))
- (set! start (fix:+ start 1))
- char))
- (else
- (read-until-key false)
- (read-char))))))
- read-char))))))
+ (let ((result (read-until-result 0)))
+ (if result
+ (set! pending-result result))
+ result)))
+ (lambda () ;peek
+ (or pending-result
+ (if (fix:< start end)
+ (string-ref string start)
+ (let ((result (read-until-result false)))
+ (if result
+ (set! pending-result result))
+ result))))
+ (lambda () ;read
+ (cond (pending-result
+ => (lambda (key)
+ (set! pending-result false)
+ key))
+ ((fix:< start end)
+ (let ((char (string-ref string start)))
+ (set! start (fix:+ start 1))
+ char))
+ (else
+ (read-until-result false)))))))))
\f
(define (read-event queue display time-limit)
- (unwind-protect
+ (dynamic-wind
(lambda ()
(lock-thread-mutex event-stream-mutex))
(lambda ()
(if inferior-thread-changes? event (loop)))
((and (vector? event)
(fix:= (vector-ref event 0) event-type:expose))
- (process-expose-event event)
+ (xterm-dump-rectangle (vector-ref event 1)
+ (vector-ref event 2)
+ (vector-ref event 3)
+ (vector-ref event 4)
+ (vector-ref event 5))
(loop))
(else event)))))
(lambda ()
(error "Illegal change event:" event)))
(update-screens! false)))
-(define (process-expose-event event)
- (xterm-dump-rectangle (vector-ref event 1)
- (vector-ref event 2)
- (vector-ref event 3)
- (vector-ref event 4)
- (vector-ref event 5)))
-
(define (process-special-event event)
(let ((handler (vector-ref event-handlers (vector-ref event 0)))
(screen (xterm->screen (vector-ref event 1))))
- (if (and handler screen)
- (handler screen event))))
+ (and handler
+ screen
+ (handler screen event))))
(define event-handlers
(make-vector number-of-event-types false))
(= y-size (screen-y-size screen))))
(begin
(set-screen-size! screen x-size y-size)
- (update-screen! screen true)))))))
+ (update-screen! screen true)))))
+ false))
(define-event-handler event-type:button-down
(lambda (screen event)
(set! last-focus-time (vector-ref event 5))
(let ((xterm (screen-xterm screen)))
- (send (screen-root-window screen) ':button-event!
- (make-down-button (vector-ref event 4))
- (xterm-map-x-coordinate xterm (vector-ref event 2))
- (xterm-map-y-coordinate xterm (vector-ref event 3))))
- (update-screen! screen false)))
+ (make-input-event execute-button-command
+ screen
+ (make-down-button (vector-ref event 4))
+ (xterm-map-x-coordinate xterm (vector-ref event 2))
+ (xterm-map-y-coordinate xterm (vector-ref event 3))))))
(define-event-handler event-type:button-up
(lambda (screen event)
(set! last-focus-time (vector-ref event 5))
(let ((xterm (screen-xterm screen)))
- (send (screen-root-window screen) ':button-event!
- (make-up-button (vector-ref event 4))
- (xterm-map-x-coordinate xterm (vector-ref event 2))
- (xterm-map-y-coordinate xterm (vector-ref event 3))))
- (update-screen! screen false)))
-\f
+ (make-input-event execute-button-command
+ screen
+ (make-up-button (vector-ref event 4))
+ (xterm-map-x-coordinate xterm (vector-ref event 2))
+ (xterm-map-y-coordinate xterm (vector-ref event 3))))))
+
(define-event-handler event-type:focus-in
(lambda (screen event)
event
- (if (not (selected-screen? screen))
- (command-reader/reset-and-execute
- (lambda ()
- (select-screen screen))))))
+ (make-input-event select-screen screen)))
(define-event-handler event-type:delete-window
(lambda (screen event)
event
- (if (not (screen-deleted? screen))
- (if (other-screen screen true)
- (delete-screen! screen)
- (begin
- (save-buffers-kill-edwin)
- ;; Return here only if user changes mind about killing
- ;; editor. In that case, the screen will need updating.
- (update-screen! screen false))))))
+ (and (not (screen-deleted? screen))
+ (if (selected-screen? screen)
+ (make-input-event delete-screen! screen)
+ (begin
+ (delete-screen! screen)
+ false)))))
(define-event-handler event-type:map
(lambda (screen event)
(if (not (screen-deleted? screen))
(begin
(set-screen-visibility! screen 'VISIBLE)
- (update-screen! screen true)))))
+ (update-screen! screen true)))
+ false))
(define-event-handler event-type:unmap
(lambda (screen event)
event
- (if (not (screen-deleted? screen))
- (begin
- (set-screen-visibility! screen 'INVISIBLE)
- (if (selected-screen? screen)
- (let ((screen (other-screen screen false)))
- (if screen
- (select-screen screen))))))))
+ (and (not (screen-deleted? screen))
+ (begin
+ (set-screen-visibility! screen 'INVISIBLE)
+ (and (selected-screen? screen)
+ (let ((screen (other-screen screen false)))
+ (and screen
+ (make-input-event select-screen screen))))))))
(define-event-handler event-type:take-focus
(lambda (screen event)
(set! last-focus-time (vector-ref event 2))
- (select-screen screen)))
+ (make-input-event select-screen screen)))
\f
(define signal-interrupts?)
(define event-stream-mutex)
(define (with-signal-interrupts enabled? thunk)
(let ((old))
- (unwind-protect (lambda ()
- (set! old signal-interrupts?)
- (set! signal-interrupts? enabled?)
- unspecific)
- thunk
- (lambda ()
- (set! signal-interrupts? old)
- unspecific))))
+ (dynamic-wind (lambda ()
+ (set! old signal-interrupts?)
+ (set! signal-interrupts? enabled?)
+ unspecific)
+ thunk
+ (lambda ()
+ (set! enabled? signal-interrupts?)
+ (set! signal-interrupts? old)
+ unspecific))))
(define (signal-interrupt!)
(editor-beep)
projects / mit-scheme.git / commitdiff