From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 11 Aug 1989 11:50:55 +0000 (+0000)
Subject: * Arrange for local bindings of current buffer to be undone when
X-Git-Tag: 20090517-FFI~11841
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8ef982010f870201e83394fd87652aeba148a735;p=mit-scheme.git

* Arrange for local bindings of current buffer to be undone when
leaving the editor; this prevents the local bindings from becoming
global when (reset-editor) is done.  Perhaps it might be useful to
remember the original global binding, and reset each variable to that?

* Change the commands `list-buffers' and `buffer-menu' to accept a
prefix arg which limits their listings to buffers that are visiting
files.  Perhaps buffer-menu mode should define the g key as Dired
does?

* Change mouse button events to invoke commands in the normal way,
binding a `current-button-event' to tell the commands where the mouse
was when they occurred; this event defaults to the location of point
so that these commands make sense when invoked by other means.  Cause
the editor to beep and do nothing if a mouse button is not bound to
any command, and if the button is located in the "decoration" of some
editor window (i.e. the modeline or vertical border).

* Change `define-key' to accept command-names (or commands) as
arguments when defining mouse buttons.  Change `define-key',
`define-prefix-key', and `define-default-key' to accept mode objects
as well as mode-names.

* Add new commands:
	debug-clean-marks
	debug-show-standard-marks

* Change the buffer redisplay code so that buffer-cursor-y is set only
when a buffer is disconnected from a window.  Further, save point's
index with the coordinate, and ignore the information if point changes
before the information is used.

* Implement new operation `mark-temporary!', which removes a permanent
mark from the marks list.  Use this operation to get rid of the marks
used by buffer-windows when they are no longer in use.  In order for
this to work, change the buffer-window code so that it never passes
one of these marks to anyone.  The only user-visible change is to
replace the operations `window-start-mark' and `window-end-mark' with
`window-start-index' and `window-end-index'.

* Add new procedure `clean-group-marks!' to delete GC'ed marks from
the marks list.
---

diff --git a/v7/src/edwin/buffer.scm b/v7/src/edwin/buffer.scm
index c1a6b8d57..0c0a5090a 100644
--- a/v7/src/edwin/buffer.scm
+++ b/v7/src/edwin/buffer.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.134 1989/08/10 04:42:50 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.135 1989/08/11 11:49:53 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989 Massachusetts Institute of Technology
 ;;;
@@ -359,6 +359,25 @@ The buffer is guaranteed to be deselected at that time."
 	      (buffer-local-bindings buffer))
     (vector-set! buffer buffer-index:local-bindings '()))
   unspecific)
+
+(define (with-current-local-bindings! thunk)
+  (let ((wind-bindings
+	 (lambda (buffer)
+	   (for-each (lambda (binding)
+		       (let ((variable (car binding)))
+			 (let ((old-value (variable-value variable)))
+			   (%set-variable-value! variable (cdr binding))
+			   (set-cdr! binding old-value))))
+		     (buffer-local-bindings buffer)))))
+    (dynamic-wind
+     (lambda ()
+       (let ((buffer (current-buffer)))
+	 (wind-bindings buffer)
+	 (perform-buffer-initializations! buffer)))
+     thunk
+     (lambda ()
+       (wind-bindings (current-buffer))))))
+
 (define (change-local-bindings! old-buffer new-buffer select-buffer!)
   ;; Assumes that interrupts are disabled and that OLD-BUFFER is selected.
   (let ((variables '()))
diff --git a/v7/src/edwin/buffrm.scm b/v7/src/edwin/buffrm.scm
index ddbd9ccd9..343af46b3 100644
--- a/v7/src/edwin/buffrm.scm
+++ b/v7/src/edwin/buffrm.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffrm.scm,v 1.33 1989/08/08 10:05:25 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffrm.scm,v 1.34 1989/08/11 11:49:58 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989 Massachusetts Institute of Technology
 ;;;
@@ -242,14 +242,6 @@
     (maybe-recompute-image! window)
     (%window-scroll-y-relative! window delta)))
 
-(define-integrable (window-y-center frame)
-  (%window-y-center (frame-text-inferior frame)))
-
-(define (window-start-mark frame)
-  (let ((window (frame-text-inferior frame)))
-    (maybe-recompute-image! window)
-    (%window-start-mark window)))
-
 (define (set-window-start-mark! frame mark force?)
   (let ((window (frame-text-inferior frame)))
     (maybe-recompute-image! window)
@@ -257,10 +249,19 @@
 			     (clip-mark-to-display window mark)
 			     force?)))
 
-(define (window-end-mark frame)
+(define-integrable (window-y-center frame)
+  (%window-y-center (frame-text-inferior frame)))
+
+(define (window-start-index frame)
+  (let ((window (frame-text-inferior frame)))
+    (maybe-recompute-image! window)
+    (%window-start-index window)))
+
+(define (window-end-index frame)
   (let ((window (frame-text-inferior frame)))
     (maybe-recompute-image! window)
-    (%window-end-mark window)))
+    (%window-end-index window)))
+
 (define (window-mark-visible? frame mark)
   (let ((window (frame-text-inferior frame)))
     (maybe-recompute-image! window)
diff --git a/v7/src/edwin/bufmnu.scm b/v7/src/edwin/bufmnu.scm
index 457eba39a..f4d624438 100644
--- a/v7/src/edwin/bufmnu.scm
+++ b/v7/src/edwin/bufmnu.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufmnu.scm,v 1.110 1989/04/28 22:47:30 cph Rel $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufmnu.scm,v 1.111 1989/08/11 11:50:01 cph Rel $
 ;;;
 ;;;	Copyright (c) 1986, 1989 Massachusetts Institute of Technology
 ;;;
@@ -51,38 +51,51 @@
   false)
 
 (define-command list-buffers
-  "Display a list of names of existing buffers."
-  ()
-  (lambda ()
-    (pop-up-buffer (update-buffer-list) false)))
+  "Display a list of names of existing buffers.
+Inserts it in buffer *Buffer-List* and displays that.
+Note that buffers with names starting with spaces are omitted.
+Non-null optional arg FILES-ONLY? means mention only file buffers.
+
+The M column contains a * for buffers that are modified.
+The R column contains a % for buffers that are read-only."
+  "P"
+  (lambda (files-only?)
+    (pop-up-buffer (update-buffer-list files-only?) false)))
 
 (define-command buffer-menu
-  "Display a list of names of existing buffers."
-  ()
-  (lambda ()
-    (pop-up-buffer (update-buffer-list) true)
+  "Make a menu of buffers so you can save, delete or select them.
+With argument, show only buffers that are visiting files.
+Type ? after invocation to get help on commands available.
+Type q immediately to make the buffer menu go away."
+  "P"
+  (lambda (files-only?)
+    (pop-up-buffer (update-buffer-list files-only?) true)
     (message "Commands: d, s, x; 1, 2, m, u, q; rubout; ? for help.")))
 
-(define (update-buffer-list)
+(define (update-buffer-list files-only?)
   (let ((buffer (temporary-buffer "*Buffer-List*")))
     (set-buffer-major-mode! buffer (ref-mode-object buffer-menu))
+    (buffer-put! buffer 'REVERT-BUFFER-FILES-ONLY? files-only?)
     (buffer-put! buffer 'REVERT-BUFFER-METHOD revert-buffer-menu)
-    (fill-buffer-menu! buffer)
+    (fill-buffer-menu! buffer files-only?)
     buffer))
 
 (define (revert-buffer-menu buffer dont-use-auto-save? dont-confirm?)
   dont-use-auto-save? dont-confirm?	;ignore
   (set-buffer-writeable! buffer)
   (region-delete! (buffer-region buffer))
-  (fill-buffer-menu! buffer))
+  (fill-buffer-menu! buffer (buffer-get buffer 'REVERT-BUFFER-FILES-ONLY?)))
 
-(define (fill-buffer-menu! buffer)
+(define (fill-buffer-menu! buffer files-only?)
   (with-output-to-mark (buffer-point buffer)
     (lambda ()
       (write-string list-buffers-header)
       (let ((current (current-buffer)))
 	(for-each (lambda (buffer)
-		    (if (not (minibuffer? buffer))			(begin
+		    (if (not (or (minibuffer? buffer)
+				 (and files-only?
+				      (not (buffer-pathname buffer)))))
+			(begin
 			 (write-string
 			  (list-buffers-format
 			   (if (eq? buffer current) "." " ")
diff --git a/v7/src/edwin/bufwfs.scm b/v7/src/edwin/bufwfs.scm
index 10b66d37e..3563a04ca 100644
--- a/v7/src/edwin/bufwfs.scm
+++ b/v7/src/edwin/bufwfs.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwfs.scm,v 1.5 1989/04/28 22:47:49 cph Rel $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwfs.scm,v 1.6 1989/08/11 11:50:05 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989 Massachusetts Institute of Technology
 ;;;
@@ -172,7 +172,7 @@
 	 (%set-buffer-point! buffer (%window-coordinates->mark window 0 y))
 	 (set! point (buffer-point buffer))
 	 (set-inferior-start! cursor-inferior 0 y)
-	 (set-buffer-cursor-y! buffer y)	 (set! point-moved? false)
+	 (set! point-moved? false)
 	 (window-modeline-event! superior 'WINDOW-SCROLLED))))))
 
 (define (redraw-at! window mark)
diff --git a/v7/src/edwin/bufwin.scm b/v7/src/edwin/bufwin.scm
index 3fcb376e5..a4934c17f 100644
--- a/v7/src/edwin/bufwin.scm
+++ b/v7/src/edwin/bufwin.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwin.scm,v 1.280 1989/08/08 10:05:29 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwin.scm,v 1.281 1989/08/11 11:50:08 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989 Massachusetts Institute of Technology
 ;;;
@@ -46,6 +46,21 @@
 
 (declare (usual-integrations))
 
+;;; The following instance variables contain marks which must -NEVER-
+;;; be passed to anyone who will keep a pointer to them.  The reason
+;;; is that the `mark-temporary!' operation is called on these marks,
+;;; which invalidates them as soon as some change happens to the
+;;; buffer.  Remember, you were warned!
+;;;
+;;; start-line-mark
+;;; start-mark
+;;; end-mark
+;;; end-line-mark
+;;; start-changes-mark
+;;; end-changes-mark
+;;; start-clip-mark
+;;; end-clip-mark
+
 (define-class buffer-window vanilla-window
   (buffer point changes-daemon clip-daemon
 	  cursor-inferior blank-inferior
@@ -64,7 +79,7 @@
   (set! changes-daemon (make-changes-daemon window))
   (set! clip-daemon (make-clip-daemon window))
   (set! override-inferior false)
-  (set! force-redraw? 'BUFFER-CURSOR-Y)
+  (set! force-redraw? 'CENTER)
   unspecific)
 
 (define-method buffer-window (:kill! window)
@@ -79,6 +94,14 @@
   (update-buffer-window! window screen x-start y-start
 			 xl xu yl yu display-style))
 
+(define-method buffer-window (:salvage! window)
+  (%set-buffer-point! buffer
+		      (make-mark (buffer-group buffer)
+				 (group-start-index (buffer-group buffer))))
+  (set! point (buffer-point buffer))
+  (window-modeline-event! superior 'SALVAGE)
+  (%window-redraw! window false))
+
 (define (set-buffer-window-size! window x y)
   (with-instance-variables buffer-window window (x y)
     (set! saved-screen false)
@@ -86,12 +109,7 @@
       (usual=> window :set-size! x y)
       ;; Preserve point y unless it is offscreen now.
       (%window-setup-truncate-lines! window false)
-      (%window-force-redraw!
-       window
-       (or (and old-y
-		(let ((y (inferior-y-start cursor-inferior)))
-		  (and (< y y-size) y)))
-	   (%window-buffer-cursor-y window))))))
+      (%window-force-redraw! window (and old-y (%window-cursor-y window))))))
 
 (define (%window-setup-truncate-lines! window redraw-type)
   (with-instance-variables buffer-window window ()
@@ -177,19 +195,27 @@
   (with-instance-variables buffer-window window ()
     buffer))
 
+(define (%window-buffer-cursor-y window)
+  (with-instance-variables buffer-window window ()
+    (let ((py (buffer-cursor-y buffer)))
+      (and py
+	   (begin
+	     (set-buffer-cursor-y! buffer false)
+	     (and (= (car py) (mark-index point))
+		  (< (cdr py) y-size)
+		  (cdr py)))))))
+
 (define (%set-window-buffer! window new-buffer)
   (with-instance-variables buffer-window window (new-buffer)
     (if (not (buffer? new-buffer)) (error "Argument not a buffer" new-buffer))
+    (set-buffer-cursor-y! buffer
+			  (let ((y (%window-cursor-y window)))
+			    (and y (cons (mark-index point) y))))
     (delete-window-buffer! window)
     (initial-buffer! window new-buffer)
     (window-modeline-event! superior 'NEW-BUFFER)
     (%window-force-redraw! window (%window-buffer-cursor-y window))))
 
-(define (%window-buffer-cursor-y window)
-  (with-instance-variables buffer-window window (new-buffer)
-    (let ((y (buffer-cursor-y buffer)))
-      (and y (< y y-size) y))))
-
 (define (initial-buffer! window new-buffer)
   (with-instance-variables buffer-window window (new-buffer)
     (set! buffer new-buffer)
@@ -231,13 +257,10 @@
   (with-instance-variables buffer-window window ()
     (inferior-window cursor-inferior)))
 
-(define-method buffer-window (:salvage! window)
-  (%set-buffer-point! buffer
-		      (make-mark (buffer-group buffer)
-				 (group-start-index (buffer-group buffer))))
-  (set! point (buffer-point buffer))
-  (window-modeline-event! superior 'SALVAGE)
-  (%window-redraw! window false))
+(define (%window-cursor-y window)
+  (with-instance-variables buffer-window window ()
+    (let ((y (inferior-y-start cursor-inferior)))
+      (and y (< y y-size) y))))
 
 ;;;; Override Message
 
@@ -266,9 +289,8 @@
 	  (set! override-inferior false)
 	  (set! inferiors
 		(cons* cursor-inferior blank-inferior line-inferiors))
-	  (let ((coordinates (%window-mark->coordinates window point)))
-	    (set-inferior-position! cursor-inferior coordinates)
-	    (set-buffer-cursor-y! buffer (cdr coordinates)))
+	  (set-inferior-position! cursor-inferior
+				  (%window-mark->coordinates window point))
 	  (blank-inferior-changed! window)
 	  (for-each inferior-needs-redisplay! inferiors)))))
 
@@ -312,6 +334,7 @@
 (define-integrable (set-line-inferiors! window inferiors start)
   (with-instance-variables buffer-window window (inferiors start)
     (set! line-inferiors inferiors)
+    (destroy-mark! start-line-mark)
     (set! start-line-mark
 	  (%make-permanent-mark (buffer-group buffer) start false))
     unspecific))
@@ -320,12 +343,14 @@
   (with-instance-variables buffer-window window ()
     (define (loop inferiors start)
       (if (null? (cdr inferiors))
-	  (begin (set! last-line-inferior (car inferiors))
-		 (set! end-line-mark
-		       (let ((group (buffer-group buffer)))
-			 (%make-permanent-mark group
-					       (line-end-index group start)
-					       true))))
+	  (begin
+	    (set! last-line-inferior (car inferiors))
+	    (destroy-mark! end-line-mark)
+	    (set! end-line-mark
+		  (let ((group (buffer-group buffer)))
+		    (%make-permanent-mark group
+					  (line-end-index group start)
+					  true))))
 	  (loop (cdr inferiors)
 		(+ start (line-inferior-length inferiors)))))
     (loop line-inferiors (mark-index start-line-mark))
@@ -409,9 +434,9 @@
 (define (update-cursor! window if-not-visible)
   (with-instance-variables buffer-window window (if-not-invisible)
     (if (%window-mark-visible? window point)
-	(let ((coordinates (%window-mark->coordinates window point)))
-	  (set-inferior-position! cursor-inferior coordinates)
-	  (set-buffer-cursor-y! buffer (cdr coordinates))
+	(begin
+	  (set-inferior-position! cursor-inferior
+				  (%window-mark->coordinates window point))
 	  (set! point-moved? false)
 	  (window-modeline-event! superior 'CURSOR-MOVED))
 	(if-not-visible window))))
@@ -446,7 +471,7 @@
   (with-instance-variables buffer-window window ()
     (set! force-redraw? (or redraw-type 'CENTER))
     (setup-redisplay-flags! redisplay-flags)))
-
+
 (define (%window-redraw-preserving-start! window)
   (with-instance-variables buffer-window window ()
     (let ((group (mark-group start-mark))
@@ -464,7 +489,7 @@
 	   (cons inferior (fill-bottom window (inferior-y-end inferior) end))
 	   start)))))
   (everything-changed! window maybe-recenter!))
-
+
 (define (%window-redraw! window y)
   (with-instance-variables buffer-window window (y)
     (redraw-screen! window
@@ -501,7 +526,7 @@
     (start-mark-changed! window)
     (end-mark-changed! window)
     (update-cursor! window if-not-visible)))
-
+
 (define (maybe-marks-changed! window inferiors y-end)
   (with-instance-variables buffer-window window (inferiors y-end)
     (no-outstanding-changes! window)
@@ -515,15 +540,20 @@
 
 (define (no-outstanding-changes! window)
   (with-instance-variables buffer-window window ()
+    (destroy-mark! start-changes-mark)
     (set! start-changes-mark false)
+    (destroy-mark! end-changes-mark)
     (set! end-changes-mark false)
+    (destroy-mark! start-clip-mark)
     (set! start-clip-mark false)
+    (destroy-mark! end-clip-mark)
     (set! end-clip-mark false)
     (set! force-redraw? false)
     unspecific))
-
+
 (define (start-mark-changed! window)
   (with-instance-variables buffer-window window ()
+    (destroy-mark! start-mark)
     (set! start-mark
 	  (%make-permanent-mark
 	   (buffer-group buffer)
@@ -538,6 +568,7 @@
 
 (define (end-mark-changed! window)
   (with-instance-variables buffer-window window ()
+    (destroy-mark! end-mark)
     (set! end-mark
 	  (let ((group (buffer-group buffer)))
 	    (%make-permanent-mark
@@ -551,13 +582,18 @@
 	     true)))
     (window-modeline-event! superior 'END-MARK-CHANGED!)))
 
-(define-integrable (%window-start-mark window)
+(define (destroy-mark! mark)
+  (if mark
+      (mark-temporary! mark)))
+
+(define-integrable (%window-start-index window)
   (with-instance-variables buffer-window window ()
-    start-mark))
+    (mark-index start-mark)))
 
-(define-integrable (%window-end-mark window)
+(define-integrable (%window-end-index window)
   (with-instance-variables buffer-window window ()
-    end-mark))
+    (mark-index end-mark)))
+
 (define-integrable (%window-mark-visible? window mark)
   (with-instance-variables buffer-window window (mark)
     (and (mark<= start-mark mark)
diff --git a/v7/src/edwin/bufwiu.scm b/v7/src/edwin/bufwiu.scm
index a10d6f5e5..ebae759cf 100644
--- a/v7/src/edwin/bufwiu.scm
+++ b/v7/src/edwin/bufwiu.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwiu.scm,v 1.10 1989/08/08 10:05:33 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwiu.scm,v 1.11 1989/08/11 11:50:13 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989 Massachusetts Institute of Technology
 ;;;
@@ -152,7 +152,9 @@
 						(<= point-index end)
 						(%window-point-y window))))
 			 (else
+			  (destroy-mark! start-clip-mark)
 			  (set! start-clip-mark false)
+			  (destroy-mark! end-clip-mark)
 			  (set! end-clip-mark false)))))
 	     (if start-changes-mark
 		 (let ((start-changes (mark-index start-changes-mark))
@@ -167,7 +169,10 @@
 			       (recompute-image!:bottom-changed window)
 			       (recompute-image!:middle-changed window)))
 		       (begin
-			 (set! start-changes-mark false)			 (set! end-changes-mark false))))))
+			 (destroy-mark! start-changes-mark)
+			 (set! start-changes-mark false)
+			 (destroy-mark! end-changes-mark)
+			 (set! end-changes-mark false))))))
 	   (if point-moved?
 	       (update-cursor! window maybe-recenter!))))))
 
diff --git a/v7/src/edwin/comman.scm b/v7/src/edwin/comman.scm
index c5c9c91af..d6f8db7b0 100644
--- a/v7/src/edwin/comman.scm
+++ b/v7/src/edwin/comman.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comman.scm,v 1.61 1989/08/10 04:42:31 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comman.scm,v 1.62 1989/08/11 11:50:16 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989 Massachusetts Institute of Technology
 ;;;
@@ -102,8 +102,9 @@
   name
   description
   value
-  assignment-daemons
-  buffer-local?)
+  buffer-local?
+  initial-value
+  assignment-daemons)
 
 (unparser/set-tagged-vector-method!
  %variable-tag
@@ -114,7 +115,7 @@
 (define (variable-name-string variable)
   (editor-name/internal->external (symbol->string (variable-name variable))))
 
-(define (make-variable name description value)
+(define (make-variable name description value buffer-local?)
   (let ((variable
 	 (let ((name (symbol->string name)))
 	   (or (string-table-get editor-variables name)
@@ -124,14 +125,19 @@
     (vector-set! variable variable-index:name name)
     (vector-set! variable variable-index:description description)
     (vector-set! variable variable-index:value value)
+    (vector-set! variable variable-index:buffer-local? buffer-local?)
+    (vector-set! variable variable-index:initial-value value)
     (vector-set! variable variable-index:assignment-daemons '())
-    (vector-set! variable variable-index:buffer-local? false)
     variable))
 
+(define-integrable (%set-variable-value! variable value)
+  (vector-set! variable variable-index:value value)
+  unspecific)
+
 (define-integrable (make-variable-buffer-local! variable)
   (vector-set! variable variable-index:buffer-local? true)
   unspecific)
-
+
 (define (add-variable-assignment-daemon! variable daemon)
   (let ((daemons (variable-assignment-daemons variable)))
     (if (not (memq daemon daemons))
@@ -150,7 +156,7 @@
 (define (name->variable name)
   (let ((name (canonicalize-name name)))
     (or (string-table-get editor-variables (symbol->string name))
-	(make-variable name "" false))))
+	(make-variable name "" false false))))
 
 (define (->variable object)
   (if (variable? object) object (name->variable object)))
@@ -163,9 +169,6 @@
 	 (%set-variable-value! variable value)
 	 (invoke-variable-assignment-daemons! variable)))))
 
-(define-integrable (%set-variable-value! variable value)
-  (vector-set! variable variable-index:value value)
-  unspecific)
 (define (with-variable-value! variable new-value thunk)
   (let ((old-value))
     (dynamic-wind (lambda ()
diff --git a/v7/src/edwin/comtab.scm b/v7/src/edwin/comtab.scm
index dfbf7c89e..7518074b3 100644
--- a/v7/src/edwin/comtab.scm
+++ b/v7/src/edwin/comtab.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comtab.scm,v 1.55 1989/06/21 11:55:22 cph Rel $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comtab.scm,v 1.56 1989/08/11 11:50:20 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989 Massachusetts Institute of Technology
 ;;;
@@ -94,9 +94,12 @@
 		    (comtab? (cadr comtabs))
 		    (comtab-entry (cdr comtabs) key)))
 	     (lambda ()
-	       (cond ((null? (cdr comtabs)) bad-command)
-		     ((comtab? (cadr comtabs)) (comtab-entry (cdr comtabs) key))
-		     (else (cadr comtabs)))))))
+	       (cond ((null? (cdr comtabs))
+		      bad-command)
+		     ((comtab? (cadr comtabs))
+		      (comtab-entry (cdr comtabs) key))
+		     (else
+		      (cadr comtabs)))))))
     (let ((try
 	   (lambda (key alist)
 	     (let ((entry (assq key alist)))
@@ -127,8 +130,9 @@
 		   (comtab? (cadr comtabs))
 		   (prefix-char-list? (cdr comtabs) chars)))))))
 
-(define (define-key mode-name key command)
-  (let ((comtabs (mode-comtabs (name->mode mode-name))))
+(define (define-key mode key command)
+  (let ((comtabs (mode-comtabs (->mode mode)))
+	(command (->command command)))
     (if (button? key)
 	(let ((alist (comtab-button-alist (car comtabs))))
 	  (let ((entry (assq key alist)))
@@ -137,12 +141,10 @@
 		(set-comtab-button-alist! (car comtabs)
 					  (cons (cons key command) alist)))))
 	(let ((normal-key
-	       (let ((command
-		      (if (command? command) command (name->command command))))
-		 (lambda (key)
-		   (comtab-lookup-prefix comtabs key false
-		     (lambda (alists char)
-		       (set-comtab-entry! alists char command)))))))
+	       (lambda (key)
+		 (comtab-lookup-prefix comtabs key false
+		   (lambda (alists char)
+		     (set-comtab-entry! alists char command))))))
 	  (cond ((or (char? key) (pair? key))
 		 (normal-key key))
 		((char-set? key)
@@ -151,9 +153,9 @@
 		 (error "Illegal comtab key" key))))))
   key)
 
-(define (define-prefix-key mode-name key command-name)
-  (let ((comtabs (mode-comtabs (name->mode mode-name)))
-	(command (name->command command-name)))
+(define (define-prefix-key mode key command)
+  (let ((comtabs (mode-comtabs (->mode mode)))
+	(command (->command command)))
     (if (or (char? key) (pair? key))
 	(comtab-lookup-prefix comtabs key false
 	  (lambda (alists char)
@@ -162,11 +164,13 @@
 	(error "Illegal comtab key" key)))
   key)
 
-(define (define-default-key mode-name command-name)
-  (let ((comtabs (mode-comtabs (name->mode mode-name))))
+(define (define-default-key mode command)
+  (let ((comtabs (mode-comtabs (->mode mode)))
+	(command (->command command)))
     (if (not (or (null? (cdr comtabs)) (command? (cadr comtabs))))
-	(error "Can't define default key for this mode" mode-name))
-    (set-cdr! comtabs (list (name->command command-name))))  'DEFAULT-KEY)
+	(error "Can't define default key for this mode" mode))
+    (set-cdr! comtabs (list command)))
+  'DEFAULT-KEY)
 
 (define (comtab-key-bindings comtabs command)
   (define (search-comtabs comtabs)
diff --git a/v7/src/edwin/debuge.scm b/v7/src/edwin/debuge.scm
index 496d538b7..80726e1ab 100644
--- a/v7/src/edwin/debuge.scm
+++ b/v7/src/edwin/debuge.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/debuge.scm,v 1.37 1989/04/28 22:49:09 cph Rel $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/debuge.scm,v 1.38 1989/08/11 11:50:23 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989 Massachusetts Institute of Technology
 ;;;
@@ -86,7 +86,7 @@
 		      (buffer-not-modified! buffer)))))))))
 
 (define-command debug-show-rings
-  ""
+  "Show the number of items in the mark and kill rings."
   ()
   (lambda ()
     (message "Mark Ring: "
@@ -95,7 +95,7 @@
 	     (write-to-string (ring-size (current-kill-ring))))))
 
 (define-command debug-count-marks
-  ""
+  "Show the number of in-use and GC'ed marks for the current buffer."
   ()
   (lambda ()
     (count-marks-group (buffer-group (current-buffer))
@@ -111,7 +111,57 @@
 	    (if (weak-pair/car? marks)
 		(receiver (1+ n-existing) n-gced)
 		(receiver n-existing (1+ n-gced)))))
-	(receiver 0 0))))
+	(receiver 0 0))))
+
+(define-command debug-clean-marks
+  "Perform a GC, then remove GC'ed marks from all buffers."
+  ()
+  (lambda ()
+    (gc-flip)
+    ((ref-command debug-count-marks))
+    (for-each (lambda (buffer) (clean-group-marks! (buffer-group buffer)))
+	      (buffer-list))))
+
+(define-command debug-show-standard-marks
+  ""
+  ()
+  (lambda ()
+    (with-output-to-temporary-buffer "*standard-marks*"
+      (lambda ()
+	(let ((buffer-frame (current-window)))
+	  (let ((window (car (instance-ref buffer-frame 'text-inferior)))
+		(buffer (window-buffer buffer-frame)))
+	    (let ((show-mark
+		   (lambda (name mark)
+		     (write-string
+		      (string-pad-right (write-to-string name) 24))
+		     (write mark)
+		     (newline))))
+	      (let ((show-instance
+		     (lambda (name)
+		       (show-mark name (instance-ref window name)))))
+		(show-instance 'point)
+		(show-instance 'start-line-mark)
+		(show-instance 'start-mark)
+		(show-instance 'end-mark)
+		(show-instance 'end-line-mark))
+	      (let ((group (buffer-group buffer)))
+		(show-mark 'group-start-mark (group-start-mark group))
+		(show-mark 'group-end-mark (group-end-mark group))
+		(show-mark 'group-display-start (group-display-start group))
+		(show-mark 'group-display-end (group-display-end group)))
+	      (let ((marks (ring-list (buffer-mark-ring buffer))))
+		(if (not (null? marks))
+		    (begin
+		      (write-string "mark-ring\t\t")
+		      (write (car marks))
+		      (newline)
+		      (for-each (lambda (mark)
+				  (write-string "\t\t\t")
+				  (write mark)
+				  (newline))
+				(cdr marks))))))))))))
+
 ;;;; Object System Debugging
 
 (define (po object)
diff --git a/v7/src/edwin/editor.scm b/v7/src/edwin/editor.scm
index 7982f113b..d5e1452ab 100644
--- a/v7/src/edwin/editor.scm
+++ b/v7/src/edwin/editor.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.189 1989/08/08 10:05:54 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.190 1989/08/11 11:50:27 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989 Massachusetts Institute of Technology
 ;;;
@@ -61,22 +61,25 @@
 		 (lambda ()
 		   (with-editor-interrupts
 		     (lambda ()
-		       (bind-condition-handler '() internal-error-handler
+		       (with-current-local-bindings!
 			 (lambda ()
-			   (perform-buffer-initializations! (current-buffer))
-			   (dynamic-wind
-			    (lambda () (update-screens! true))
-			    (lambda ()
-			      ;; Should this be in a dynamic wind? -- Jinx
-			      (if edwin-initialization (edwin-initialization))
-			      (let ((message (cmdl-message/null)))
-				(push-cmdl (lambda (cmdl)
-					     cmdl ;ignore
-					     (top-level-command-reader)
-					     message)
-					   false
-					   message)))
-			    (lambda () unspecific)))))))))))))))  ;; Should this be here or in a dynamic wind? -- Jinx
+			   (bind-condition-handler '() internal-error-handler
+			     (lambda ()
+			       (dynamic-wind
+				(lambda () (update-screens! true))
+				(lambda ()
+				  ;; Should this be in a dynamic wind? -- Jinx
+				  (if edwin-initialization
+				      (edwin-initialization))
+				  (let ((message (cmdl-message/null)))
+				    (push-cmdl (lambda (cmdl)
+						 cmdl ;ignore
+						 (top-level-command-reader)
+						 message)
+					       false
+					       message)))
+				(lambda () unspecific)))))))))))))))))
+  ;; Should this be here or in a dynamic wind? -- Jinx
   (if edwin-finalization (edwin-finalization))
   unspecific)
 
diff --git a/v7/src/edwin/edtfrm.scm b/v7/src/edwin/edtfrm.scm
index 3f84f3c8b..57e53e1cb 100644
--- a/v7/src/edwin/edtfrm.scm
+++ b/v7/src/edwin/edtfrm.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtfrm.scm,v 1.78 1989/08/08 10:05:57 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtfrm.scm,v 1.79 1989/08/11 11:50:30 cph Exp $
 ;;;
 ;;;	Copyright (c) 1985, 1989 Massachusetts Institute of Technology
 ;;;
@@ -162,27 +162,26 @@
 
 ;;;; Button Events
 
-(define (editor-frame-button-event editor-frame button x y)
-  (values-let (((frame relative-x relative-y)
-		(values-let (((window relative-x relative-y)
-			      (inferior-containing-coordinates editor-frame
-							       x
-							       y
-							       buffer-frame?)))
-		  (if window
-		      (=> window :leaf-containing-coordinates
-			  relative-x relative-y)
-		      (values false false false)))))
-    (if frame
-	 (let ((button-command
-		(comtab-entry (buffer-comtabs (window-buffer frame)) button)))
-	   (if button-command
-	       (button-command
-		frame
-		(min relative-x (buffer-frame-x-size frame))
-		(min relative-y (buffer-frame-y-size frame))))))))
-
-(define-method editor-frame :button-event! editor-frame-button-event)
+(define-method editor-frame (:button-event! editor-frame button x y)
+  (with-values
+      (lambda ()
+	(inferior-containing-coordinates editor-frame x y buffer-frame?))
+    (lambda (frame relative-x relative-y)
+      (if frame
+	  ;; Make sure the event is inside the text portion of the
+	  ;; buffer, not in the modeline or other decoration.
+	  (cond ((and (< -1 relative-x (buffer-frame-x-size frame))
+		      (< -1 relative-y (buffer-frame-y-size frame)))
+		 (let ((command
+			(comtab-entry (buffer-comtabs (window-buffer frame))
+				      button)))
+		   (if command
+		       (with-current-button-event
+			(make-button-event frame relative-x relative-y)
+			(lambda () (execute-command command)))
+		       (editor-beep))))
+		((down-button? button)
+		 (editor-beep)))))))
 
 (define-integrable (button-upify button-number)
   (vector-ref up-buttons button-number))
@@ -191,8 +190,15 @@
   (vector-ref down-buttons button-number))
 
 (define (button? object)
-  (or (vector-find-next-element up-buttons object)
-      (vector-find-next-element down-buttons object)))
+  (or (up-button? object)
+      (down-button? object)))
+
+(define-integrable (up-button? object)
+  (vector-find-next-element up-buttons object))
+
+(define-integrable (down-button? object)
+  (vector-find-next-element down-buttons object))
+
 (define up-buttons '#())
 (define down-buttons '#())
 
diff --git a/v7/src/edwin/edtstr.scm b/v7/src/edwin/edtstr.scm
index c9e80828f..1bf93c14c 100644
--- a/v7/src/edwin/edtstr.scm
+++ b/v7/src/edwin/edtstr.scm
@@ -50,7 +50,8 @@
   (frame-window false read-only true)
   (bufferset false read-only true)
   (kill-ring false read-only true)
-  (char-history false read-only true))
+  (char-history false read-only true)
+  (button-event false))
 
 (define (make-editor name screen)
   (let ((initial-buffer (make-buffer initial-buffer-name initial-buffer-mode)))
@@ -66,7 +67,8 @@
 		      frame
 		      bufferset
 		      (make-ring 10)
-		      (make-ring 100))))))
+		      (make-ring 100)
+		      false)))))
 
 (define-integrable (current-screen)
   (editor-screen current-editor))
@@ -89,4 +91,34 @@
   (editor-kill-ring current-editor))
 
 (define-integrable (current-char-history)
-  (editor-char-history current-editor))
\ No newline at end of file
+  (editor-char-history current-editor))
+
+(define-structure (button-event
+		   (conc-name button-event/))
+  (window false read-only true)
+  (x false read-only true)
+  (y false read-only true))
+
+(define (current-button-event)
+  (or (editor-button-event current-editor)
+      ;; Create a "dummy" event at point.
+      (let ((window (current-window)))
+	(let ((coordinates (window-point-coordinates window)))
+	  (make-button-event window
+			     (car coordinates)
+			     (cdr coordinates))))))
+
+(define (with-current-button-event button-event thunk)
+  (let ((old-button-event))
+    (dynamic-wind
+     (lambda ()
+       (set! old-button-event (editor-button-event current-editor))
+       (set-editor-button-event! current-editor button-event)
+       (set! button-event false)
+       unspecific)
+     thunk
+     (lambda ()
+       (set! button-event (editor-button-event current-editor))
+       (set-editor-button-event! current-editor old-button-event)
+       (set! old-button-event false)
+       unspecific))))
\ No newline at end of file
diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 822c5c7a4..f324f9f07 100644
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.9 1989/08/09 13:17:16 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.10 1989/08/11 11:50:37 cph Exp $
 
 Copyright (c) 1989 Massachusetts Institute of Technology
 
@@ -287,7 +287,7 @@ MIT in each case. |#
 	  window-direct-output-insert-newline!
 	  window-direct-output-insert-substring!
 	  window-direct-update!
-	  window-end-mark
+	  window-end-index
 	  window-home-cursor!
 	  window-mark->coordinates
 	  window-mark->x
@@ -306,7 +306,7 @@ MIT in each case. |#
 	  window-select-time
 	  window-set-override-message!
 	  window-setup-truncate-lines!
-	  window-start-mark
+	  window-start-index
 	  window-y-center
 	  with-editor-interrupts
 	  with-editor-interrupts-enabled
diff --git a/v7/src/edwin/macros.scm b/v7/src/edwin/macros.scm
index 2a020e5de..cee6dc2bc 100644
--- a/v7/src/edwin/macros.scm
+++ b/v7/src/edwin/macros.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/macros.scm,v 1.48 1989/08/08 10:06:18 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/macros.scm,v 1.49 1989/08/11 11:50:41 cph Rel $
 ;;;
 ;;;	Copyright (c) 1986, 1989 Massachusetts Institute of Technology
 ;;;
@@ -127,27 +127,21 @@
 (define (command-name->scheme-name name)
   (symbol-append 'EDWIN-COMMAND$ name))
 
-(syntax-table-define edwin-syntax-table 'DEFINE-VARIABLE
-  (lambda (name description #!optional value)
-    (let ((name (canonicalize-name name)))
-      `(BEGIN
-	 (DEFINE ,(variable-name->scheme-name name)
-	   (MAKE-VARIABLE ',name
-			  ',description
-			  ,(if (default-object? value) '#F value)))
-	 ',name))))
-
-(syntax-table-define edwin-syntax-table 'DEFINE-VARIABLE-PER-BUFFER
-  (lambda (name description #!optional value)
-    (let ((name (canonicalize-name name)))
-      (let ((scheme-name (variable-name->scheme-name name)))
-	`(BEGIN
-	   (DEFINE ,scheme-name
-	     (MAKE-VARIABLE ',name
-			    ',description
-			    ,(if (default-object? value) '#F value)))
-	   (MAKE-VARIABLE-BUFFER-LOCAL! ,scheme-name)
-	   ',name)))))
+(let ((variable-definition
+       (lambda (buffer-local?)
+	 (lambda (name description #!optional value)
+	   (let ((name (canonicalize-name name)))
+	     `(BEGIN
+		(DEFINE ,(variable-name->scheme-name name)
+		  (MAKE-VARIABLE ',name
+				 ',description
+				 ,(if (default-object? value) '#F value)
+				 ',buffer-local?))
+		',name))))))
+  (syntax-table-define edwin-syntax-table 'DEFINE-VARIABLE
+    (variable-definition false))
+  (syntax-table-define edwin-syntax-table 'DEFINE-VARIABLE-PER-BUFFER
+    (variable-definition true)))
 
 (syntax-table-define edwin-syntax-table 'REF-VARIABLE-OBJECT
   (lambda (name)
@@ -230,25 +224,21 @@
 
 (syntax-table-define edwin-syntax-table 'VALUES-LET
   (lambda (bindings . forms)
+
     (define (transform/binding binding forms)
       (if (or (not (pair? binding))
 	      (not (pair? (cdr binding))))
-	  (error "values-let: bad binding clause"
-		 binding)
-	  `(WITH-VALUES
-	       (LAMBDA () ,(cadr binding))
-	     (LAMBDA (,@(car binding))
-	       ,@forms))))
+	  (error "values-let: bad binding clause" binding))
+      `(WITH-VALUES (LAMBDA () ,(cadr binding))
+	 (LAMBDA (,@(car binding)) ,@forms)))
+
     (define (transform/values-let bindings forms)
       (transform/binding
        (car bindings)
        (if (null? (cdr bindings))
 	   forms
-	   (list
-	    (transform/values-let (cdr bindings)
-				  forms)))))
+	   (list (transform/values-let (cdr bindings) forms)))))
+
     (if (not (pair? bindings))
-	(error "values-let: missing bindings"
-	       (cons bindings forms))
-	(transform/values-let bindings
-			      forms))))
\ No newline at end of file
+	(error "values-let: missing bindings" (cons bindings forms))
+	(transform/values-let bindings forms))))
\ No newline at end of file
diff --git a/v7/src/edwin/make.scm b/v7/src/edwin/make.scm
index 72a435092..197ddd9f9 100644
--- a/v7/src/edwin/make.scm
+++ b/v7/src/edwin/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.14 1989/08/09 13:17:47 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.15 1989/08/11 11:50:45 cph Exp $
 
 Copyright (c) 1989 Massachusetts Institute of Technology
 
@@ -37,4 +37,4 @@ MIT in each case. |#
 (declare (usual-integrations))
 
 (package/system-loader "edwin" '() 'QUERY)
-(add-system! (make-system "Edwin" 3 14 '()))
\ No newline at end of file
+(add-system! (make-system "Edwin" 3 15 '()))
\ No newline at end of file
diff --git a/v7/src/edwin/struct.scm b/v7/src/edwin/struct.scm
index 31f4fd100..04cc1e374 100644
--- a/v7/src/edwin/struct.scm
+++ b/v7/src/edwin/struct.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/struct.scm,v 1.69 1989/06/19 22:42:29 markf Rel $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/struct.scm,v 1.70 1989/08/11 11:50:48 cph Exp $
 ;;;
 ;;;	Copyright (c) 1985, 1989 Massachusetts Institute of Technology
 ;;;
@@ -393,8 +393,99 @@
 					      (group-marks group)))
 	  mark))))
 
-;;; Here is a simple algorithm that is haired up the wazoo for speed.
+;;; The next few procedures are simple algorithms that are haired up
+;;; the wazoo for maximum speed.
 
+(define (clean-group-marks! group)
+
+  (define (scan-head marks)
+    (cond ((null? marks)
+	   (set-group-marks! group '()))
+	  ((not (system-pair-car marks))
+	   (scan-head (system-pair-cdr marks)))
+	  (else
+	   (set-group-marks! group marks)
+	   (scan-tail marks (system-pair-cdr marks)))))
+
+  (define (scan-tail previous marks)
+    (cond ((null? marks)
+	   unspecific)
+	  ((not (system-pair-car marks))
+	   (skip-nulls previous (system-pair-cdr marks)))
+	  (else
+	   (scan-tail marks (system-pair-cdr marks)))))
+
+  (define (skip-nulls previous marks)
+    (cond ((null? marks)
+	   (system-pair-set-cdr! previous '())
+	   unspecific)
+	  ((not (system-pair-car marks))
+	   (skip-nulls previous (system-pair-cdr marks)))
+	  (else
+	   (system-pair-set-cdr! previous marks)
+	   (scan-tail marks (system-pair-cdr marks)))))
+
+  (let ((marks (group-marks group)))
+    (cond ((null? marks)
+	   unspecific)
+	  ((not (system-pair-car marks))
+	   (scan-head (system-pair-cdr marks)))
+	  (else
+	   (scan-tail marks (system-pair-cdr marks))))))
+
+(define (mark-temporary! mark)
+  ;; I'd think twice about using this one.
+  (if (not recycle-permanent-marks?)
+      (let ((group (mark-group mark)))
+
+	(define (scan-head marks)
+	  (if (null? marks)
+	      (set-group-marks! group '())
+	      (let ((mark* (system-pair-car marks)))
+		(cond ((not mark*)
+		       (scan-head (system-pair-cdr marks)))
+		      ((eq? mark mark*)
+		       (set-group-marks! group (system-pair-cdr marks)))
+		      (else
+		       (set-group-marks! group marks)
+		       (scan-tail marks (system-pair-cdr marks)))))))
+
+	(define (scan-tail previous marks)
+	  (if (not (null? marks))
+	      (let ((mark* (system-pair-car marks)))
+		(cond ((not mark*)
+		       (skip-nulls previous (system-pair-cdr marks)))
+		      ((eq? mark mark*)
+		       (system-pair-set-cdr! previous marks)
+		       unspecific)
+		      (else
+		       (scan-tail marks (system-pair-cdr marks)))))))
+
+	(define (skip-nulls previous marks)
+	  (if (null? marks)
+	      (begin
+		(system-pair-set-cdr! previous '())
+		unspecific)
+	      (let ((mark* (system-pair-car marks)))
+		(cond ((not mark*)
+		       (skip-nulls previous (system-pair-cdr marks)))
+		      ((eq? mark mark*)
+		       (system-pair-set-cdr! previous (system-pair-cdr marks))
+		       unspecific)
+		      (else
+		       (system-pair-set-cdr! previous marks)
+		       (scan-tail marks (system-pair-cdr marks)))))))
+
+	(let ((marks (group-marks group)))
+	  (if (not (null? marks))
+	      (let ((mark* (system-pair-car marks)))
+		(cond ((not mark*)
+		       (scan-head (system-pair-cdr marks)))
+		      ((eq? mark mark*)
+		       (set-group-marks! group (system-pair-cdr marks)))
+		      (else
+		       (scan-tail marks (system-pair-cdr marks))))))))))
+
 (define (find-permanent-mark group position left-inserting?)
 
   (define (scan-head marks)
@@ -444,7 +535,18 @@
 		    mark
 		    (scan-tail marks (system-pair-cdr marks))))))))
 
-  (scan-head (group-marks group)))
+  (let ((marks (group-marks group)))
+    (and (not (null? marks))
+	 (let ((mark (system-pair-car marks)))
+	   (cond ((not mark)
+		  (scan-head (system-pair-cdr marks)))
+		 ((and (if (mark-left-inserting? mark)
+			   left-inserting?
+			   (not left-inserting?))
+		       (= (mark-position mark) position))
+		  mark)
+		 (else
+		  (scan-tail marks (system-pair-cdr marks))))))))
 
 (define (for-each-mark group procedure)
 
@@ -484,7 +586,16 @@
 		(scan-tail marks rest))
 	      (skip-nulls previous rest)))))
 
-  (scan-head (group-marks group)))
+  (let ((marks (group-marks group)))
+    (if (not (null? marks))
+	(let ((mark (system-pair-car marks))
+	      (rest (system-pair-cdr marks)))
+	  (if mark
+	      (begin
+		(procedure mark)
+		(scan-tail marks rest))
+	      (scan-head rest))))))
+
 ;;;; Regions
 
 (define-integrable %make-region cons)
diff --git a/v7/src/edwin/wincom.scm b/v7/src/edwin/wincom.scm
index e33da095c..da5fbce8b 100644
--- a/v7/src/edwin/wincom.scm
+++ b/v7/src/edwin/wincom.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/wincom.scm,v 1.94 1989/08/08 10:06:36 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/wincom.scm,v 1.95 1989/08/11 11:50:52 cph Exp $
 ;;;
 ;;;	Copyright (c) 1987, 1989 Massachusetts Institute of Technology
 ;;;
@@ -207,10 +207,11 @@ Just minus as an argument moves down full screen."
 
 (define (scroll-window window n #!optional limit)
   (if (if (negative? n)
-	  (mark= (window-start-mark window)
-		 (buffer-start (window-buffer window)))
-	  (mark= (window-end-mark window)
-		 (buffer-end (window-buffer window))))      ((if (default-object? limit) editor-error limit))
+	  (= (window-start-index window)
+	     (mark-index (buffer-start (window-buffer window))))
+	  (= (window-end-index window)
+	     (mark-index (buffer-end (window-buffer window)))))
+      ((if (default-object? limit) editor-error limit))
       (window-scroll-y-relative! window n)))
 
 (define (standard-scroll-window-argument window argument factor)
diff --git a/v7/src/edwin/xcom.scm b/v7/src/edwin/xcom.scm
index 770c46a95..bd399e2b7 100644
--- a/v7/src/edwin/xcom.scm
+++ b/v7/src/edwin/xcom.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xcom.scm,v 1.1 1989/06/21 10:42:34 cph Rel $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xcom.scm,v 1.2 1989/08/11 11:50:55 cph Exp $
 ;;;
 ;;;	Copyright (c) 1989 Massachusetts Institute of Technology
 ;;;
@@ -235,15 +235,77 @@ When called interactively, completion is available on the input."
      "watch"
      "xterm"))
 
-(define (x-switch-to-window window x y)
-  x y					;ignore
-  (select-window window))
-
-(define (x-move-to-coordinates window x y)
-  (select-window window)
-  (set-current-point!
-   (or (window-coordinates->mark window x y)
-       (buffer-end (window-buffer window)))))
-
-(define-key 'fundamental button1-down x-move-to-coordinates)
-(define-key 'fundamental button3-down x-switch-to-window)
\ No newline at end of file
+;;;; Mouse Commands
+
+(define-command x-mouse-select
+  "Select window the mouse is on."
+  ()
+  (lambda ()
+    (select-window (button-event/window (current-button-event)))))
+
+(define-command x-mouse-keep-one-window
+  "Select window mouse is on, then kill all other windows."
+  ()
+  (lambda ()
+    ((ref-command x-mouse-select))
+    ((ref-command delete-other-windows))))
+
+(define-command x-mouse-select-and-split
+  "Select window mouse is on, then split it vertically in half."
+  ()
+  (lambda ()
+    ((ref-command x-mouse-select))
+    ((ref-command split-window-vertically) false)))
+
+(define-command x-mouse-set-point
+  "Select window mouse is on, and move point to mouse position."
+  ()
+  (lambda ()
+    (let ((button-event (current-button-event)))
+      (let ((window (button-event/window button-event)))
+	(select-window window)
+	(set-current-point!
+	 (or (window-coordinates->mark window
+				       (button-event/x button-event)
+				       (button-event/y button-event))
+	     (buffer-end (window-buffer window))))))))
+
+(define-command x-mouse-set-mark
+  "Select window mouse is on, and set mark at mouse position.
+Display cursor at that position for a second."
+  ()
+  (lambda ()
+    (let ((button-event (current-button-event)))
+      (let ((window (button-event/window button-event)))
+	(select-window window)
+	(let ((mark
+	       (or (window-coordinates->mark window
+					     (button-event/x button-event)
+					     (button-event/y button-event))
+		   (buffer-end (window-buffer window)))))
+	  (push-current-mark! mark)
+	  (mark-flash mark))))))
+
+(define-command x-mouse-show-event
+  "Show the mouse position in the minibuffer."
+  ()
+  (lambda ()
+    (let ((button-event (current-button-event)))
+      (message "window: " (button-event/window button-event)
+	       " x: " (button-event/x button-event)
+	       " y: " (button-event/y button-event)))))
+
+(define-command x-mouse-ignore
+  "Don't do anything."
+  ()
+  (lambda () unspecific))
+
+;;; Prevent beeps on button-up.  If the button isn't bound to
+;;; anything, it will beep on button-down.
+(define-key 'fundamental button1-up 'x-mouse-ignore)
+(define-key 'fundamental button2-up 'x-mouse-ignore)
+(define-key 'fundamental button3-up 'x-mouse-ignore)
+(define-key 'fundamental button4-up 'x-mouse-ignore)
+(define-key 'fundamental button5-up 'x-mouse-ignore)
+
+(define-key 'fundamental button1-down 'x-mouse-set-point)
\ No newline at end of file