From a8703bd8fc7876d37feb5d7ddc63c4890646099e Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 7 Apr 1992 09:35:39 +0000
Subject: [PATCH] Redesign local-variable binding mechanism so that default
 global value is always stored in a special slot in the variable object. 
 Variable assignment daemons are now called only when the value changes in
 some perceptible way, not when the local bindings are swapped in or out of
 the value cache.  Also, variable assignment daemons now take an additional
 argument, either a buffer or #F, indicating whether the change is local or
 global.

---
 v7/src/edwin/buffer.scm | 189 +++++++++++++++++++++-------------------
 v7/src/edwin/buffrm.scm |   9 +-
 v7/src/edwin/comman.scm |  39 ++-------
 3 files changed, 110 insertions(+), 127 deletions(-)

diff --git a/v7/src/edwin/buffer.scm b/v7/src/edwin/buffer.scm
index 94736e7d8..cae98c934 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.153 1992/04/04 13:07:05 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.154 1992/04/07 09:35:20 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
 ;;;
@@ -324,13 +324,19 @@ The buffer is guaranteed to be deselected at that time."
 
 (define (with-read-only-defeated mark thunk)
   (let ((group (mark-group mark))
-	(read-only?))
-    (unwind-protect (lambda ()
-		      (set! read-only? (group-read-only? group))
-		      (set-group-writeable! group))
-		    thunk
-		    (lambda ()
-		      (if read-only? (set-group-read-only! group))))))
+	(outside)
+	(inside false))
+    (dynamic-wind (lambda ()
+		    (set! outside (group-read-only? group))
+		    (if inside
+			(set-group-read-only! group)
+			(set-group-writeable! group)))
+		  thunk
+		  (lambda ()
+		    (set! inside (group-read-only? group))
+		    (if outside
+			(set-group-read-only! group)
+			(set-group-writeable! group))))))
 
 ;;;; Local Bindings
 
@@ -339,20 +345,15 @@ The buffer is guaranteed to be deselected at that time."
   (without-interrupts
    (lambda ()
      (let ((binding (search-local-bindings buffer variable)))
-       (if (buffer-local-bindings-installed? buffer)
-	   (begin
-	     (if (not binding)
-		 (vector-set! buffer
-			      buffer-index:local-bindings
-			      (cons (cons variable (variable-value variable))
-				    (buffer-local-bindings buffer))))
-	     (%set-variable-value! variable value))
-	   (if binding
-	       (set-cdr! binding value)
-	       (vector-set! buffer
-			    buffer-index:local-bindings
-			    (cons (cons variable value)
-				  (buffer-local-bindings buffer)))))))))
+       (if binding
+	   (set-cdr! binding value)
+	   (vector-set! buffer
+			buffer-index:local-bindings
+			(cons (cons variable value)
+			      (buffer-local-bindings buffer)))))
+     (if (buffer-local-bindings-installed? buffer)
+	 (vector-set! variable variable-index:value value))
+     (invoke-variable-assignment-daemons! buffer variable))))
 
 (define (undefine-variable-local-value! buffer variable)
   (without-interrupts
@@ -364,16 +365,16 @@ The buffer is guaranteed to be deselected at that time."
 			  buffer-index:local-bindings
 			  (delq! binding (buffer-local-bindings buffer)))
 	     (if (buffer-local-bindings-installed? buffer)
-		 (%set-variable-value! variable (cdr binding)))))))))
+		 (vector-set! variable
+			      variable-index:value
+			      (variable-default-value variable)))
+	     (invoke-variable-assignment-daemons! buffer variable)))))))
 
 (define (variable-local-value buffer variable)
-  (let ((buffer (->buffer buffer)))
-    (if (buffer-local-bindings-installed? buffer)
-	(variable-value variable)
-	(let ((binding (search-local-bindings buffer variable)))
-	  (if binding
-	      (cdr binding)
-	      (variable-default-value variable))))))
+  (let ((binding (search-local-bindings (->buffer buffer) variable)))
+    (if binding
+	(cdr binding)
+	(variable-default-value variable))))
 
 (define (set-variable-local-value! buffer variable value)
   (if (variable-buffer-local? variable)
@@ -382,27 +383,26 @@ The buffer is guaranteed to be deselected at that time."
 	(check-variable-value-validity! variable value)
 	(without-interrupts
 	 (lambda ()
-	   (let ((binding
-		  (and (not (buffer-local-bindings-installed? buffer))
-		       (search-local-bindings buffer variable))))
+	   (let ((binding (search-local-bindings buffer variable)))
 	     (if binding
-		 (set-cdr! binding value)
-		 (%set-variable-value! variable value))))))))
-
-(define (variable-default-value variable)
-  (let ((binding (search-local-bindings (current-buffer) variable)))
-    (if binding
-	(cdr binding)
-	(variable-value variable))))
+		 (begin
+		   (set-cdr! binding value)
+		   (if (buffer-local-bindings-installed? buffer)
+		       (vector-set! variable variable-index:value value))
+		   (invoke-variable-assignment-daemons! buffer variable))
+		 (begin
+		   (vector-set! variable variable-index:default-value value)
+		   (vector-set! variable variable-index:value value)
+		   (invoke-variable-assignment-daemons! false variable)))))))))
 
 (define (set-variable-default-value! variable value)
   (check-variable-value-validity! variable value)
   (without-interrupts
    (lambda ()
-     (let ((binding (search-local-bindings (current-buffer) variable)))
-       (if binding
-	   (set-cdr! binding value)
-	   (%set-variable-value! variable value))))))
+     (vector-set! variable variable-index:default-value value)
+     (if (not (search-local-bindings (current-buffer) variable))
+	 (vector-set! variable variable-index:value value))
+     (invoke-variable-assignment-daemons! false variable))))
 
 (define-integrable (search-local-bindings buffer variable)
   (let loop ((bindings (buffer-local-bindings buffer)))
@@ -417,61 +417,66 @@ The buffer is guaranteed to be deselected at that time."
     (let ((bindings (buffer-local-bindings buffer)))
       (do ((bindings bindings (cdr bindings)))
 	  ((null? bindings))
-	(%%set-variable-value! (caar bindings) (cdar bindings)))
+	(vector-set! (caar bindings)
+		     variable-index:value
+		     (variable-default-value (caar bindings))))
       (vector-set! buffer buffer-index:local-bindings '())
       (do ((bindings bindings (cdr bindings)))
 	  ((null? bindings))
-	(invoke-variable-assignment-daemons! (caar bindings))))))
+	(invoke-variable-assignment-daemons! buffer (caar bindings))))))
 
 (define (with-current-local-bindings! thunk)
-  (let ((wind-bindings
-	 (lambda (buffer installed?)
-	   (do ((bindings (buffer-local-bindings buffer) (cdr bindings)))
-	       ((null? bindings))
-	     (let ((old-value (variable-value (caar bindings))))
-	       (%%set-variable-value! (caar bindings) (cdar bindings))
-	       (set-cdr! (car bindings) old-value)))
-	   (vector-set! buffer
-			buffer-index:local-bindings-installed?
-			installed?))))
-    (unwind-protect
-     (lambda ()
-       (let ((buffer (current-buffer)))
-	 (wind-bindings buffer true)
-	 (perform-buffer-initializations! buffer)))
-     thunk
-     (lambda ()
-       (wind-bindings (current-buffer) false)))))
+  (dynamic-wind (lambda ()
+		  (install-buffer-local-bindings! (current-buffer)))
+		thunk
+		(lambda ()
+		  (uninstall-buffer-local-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 '()))
-    (do ((bindings (buffer-local-bindings old-buffer) (cdr bindings)))
-	((null? bindings))
-      (let ((old-value (variable-value (caar bindings))))
-	(%%set-variable-value! (caar bindings) (cdar bindings))
-	(set-cdr! (car bindings) old-value))
-      (if (not (null? (variable-assignment-daemons (caar bindings))))
-	  (set! variables (cons (caar bindings) variables))))
-    (vector-set! old-buffer buffer-index:local-bindings-installed? false)
-    (select-buffer!)
-    (do ((bindings (buffer-local-bindings new-buffer) (cdr bindings)))
-	((null? bindings))
-      (let ((old-value (variable-value (caar bindings))))
-	(%%set-variable-value! (caar bindings) (cdar bindings))
-	(set-cdr! (car bindings) old-value))
-      (if (and (not (null? (variable-assignment-daemons (caar bindings))))
-	       (not (let loop ((variables variables))
-		      (and (not (null? variables))
-			   (or (eq? (caar bindings) (car variables))
-			       (loop (cdr variables)))))))
-	  (set! variables (cons (caar bindings) variables))))
-    (vector-set! new-buffer buffer-index:local-bindings-installed? true)
-    (perform-buffer-initializations! new-buffer)
-    (if (not (null? variables))
-	(do ((variables variables (cdr variables)))
-	    ((null? variables))
-	  (invoke-variable-assignment-daemons! (car variables))))))
+  (uninstall-buffer-local-bindings! old-buffer)
+  (select-buffer!)
+  (install-buffer-local-bindings! new-buffer))
+
+(define (install-buffer-local-bindings! buffer)
+  (do ((bindings (buffer-local-bindings buffer) (cdr bindings)))
+      ((null? bindings))
+    (vector-set! (caar bindings) variable-index:value (cdar bindings)))
+  (vector-set! buffer buffer-index:local-bindings-installed? true)
+  (perform-buffer-initializations! buffer))
+
+(define (uninstall-buffer-local-bindings! buffer)
+  (do ((bindings (buffer-local-bindings buffer) (cdr bindings)))
+      ((null? bindings))
+    (vector-set! (caar bindings)
+		 variable-index:value
+		 (variable-value (caar bindings))))
+  (vector-set! buffer buffer-index:local-bindings-installed? false))
+
+(define (set-variable-value! variable value)
+  (if within-editor?
+      (set-variable-local-value! (current-buffer) variable value)
+      (begin
+	(check-variable-value-validity! variable value)
+	(without-interrupts
+	 (lambda ()
+	   (vector-set! variable variable-index:default-value value)
+	   (vector-set! variable variable-index:value value)
+	   (invoke-variable-assignment-daemons! false variable))))))
+
+(define (with-variable-value! variable new-value thunk)
+  (let ((old-value))
+    (dynamic-wind (lambda ()
+		    (set! old-value (variable-value variable))
+		    (set-variable-value! variable new-value)
+		    (set! new-value)
+		    unspecific)
+		  thunk
+		  (lambda ()
+		    (set! new-value (variable-value variable))
+		    (set-variable-value! variable old-value)
+		    (set! old-value)
+		    unspecific))))
 
 ;;;; Modes
 
diff --git a/v7/src/edwin/buffrm.scm b/v7/src/edwin/buffrm.scm
index c3622b0eb..9f4324959 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.41 1992/03/13 10:52:38 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffrm.scm,v 1.42 1992/04/07 09:35:39 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
 ;;;
@@ -320,9 +320,12 @@ Automatically becomes local when set in any fashion."
   exact-nonnegative-integer?)
 
 (let ((setup-truncate-lines!
-       (lambda (variable)
+       (lambda (buffer variable)
 	 variable			;ignore
-	 (for-each window-redraw! (window-list)))))
+	 (for-each window-redraw!
+		   (if buffer
+		       (buffer-windows buffer)
+		       (window-list))))))
   (add-variable-assignment-daemon!
    (ref-variable-object truncate-lines)
    setup-truncate-lines!)
diff --git a/v7/src/edwin/comman.scm b/v7/src/edwin/comman.scm
index 2dd6a5fed..0a98aa9bc 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.68 1992/02/04 04:01:39 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comman.scm,v 1.69 1992/04/07 09:35:32 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
 ;;;
@@ -104,6 +104,7 @@
   value
   buffer-local?
   initial-value
+  default-value
   assignment-daemons
   value-validity-test)
 
@@ -128,16 +129,14 @@
     (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:default-value value)
     (vector-set! variable variable-index:assignment-daemons '())
     (vector-set! variable variable-index:value-validity-test false)
     variable))
 
-(define-integrable (%%set-variable-value! variable value)
-  (vector-set! variable variable-index:value value))
-
 (define-integrable (make-variable-buffer-local! variable)
   (vector-set! variable variable-index:buffer-local? true))
-
+
 (define (define-variable-value-validity-test variable test)
   (vector-set! variable variable-index:value-validity-test test))
 
@@ -157,10 +156,10 @@
 		     variable-index:assignment-daemons
 		     (cons daemon daemons)))))
 
-(define (invoke-variable-assignment-daemons! variable)
+(define (invoke-variable-assignment-daemons! buffer variable)
   (do ((daemons (variable-assignment-daemons variable) (cdr daemons)))
       ((null? daemons))
-    ((car daemons) variable)))
+    ((car daemons) buffer variable)))
 
 (define editor-variables (make-string-table 50))
 
@@ -170,28 +169,4 @@
 	(make-variable name "" false false))))
 
 (define (->variable object)
-  (if (variable? object) object (name->variable object)))
-
-(define-integrable (%set-variable-value! variable value)
-  (%%set-variable-value! variable value)
-  (invoke-variable-assignment-daemons! variable))
-
-(define (set-variable-value! variable value)
-  (if (variable-buffer-local? variable)
-      (define-variable-local-value! (current-buffer) variable value)
-      (begin
-	(check-variable-value-validity! variable value)
-	(without-interrupts
-	 (lambda ()
-	   (%set-variable-value! variable value))))))
-
-(define (with-variable-value! variable new-value thunk)
-  (let ((old-value))
-    (unwind-protect (lambda ()
-		      (set! old-value (variable-value variable))
-		      (set-variable-value! variable new-value)
-		      (set! new-value)
-		      unspecific)
-		    thunk
-		    (lambda ()
-		      (set-variable-value! variable old-value)))))
\ No newline at end of file
+  (if (variable? object) object (name->variable object)))
\ No newline at end of file
-- 
2.25.1