From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 8 May 2000 17:34:51 +0000 (+0000)
Subject: Add ability to specify "command suffixes" -- thunks that are executed
X-Git-Tag: 20090517-FFI~3916
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b4a0e11effcba041bb580662915c9191f17a688b;p=mit-scheme.git

Add ability to specify "command suffixes" -- thunks that are executed
when the current command ends.
---

diff --git a/v7/src/edwin/comred.scm b/v7/src/edwin/comred.scm
index d3b01c76e..609e34127 100644
--- a/v7/src/edwin/comred.scm
+++ b/v7/src/edwin/comred.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: comred.scm,v 1.117 2000/02/29 01:34:55 cph Exp $
+;;; $Id: comred.scm,v 1.118 2000/05/08 17:34:43 cph Exp $
 ;;;
 ;;; Copyright (c) 1986, 1989-2000 Massachusetts Institute of Technology
 ;;;
@@ -34,11 +34,13 @@
 (define command-history)
 (define command-history-limit 30)
 (define command-reader-override-queue)
+(define *command-suffixes*)
 
 (define (initialize-command-reader!)
   (set! keyboard-keys-read 0)
   (set! command-history (make-circular-list command-history-limit false))
   (set! command-reader-override-queue (make-queue))
+  (set! *command-suffixes* #f)
   unspecific)
 
 (define (top-level-command-reader init)
@@ -74,7 +76,7 @@
 	    (do () (false)
 	      (bind-abort-editor-command
 	       (lambda ()
-		 (do () (false)
+		 (do () (#f)
 		   (reset-command-state!)
 		   (if (queue-empty? command-reader-override-queue)
 		       (let ((input (get-next-keyboard-char)))
@@ -206,6 +208,19 @@
 	  (if (eq? history command-history)
 	      '()
 	      (loop history))))))
+
+(define (add-command-suffix! suffix)
+  (if *command-suffixes*
+      (enqueue! *command-suffixes* suffix)
+      (suffix)))
+
+(define (maybe-add-command-suffix! suffix)
+  (if *command-suffixes*
+      (without-interrupts
+       (lambda ()
+	 (if (not (queued?/unsafe *command-suffixes* suffix))
+	     (enqueue!/unsafe *command-suffixes* suffix))))
+      (suffix)))
 
 ;;; The procedures for executing commands come in two flavors.  The
 ;;; difference is that the EXECUTE-foo procedures reset the command
@@ -259,7 +274,16 @@
 	     (set! *non-undo-count* 0)
 	     (if (not *command-argument*)
 		 (undo-boundary! point))
-	     (apply procedure (interactive-arguments command record?)))))
+	     (fluid-let ((*command-suffixes* (make-queue)))
+	       (let ((v
+		      (apply procedure
+			     (interactive-arguments command record?))))
+		 (let loop ()
+		   (if (not (queue-empty? *command-suffixes*))
+		       (begin
+			 ((dequeue! *command-suffixes*))
+			 (loop))))
+		 v)))))
       (cond ((or *executing-keyboard-macro?* *command-argument*)
 	     (normal))
 	    ((and (char? *command-key*)
diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 8db30668b..834cde203 100644
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: edwin.pkg,v 1.255 2000/05/01 03:02:23 cph Exp $
+$Id: edwin.pkg,v 1.256 2000/05/08 17:34:51 cph Exp $
 
 Copyright (c) 1989-2000 Massachusetts Institute of Technology
 
@@ -398,6 +398,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (parent (edwin))
   (export (edwin)
 	  abort-current-command
+	  add-command-suffix!
 	  auto-argument-mode?
 	  command-argument
 	  command-history-list
@@ -415,6 +416,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	  keyboard-keys-read
 	  last-command
 	  last-command-key
+	  maybe-add-command-suffix!
 	  override-next-command!
 	  read-and-dispatch-on-key
 	  return-to-command-loop