X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgutter-items.el;h=8ac62f6c26b51692ac63a5c5ac4e315fb898b0b8;hb=8ccf542c980645ba3c02074a8bc67cd4fc8e7a1f;hp=8a83ed55f9b3bd78f5f5a20ace56b44efce0c1c4;hpb=2fd9701a4f902054649dde9143a3f77809afee8f;p=chise%2Fxemacs-chise.git.1

diff --git a/lisp/gutter-items.el b/lisp/gutter-items.el
index 8a83ed5..8ac62f6 100644
--- a/lisp/gutter-items.el
+++ b/lisp/gutter-items.el
@@ -2,6 +2,7 @@
 
 ;; Copyright (C) 1999 Free Software Foundation, Inc.
 ;; Copyright (C) 1999, 2000 Andy Piper.
+;; Copyright (C) 2000 Ben Wing.
 
 ;; Maintainer: XEmacs Development Team
 ;; Keywords: frames, extensions, internal, dumped
@@ -24,88 +25,6 @@
 ;; Boston, MA 02111-1307, USA.
 
 ;; Some of this is taken from the buffer-menu stuff in menubar-items.el
-;; and the custom specs in toolbar.el.
-
-(defgroup gutter nil
-  "Input from the gutters."
-  :group 'environment)
-
-;; Although these customizations appear bogus, they are neccessary in
-;; order to be able to save options through the options menu.
-(defcustom default-gutter-position
-  (default-gutter-position)
-  "The location of the default gutter. It can be 'top, 'bottom, 'left or
-'right. This option should be customized through the options menu.
-To set the gutter position explicitly use `set-default-gutter-position'"
-  :group 'gutter
-  :type '(choice (const :tag "top" top)
-		 (const :tag "bottom" bottom)
-		 (const :tag "left" left)
-		 (const :tag "right" right))
-  :set #'(lambda (var val)
-	   (set-default-gutter-position val)
-	   (setq default-gutter-position val)))
-
-;;; Gutter helper functions
-
-;; called by Fset_default_gutter_position()
-(defvar default-gutter-position-changed-hook nil
-  "Function or functions to be called when the gutter position is changed.
-The value of this variable may be buffer-local.")
-
-;; called by set-gutter-element-visible-p
-(defvar gutter-element-visibility-changed-hook nil
-  "Function or functions to be called when the visibility of an
-element in the gutter changes.  The value of this variable may be
-buffer-local. The gutter element symbol is passed as an argument to
-the hook, as is the visibility flag.")
-
-(defun set-gutter-element (gutter-specifier prop val &optional locale tag-set)
-  "Set GUTTER-SPECIFIER gutter element PROP to VAL in optional LOCALE.
-This is a convenience function for setting gutter elements."
-  (map-extents #'(lambda (extent arg) 
-		   (set-extent-property extent 'duplicable t)) val)
-  (modify-specifier-instances gutter-specifier #'plist-put (list prop val)
-                              'force nil locale tag-set))
-
-(defun remove-gutter-element (gutter-specifier prop &optional locale tag-set)
-  "Remove gutter element PROP from GUTTER-SPECIFIER in optional LOCALE.
-This is a convenience function for removing gutter elements."
-  (modify-specifier-instances gutter-specifier #'plist-remprop (list prop)
-                              'force nil locale tag-set))
-
-(defun set-gutter-element-visible-p (gutter-visible-specifier-p
-				     prop &optional visible-p
-				     locale tag-set)
-  "Change the visibility of gutter elements.
-Set the visibility of element PROP to VISIBLE-P for
-GUTTER-SPECIFIER-VISIBLE-P in optional LOCALE.  
-This is a convenience function for hiding and showing gutter elements."
-  (modify-specifier-instances 
-   gutter-visible-specifier-p #'(lambda (spec prop visible-p)
-				  (if (consp spec)
-				      (if visible-p 
-					  (if (memq prop spec) spec  
-					    (cons prop spec))
-					(delq prop spec))
-				    (if visible-p (list prop))))
-   (list prop visible-p)
-   'force nil locale tag-set)
-  (run-hook-with-args 'gutter-element-visibility-changed-hook prop visible-p))
-
-(defun gutter-element-visible-p (gutter-visible-specifier-p
-				 prop &optional domain)
-  "Determine whether a gutter element is visible.
-Given GUTTER-VISIBLE-SPECIFIER-P and gutter element PROP, return
-non-nil if it is visible in optional DOMAIN."
-  (let ((spec (specifier-instance gutter-visible-specifier-p domain)))
-    (or (and (listp spec) (memq 'buffers-tab spec))
- 	spec)))
-
-(defun init-gutter ()
-  "Initialize the gutter."
-  ;; do nothing as yet.
-  )
 
 ;;; The Buffers tab
 
@@ -115,24 +34,30 @@ non-nil if it is visible in optional DOMAIN."
 
 (defvar gutter-buffers-tab nil
   "A tab widget in the gutter for displaying buffers.
-Do not set this. Use `glyph-image-instance' and
-`set-image-instance-property' to change the properties of the tab.")
+Do not set this. Use `set-glyph-image' to change the properties of the tab.")
 
 (defcustom gutter-buffers-tab-visible-p
   (gutter-element-visible-p default-gutter-visible-p 'buffers-tab)
   "Whether the buffers tab is globally visible. 
-This option should be set through the options menu."
+
+There are side-effects, so don't setq it; use Customize or the options menu."
   :group 'buffers-tab
   :type 'boolean
   :set #'(lambda (var val)
-	   (set-gutter-element-visible-p default-gutter-visible-p 'buffers-tab val)
+	   (set-gutter-element-visible-p default-gutter-visible-p 
+					 'buffers-tab val)
 	   (setq gutter-buffers-tab-visible-p val)))
 
+(defcustom gutter-buffers-tab-enabled t
+  "*Whether to enable support for buffers tab in the gutter.
+This is different to `gutter-buffers-tab-visible-p' which still runs hooks
+even when the gutter is invisible."
+  :group 'buffers-tab
+  :type 'boolean)
+
 (defvar gutter-buffers-tab-orientation 'top
   "Where the buffers tab currently is. Do not set this.")
 
-(defvar gutter-buffers-tab-extent nil)
-
 (defcustom buffers-tab-max-size 6
   "*Maximum number of entries which may appear on the \"Buffers\" tab.
 If this is 10, then only the ten most-recently-selected buffers will be
@@ -151,24 +76,40 @@ a large number or nil will slow down tab responsiveness."
   :group 'buffers-tab)
 
 (defcustom buffers-tab-omit-function 'buffers-menu-omit-invisible-buffers
-  "*If non-nil, a function specifying the buffers to omit from the buffers tab.
+  "*A function specifying the buffers to omit from the buffers tab, or nil.
 This is passed a buffer and should return non-nil if the buffer should be
-omitted.  The default value `buffers-tab-omit-invisible-buffers' omits
+omitted.  The default value `buffers-menu-omit-invisible-buffers' omits
 buffers that are normally considered \"invisible\" (those whose name
 begins with a space)."
   :type '(choice (const :tag "None" nil)
 		 function)
   :group 'buffers-tab)
 
-(defcustom buffers-tab-selection-function 'select-buffers-tab-buffers-by-mode
-  "*If non-nil, a function specifying the buffers to select from the
-buffers tab.  This is passed two buffers and should return non-nil if
-the second buffer should be selected.  The default value
-`select-buffers-tab-buffers-by-mode' groups buffers by major mode and
-by `buffers-tab-grouping-regexp'."
+(make-obsolete-variable 'buffers-tab-selection-function
+			'buffers-tab-filter-functions)
+(defcustom buffers-tab-selection-function nil
+  "*A function specifying buffers to display in the buffers tab, or nil.
+Don't use this---it is never consulted.  Use `buffers-tab-filter-functions'
+instead.
+
+The function must take arguments (BUF1 BUF2).  BUF1 is a candidate for
+display in the buffers tab control.  BUF2 is current (first in the buffers
+list).  Return non-nil if BUF1 should be added to the tab control."
+  :type '(choice function (const :tag "None" nil))
+  :group 'buffers-tab)
 
-  :type '(choice (const :tag "None" nil)
-		 function)
+(defcustom buffers-tab-filter-functions '(select-buffers-tab-buffers-by-mode)
+  "*A list of functions specifying buffers to display in the buffers tab.
+
+If nil, all buffers are kept, up to `buffers-tab-max-size', in usual order.
+Otherwise, each function in the list must take arguments (BUF1 BUF2).
+BUF1 is the candidate, and BUF2 is the current buffer (first in the buffers
+list).  The function should return non-nil if BUF1 should be added to the
+buffers tab.  BUF1 will be omitted if any of the functions returns nil.
+
+Defaults to `select-buffers-tab-buffers-by-mode', which adds BUF1 if BUF1 and
+BUF2 have the same major mode, or both match `buffers-tab-grouping-regexp'."
+  :type '(repeat function)
   :group 'buffers-tab)
 
 (defcustom buffers-tab-sort-function nil
@@ -182,7 +123,7 @@ list in `buffer-list' order (usual most-recently-selected-first)."
   :group 'buffers-tab)
 
 (make-face 'buffers-tab "Face for displaying the buffers tab.")
-(set-face-parent 'buffers-tab 'default)
+(set-face-parent 'buffers-tab 'modeline)
 
 (defcustom buffers-tab-face 'buffers-tab
   "*Face to use for displaying the buffers tab."
@@ -231,17 +172,23 @@ If this is 0, then the full buffer name will be shown."
 (defun buffers-tab-switch-to-buffer (buffer)
   "For use as a value for `buffers-tab-switch-to-buffer-function'."
   (unless (eq (window-buffer) buffer)
+    ;; this used to add the norecord flag to both calls below.
+    ;; this is bogus because it is a pervasive assumption in XEmacs
+    ;; that the current buffer is at the front of the buffers list.
+    ;; for example, select an item and then do M-C-l
+    ;; (switch-to-other-buffer).  Things get way confused.
     (if (> (length (windows-of-buffer buffer)) 0)
-	(select-window (car (windows-of-buffer buffer)) t)
-      (switch-to-buffer buffer t))))
+	(select-window (car (windows-of-buffer buffer)))
+      (switch-to-buffer buffer))))
 
-(defun select-buffers-tab-buffers-by-mode (buf1 buf2)
+(defun select-buffers-tab-buffers-by-mode (buffer-to-select buf1)
   "For use as a value of `buffers-tab-selection-function'.
 This selects buffers by major mode `buffers-tab-grouping-regexp'."
   (let ((mode1 (symbol-name (symbol-value-in-buffer 'major-mode buf1)))
-	(mode2 (symbol-name (symbol-value-in-buffer 'major-mode buf2)))
+	(mode2 (symbol-name (symbol-value-in-buffer 'major-mode 
+						    buffer-to-select)))
 	(modenm1 (symbol-value-in-buffer 'mode-name buf1))
-	(modenm2 (symbol-value-in-buffer 'mode-name buf2)))
+	(modenm2 (symbol-value-in-buffer 'mode-name buffer-to-select)))
     (cond ((or (eq mode1 mode2)
 	       (eq modenm1 modenm2)
 	       (and (string-match "^[^-]+-" mode1)
@@ -288,32 +235,25 @@ This just returns the buffer's name, optionally truncated."
 	   (when selected (setq selected nil))))
      buffers)))
 
-;;; #### SJT I'd really like this function to have just two hooks: (1) the
-;;; buffer filter list and (2) a sort function list.  Both should be lists
-;;; of functions.  Each filter takes two arguments:  a buffer and a model
-;;; buffer.  (The model buffer argument allows selecting according to the
-;;; mode or directory of that buffer.)  The filter returns t if the buffer
-;;; should be listed and nil otherwise.  Effectively the filter amounts to
-;;; the conjuction of the filter list.  (Optionally the filter could take a
-;;; frame instead of a buffer or generalize to a locale as in a specifier?)
-;;; The filtering is done this way to preserve the ordering imposed by
-;;; `buffer-list'.  In addition, the in-deletion argument will be used the
-;;; same way as in the current design.
-;;; The list is checked for length and pruned according to least-recently-
-;;; selected.  (Optionally there could be some kind of sort function here,
-;;; too.)
-;;; Finally the list is sorted to gutter display order, and the tab data
-;;; structure is created and returned.
-;;; #### Docstring isn't very well expressed.
+;;; #### SJT would like this function to have a sort function list. I
+;;; don't see how this could work given that sorting is not
+;;; cumulative --andyp.
 (defun buffers-tab-items (&optional in-deletion frame force-selection)
-  "This is the tab filter for the top-level buffers \"Buffers\" tab.
-It dynamically creates a list of buffers to use as the contents of the tab.
-Only the most-recently-used few buffers will be listed on the tab, for
-efficiency reasons.  You can control how many buffers will be shown by
-setting `buffers-tab-max-size'.  You can control the text of the tab
-items by redefining the function `format-buffers-menu-line'."
+  "Return a list of tab instantiators based on the current buffers list.
+This function is used as the tab filter for the top-level buffers
+\"Buffers\" tab.  It dynamically creates a list of tab instantiators
+to use as the contents of the tab.  The contents and order of the list
+is controlled by `buffers-tab-filter-functions' which by default
+groups buffers according to major mode and removes invisible buffers.
+You can control how many buffers will be shown by setting
+`buffers-tab-max-size'.  You can control the text of the tab items by
+redefining the function `format-buffers-menu-line'."
   (save-match-data
-    (let* ((buffers (delete-if buffers-tab-omit-function (buffer-list frame)))
+    ;; NB it is too late if we run the omit function as part of the
+    ;; filter functions because we need to know which buffer is the
+    ;; context buffer before they get run.
+    (let* ((buffers (delete-if 
+		     buffers-tab-omit-function (buffer-list frame)))
 	   (first-buf (car buffers)))
       ;; maybe force the selected window
       (when (and force-selection
@@ -325,16 +265,24 @@ items by redefining the function `format-buffers-menu-line'."
       (when in-deletion 
 	(setq buffers (delq (current-buffer) buffers))
 	(setq first-buf (car buffers)))
-      ;; select buffers in group (default is by mode)
-      (when buffers-tab-selection-function
-	(delete-if-not #'(lambda (buf)
-			   (funcall buffers-tab-selection-function
-				    first-buf buf)) buffers))
+      ;; filter buffers
+      (when buffers-tab-filter-functions
+	(setq buffers
+	      (delete-if 
+	       #'null 
+	       (mapcar #'(lambda (buf)
+			   (let ((tmp-buf buf))
+			     (mapc #'(lambda (fun)
+				       (unless (funcall fun buf first-buf)
+					 (setq tmp-buf nil)))
+				   buffers-tab-filter-functions)
+			     tmp-buf))
+		       buffers))))
       ;; maybe shorten list of buffers
       (and (integerp buffers-tab-max-size)
 	   (> buffers-tab-max-size 1)
 	   (> (length buffers) buffers-tab-max-size)
-	   (setcdr (nthcdr buffers-tab-max-size buffers) nil))
+	   (setcdr (nthcdr (1- buffers-tab-max-size) buffers) nil))
       ;; sort buffers in group (default is most-recently-selected)
       (when buffers-tab-sort-function
 	(setq buffers (funcall buffers-tab-sort-function buffers)))
@@ -345,23 +293,11 @@ items by redefining the function `format-buffers-menu-line'."
 (defun add-tab-to-gutter ()
   "Put a tab control in the gutter area to hold the most recent buffers."
   (setq gutter-buffers-tab-orientation (default-gutter-position))
-  (let ((gutter-string "\n"))
-    (unless gutter-buffers-tab-extent
-      (setq gutter-buffers-tab-extent (make-extent 0 1 gutter-string)))
-    (set-extent-begin-glyph 
-     gutter-buffers-tab-extent
-     (setq gutter-buffers-tab 
-	   (make-glyph 
-	    (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face
-		    :orientation gutter-buffers-tab-orientation
-		    (if (or (eq gutter-buffers-tab-orientation 'top)
-			    (eq gutter-buffers-tab-orientation 'bottom))
-			:pixel-width :pixel-height)
-		    (if (or (eq gutter-buffers-tab-orientation 'top)
-			    (eq gutter-buffers-tab-orientation 'bottom))
-			'(gutter-pixel-width) '(gutter-pixel-height))
-		    :properties (list :items (buffers-tab-items nil nil t))))))
-
+  (let* ((gutter-string (copy-sequence "\n"))
+	 (gutter-buffers-tab-extent (make-extent 0 1 gutter-string)))
+    (set-extent-begin-glyph gutter-buffers-tab-extent
+			    (setq gutter-buffers-tab 
+				  (make-glyph)))
     ;; Nuke all existing tabs
     (remove-gutter-element top-gutter 'buffers-tab)
     (remove-gutter-element bottom-gutter 'buffers-tab)
@@ -383,71 +319,67 @@ items by redefining the function `format-buffers-menu-line'."
 		 ((eq gutter-buffers-tab-orientation 'left)
 		  (set-specifier left-gutter-border-width 0 'global x)
 		  (set-gutter-element left-gutter 'buffers-tab
-				      gutter-string 'global x)
-		  (set-specifier left-gutter-width
-				 (glyph-width gutter-buffers-tab)
-				 'global x))
+				      gutter-string 'global x))
 		 ((eq gutter-buffers-tab-orientation 'right)
 		  (set-specifier right-gutter-border-width 0 'global x)
 		  (set-gutter-element right-gutter 'buffers-tab
-				      gutter-string 'global x)
-		  (set-specifier right-gutter-width
-				 (glyph-width gutter-buffers-tab)
-				 'global x))
+				      gutter-string 'global x))
 		 )))
      (console-type-list))))
 
-(defun update-tab-in-gutter (&optional frame-or-buffer force-selection)
+(defun update-tab-in-gutter (frame &optional force-selection)
   "Update the tab control in the gutter area."
-  (let ((locale (if (framep frame-or-buffer) frame-or-buffer)))
     ;; dedicated frames don't get tabs
-    (unless (and (framep locale)
-		 (window-dedicated-p (frame-selected-window locale)))
-      (when (specifier-instance default-gutter-visible-p locale)
-	(unless (and gutter-buffers-tab 
-		     (eq (default-gutter-position)
-			 gutter-buffers-tab-orientation))
-	  (add-tab-to-gutter))
-	(when (valid-image-instantiator-format-p 'tab-control locale)
-	  (let ((inst (glyph-image-instance 
-		       gutter-buffers-tab
-		       (when (framep frame-or-buffer)
-			 (last-nonminibuf-window frame-or-buffer)))))
-	    (set-image-instance-property inst :items 
-					 (buffers-tab-items 
-					  nil locale force-selection))))))))
-
-(defun remove-buffer-from-gutter-tab ()
-  "Remove the current buffer from the tab control in the gutter area."
-  (when (and (valid-image-instantiator-format-p 'tab-control)
-	     (specifier-instance default-gutter-visible-p))
-    (let ((inst (glyph-image-instance gutter-buffers-tab))
-	  (buffers (buffers-tab-items t)))
-      (unless buffers
-	(setq buffers (build-buffers-tab-internal 
-		       (list 
-			(get-buffer-create "*scratch*")))))
-      (set-image-instance-property inst :items buffers))))
+  (unless (or (window-dedicated-p (frame-selected-window frame))
+	      (frame-property frame 'popup))
+    (when (specifier-instance default-gutter-visible-p frame)
+      (unless (and gutter-buffers-tab
+		   (eq (default-gutter-position)
+		       gutter-buffers-tab-orientation))
+	(add-tab-to-gutter))
+      (when (valid-image-instantiator-format-p 'tab-control frame)
+	(let ((items (buffers-tab-items nil frame force-selection)))
+	  (when items
+	    (set-glyph-image
+	     gutter-buffers-tab
+	     (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face
+		     :orientation gutter-buffers-tab-orientation
+		     (if (or (eq gutter-buffers-tab-orientation 'top)
+			     (eq gutter-buffers-tab-orientation 'bottom))
+			 :pixel-width :pixel-height)
+		     (if (or (eq gutter-buffers-tab-orientation 'top)
+			     (eq gutter-buffers-tab-orientation 'bottom))
+			 '(gutter-pixel-width) '(gutter-pixel-height)) 
+		     :items items)
+	     frame)
+	    ;; set-glyph-image will not make the gutter dirty
+	    (set-gutter-dirty-p gutter-buffers-tab-orientation)))))))
 
 ;; A myriad of different update hooks all doing slightly different things
-(add-hook 'kill-buffer-hook 'remove-buffer-from-gutter-tab)
-(add-hook 'create-frame-hook 
-	  #'(lambda (frame)
-	      (when gutter-buffers-tab (update-tab-in-gutter frame t))))
-(add-hook 'record-buffer-hook 'update-tab-in-gutter)
-(add-hook 'default-gutter-position-changed 
-	  #'(lambda (arg)
-	      (when gutter-buffers-tab (update-tab-in-gutter arg))))
-(add-hook 'gutter-element-visibility-changed-hook
-	  #'(lambda (prop visible-p)
-	      (when (and (eq prop 'buffers-tab) visible-p)
-		(update-tab-in-gutter))))
+(add-one-shot-hook 
+ 'after-init-hook
+ #'(lambda ()
+     ;; don't add the hooks if the user really doesn't want them
+     (when gutter-buffers-tab-enabled
+       (add-hook 'create-frame-hook 
+		 #'(lambda (frame)
+		     (when gutter-buffers-tab (update-tab-in-gutter frame t))))
+       (add-hook 'buffer-list-changed-hook 'update-tab-in-gutter)
+       (add-hook 'default-gutter-position-changed-hook
+		 #'(lambda ()
+		     (when gutter-buffers-tab
+		       (mapc #'update-tab-in-gutter (frame-list)))))
+       (add-hook 'gutter-element-visibility-changed-hook
+		 #'(lambda (prop visible-p)
+		     (when (and (eq prop 'buffers-tab) visible-p)
+		       (mapc #'update-tab-in-gutter (frame-list)))))
+       (update-tab-in-gutter (selected-frame) t))))
 
 ;;
 ;; progress display
 ;; ripped off from message display
 ;;
-(defcustom progress-display-use-echo-area nil
+(defcustom progress-feedback-use-echo-area nil
   "*Whether progress gauge display should display in the echo area.
 If NIL then progress gauges will be displayed with whatever native widgets
 are available on the current console. If non-NIL then progress display will be
@@ -455,69 +387,87 @@ textual and displayed in the echo area."
   :type 'boolean
   :group 'gutter)
 
-(defvar progress-stack nil
-  "An alist of label/string pairs representing active progress gauges.
-The first element in the list is currently displayed in the gutter area.
-Do not modify this directly--use the `progress-display' or
-`display-progress-display'/`clear-progress-display' functions.")
-
-(defvar progress-glyph-height 32
-  "Height of the gutter area for progress messages.")
+(defvar progress-glyph-height 24
+  "Height of the progress gauge glyph.")
 
-(defvar progress-display-stop-callback 'progress-display-quit-function
-  "Function to call to stop the progress operation.")
-
-(defvar progress-display-popup-period 0.5
+(defvar progress-feedback-popup-period 0.5
   "The time that the progress gauge should remain up after completion")
 
-(defun progress-display-quit-function ()
-  "Default function to call for the stop button in a progress gauge.
-This just removes the progress gauge and calls quit."
-  (interactive)
-  (clear-progress-display)
-  (keyboard-quit))
+(defcustom progress-feedback-style 'large
+  "*Control the appearance of the progress gauge.
+If 'large, the default, then the progress-feedback text is displayed
+above the gauge itself. If 'small then the gauge and text are arranged
+side-by-side."
+  :group 'gutter
+  :type '(choice (const :tag "large" large)
+		 (const :tag "small" small)))
 
 ;; private variables
-(defvar progress-gauge-glyph
-  (make-glyph
-   (vector 'progress-gauge
-	   :pixel-height (- progress-glyph-height 8)
-	   :pixel-width 250
-	   :descriptor "Progress")))
-
-(defvar progress-text-glyph
-  (make-glyph [string :data ""]))
-
-(defvar progress-layout-glyph
-  (make-glyph
-   (vector 
-    'layout :orientation 'vertical :justify 'left
-    :items (list 
-	    progress-text-glyph
-	    (make-glyph
-	     (vector 
-	      'layout :pixel-height progress-glyph-height 
-	      :orientation 'horizontal
-	      :items (list 
-		      progress-gauge-glyph
-		      (vector 
-		       'button :pixel-height (- progress-glyph-height 8)
-		       :descriptor " Stop "
-		       :callback '(funcall progress-display-stop-callback)))))))))
-
-(defvar progress-abort-glyph
-  (make-glyph
-   (vector 'layout :orientation 'vertical :justify 'left
-	   :items (list progress-text-glyph
-			(make-glyph 
-			 (vector 'layout 
-				 :pixel-height progress-glyph-height
-				 :orientation 'horizontal))))))
-
-(defvar progress-extent-text "\n")
-(defvar progress-extent nil)
-
-(defun progress-displayed-p (&optional return-string frame)
+(defvar progress-text-instantiator [string :data ""])
+(defvar progress-layout-glyph (make-glyph))
+(defvar progress-layout-instantiator nil)
+
+(defvar progress-gauge-instantiator
+  [progress-gauge
+   :value 0
+   :pixel-height (eval progress-glyph-height)
+   :pixel-width 250
+   :descriptor "Progress"])
+
+(defun set-progress-feedback-instantiator (&optional locale)
+  (cond
+   ((eq progress-feedback-style 'small)
+    (setq progress-glyph-height 16)
+    (setq progress-layout-instantiator
+	  `[layout
+	    :orientation vertical :margin-width 4
+	    :horizontally-justify left :vertically-justify center
+	    :items (,progress-gauge-instantiator
+		    [button
+		     :pixel-height (eval progress-glyph-height)
+		     ;; 'quit is special and acts "asynchronously".
+		     :descriptor "Stop" :callback 'quit]
+		    ,progress-text-instantiator)])
+    (set-glyph-image progress-layout-glyph progress-layout-instantiator
+		     locale))
+   (t 
+    (setq progress-glyph-height 24)
+    (setq progress-layout-instantiator
+	  `[layout 
+	    :orientation vertical :margin-width 4
+	    :horizontally-justify left :vertically-justify center
+	    :items (,progress-text-instantiator
+		    [layout 
+		     :orientation horizontal
+		     :items (,progress-gauge-instantiator
+			     [button 
+			      :pixel-height (eval progress-glyph-height)
+			      :descriptor " Stop "
+			      ;; 'quit is special and acts "asynchronously".
+			      :callback 'quit])])])
+    (set-glyph-image progress-layout-glyph progress-layout-instantiator
+		     locale))))
+
+(defvar progress-abort-glyph (make-glyph))
+
+(defun set-progress-abort-instantiator (&optional locale)
+  (set-glyph-image progress-abort-glyph
+		   `[layout :orientation vertical
+			    :horizontally-justify left :vertically-justify center
+			    :items (,progress-text-instantiator
+				    [layout
+				     :margin-width 4
+				     :pixel-height progress-glyph-height
+				     :orientation horizontal])]
+		   locale))
+
+(defvar progress-stack nil
+  "An alist of label/string pairs representing active progress gauges.
+The first element in the list is currently displayed in the gutter area.
+Do not modify this directly--use the `progress-feedback' or
+`display-progress-feedback'/`clear-progress-feedback' functions.")
+
+(defun progress-feedback-displayed-p (&optional return-string frame)
   "Return a non-nil value if a progress gauge is presently displayed in the
 gutter area.  If optional argument RETURN-STRING is non-nil,
 return a string containing the message, otherwise just return t."
@@ -529,7 +479,7 @@ return a string containing the message, otherwise just return t."
 
 ;;; Returns the string which remains in the echo area, or nil if none.
 ;;; If label is nil, the whole message stack is cleared.
-(defun clear-progress-display (&optional label frame no-restore)
+(defun clear-progress-feedback (&optional label frame no-restore)
   "Remove any progress gauge with LABEL from the progress gauge-stack,
 erasing it from the gutter area if it's currently displayed there.
 If a message remains at the head of the progress-stack and NO-RESTORE
@@ -540,10 +490,10 @@ If LABEL is nil, the entire progress-stack is cleared.
 Unless you need the return value or you need to specify a label,
 you should just use (progress nil)."
   (if (or (not (valid-image-instantiator-format-p 'progress-gauge frame))
-	  progress-display-use-echo-area)
+	  progress-feedback-use-echo-area)
       (clear-message label frame nil no-restore)
     (or frame (setq frame (selected-frame)))
-    (remove-progress-display label frame)
+    (remove-progress-feedback label frame)
     (let ((inhibit-read-only t)
 	  (zmacs-region-stays zmacs-region-stays)) ; preserve from change
       (erase-buffer (get-buffer-create " *Gutter Area*")))
@@ -551,21 +501,19 @@ you should just use (progress nil)."
 	nil			; just preparing to put another msg up
       (if progress-stack
 	  (let ((oldmsg (cdr (car progress-stack))))
-	    (raw-append-progress-display oldmsg frame)
+	    (raw-append-progress-feedback oldmsg nil frame)
 	    oldmsg)
 	;; nothing to display so get rid of the gauge
 	(set-specifier bottom-gutter-border-width 0 frame)
 	(set-gutter-element-visible-p bottom-gutter-visible-p 
 				      'progress nil frame)))))
 
-(defun progress-display-clear-when-idle (&optional label)
-  (add-hook 'pre-idle-hook
-	    (defun progress-display-clear-pre-idle-hook ()
-	      (clear-progress-display label)
-	      (remove-hook 'pre-idle-hook 
-			   'progress-display-clear-pre-idle-hook))))
+(defun progress-feedback-clear-when-idle (&optional label)
+  (add-one-shot-hook 'pre-idle-hook
+		     `(lambda ()
+			(clear-progress-feedback ',label))))
 
-(defun remove-progress-display (&optional label frame)
+(defun remove-progress-feedback (&optional label frame)
   ;; If label is nil, we want to remove all matching progress gauges.
   (while (and progress-stack
 	      (or (null label)	; null label means clear whole stack
@@ -579,7 +527,15 @@ you should just use (progress nil)."
 	      (setcdr s (cdr (cdr s))))
 	  (setq s (cdr s)))))))
 
-(defun append-progress-display (label message &optional value frame)
+(defun progress-feedback-dispatch-non-command-events ()
+  ;; don't allow errors to hose things
+  (condition-case t 
+      ;; (sit-for 0) is too agressive and cause more display than we
+      ;; want.
+      (dispatch-non-command-events)
+    nil))
+
+(defun append-progress-feedback (label message &optional value frame)
   (or frame (setq frame (selected-frame)))
   ;; Add a new entry to the message-stack, or modify an existing one
   (let* ((top (car progress-stack))
@@ -588,24 +544,22 @@ you should just use (progress nil)."
 	(progn
 	  (setcdr top message)
 	  (if (equal tmsg message)
-	      (set-image-instance-property 
-	       (glyph-image-instance progress-gauge-glyph)
-	       :percent value)
-	    (raw-append-progress-display message value frame))
+	      (progn 
+		(set-instantiator-property progress-gauge-instantiator :value value)
+		(set-progress-feedback-instantiator (frame-selected-window frame)))
+	    (raw-append-progress-feedback message value frame))
 	  (redisplay-gutter-area))
       (push (cons label message) progress-stack)
-      (raw-append-progress-display message value frame))
-    (dispatch-non-command-events)
+      (raw-append-progress-feedback message value frame))
+    (progress-feedback-dispatch-non-command-events)
     ;; either get command events or sit waiting for them
-    (if (not (eq value 100))
-	(when (input-pending-p)
-	  (dispatch-event (next-command-event)))
-      (sit-for progress-display-popup-period nil)
-      (clear-progress-display label))))
+    (when (eq value 100)
+;      (sit-for progress-feedback-popup-period nil)
+      (clear-progress-feedback label))))
 
-(defun abort-progress-display (label message &optional frame)
+(defun abort-progress-feedback (label message &optional frame)
   (if (or (not (valid-image-instantiator-format-p 'progress-gauge frame))
-	  progress-display-use-echo-area)
+	  progress-feedback-use-echo-area)
       (display-message label (concat message "aborted.") frame)
     (or frame (setq frame (selected-frame)))
     ;; Add a new entry to the message-stack, or modify an existing one
@@ -617,57 +571,54 @@ you should just use (progress nil)."
 	(push (cons label message) progress-stack))
       (unless (equal message "")
 	(insert-string message (get-buffer-create " *Gutter Area*"))
-	;; Do what the device is able to cope with.
-	;; do some funky display here.
-	(unless progress-extent
-	  (setq progress-extent (make-extent 0 1 progress-extent-text)))
-	(let ((bglyph (extent-begin-glyph progress-extent)))
-	  (set-extent-begin-glyph progress-extent progress-abort-glyph)
+	(let* ((gutter-string (copy-sequence "\n"))
+	       (ext (make-extent 0 1 gutter-string)))
+	  ;; do some funky display here.
+	  (set-extent-begin-glyph ext progress-abort-glyph)
 	  ;; fixup the gutter specifiers
-	  (set-gutter-element bottom-gutter 
-			      'progress progress-extent-text frame)
+	  (set-gutter-element bottom-gutter 'progress gutter-string frame)
 	  (set-specifier bottom-gutter-border-width 2 frame)
-	  (set-image-instance-property 
-	   (glyph-image-instance progress-text-glyph) :data message)
+	  (set-instantiator-property progress-text-instantiator :data message)
+	  (set-progress-abort-instantiator (frame-selected-window frame))
 	  (set-specifier bottom-gutter-height 'autodetect frame)
 	  (set-gutter-element-visible-p bottom-gutter-visible-p 
 					'progress t frame)
 	  ;; we have to do this so redisplay is up-to-date and so
 	  ;; redisplay-gutter-area performs optimally.
 	  (redisplay-gutter-area)
-	  (sit-for progress-display-popup-period nil)
-	  (clear-progress-display label)
-	  (set-extent-begin-glyph progress-extent bglyph)
+	  (sit-for progress-feedback-popup-period nil)
+	  (clear-progress-feedback label frame)
+	  (set-extent-begin-glyph ext progress-layout-glyph)
+	  (set-gutter-element bottom-gutter 'progress gutter-string frame)
 	  )))))
 
-(defun raw-append-progress-display (message &optional value frame)
+(defun raw-append-progress-feedback (message &optional value frame)
   (unless (equal message "")
-    (let ((inhibit-read-only t)
+    (let* ((inhibit-read-only t)
 	  (zmacs-region-stays zmacs-region-stays)
-	  (val (or value 0)))
+	  (val (or value 0))
+	  (gutter-string (copy-sequence "\n"))
+	  (ext (make-extent 0 1 gutter-string)))
       (insert-string message (get-buffer-create " *Gutter Area*"))
       ;; do some funky display here.
-      (unless progress-extent
-	(setq progress-extent (make-extent 0 1 progress-extent-text))
-	(set-extent-begin-glyph progress-extent progress-layout-glyph))
+      (set-extent-begin-glyph ext progress-layout-glyph)
       ;; fixup the gutter specifiers
-      (set-gutter-element bottom-gutter 'progress progress-extent-text frame)
+      (set-gutter-element bottom-gutter 'progress gutter-string frame)
       (set-specifier bottom-gutter-border-width 2 frame)
-      (set-image-instance-property 
-       (glyph-image-instance progress-gauge-glyph) :percent val)
-      (set-image-instance-property 
-       (glyph-image-instance progress-text-glyph) :data message)
+      (set-instantiator-property progress-gauge-instantiator :value val)
+      (set-progress-feedback-instantiator (frame-selected-window frame))
+
+      (set-instantiator-property progress-text-instantiator :data message)
+      (set-progress-feedback-instantiator (frame-selected-window frame))
       (if (and (eq (specifier-instance bottom-gutter-height frame)
 		   'autodetect)
 	       (gutter-element-visible-p bottom-gutter-visible-p
 					 'progress frame))
+	  ;; if the gauge is already visible then just draw the gutter
+	  ;; checking for user events
 	  (progn
-	    ;; if the gauge is already visible then just draw the gutter
-	    ;; checking for user events
 	    (redisplay-gutter-area)
-	    (dispatch-non-command-events)
-	    (when (input-pending-p)
-	      (dispatch-event (next-command-event))))
+	    (progress-feedback-dispatch-non-command-events))
 	;; otherwise make the gutter visible and redraw the frame
 	(set-specifier bottom-gutter-height 'autodetect frame)
 	(set-gutter-element-visible-p bottom-gutter-visible-p
@@ -675,36 +626,36 @@ you should just use (progress nil)."
 	;; we have to do this so redisplay is up-to-date and so
 	;; redisplay-gutter-area performs optimally. This may also
 	;; make sure the frame geometry looks ok.
-	(dispatch-non-command-events)
-	(redisplay-frame)
+	(progress-feedback-dispatch-non-command-events)
+	(redisplay-frame frame)
 	))))
 
-(defun display-progress-display (label message &optional value frame)
+(defun display-progress-feedback (label message &optional value frame)
   "Display a progress gauge and message in the bottom gutter area.
  First argument LABEL is an identifier for this message.  MESSAGE is
-the string to display.  Use `clear-progress-display' to remove a labelled
+the string to display.  Use `clear-progress-feedback' to remove a labelled
 message."
   (cond ((eq value 'abort)
-	 (abort-progress-display label message frame))
+	 (abort-progress-feedback label message frame))
 	((or (not (valid-image-instantiator-format-p 'progress-gauge frame))
-	     progress-display-use-echo-area)
+	     progress-feedback-use-echo-area)
 	 (display-message label 
 	   (concat message (if (eq value 100) "done."
 			     (make-string (/ value 5) ?.)))
 	   frame))
 	(t
-	 (append-progress-display label message value frame))))
+	 (append-progress-feedback label message value frame))))
 
-(defun current-progress-display (&optional frame)
+(defun current-progress-feedback (&optional frame)
   "Return the current progress gauge in the gutter area, or nil.
 The FRAME argument is currently unused."
   (cdr (car progress-stack)))
 
 ;;; may eventually be frame-dependent
-(defun current-progress-display-label (&optional frame)
+(defun current-progress-feedback-label (&optional frame)
   (car (car progress-stack)))
 
-(defun progress-display (fmt &optional value &rest args)
+(defun progress-feedback (fmt &optional value &rest args)
   "Print a progress gauge and message in the bottom gutter area of the frame.
 The arguments are the same as to `format'.
 
@@ -712,23 +663,25 @@ If the only argument is nil, clear any existing progress gauge."
   (save-excursion
     (if (and (null fmt) (null args))
 	(prog1 nil
-	  (clear-progress-display nil))
+	  (clear-progress-feedback nil))
       (let ((str (apply 'format fmt args)))
-	(display-progress-display 'progress str value)
+	(display-progress-feedback 'progress str value)
 	str))))
 
-(defun lprogress-display (label fmt &optional value &rest args)
+(defun progress-feedback-with-label (label fmt &optional value &rest args)
   "Print a progress gauge and message in the bottom gutter area of the frame.
-First argument LABEL is an identifier for this progress gauge.  The rest of the
-arguments are the same as to `format'."
+LABEL is an identifier for this progress gauge.
+FMT is a format string to be passed to `format' along with ARGS.
+Optional VALUE is the current degree of progress, an integer 0-100.
+The remaining ARGS are passed with FMT `(apply #'format FMT ARGS)'."
   ;; #### sometimes the buffer gets changed temporarily. I don't know
   ;; why this is, so protect against it.
   (save-excursion
     (if (and (null fmt) (null args))
 	(prog1 nil
-	  (clear-progress-display label nil))
+	  (clear-progress-feedback label nil))
       (let ((str (apply 'format fmt args)))
-	(display-progress-display label str value)
+	(display-progress-feedback label str value)
 	str))))
 
 (provide 'gutter-items)