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.

diff --git a/v7/src/edwin/comred.scm b/v7/src/edwin/comred.scm
index a61939511c8a14282f88127667dc9900fc210e23..cb1e902a3ce506bac07bde1c4e3fee1d534b8d6f 100644 (file)
--- 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)))
 \f
 (define (reset-command-state!)
   (set! *last-command* *command*)

diff --git a/v7/src/edwin/debug.scm b/v7/src/edwin/debug.scm
index 450e4e1f17bad93cca686d03bea5b0b7acd31f4c..8939199a6d02ac43db5a79eafb75493281de394c 100644 (file)
--- 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)
 \f

diff --git a/v7/src/edwin/editor.scm b/v7/src/edwin/editor.scm
index 048b70c9bb460cd82ecf1b7379c408881404bca9..e621779a67c18328ab66ffd59ef1f9fcf13f4b12 100644 (file)
--- 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))
 \f
 (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 b8ec1a53fbc2ec428465df569ecc3567752d5793..9a1b774624f92eb61380d6e4764a0e140bd68065 100644 (file)
--- 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 10e5d857c89fa43c367a579edba39d51dafc64dd..97cc806a891d3ba898719154f18e9c2be9fe7845 100644 (file)
--- 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)))