From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 25 Oct 2000 05:07:27 +0000 (+0000)
Subject: Add pre-selection buffer hooks.  These hooks allow a buffer to
X-Git-Tag: 20090517-FFI~3235
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=882d1128006f7f1d01828622900451f6ba5f0de5;p=mit-scheme.git

Add pre-selection buffer hooks.  These hooks allow a buffer to
intercede in its selection.
---

diff --git a/v7/src/edwin/curren.scm b/v7/src/edwin/curren.scm
index 1227cf81c..b6e01e469 100644
--- a/v7/src/edwin/curren.scm
+++ b/v7/src/edwin/curren.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: curren.scm,v 1.126 2000/05/23 02:10:13 cph Exp $
+;;; $Id: curren.scm,v 1.127 2000/10/25 05:07:27 cph Exp $
 ;;;
 ;;; Copyright (c) 1986, 1989-2000 Massachusetts Institute of Technology
 ;;;
@@ -395,10 +395,10 @@ The frame is guaranteed to be deselected at that time."
 	       (get-buffer-hooks buffer 'RENAME-BUFFER-HOOKS))
      (bufferset-rename-buffer (current-bufferset) buffer new-name))))
 
-(define-integrable (add-rename-buffer-hook buffer hook)
+(define (add-rename-buffer-hook buffer hook)
   (add-buffer-hook buffer 'RENAME-BUFFER-HOOKS hook))
 
-(define-integrable (remove-rename-buffer-hook buffer hook)
+(define (remove-rename-buffer-hook buffer hook)
   (remove-buffer-hook buffer 'RENAME-BUFFER-HOOKS hook))
 
 (define (kill-buffer buffer)
@@ -423,10 +423,10 @@ The frame is guaranteed to be deselected at that time."
 		 (select-buffer-in-window new-buffer (car windows) #f)
 		 (loop (cdr windows) new-buffer)))))))
 
-(define-integrable (add-kill-buffer-hook buffer hook)
+(define (add-kill-buffer-hook buffer hook)
   (add-buffer-hook buffer 'KILL-BUFFER-HOOKS hook))
 
-(define-integrable (remove-kill-buffer-hook buffer hook)
+(define (remove-kill-buffer-hook buffer hook)
   (remove-buffer-hook buffer 'KILL-BUFFER-HOOKS hook))
 
 (define (add-buffer-hook buffer key hook)
@@ -439,7 +439,7 @@ The frame is guaranteed to be deselected at that time."
 (define (remove-buffer-hook buffer key hook)
   (buffer-put! buffer key (delq! hook (get-buffer-hooks buffer key))))
 
-(define-integrable (get-buffer-hooks buffer key)
+(define (get-buffer-hooks buffer key)
   (or (buffer-get buffer key) '()))
 
 (define (select-buffer buffer)
@@ -459,21 +459,34 @@ The frame is guaranteed to be deselected at that time."
 	 (set-window-buffer! window buffer)))))
 
 (define (change-selected-buffer window buffer record? selection-thunk)
-  (change-local-bindings! (selected-buffer) buffer selection-thunk)
-  (set-buffer-point! buffer (window-point window))
-  (if record?
-      (bufferset-select-buffer! (current-bufferset) buffer))
-  (for-each (lambda (hook) (hook buffer window))
-	    (get-buffer-hooks buffer 'SELECT-BUFFER-HOOKS))
-  (if (not (minibuffer? buffer))
-      (event-distributor/invoke! (ref-variable select-buffer-hook #f)
-				 buffer
-				 window)))
-
-(define-integrable (add-select-buffer-hook buffer hook)
+  (let ((finish-selection
+	 (lambda ()
+	   (change-local-bindings! (selected-buffer) buffer selection-thunk)
+	   (set-buffer-point! buffer (window-point window))
+	   (if record?
+	       (bufferset-select-buffer! (current-bufferset) buffer))
+	   (for-each (lambda (hook) (hook buffer window))
+		     (get-buffer-hooks buffer 'SELECT-BUFFER-HOOKS))
+	   (if (not (minibuffer? buffer))
+	       (event-distributor/invoke! (ref-variable select-buffer-hook #f)
+					  buffer
+					  window)))))
+    (let loop ((hooks (get-buffer-hooks buffer 'PRE-SELECT-BUFFER-HOOKS)))
+      (if (pair? hooks)
+	  ((car hooks) buffer window finish-selection
+		       (lambda () (loop (cdr hooks))))
+	  (finish-selection)))))
+
+(define (add-pre-select-buffer-hook buffer hook)
+  (add-buffer-hook buffer 'PRE-SELECT-BUFFER-HOOKS hook))
+
+(define (remove-pre-select-buffer-hook buffer hook)
+  (remove-buffer-hook buffer 'PRE-SELECT-BUFFER-HOOKS hook))
+
+(define (add-select-buffer-hook buffer hook)
   (add-buffer-hook buffer 'SELECT-BUFFER-HOOKS hook))
 
-(define-integrable (remove-select-buffer-hook buffer hook)
+(define (remove-select-buffer-hook buffer hook)
   (remove-buffer-hook buffer 'SELECT-BUFFER-HOOKS hook))
 
 (define-variable select-buffer-hook