;;; -*-Scheme-*-
;;;
-;;; $Id: comred.scm,v 1.98 1993/08/01 00:15:49 cph Exp $
+;;; $Id: comred.scm,v 1.99 1993/08/02 03:06:32 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
;;;
;;;; Command Reader
(declare (usual-integrations))
-\f
-(define *command-continuation*) ;Continuation of current command
+
(define *command-key*) ;Key read to find current command
(define *command*) ;The current command
(define *last-command*) ;The previous command, excluding arg commands
(set! command-history (make-circular-list command-history-limit false))
(set! command-reader-override-queue (make-queue))
unspecific)
-
-(define (top-level-command-reader initialization)
- (let loop ((initialization initialization))
+\f
+(define (top-level-command-reader init)
+ (do ((init init #f)) (#f)
(with-keyboard-macro-disabled
(lambda ()
- (intercept-^G-interrupts (lambda () unspecific)
+ (bind-abort-current-command #t
(lambda ()
- (command-reader initialization)))))
- (loop false)))
-
-(define (override-next-command! override)
- (enqueue! command-reader-override-queue override))
-
-(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)
- (reset-command-state!)
- (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/))
- (type false read-only true)
- (operator false read-only true)
- (operands false read-only true))
-
-(define (make-input-event type operator . operands)
- (%make-input-event type operator operands))
+ (command-reader init)))))))
-(define (apply-input-event input-event)
- (if (not (input-event? input-event))
- (error:wrong-type-argument input-event "input event" apply-input-event))
- (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-message*)
(*next-message* false)
(*non-undo-count* 0)
- (*command-key* false)
- (*command-continuation*))
+ (*command-key* false))
(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))))
+ (bind-abort-current-command #f
+ (lambda ()
+ (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)))
+ (bind-abort-current-command #f
+ (lambda ()
+ (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 (bind-abort-current-command handle-^G? thunk)
+ (call-with-current-continuation
+ (lambda (continuation)
+ (bind-condition-handler (list condition-type:abort-current-command)
+ (lambda (condition)
+ (if (or handle-^G? (not (condition/^G? condition)))
+ (let ((input (abort-current-command/input condition)))
+ (within-continuation continuation
+ (lambda ()
(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)))))))))))
-
+ (reset-command-state!)
+ (apply-input-event input)))
+ 'ABORT)))))
+ thunk))))
+\f
(define (reset-command-state!)
(set! *last-command* *command*)
(set! *command* false)
(reset-command-prompt!))
(if *defining-keyboard-macro?*
(keyboard-macro-finalize-keys)))
-\f
+
+(define (override-next-command! override)
+ (enqueue! command-reader-override-queue override))
+
(define-integrable (current-command-key)
*command-key*)
;;; -*-Scheme-*-
;;;
-;;; $Id: editor.scm,v 1.227 1993/04/27 09:22:26 cph Exp $
+;;; $Id: editor.scm,v 1.228 1993/08/02 03:06:32 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-1993 Massachusetts Institute of Technology
;;;
(editor-beep)
(abort-current-command))
\f
+(define condition-type:abort-current-command
+ (make-condition-type 'ABORT-CURRENT-COMMAND #f '(INPUT)
+ (lambda (condition port)
+ (write-string "Abort current command" port)
+ (let ((input (abort-current-command/input condition)))
+ (if input
+ (begin
+ (write-string " with input: " port)
+ (write input port))))
+ (write-string "." port))))
+
+(define condition/abort-current-command?
+ (condition-predicate condition-type:abort-current-command))
+
+(define abort-current-command/input
+ (condition-accessor condition-type:abort-current-command 'INPUT))
+
+(define abort-current-command
+ (let ((signaller
+ (condition-signaller condition-type:abort-current-command
+ '(INPUT)
+ standard-error-handler)))
+ (lambda (#!optional input)
+ (let ((input (if (default-object? input) #f input)))
+ (if (not (or (not input) (input-event? input)))
+ (error:wrong-type-argument input "input event"
+ 'ABORT-CURRENT-COMMAND))
+ (keyboard-macro-disable)
+ (signaller input)))))
+
+(define-structure (input-event
+ (constructor make-input-event (type operator . operands))
+ (conc-name input-event/))
+ (type false read-only true)
+ (operator false read-only true)
+ (operands false read-only true))
+
+(define (apply-input-event input-event)
+ (if (not (input-event? input-event))
+ (error:wrong-type-argument input-event "input event" apply-input-event))
+ (apply (input-event/operator input-event)
+ (input-event/operands input-event)))
+
+(define condition-type:^G
+ (make-condition-type '^G condition-type:abort-current-command '()
+ (lambda (condition port)
+ condition
+ (write-string "Signal editor ^G." port))))
+
+(define condition/^G?
+ (condition-predicate condition-type:^G))
+
+(define ^G-signal
+ (let ((signaller
+ (condition-signaller condition-type:^G
+ '(INPUT)
+ standard-error-handler)))
+ (lambda ()
+ (signaller #f))))
+\f
(define (quit-editor-and-signal-error condition)
(quit-editor-and (lambda () (error condition))))
(define (exit-scheme)
(within-continuation editor-abort %exit))
-(define (^G-signal)
- (let ((handler *^G-interrupt-handler*))
- (if handler
- (handler))))
-
-(define (intercept-^G-interrupts interceptor thunk)
- (let ((signal-tag "signal-tag"))
- (let ((value
- (call-with-current-continuation
- (lambda (continuation)
- (fluid-let ((*^G-interrupt-handler*
- (lambda () (continuation signal-tag))))
- (thunk))))))
- (if (eq? value signal-tag)
- (interceptor)
- value))))
-
(define call-with-protected-continuation
call-with-current-continuation)
(define (unwind-protect setup body cleanup)
(dynamic-wind (or setup (lambda () unspecific)) body cleanup))
-(define *^G-interrupt-handler* false)
-\f
(define (editor-grab-display editor receiver)
(display-type/with-display-grabbed (editor-display-type editor)
(lambda (with-display-ungrabbed operations)
(lambda (cmdl thunk)
cmdl
(with-editor-ungrabbed thunk)))
-
+\f
(define inferior-thread-changes?)
(define inferior-threads)
flags))
(define (inferior-thread-output! flags)
- (without-interrupts
- (lambda ()
- (set-car! flags true)
- (set! inferior-thread-changes? true)
- (signal-thread-event editor-thread #f))))
+ (without-interrupts (lambda () (inferior-thread-output!/unsafe flags))))
-(define (inferior-thread-output!/unsafe flags)
+(define-integrable (inferior-thread-output!/unsafe flags)
(set-car! flags true)
(set! inferior-thread-changes? true)
(signal-thread-event editor-thread #f))
(if (car flags)
(begin
(set-car! flags false)
- (or ((cdr flags)) output?))
+ (let ((result ((cdr flags))))
+ (if (eq? output? 'FORCE-RETURN)
+ output?
+ (or result output?))))
output?))
(begin
(if prev
#| -*-Scheme-*-
-$Id: edwin.pkg,v 1.121 1993/08/01 05:06:25 cph Exp $
+$Id: edwin.pkg,v 1.122 1993/08/02 03:06:33 cph Exp $
Copyright (c) 1989-1993 Massachusetts Institute of Technology
(parent (edwin))
(export (edwin)
abort-current-command
- apply-input-event
auto-argument-mode?
command-argument
command-history-list
execute-command
execute-command-history-entry
initialize-command-reader!
- input-event/operands
- input-event/operator
- input-event/type
- input-event?
keyboard-keys-read
last-command
last-command-key
- make-input-event
override-next-command!
read-and-dispatch-on-key
set-command-argument!
;;; -*-Scheme-*-
;;;
-;;; $Id: intmod.scm,v 1.58 1993/08/01 05:30:29 cph Exp $
+;;; $Id: intmod.scm,v 1.59 1993/08/02 03:06:34 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
;;;
(set-buffer-major-mode! buffer (ref-mode-object inferior-repl))
(if (ref-variable repl-mode-locked)
(buffer-put! buffer 'MAJOR-MODE-LOCKED true))
- (set-buffer-default-directory! buffer (working-directory-pathname))
(create-thread editor-thread-root-continuation
- (lambda ()
- (let ((thread (current-thread)))
- (detach-thread thread)
- (let ((port (make-interface-port buffer thread)))
- (attach-buffer-interface-port! buffer port)
- (with-input-from-port port
- (lambda ()
- (with-output-to-port port
- (lambda ()
- (repl/start (make-repl false
- port
- environment
- syntax-table
- false
- `((ERROR-DECISION
- ,error-decision))
- user-initial-prompt)
- message))))))))))
-
+ (lambda ()
+ (let ((port
+ (make-interface-port buffer
+ (let ((thread (current-thread)))
+ (detach-thread thread)
+ thread))))
+ (attach-buffer-interface-port! buffer port)
+ (with-input-from-port port
+ (lambda ()
+ (with-output-to-port port
+ (lambda ()
+ (fluid-let ((%exit inferior-repl/%exit)
+ (quit inferior-repl/quit))
+ (dynamic-wind
+ (lambda () unspecific)
+ (lambda ()
+ (repl/start (make-repl false
+ port
+ environment
+ syntax-table
+ false
+ `((ERROR-DECISION ,error-decision))
+ user-initial-prompt)
+ (make-init-message message)))
+ (lambda ()
+ (unwind-inferior-repl-buffer buffer))))))))))))
+
+(define (make-init-message message)
+ (if message
+ (cmdl-message/append cmdl-message/init-inferior message)
+ cmdl-message/init-inferior))
+
+(define cmdl-message/init-inferior
+ (cmdl-message/active
+ (lambda (port)
+ port
+ (set-working-directory-pathname!
+ (buffer-default-directory (port/buffer port))))))
+
+(define (inferior-repl/%exit #!optional integer)
+ (exit-current-thread (if (default-object? integer) 0 integer)))
+
+(define (inferior-repl/quit)
+ unspecific)
+\f
(define (current-repl-buffer)
(let ((buffer (current-repl-buffer*)))
(if (not buffer)
(define (initialize-inferior-repls!)
(set! repl-buffers '())
unspecific)
-\f
+
(define (wait-for-input port level mode)
(signal-thread-event editor-thread
(lambda ()
transcript?
(if (not (group-start? mark))
(guarantee-newlines 2 mark))
- (undo-boundary! mark))))
+ (undo-boundary! mark)
+ #t)))
(define (maybe-switch-modes! port mode)
(let ((buffer (port/buffer port)))
(define (kill-buffer-inferior-repl buffer)
(let ((port (buffer-interface-port buffer)))
(if port
+ (let ((thread (port/thread port)))
+ (if (not (thread-dead? thread))
+ (signal-thread-event thread
+ (lambda ()
+ (exit-current-thread unspecific))))))))
+
+(define (unwind-inferior-repl-buffer buffer)
+ (buffer-remove! buffer 'INTERFACE-PORT)
+ (let ((run-light (ref-variable-object run-light))
+ (evaluate-in-inferior-repl
+ (ref-variable evaluate-in-inferior-repl buffer)))
+ (if (and evaluate-in-inferior-repl
+ (eq? buffer (current-repl-buffer*)))
(begin
- (let ((thread (port/thread port)))
- (if (not (thread-dead? thread))
- (signal-thread-event thread
- (lambda ()
- (exit-current-thread unspecific)))))
- (buffer-remove! buffer 'INTERFACE-PORT)
- (let ((run-light (ref-variable-object run-light))
- (evaluate-in-inferior-repl
- (ref-variable evaluate-in-inferior-repl buffer)))
- (if (and evaluate-in-inferior-repl
- (eq? buffer (current-repl-buffer*)))
- (begin
- (set-variable-default-value! run-light false)
- (global-window-modeline-event!)))
- (set! repl-buffers (delq! buffer repl-buffers))
- (let ((buffer
- (and evaluate-in-inferior-repl
- (current-repl-buffer*))))
- (if buffer
- (let ((value (variable-local-value buffer run-light)))
- (undefine-variable-local-value! buffer run-light)
- (set-variable-default-value! run-light value)
- (global-window-modeline-event!)))))))))
+ (set-variable-default-value! run-light false)
+ (global-window-modeline-event!)))
+ (set! repl-buffers (delq! buffer repl-buffers))
+ (let ((buffer
+ (and evaluate-in-inferior-repl
+ (current-repl-buffer*))))
+ (if buffer
+ (let ((value (variable-local-value buffer run-light)))
+ (undefine-variable-local-value! buffer run-light)
+ (set-variable-default-value! run-light value)
+ (global-window-modeline-event!))))))
\f
(define (error-decision repl condition)
(if (ref-variable repl-error-decision)
(message "Evaluation error in "
(buffer-name (mark-buffer mark))
" buffer")
- (editor-beep)))))
+ (editor-beep)))
+ #t))
(let ((level (number->string (cmdl/level repl))))
(let loop ()
(fresh-line port)
mark
(if (not transcript?)
(start-continuation-browser port
- condition)))))
+ condition))
+ #t)))
((not (char-ci=? char #\q))
(beep port)
(loop))))))
"r"
(lambda (region)
(let ((buffer (mark-buffer (region-start region))))
- (ring-push! (port/input-ring (buffer-interface-port buffer))
- (region->string region))
+ (comint-record-input (port/input-ring (buffer-interface-port buffer))
+ (region->string region))
(inferior-repl-eval-region buffer region))))
\f
(define-command inferior-repl-debug
(define (operation/fresh-line port)
(enqueue-output-operation!
port
- (lambda (mark transcript?) transcript? (guarantee-newline mark))))
+ (lambda (mark transcript?) transcript? (guarantee-newline mark) #t)))
(define (operation/beep port)
(enqueue-output-operation!
port
- (lambda (mark transcript?) mark (if (not transcript?) (editor-beep)))))
+ (lambda (mark transcript?) mark (if (not transcript?) (editor-beep)) #t)))
(define (operation/x-size port)
(let ((buffer (port/buffer port)))
(let ((windows (buffer-windows buffer)))
(and (not (null? windows))
(apply min (map window-x-size windows)))))))
-
+\f
(define (enqueue-output-string! port string)
(let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
(set-port/output-strings! port (cons string (port/output-strings port)))
(let ((string (apply string-append (reverse! strings))))
(lambda (mark transcript?)
transcript?
- (region-insert-string! mark string)))))))
+ (region-insert-string! mark string)
+ #t))))))
(enqueue!/unsafe (port/output-queue port) operator)
(inferior-thread-output!/unsafe (port/output-registration port))
(set-interrupt-enables! interrupt-mask)
(define (process-output-queue port)
(let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))
- (mark (port/mark port)))
+ (mark (port/mark port))
+ (result #t))
(call-with-transcript-output-mark (port/buffer port)
(lambda (transcript-mark)
- (let loop ()
- (let ((operation (dequeue!/unsafe (port/output-queue port) false)))
- (if operation
- (begin
- (operation mark false)
- (if transcript-mark (operation transcript-mark true))
- (loop)))))
+ (let ((run-operation
+ (lambda (operation mark transcript?)
+ (let ((flag (operation mark transcript?)))
+ (if (eq? flag 'FORCE-RETURN)
+ (set! result flag)))
+ unspecific)))
+ (let loop ()
+ (let ((operation (dequeue!/unsafe (port/output-queue port) false)))
+ (if operation
+ (begin
+ (run-operation operation mark false)
+ (if transcript-mark
+ (run-operation operation transcript-mark true))
+ (loop))))))
(let ((strings (port/output-strings port)))
(if (not (null? strings))
(begin
(if transcript-mark
(region-insert-string! transcript-mark
(car strings)))))))))
- (set-interrupt-enables! interrupt-mask))
- true)
+ (set-interrupt-enables! interrupt-mask)
+ result))
\f
;;; Input operations
(wait-for-input port level (ref-mode-object inferior-repl))
(loop))
expression))))))
-\f
+
;;; Debugger
(define (operation/debugger-failure port string)
(if (not transcript?)
(begin
(message string)
- (editor-beep))))))
+ (editor-beep)))
+ #t)))
(define (operation/debugger-message port string)
(enqueue-output-operation!
port
- (lambda (mark transcript?) mark (if (not transcript?) (message string)))))
+ (lambda (mark transcript?)
+ mark
+ (if (not transcript?) (message string))
+ #t)))
(define (operation/debugger-presentation port thunk)
(fresh-line port)
(thunk))
-
+\f
;;; Prompting
(define (operation/prompt-for-expression port prompt)
(unsolicited-prompt port prompt-for-confirmation? prompt))
(define unsolicited-prompt
- (let ((unique (list false)))
+ (let ((wait-value (list false))
+ (abort-value (list false)))
(lambda (port procedure prompt)
- (let ((value unique))
+ (let ((value wait-value))
(signal-thread-event editor-thread
(lambda ()
- ;; This would be even better if it could notify the use
+ ;; This would be even better if it could notify the user
;; that the inferior REPL wanted some attention.
(when-buffer-selected (port/buffer port)
(lambda ()
- (override-next-command!
- (lambda ()
- (set! value (procedure prompt))
- (signal-thread-event (port/thread port) false)))))))
- (do () ((not (eq? value unique)))
- (suspend-current-thread))
- value))))
+ ;; We're using ENQUEUE-OUTPUT-OPERATION! here solely
+ ;; to force KEYBOARD-READ to exit so that the command
+ ;; reader loop will get control and notice the command
+ ;; override.
+ (enqueue-output-operation! port
+ (lambda (mark transcript?)
+ mark transcript?
+ (if (not transcript?)
+ (override-next-command!
+ (lambda ()
+ (let ((continue
+ (lambda (v)
+ (set! value v)
+ (signal-thread-event (port/thread port)
+ #f))))
+ (bind-condition-handler
+ (list condition-type:abort-current-command)
+ (lambda (condition)
+ (continue abort-value)
+ (signal-condition condition))
+ (lambda ()
+ (continue (procedure prompt))))))))
+ 'FORCE-RETURN))))))
+ (let loop ()
+ (cond ((eq? value wait-value) (suspend-current-thread) (loop))
+ ((eq? value abort-value) (abort->nearest))
+ (else value)))))))
(define (when-buffer-selected buffer thunk)
(if (current-buffer? buffer)
(if (not transcript?)
(begin
(set-buffer-default-directory! (mark-buffer mark) directory)
- (message (->namestring directory)))))))
+ (message (->namestring directory))))
+ #t)))
(define (operation/set-default-environment port environment)
(enqueue-output-operation! port
(if (not transcript?)
(define-variable-local-value! (mark-buffer mark)
(ref-variable-object scheme-environment)
- environment)))))
+ environment))
+ #t)))
(define (operation/set-default-syntax-table port syntax-table)
(enqueue-output-operation! port
(if (not transcript?)
(define-variable-local-value! (mark-buffer mark)
(ref-variable-object scheme-syntax-table)
- syntax-table)))))
+ syntax-table))
+ #t)))
(define interface-port-template
(make-i/o-port
;;; -*-Scheme-*-
;;;
-;;; $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 $
+;;; $Id: iserch.scm,v 1.18 1993/08/02 03:06:35 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
(lambda (condition)
(continuation (access-condition condition 'MESSAGE)))
(lambda ()
- (intercept-^G-interrupts (lambda () 'ABORT)
+ (bind-condition-handler (list condition-type:^G)
+ (lambda (condition) condition (continuation 'ABORT))
(lambda ()
(with-editor-interrupts-enabled
(lambda ()
;;; -*-Scheme-*-
;;;
-;;; $Id: process.scm,v 1.29 1993/04/27 09:22:31 cph Exp $
+;;; $Id: process.scm,v 1.30 1993/08/02 03:06:36 cph Exp $
;;;
;;; Copyright (c) 1991-93 Massachusetts Institute of Technology
;;;
(define (run-synchronous-process input-region output-mark directory pty?
program . arguments)
(let ((process false))
- (intercept-^g-interrupts
- (lambda ()
+ (bind-condition-handler (list condition-type:abort-current-command)
+ (lambda (condition)
(if (and process (not (eq? process 'DELETED)))
(begin
(subprocess-delete process)
(set! process 'DELETED)))
- (^G-signal))
+ (signal-condition condition))
(lambda ()
(set! process
(start-subprocess
;;; -*-Scheme-*-
;;;
-;;; $Id: prompt.scm,v 1.157 1993/08/01 00:15:58 cph Exp $
+;;; $Id: prompt.scm,v 1.158 1993/08/02 03:06:37 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
;;;
(select-window (car typein-saved-windows)))
((zero? typein-edit-depth)
(select-window (other-window)))))))))))
- (cond ((eq? value typein-edit-abort-flag)
- (abort-current-command))
+ (cond ((condition? value)
+ (signal-condition value))
((and (pair? value) (eq? (car value) typein-edit-abort-flag))
(abort-current-command (cdr value)))
(else
(with-text-clipped (mark-right-inserting mark)
(mark-left-inserting mark)
(lambda ()
- (intercept-^G-interrupts
- (lambda ()
- (cond ((not (eq? (current-window) (typein-window)))
- (abort-current-command))
- (typein-edit-continuation
- (typein-edit-continuation typein-edit-abort-flag))
- (else
- (error "illegal ^G signaled in typein window"))))
- thunk)))))))))
+ (bind-condition-handler (list condition-type:^G)
+ (lambda (condition)
+ (cond ((not (eq? (current-window) (typein-window)))
+ (signal-condition condition))
+ (typein-edit-continuation
+ (typein-edit-continuation condition))
+ (else
+ (error "illegal ^G signaled in typein window"))))
+ thunk)))))))))
(define ((typein-editor-thunk mode))
(let ((buffer (current-buffer)))
;;; -*-Scheme-*-
;;;
-;;; $Id: xterm.scm,v 1.40 1993/08/01 00:16:08 cph Exp $
+;;; $Id: xterm.scm,v 1.41 1993/08/02 03:06:38 cph Exp $
;;;
;;; Copyright (c) 1989-93 Massachusetts Institute of Technology
;;;
;; These constants must match "microcode/x11base.c"
(define-integrable event:process-output -2)
(define-integrable event:process-status -3)
-(define-integrable event:interrupt -4)
+(define-integrable event:inferior-thread-output -4)
(define-integrable event-type:button-down 0)
(define-integrable event-type:button-up 1)
(define-integrable event-type:configure 2)
(cond ((not event)
(error "#F returned from blocking read"))
((not (vector? event))
- (if (process-change-event event)
- (make-input-event 'UPDATE update-screens! #f)
- (loop)))
+ (let ((flag (process-change-event event)))
+ (if flag
+ (make-input-event
+ (if (eq? flag 'FORCE-RETURN)
+ 'RETURN
+ 'UPDATE)
+ update-screens!
+ #f)
+ (loop))))
(else
(or (process-event event) (loop)))))))))
(values
(define (read-event-1 display block?)
(or (x-display-process-events display 2)
(let loop ()
- (cond (inferior-thread-changes? event:interrupt)
+ (cond (inferior-thread-changes? event:inferior-thread-output)
((process-output-available?) event:process-output)
(else
(case (test-for-input-on-descriptor
(define (process-change-event event)
(cond ((fix:= event event:process-output) (accept-process-output))
((fix:= event event:process-status) (handle-process-status-changes))
- ((fix:= event event:interrupt) (accept-thread-output))
+ ((fix:= event event:inferior-thread-output) (accept-thread-output))
(else (error "Illegal change event:" event))))
(define (process-special-event event)
projects / mit-scheme.git / commitdiff