From 11a59aade9d36d36b010e5b7561b99e3d63a56cc Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 2 Aug 1993 23:54:26 +0000 Subject: [PATCH] Condition handlers can not invoke ABORT-CURRENT-COMMAND because the handler for that condition might have been bound inside of the binding for the condition being handled, and thus be unavailable at that time. This is fixed by introducing a restart, ABORT-EDITOR-COMMAND, and an associated procedure, RETURN-TO-COMMAND-LOOP. Condition handlers should invoke this restart rather than signalling the ABORT-CURRENT-COMMAND condition. --- v7/src/edwin/comred.scm | 108 ++++++++++++++++++++++------------------ v7/src/edwin/debug.scm | 6 +-- v7/src/edwin/editor.scm | 10 ++-- v7/src/edwin/edwin.pkg | 3 +- v7/src/edwin/evlcom.scm | 6 +-- 5 files changed, 70 insertions(+), 63 deletions(-) diff --git a/v7/src/edwin/comred.scm b/v7/src/edwin/comred.scm index a61939511..cb1e902a3 100644 --- a/v7/src/edwin/comred.scm +++ b/v7/src/edwin/comred.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: comred.scm,v 1.99 1993/08/02 03:06:32 cph Exp $ +;;; $Id: comred.scm,v 1.100 1993/08/02 23:54:16 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology ;;; @@ -69,9 +69,9 @@ (do ((init init #f)) (#f) (with-keyboard-macro-disabled (lambda () - (bind-abort-current-command #t - (lambda () - (command-reader init))))))) + (bind-condition-handler (list condition-type:abort-current-command) + handle-abort-condition + (lambda () (command-reader init))))))) (define (command-reader #!optional initialization) (fluid-let ((*last-command* false) @@ -85,54 +85,64 @@ (bind-condition-handler (list condition-type:editor-error) editor-error-handler (lambda () - (if (and (not (default-object? initialization)) initialization) - (bind-abort-current-command #f - (lambda () - (reset-command-state!) - (initialization)))) - (do () (false) - (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))))))))))) + (bind-condition-handler (list condition-type:abort-current-command) + (lambda (condition) + (if (not (condition/^G? condition)) + (handle-abort-condition condition))) + (lambda () + (if (and (not (default-object? initialization)) initialization) + (bind-abort-editor-command + (lambda () + (reset-command-state!) + (initialization)))) + (do () (false) + (bind-abort-editor-command + (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) +(define (bind-abort-editor-command 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) - (begin - (reset-command-state!) - (apply-input-event input))) - 'ABORT))))) - thunk)))) + (bind-restart 'ABORT-EDITOR-COMMAND "Return to the editor command loop." + (lambda (#!optional input) + (within-continuation continuation + (lambda () + (if (and (not (default-object? input)) (input-event? input)) + (begin + (reset-command-state!) + (apply-input-event input)))))) + (lambda (restart) restart (thunk)))))) + +(define (handle-abort-condition condition) + (return-to-command-loop (abort-current-command/input condition))) + +(define (return-to-command-loop input) + (let ((restart (find-restart 'ABORT-EDITOR-COMMAND))) + (if (not restart) (error "Missing ABORT-EDITOR-COMMAND restart.")) + (invoke-restart restart input))) (define (reset-command-state!) (set! *last-command* *command*) diff --git a/v7/src/edwin/debug.scm b/v7/src/edwin/debug.scm index 450e4e1f1..8939199a6 100644 --- a/v7/src/edwin/debug.scm +++ b/v7/src/edwin/debug.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/debug.scm,v 1.3 1992/08/20 22:21:33 cph Exp $ +;;; $Id: debug.scm,v 1.4 1993/08/02 23:54:19 cph Exp $ ;;; -;;; Copyright (c) 1992 Massachusetts Institute of Technology +;;; Copyright (c) 1992-93 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -768,7 +768,7 @@ Set this variable to #F to disable this abbreviation." (fluid-let ((starting-debugger? true)) (select-continuation-browser-buffer condition)) (message error-type-name " error"))) - (abort-current-command)))) + (return-to-command-loop #f)))) (define starting-debugger? false) diff --git a/v7/src/edwin/editor.scm b/v7/src/edwin/editor.scm index 048b70c9b..e621779a6 100644 --- a/v7/src/edwin/editor.scm +++ b/v7/src/edwin/editor.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: editor.scm,v 1.228 1993/08/02 03:06:32 cph Exp $ +;;; $Id: editor.scm,v 1.229 1993/08/02 23:54:22 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-1993 Massachusetts Institute of Technology ;;; @@ -290,7 +290,7 @@ with the contents of the startup message." (else (editor-beep) (message (condition/report-string condition)) - (abort-current-command)))) + (return-to-command-loop #f)))) (define-variable debug-on-internal-error "True means enter debugger if error is signalled while the editor is running. @@ -325,15 +325,11 @@ This does not affect editor errors or evaluation errors." (let ((strings (editor-error-strings condition))) (if (not (null? strings)) (apply message strings))) - (abort-current-command)))) + (return-to-command-loop #f)))) (define-variable debug-on-editor-error "True means signal Scheme error when an editor error occurs." false) - -(define (%editor-error) - (editor-beep) - (abort-current-command)) (define condition-type:abort-current-command (make-condition-type 'ABORT-CURRENT-COMMAND #f '(INPUT) diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index b8ec1a53f..9a1b77462 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edwin.pkg,v 1.122 1993/08/02 03:06:33 cph Exp $ +$Id: edwin.pkg,v 1.123 1993/08/02 23:54:24 cph Exp $ Copyright (c) 1989-1993 Massachusetts Institute of Technology @@ -423,6 +423,7 @@ MIT in each case. |# last-command-key override-next-command! read-and-dispatch-on-key + return-to-command-loop set-command-argument! set-command-message! set-current-command! diff --git a/v7/src/edwin/evlcom.scm b/v7/src/edwin/evlcom.scm index 10e5d857c..97cc806a8 100644 --- a/v7/src/edwin/evlcom.scm +++ b/v7/src/edwin/evlcom.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: evlcom.scm,v 1.41 1992/11/17 22:55:48 cph Exp $ +;;; $Id: evlcom.scm,v 1.42 1993/08/02 23:54:26 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 @@ -465,7 +465,7 @@ Set by Scheme evaluation code to update the mode line." (debug-scheme-error condition "evaluation") (begin (editor-beep) - (abort-current-command)))) + (return-to-command-loop #f)))) (define (default-report-error condition error-type-name) (let ((report-string (condition/report-string condition))) -- 2.25.1