--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/utils/facemenu.el	Mon Aug 13 08:45:50 2007 +0200
@@ -0,0 +1,773 @@
+;;; facemenu.el --- create a face menu for interactively adding fonts to text
+;; Copyright (c) 1994, 1995 Free Software Foundation, Inc.
+
+;; XEmacs version: Mike Sperber <sperber@informatik.uni-tuebingen.de>
+;; Original author: Boris Goldowsky <boris@gnu.ai.mit.edu>
+;; Keywords: faces
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Synched up with: FSF 19.30.
+
+;;; Commentary:
+;; This file defines a menu of faces (bold, italic, etc) which allows you to
+;; set the face used for a region of the buffer.  Some faces also have
+;; keybindings, which are shown in the menu.  Faces with names beginning with
+;; "fg:" or "bg:", as in "fg:red", are treated specially.
+;; Such faces are assumed to consist only of a foreground (if "fg:") or
+;; background (if "bg:") color.  They are thus put into the color submenus
+;; rather than the general Face submenu.  These faces can also be
+;; automatically created by selecting the "Other..." menu items in the
+;; "Foreground" and "Background" submenus.
+;;
+;; The menu also contains submenus for indentation and justification-changing
+;; commands.
+
+;;; Installation:
+;; Just do a (require 'facemenu).
+;; If you want the menu bound to a mouse button under XEmacs, do
+;; (define-key global-map '(control button2) 'facemenu-menu)
+
+;;; Usage:
+;; Selecting a face from the menu or typing the keyboard equivalent will
+;; change the region to use that face.  If you use transient-mark-mode and the
+;; region is not active, the face will be remembered and used for the next
+;; insertion.  It will be forgotten if you move point or make other
+;; modifications before inserting or typing anything.
+;;
+;; Faces can be selected from the keyboard as well.  
+;; The standard keybindings are M-g (or ESC g) + letter:
+;; M-g i = "set italic",  M-g b = "set bold", etc.
+
+;;
+;; The order of the faces that appear in the menu and their keybindings can be
+;; controlled by setting the variables `facemenu-keybindings' and
+;; `facemenu-new-faces-at-end'.  List faces that you don't use in documents
+;; (eg, `region') in `facemenu-unlisted-faces'.
+
+;;; Known Problems:
+;; Bold and Italic do not combine to create bold-italic if you select them
+;; both, although most other combinations (eg bold + underline + some color)
+;; do the intuitive thing.
+;;
+;; There is at present no way to display what the faces look like in
+;; the menu itself.
+;;
+;; `list-faces-display' shows the faces in a different order than
+;; this menu, which could be confusing.  I do /not/ sort the list
+;; alphabetically, because I like the default order: it puts the most
+;; basic, common fonts first.
+;;
+;; Please send me any other problems, comments or ideas.
+
+;;; Code:
+
+(provide 'facemenu)
+
+(require 'easymenu)
+
+;;; Provide some binding for startup:
+;;; XEmacs -- goto-line is a *much* better binding for M-g.
+;;;dont ###autoload (define-key global-map "\M-g" 'facemenu-keymap)
+
+(defvar facemenu-key "\M-g"
+  "Prefix key to use for facemenu commands.")
+
+(defvar facemenu-keybindings
+  '((default     . "d")
+    (bold        . "b")
+    (italic      . "i")
+    (bold-italic . "l") ; {bold} intersect {italic} = {l}
+    (underline   . "u"))
+  "Alist of interesting faces and keybindings. 
+Each element is itself a list: the car is the name of the face,
+the next element is the key to use as a keyboard equivalent of the menu item;
+the binding is made in facemenu-keymap.
+
+The faces specifically mentioned in this list are put at the top of
+the menu, in the order specified.  All other faces which are defined,
+except for those in `facemenu-unlisted-faces', are listed after them, 
+but get no keyboard equivalents.
+
+If you change this variable after loading facemenu.el, you will need to call
+`facemenu-update' to make it take effect.")
+
+(defvar facemenu-new-faces-at-end t
+  "Where in the menu to insert newly-created faces.
+This should be nil to put them at the top of the menu, or t to put them
+just before \"Other\" at the end.")
+
+(defvar facemenu-unlisted-faces
+  '(modeline region secondary-selection highlight scratch-face
+    gui-button-face isearch hyperlink
+    modeline modeline-buffer-id modeline-mousable modeline-mousable-minor-mode
+    pointer primary-selection secondary-selection list-mode-item-selected
+    text-cursor zmacs-region
+    left-margin right-margin)
+  "List of faces not to include in the Face menu.
+You can set this list before loading facemenu.el, or add a face to it before
+creating that face if you do not want it to be listed.  If you change the
+variable so as to eliminate faces that have already been added to the menu,
+call `facemenu-update' to recalculate the menu contents.
+
+If this variable is t, no faces will be added to the menu.  This is useful for
+temporarily turning off the feature that automatically adds faces to the menu
+when they are created.")
+
+(defvar facemenu-relevant-face-attributes
+  '(foreground background font underline highlight dim blinking reverse)
+  "List of face attributes that facemenu fiddles with.
+This is only relevant for XEmacs.")
+
+(easy-menu-define facemenu-face-menu ()
+   "Menu for faces"
+   `("Face"
+     ["Other..." facemenu-set-face t]))
+
+(easy-menu-define facemenu-foreground-menu ()
+  "Menu for foreground colors"
+  `("Foreground Color"
+    ["Other..." facemenu-set-foreground t]))
+
+(easy-menu-define facemenu-background-menu ()
+  "Menu for background colors"
+  `("Background Color"
+    ["Other..." facemenu-set-background t]))
+
+(easy-menu-define facemenu-size-menu ()
+  "Menu for font sizes."
+  '("Size"
+    ["Default" facemenu-set-size-default t]
+    ["Bigger" facemenu-make-larger t]
+    ["Smaller" facemenu-make-smaller t]
+    ["Much Bigger" facemenu-make-much-larger t]
+    ["Much Smaller" facemenu-make-much-smaller t]))
+
+(easy-menu-define facemenu-special-menu ()
+  "Menu for non-face text-properties."
+  '("Special"
+    ["Read-Only" facemenu-set-read-only t]
+    ["Invisible" facemenu-set-invisible t]
+    ["Intangible" facemenu-set-intangible t]
+    ["Remove Special" facemenu-remove-special t]))
+
+(easy-menu-define facemenu-justification-menu ()
+  "Menu for text justification commands."
+  '("Justification"
+    ["Center" set-justification-center t]
+    ["Full" set-justification-full t]
+    ["Right" set-justification-right t]
+    ["Unfilled" set-justification-none t]))
+
+(easy-menu-define facemenu-indentation-menu
+  ()
+  "Submenu for indentation commands."
+  '("Indentation"
+    ["Indent More" increase-left-margin t]
+    ["Indent Less" decrease-left-margin t]
+    ["Indent Right More" increase-right-margin t]
+    ["Indent Right Less" decrease-right-margin t]))
+
+;;;###autoload
+(defvar facemenu-menu nil
+  "Facemenu top-level menu keymap.")
+
+(defun facemenu-update-facemenu-menu ()
+  (easy-menu-define facemenu-menu ()
+   "Facemenu top-level menu"
+   (list "Text Properties"
+	 facemenu-face-menu
+	 facemenu-foreground-menu
+	 facemenu-background-menu
+	 facemenu-size-menu
+	 facemenu-special-menu
+	 "---"
+	 facemenu-justification-menu
+	 facemenu-indentation-menu
+	 "---"
+	 ["Remove Properties" facemenu-remove-props t]
+	 ["List Properties" list-text-properties-at t]
+	 ["Display Faces" list-faces-display t]
+	 ["Display Colors" list-colors-display t])))
+
+;;;###autoload
+(defvar facemenu-keymap
+  (let ((map (make-sparse-keymap "Set face")))
+    (define-key map ?o 'facemenu-set-face)
+    map)
+  "Keymap for face-changing commands.
+`Facemenu-update' fills in the keymap according to the bindings
+requested in `facemenu-keybindings'.")
+(defalias 'facemenu-keymap facemenu-keymap)
+
+;;; Internal Variables
+
+(defvar facemenu-color-alist nil
+  ;; Don't initialize here; that doesn't work if preloaded.
+  "Alist of colors, used for completion.
+If null, `facemenu-read-color' will set it.")
+
+(defun facemenu-update ()
+  "Add or update the \"Face\" menu in the menu bar.
+You can call this to update things if you change any of the menu configuration
+variables."
+  (interactive)
+
+  ;; Add each defined face to the menu.
+  (facemenu-iterate 'facemenu-add-new-face
+		    (facemenu-complete-face-list facemenu-keybindings))
+  (facemenu-update-facemenu-menu)
+  
+  ;; Global bindings:
+  (if (string-match "XEmacs" emacs-version)
+      (easy-menu-change '("Edit") (car facemenu-menu) (cdr facemenu-menu))
+    (define-key global-map [C-down-mouse-2] 'facemenu-menu))
+  (if facemenu-key (define-key global-map facemenu-key 'facemenu-keymap)))
+
+(fset 'facemenu-region-active-p
+      (if (string-match "XEmacs" emacs-version)
+	  'region-active-p
+	#'(lambda ()
+	    mark-active)))
+
+;;;###autoload
+(defun facemenu-set-face (face &optional start end)
+  "Add FACE to the region or next character typed.
+It will be added to the top of the face list; any faces lower on the list that
+will not show through at all will be removed.
+
+Interactively, the face to be used is read with the minibuffer.
+
+If the region is active and there is no prefix argument,
+this command sets the region to the requested face.
+
+Otherwise, this command specifies the face for the next character
+inserted.  Moving point or switching buffers before
+typing a character to insert cancels the specification." 
+  (interactive (list (read-face-name "Use face: ")))
+  (setq zmacs-region-stays t)
+  (barf-if-buffer-read-only)
+  (facemenu-add-new-face face)
+  (facemenu-update-facemenu-menu)
+  (if (and (facemenu-region-active-p)
+	   (not current-prefix-arg))
+      (let ((start (or start (region-beginning)))
+	    (end (or end (region-end))))
+	(facemenu-add-face face start end))
+    (facemenu-self-insert-face face)))
+
+;;;###autoload
+(defun facemenu-set-foreground (color &optional start end)
+  "Set the foreground color of the region or next character typed.
+The color is prompted for.  A face named `fg:color' is used \(or created).
+If the region is active, it will be set to the requested face.  If
+it is inactive \(even if mark-even-if-inactive is set) the next
+character that is typed \(via `self-insert-command') will be set to
+the selected face.  Moving point or switching buffers before
+typing a character cancels the request." 
+  (interactive (list (facemenu-read-color "Foreground color: ")))
+  (setq zmacs-region-stays t)
+  (let ((face (intern (concat "fg:" color))))
+    (or (facemenu-get-face face)
+	(error "Unknown color: %s" color))
+    (facemenu-set-face face start end)))
+
+;;;###autoload
+(defun facemenu-set-background (color &optional start end)
+  "Set the background color of the region or next character typed.
+The color is prompted for.  A face named `bg:color' is used \(or created).
+If the region is active, it will be set to the requested face.  If
+it is inactive \(even if mark-even-if-inactive is set) the next
+character that is typed \(via `self-insert-command') will be set to
+the selected face.  Moving point or switching buffers before
+typing a character cancels the request." 
+  (interactive (list (facemenu-read-color "Background color: ")))
+  (setq zmacs-region-stays t)
+  (let ((face (intern (concat "bg:" color))))
+    (or (facemenu-get-face face)
+	(error "Unknown color: %s" color))
+    (facemenu-set-face face start end)))
+
+;;;###autoload
+(defun facemenu-set-face-from-menu (face)
+  "Set the face of the region or next character typed.
+This function is designed to be called from a menu; the face to use
+is the menu item's name.
+
+If the region is active and there is no prefix argument,
+this command sets the region to the requested face.
+
+Otherwise, this command specifies the face for the next character
+inserted.  Moving point or switching buffers before
+typing a character to insert cancels the specification." 
+  (let ((start (if (and (facemenu-region-active-p)
+			(not current-prefix-arg))
+		   (region-beginning)))
+	(end (if (and (facemenu-region-active-p)
+		      (not current-prefix-arg))
+		 (region-end))))
+    (barf-if-buffer-read-only)
+    (setq zmacs-region-stays t)
+    (facemenu-get-face face)
+    (if start
+	(facemenu-add-face face start end)
+      (facemenu-self-insert-face face))))
+
+(defun facemenu-self-insert-face (face)
+  (setq self-insert-face (cond
+			  ((null self-insert-face) face)
+			  ((consp self-insert-face)
+			   (facemenu-active-faces (cons face self-insert-face)))
+			  (t
+			   (facemenu-active-faces (list face self-insert-face))))
+	self-insert-face-command this-command))
+
+(defun facemenu-face-strip-size (face)
+  "Create a symbol from the name of FACE devoid of size information,
+i.e. remove all larger- and smaller- prefixes."
+  (let* ((face-symbol (face-name face))
+	 (face-name (symbol-name face-symbol))
+	 (old-name face-name)
+	 new-name)
+    (while
+	(not (string-equal
+	      old-name
+	      (setq new-name (replace-in-string old-name "^larger-" ""))))
+      (setq old-name new-name))
+    
+    (while
+	(not (string-equal
+	      old-name
+	      (setq new-name (replace-in-string old-name "^smaller-" ""))))
+      (setq old-name new-name))
+    
+    (if (string-equal new-name face-name)
+	face-symbol
+      (intern new-name))))
+
+(defun facemenu-face-default-size (face)
+  (cond ((null face) nil)
+	((consp face) (mapcar 'facemenu-face-strip-size face))
+	(t (facemenu-face-strip-size face))))
+
+;;;###autoload
+(defun facemenu-set-size-default (start end)
+  (interactive "_r")
+  (put-text-property start end 'size nil)
+  (alter-text-property start end 'face 'facemenu-face-default-size))
+
+(defun facemenu-ensure-size-property (start end)
+  "Ensure that the text between START and END has a 'size text property.
+If it is not present, it is set to 0."
+  (let ((start start)
+	pos bound)
+    (while (setq pos (text-property-any start end 'size nil))
+      (setq bound (or (text-property-not-all pos end 'size nil) end))
+      (put-text-property pos bound 'size 0))))
+
+(defun facemenu-sized-face (face size)
+  "Make a face FACE larger or smaller according to SIZE.
+If SIZE is positive, it calls `make-face-larger' SIZE times,
+else it calls `make-face-smaller' -SIZE times."
+  (if (zerop size)
+      face
+    (let ((name (symbol-name face))
+	  (measure size)
+	  (change-face 'make-face-larger))
+
+      (if (> measure 0)
+	  (setq prefix "larger-")
+	(setq prefix "smaller-")
+	(setq measure (- measure))
+	(setq size (- size))
+	(setq change-face 'make-face-smaller))
+
+      (while (not (zerop measure))
+	(setq name (concat prefix name))
+	(setq measure (1- measure)))
+
+      (let ((symbol (intern name)))
+	(or (find-face symbol)
+	    (let ((face (copy-face face symbol)))
+	      (while (not (zerop size))
+		(funcall change-face face)
+		(setq size (1- size)))
+	      face))))))
+
+(defun facemenu-adjust-face-sizes (face)
+  (cond
+   ((null face) (facemenu-sized-face 'default size))
+   ((consp face) (mapcar 
+		  #'(lambda (face)
+		      (facemenu-sized-face (facemenu-face-strip-size face)
+					    size))
+		  face))
+   (t (facemenu-sized-face face size))))
+
+(defun facemenu-adjust-size (from to)
+  "Adjust the size of the text between FROM and TO according
+to the values of the 'size property in that region."
+  (let ((pos from)
+	bound size)
+    (while (< pos to)
+      (setq size (get-text-property pos 'size))
+      (setq bound (or (text-property-not-all pos to 'size size) to))
+      (alter-text-property pos bound 'face 'facemenu-adjust-face-sizes)
+      (setq pos bound))))
+
+(defun facemenu-change-size (from to f)
+  (facemenu-ensure-size-property from to)
+  (alter-text-property from to 'size f)
+  (facemenu-adjust-size from to))
+
+;;;###autoload
+(defun facemenu-make-larger (from to)
+  (interactive "_r")
+  (facemenu-change-size from to '1+))
+
+;;;###autoload
+(defun facemenu-make-smaller (from to)
+  (interactive "_r")
+  (facemenu-change-size from to '1-))
+
+;;;###autoload
+(defun facemenu-make-much-larger (from to)
+  (interactive "_r")
+  (facemenu-change-size from to #'(lambda (s) (+ 5 s))))
+
+;;;###autoload
+(defun facemenu-make-much-smaller (from to)
+  (interactive "_r")
+  (facemenu-change-size from to #'(lambda (s) (- s 5))))
+
+;;;###autoload
+(defun facemenu-set-invisible (start end)
+  "Make the region invisible.
+This sets the `invisible' text property; it can be undone with
+`facemenu-remove-special'."
+  (interactive "r")
+  (put-text-property start end 'invisible t))
+
+;;;###autoload
+(defun facemenu-set-intangible (start end)
+  "Make the region intangible: disallow moving into it.
+This sets the `intangible' text property; it can be undone with
+`facemenu-remove-special'."
+  (interactive "r")
+  (put-text-property start end 'intangible t))
+
+;;;###autoload
+(defun facemenu-set-read-only (start end)
+  "Make the region unmodifiable.
+This sets the `read-only' text property; it can be undone with
+`facemenu-remove-special'."
+  (interactive "r")
+  (put-text-property start end 'read-only t))
+
+;;;###autoload
+(defun facemenu-remove-props (start end)
+  "Remove all text properties that facemenu added to region."
+  (interactive "*_r") ; error if buffer is read-only despite the next line.
+  (let ((inhibit-read-only t))
+    (remove-text-properties 
+     start end '(face nil invisible nil intangible nil 
+		 read-only nil category nil size nil))))
+
+;;;###autoload
+(defun facemenu-remove-special (start end)
+  "Remove all the \"special\" text properties from the region.
+These special properties include `invisible', `intangible' and `read-only'."
+  (interactive "*_r") ; error if buffer is read-only despite the next line.
+  (let ((inhibit-read-only t))
+    (remove-text-properties 
+     start end '(invisible nil intangible nil read-only nil))))
+
+;;;###autoload
+(defun list-text-properties-at (p)
+  "Pop up a buffer listing text-properties at LOCATION."
+  (interactive "d")
+  (let ((props (text-properties-at p)))
+    (if (null props)
+	(message "None")
+      (with-output-to-temp-buffer "*Text Properties*"
+	(princ (format "Text properties at %d:\n\n" p))
+	(while props
+	  (princ (format "%-20s %S\n"
+			 (car props) (car (cdr props))))
+	  (setq props (cdr (cdr props))))))))
+
+;;;###autoload
+(defun facemenu-read-color (&optional prompt)
+  "Read a color using the minibuffer."
+  (if (string-match "XEmacs" emacs-version)
+      (read-color prompt)
+    (let ((col (completing-read
+		(or prompt "Color: ") 
+		(or facemenu-color-alist
+		    (if (or (eq window-system 'x) (eq window-system 'win32))
+			(mapcar 'list (x-defined-colors))))
+		nil t)))
+      (if (equal "" col)
+	  nil
+	col))))
+
+(defun facemenu-canonicalize-color (c)
+  (downcase (replace-in-string c " " "")))
+
+(defun facemenu-unique (list)
+  "Uniquify LIST, deleting elements using `delete'.
+Return the list with subsequent duplicate items removed by side effects."
+  (let ((list list))
+    (while list
+      (setq list (setcdr list (delete (car list) (cdr list))))))
+  list)
+
+;;;###autoload
+(defun list-colors-display (&optional list)
+  "Display names of defined colors, and show what they look like.
+If the optional argument LIST is non-nil, it should be a list of
+colors to display.  Otherwise, this command computes a list
+of colors that the current display can handle."
+  (interactive)
+  (if (string-match "XEmacs" emacs-version)
+      (setq list
+	    (facemenu-unique
+	     (mapcar 'facemenu-canonicalize-color
+		     (mapcar 'car (read-color-completion-table)))))
+    (if (and (null list) (or (eq window-system 'x) (eq window-system 'win32)))
+	(progn
+	  (setq list (x-defined-colors))
+	  ;; Delete duplicate colors.
+	  (let ((l list))
+	    (while (cdr l)
+	      (if (facemenu-color-equal (car l) (car (cdr l)))
+		  (setcdr l (cdr (cdr l)))
+		(setq l (cdr l))))))))
+  (with-output-to-temp-buffer "*Colors*"
+    (save-excursion
+      (set-buffer standard-output)
+      (let ((facemenu-unlisted-faces t)
+	    s)
+	(while list
+	  (if (not (string-match "[0-9]" (car list)))
+	      (progn
+		(setq s (point))
+		(insert (car list))
+		(indent-to 20)
+		(put-text-property s (point) 'face 
+				   (facemenu-get-face 
+				    (intern (concat "bg:" (car list)))))
+		(setq s (point))
+		(insert "  " (car list) "\n")
+		(put-text-property s (point) 'face 
+				   (facemenu-get-face 
+				    (intern (concat "fg:" (car list)))))))
+	  (setq list (cdr list)))))))
+
+(fset 'facemenu-color-values 
+	(if (fboundp 'x-color-values)
+	    'x-color-values
+	  #'(lambda (color)
+	      (color-instance-rgb-components
+	       (make-color-instance color)))))
+
+(defun facemenu-color-equal (a b)
+  "Return t if colors A and B are the same color.
+A and B should be strings naming colors.
+This function queries the window-system server to find out what the
+color names mean.  It returns nil if the colors differ or if it can't
+determine the correct answer."
+  (cond ((equal a b) t)
+	((and (equal (facemenu-color-values a)
+		     (facemenu-color-values b))))))
+
+(defun facemenu-add-face (face start end)
+  "Add FACE to text between START and END.
+For each section of that region that has a different face property, FACE will
+be consed onto it, and other faces that are completely hidden by that will be
+removed from the list.
+
+As a special case, if FACE is `default', then the region is left with NO face
+text property.  Otherwise, selecting the default face would not have any
+effect."
+  (interactive "*_xFace:\nr")
+  (if (eq face 'default)
+      (remove-text-properties start end '(face default))
+    (let ((part-start start) part-end)
+      (while (not (= part-start end))
+	(setq part-end (next-single-property-change part-start 'face nil end))
+	(let* ((prev (get-text-property part-start 'face))
+	       (size (get-text-property part-start 'size))
+	       (face (if size (facemenu-sized-face face size) face)))
+	  (put-text-property part-start part-end 'face
+			     (if (null prev)
+				 face
+			       (facemenu-active-faces
+				(cons face
+				      (if (listp prev) prev (list prev)))))))
+	(setq part-start part-end)))))
+
+(defun facemenu-face-attributes (face)
+  "Create a vector of the relevant face attributes of face FACE."
+  (if (string-match "XEmacs" emacs-version)
+      (apply 'vector (mapcar #'(lambda (prop)
+				(face-property-instance face prop))
+			    facemenu-relevant-face-attributes))
+    (internal-get-face (car face-list))))
+
+(defun facemenu-active-faces (face-list)
+  "Return from FACE-LIST those faces that would be used for display.
+This means each face attribute is not specified in a face earlier in FACE-LIST
+and such a face is therefore active when used to display text."
+  (let* ((mask-atts (copy-sequence (facemenu-face-attributes (car face-list))))
+	 (default-atts (facemenu-face-attributes 'default))
+	 (active-list (list (car face-list)))
+	 (face-list (cdr face-list))
+	 (mask-len (length mask-atts)))
+    (while face-list
+      (if (let ((face-atts (facemenu-face-attributes (car face-list)))
+		(i mask-len)
+		(useful nil))
+	    (while (>= (setq i (1- i)) 0)
+	      (if (and (aref face-atts i)
+		       (or (not (aref mask-atts i))
+			   (eq (aref mask-atts i) (aref default-atts i)))
+		       (not (eq (aref face-atts i) (aref default-atts i))))
+		  (aset mask-atts i (setq useful t))))
+	    useful)
+	  (setq active-list (cons (car face-list) active-list)))
+      (setq face-list (cdr face-list)))
+    (nreverse active-list)))
+
+(fset 'facemenu-find-face
+      (if (string-match "XEmacs" emacs-version)
+	  'find-face
+	'internal-find-face))
+
+(fset 'facemenu-color-defined-p
+      (if (string-match "XEmacs" emacs-version)
+	  #'(lambda (c)
+	      (color-instance-p (make-color-instance c nil t)))
+	#'(lambda (c)
+	    (and (or (eq window-system 'x) (eq window-system 'win32))
+		 (x-color-defined-p color)))))
+
+(defun facemenu-get-face (symbol)
+  "Make sure FACE exists.
+If not, it is created.  If it is created and is of the form `fg:color', then
+set the foreground to that color. If of the form `bg:color', set the
+background.  In any case, add it to the appropriate menu.  Returns the face,
+or nil if given a bad color."
+  (if (or (facemenu-find-face symbol)
+	  (let* ((face (make-face symbol))
+		 (name (symbol-name symbol))
+		 (color-name (substring name 3))
+		 (color (if (string-match "XEmacs" emacs-version)
+			    (make-color-specifier color-name)
+			  color-name)))
+	    (facemenu-add-new-face symbol)
+	    (cond ((string-match "^fg:" name)
+		   (set-face-foreground face color)
+		   (facemenu-color-defined-p color-name))
+		  ((string-match "^bg:" name)
+		   (set-face-background face color)
+		   (facemenu-color-defined-p color-name))
+		  (t))))
+      symbol))
+
+(defun facemenu-menu-has-face (menu face-name)
+  "Check if menu MENU has an entry for face named by string FACE-NAME.
+Returns entry if successful."
+  (facemenu-iterate
+   #'(lambda (m)
+       (and (vectorp m) 
+	    (string-equal face-name (aref m 0))
+	    m))
+   (cdr menu)))
+
+(defun facemenu-insert-menu-entry (menu before-entry name function)
+  "Insert menu item with name NAME and associated function FUNCTION
+into menu MENU before entry BEFORE-ENTRY."
+  (while (not (eq (cadr menu) before-entry))
+    (setq menu (cdr menu)))
+  (setcdr menu (cons (vector name function t) (cdr menu))))
+
+(defun facemenu-add-new-face (face)
+  "Add a FACE to the appropriate Face menu.
+Automatically called when a new face is created."
+  (let* ((name (symbol-name face))
+	 (menu (cond ((string-match "^fg:" name) 
+		      (setq name (substring name 3))
+		      'facemenu-foreground-menu)
+		     ((string-match "^bg:" name) 
+		      (setq name (substring name 3))
+		      'facemenu-background-menu)
+		     (t 'facemenu-face-menu)))
+	 (menu-value (symbol-value menu))
+	 (key (cdr (assoc face facemenu-keybindings))))
+    (cond ((eq t facemenu-unlisted-faces))
+	  ((string-match "^larger-" name))
+	  ((string-match "^smaller-" name))
+	  ((memq face facemenu-unlisted-faces))
+	  (key ; has a keyboard equivalent.  These go at the front.
+	   (let ((function (intern (concat "facemenu-set-" name))))
+	     (fset function
+		   (` (lambda ()
+			(interactive "_")
+			(facemenu-set-face (quote (, face))))))
+	     (define-key 'facemenu-keymap key function)
+	     (if (not (facemenu-menu-has-face menu-value name))
+		 (set menu
+		      (cons (car menu-value)
+			    (cons (vector name function t)
+				  (cdr menu-value)))))))
+	  ((facemenu-menu-has-face menu-value name))
+	  (t   ; No keyboard equivalent.  Figure out where to put it:
+	   (let ((before-entry
+		   (or (and facemenu-new-faces-at-end
+				     (facemenu-menu-has-face menu-value "Other..."))
+		       (cadr menu-value))))
+	     (facemenu-insert-menu-entry
+	      menu-value before-entry name
+	      (` (facemenu-set-face (quote (, face)))))))))
+  nil) ; Return nil for facemenu-iterate
+
+(defun facemenu-complete-face-list (&optional oldlist)
+  "Return list of all faces that look different.
+Starts with given ALIST of faces, and adds elements only if they display 
+differently from any face already on the list.
+The faces on ALIST will end up at the end of the returned list, in reverse 
+order."
+  (let ((list (nreverse (mapcar 'car oldlist))))
+    (facemenu-iterate 
+     (lambda (new-face) 
+       (if (not (memq new-face list))
+	   (setq list (cons new-face list)))
+       nil)
+     (nreverse (face-list)))
+    list))
+
+(defun facemenu-iterate (func iterate-list)
+  "Apply FUNC to each element of LIST until one returns non-nil.
+Returns the non-nil value it found, or nil if all were nil."
+  (while (and iterate-list (not (funcall func (car iterate-list))))
+    (setq iterate-list (cdr iterate-list)))
+  (car iterate-list))
+
+(facemenu-update)
+
+;;; facemenu.el ends here