From eee277b4b87fcaf7800e6143efdbc5ab32bdaa4b Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 2 Aug 1993 03:06:38 +0000 Subject: [PATCH] * Change handling of ^G interrupts and of ABORT-CURRENT-COMMAND. Both now use the condition system; ^G conditions are a specialization of ABORT-CURRENT-COMMAND conditions. This change makes it easy to bind some action to occur when a command is aborted for whatever reason. Consequently, the procedure INTERCEPT-^G-INTERRUPTS has been deleted. * The inferior thread output mechanism has been modified to allow a thread to request that the editor exit the keyboard reader and return to the command reader. The request is phrased by the thread output procedure returning 'FORCE-RETURN. This new mechanism is used by the inferior REPL code to force the command reader to immediately execute a command override for an unsolicited prompt. * Aborting an unsolicited prompt causes the associated inferior thread to execute ABORT->NEAREST. * Inferior REPL buffers now initialize their working directory to the default directory of the selected buffer at the time the REPL buffer is created. * Inferior REPL buffers now have their own bindings of %EXIT and QUIT that affect only the inferior thread. In particular, %EXIT kills the inferior thread but leaves Scheme running; QUIT does nothing. --- v7/src/edwin/comred.scm | 134 ++++++++++------------- v7/src/edwin/editor.scm | 96 ++++++++++++----- v7/src/edwin/edwin.pkg | 8 +- v7/src/edwin/intmod.scm | 228 +++++++++++++++++++++++++-------------- v7/src/edwin/iserch.scm | 7 +- v7/src/edwin/process.scm | 8 +- v7/src/edwin/prompt.scm | 24 ++--- v7/src/edwin/xterm.scm | 20 ++-- 8 files changed, 306 insertions(+), 219 deletions(-) diff --git a/v7/src/edwin/comred.scm b/v7/src/edwin/comred.scm index 23da6f563..a61939511 100644 --- a/v7/src/edwin/comred.scm +++ b/v7/src/edwin/comred.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -45,8 +45,7 @@ ;;;; Command Reader (declare (usual-integrations)) - -(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 @@ -65,50 +64,15 @@ (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)) + +(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))) - (define (command-reader #!optional initialization) (fluid-let ((*last-command* false) (*command* false) @@ -117,46 +81,59 @@ (*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)))) + (define (reset-command-state!) (set! *last-command* *command*) (set! *command* false) @@ -169,7 +146,10 @@ (reset-command-prompt!)) (if *defining-keyboard-macro?* (keyboard-macro-finalize-keys))) - + +(define (override-next-command! override) + (enqueue! command-reader-override-queue override)) + (define-integrable (current-command-key) *command-key*) diff --git a/v7/src/edwin/editor.scm b/v7/src/edwin/editor.scm index 210cbb8d9..048b70c9b 100644 --- a/v7/src/edwin/editor.scm +++ b/v7/src/edwin/editor.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -335,6 +335,66 @@ This does not affect editor errors or evaluation errors." (editor-beep) (abort-current-command)) +(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)))) + (define (quit-editor-and-signal-error condition) (quit-editor-and (lambda () (error condition)))) @@ -359,31 +419,12 @@ This does not affect editor errors or evaluation errors." (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) - (define (editor-grab-display editor receiver) (display-type/with-display-grabbed (editor-display-type editor) (lambda (with-display-ungrabbed operations) @@ -412,7 +453,7 @@ This does not affect editor errors or evaluation errors." (lambda (cmdl thunk) cmdl (with-editor-ungrabbed thunk))) - + (define inferior-thread-changes?) (define inferior-threads) @@ -424,13 +465,9 @@ This does not affect editor errors or evaluation errors." 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)) @@ -454,7 +491,10 @@ This does not affect editor errors or evaluation errors." (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 diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index 8c37f9eb1..b8ec1a53f 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-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 @@ -404,7 +404,6 @@ MIT in each case. |# (parent (edwin)) (export (edwin) abort-current-command - apply-input-event auto-argument-mode? command-argument command-history-list @@ -419,14 +418,9 @@ MIT in each case. |# 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! diff --git a/v7/src/edwin/intmod.scm b/v7/src/edwin/intmod.scm index ab33477e3..151f72b32 100644 --- a/v7/src/edwin/intmod.scm +++ b/v7/src/edwin/intmod.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -94,27 +94,52 @@ REPL uses current evaluation environment." (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) + (define (current-repl-buffer) (let ((buffer (current-repl-buffer*))) (if (not buffer) @@ -134,7 +159,7 @@ REPL uses current evaluation environment." (define (initialize-inferior-repls!) (set! repl-buffers '()) unspecific) - + (define (wait-for-input port level mode) (signal-thread-event editor-thread (lambda () @@ -163,7 +188,8 @@ REPL uses current evaluation environment." 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))) @@ -212,30 +238,31 @@ REPL uses current evaluation environment." (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!)))))) (define (error-decision repl condition) (if (ref-variable repl-error-decision) @@ -250,7 +277,8 @@ REPL uses current evaluation environment." (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) @@ -267,7 +295,8 @@ REPL uses current evaluation environment." mark (if (not transcript?) (start-continuation-browser port - condition))))) + condition)) + #t))) ((not (char-ci=? char #\q)) (beep port) (loop)))))) @@ -405,8 +434,8 @@ Additionally, these commands abort the command 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)))) (define-command inferior-repl-debug @@ -634,12 +663,12 @@ If this is an error, the debugger examines the error condition." (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))) @@ -647,7 +676,7 @@ If this is an error, the debugger examines the error condition." (let ((windows (buffer-windows buffer))) (and (not (null? windows)) (apply min (map window-x-size windows))))))) - + (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))) @@ -666,7 +695,8 @@ If this is an error, the debugger examines the error condition." (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) @@ -674,16 +704,24 @@ If this is an error, the debugger examines the error condition." (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 @@ -694,8 +732,8 @@ If this is an error, the debugger examines the error condition." (if transcript-mark (region-insert-string! transcript-mark (car strings))))))))) - (set-interrupt-enables! interrupt-mask)) - true) + (set-interrupt-enables! interrupt-mask) + result)) ;;; Input operations @@ -720,7 +758,7 @@ If this is an error, the debugger examines the error condition." (wait-for-input port level (ref-mode-object inferior-repl)) (loop)) expression)))))) - + ;;; Debugger (define (operation/debugger-failure port string) @@ -730,17 +768,21 @@ If this is an error, the debugger examines the error condition." (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)) - + ;;; Prompting (define (operation/prompt-for-expression port prompt) @@ -750,22 +792,43 @@ If this is an error, the debugger examines the error condition." (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) @@ -807,7 +870,8 @@ If this is an error, the debugger examines the error condition." (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 @@ -815,7 +879,8 @@ If this is an error, the debugger examines the error condition." (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 @@ -823,7 +888,8 @@ If this is an error, the debugger examines the error condition." (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 diff --git a/v7/src/edwin/iserch.scm b/v7/src/edwin/iserch.scm index 4d4c32200..9b7fdb7a2 100644 --- a/v7/src/edwin/iserch.scm +++ b/v7/src/edwin/iserch.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -367,7 +367,8 @@ (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 () diff --git a/v7/src/edwin/process.scm b/v7/src/edwin/process.scm index 176c8dc98..716ce3c4e 100644 --- a/v7/src/edwin/process.scm +++ b/v7/src/edwin/process.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -514,13 +514,13 @@ after the listing is made.)" (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 diff --git a/v7/src/edwin/prompt.scm b/v7/src/edwin/prompt.scm index e2b846aea..56ad46af1 100644 --- a/v7/src/edwin/prompt.scm +++ b/v7/src/edwin/prompt.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -105,8 +105,8 @@ (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 @@ -149,15 +149,15 @@ (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))) diff --git a/v7/src/edwin/xterm.scm b/v7/src/edwin/xterm.scm index 73afb99cc..bc7505f3d 100644 --- a/v7/src/edwin/xterm.scm +++ b/v7/src/edwin/xterm.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -88,7 +88,7 @@ ;; 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) @@ -380,9 +380,15 @@ (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 @@ -437,7 +443,7 @@ (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 @@ -489,7 +495,7 @@ (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) -- 2.25.1