--- a/lisp/custom/cus-face.el	Mon Aug 13 09:58:32 2007 +0200
+++ b/lisp/custom/cus-face.el	Mon Aug 13 09:59:05 2007 +0200
@@ -1,143 +1,70 @@
-;;; cus-face.el -- XEmacs specific custom support.
+;;; cus-face.el -- Support for Custom faces.
 ;;
 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
+;; Maintainer: Hrvoje Niksic <hniksic@srce.hr>
 ;; Keywords: help, faces
-;; Version: 1.9960
+;; Version: 1.9960-x
 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
 
 ;;; Commentary:
 ;;
 ;; See `custom.el'.
 
+;; This file should probably be dissolved, and code moved to faces.el,
+;; like Stallman did.
+
 ;;; Code:
 
 (require 'custom)
 
-(eval-when-compile (require 'cl))
-
-;;; Compatibility.
-
-(if (string-match "XEmacs" emacs-version)
-    (defun custom-face-background (face &optional frame)
-      ;; Specifiers suck!
-      "Return the background color name of face FACE, or nil if unspecified."
-      (color-instance-name (specifier-instance (face-background face) frame)))
-  (defalias 'custom-face-background 'face-background))
-
-(if (string-match "XEmacs" emacs-version)
-    (defun custom-face-foreground (face &optional frame)
-      ;; Specifiers suck!
-      "Return the background color name of face FACE, or nil if unspecified."
-      (color-instance-name (specifier-instance (face-foreground face) frame)))
-  (defalias 'custom-face-foreground 'face-foreground))
-
-(defalias 'custom-face-font-name (if (string-match "XEmacs" emacs-version)
-				     'face-font-name
-				   'face-font))
+;; To elude the warnings for font functions.
+(eval-when-compile
+  (require 'font))
 
-(eval-and-compile
-  (cond ((fboundp 'frame-property)
-	 ;; XEmacs.
-	 (defalias 'custom-frame-parameter 'frame-property))
-	((fboundp 'frame-parameter)
-	 ;; Emacs 19.35.
-	 (defalias 'custom-frame-parameter 'frame-parameter))
-	(t
-	 ;; Old emacsen.
-	 (defun custom-frame-parameter (frame property &optional default)
-	   "Return FRAME's value for property PROPERTY."
-	   (or (cdr (assq property (frame-parameters frame)))
-	       default))))
+;;;###autoload
+(defcustom frame-background-mode nil
+  "*The brightness of the background.
+Set this to the symbol dark if your background color is dark, light if
+your background is light, or nil (default) if you want Emacs to
+examine the brightness for you."
+  :group 'faces
+  :type '(choice (choice-item dark) 
+		 (choice-item light)
+		 (choice-item :tag "Auto" nil)))
 
-  (unless (fboundp 'face-doc-string)
-    ;; XEmacs function missing in Emacs.
-    (defun face-doc-string (face)
-      "Get the documentation string for FACE."
-      (get face 'face-documentation)))
-
-  (unless (fboundp 'set-face-doc-string)
-    ;; XEmacs function missing in Emacs.
-    (defun set-face-doc-string (face string)
-      "Set the documentation string for FACE to STRING."
-      (put face 'face-documentation string))))
 
-(unless (fboundp 'x-color-values)
-  ;; Emacs function missing in XEmacs 19.14.
-  (defun x-color-values  (color &optional frame)
-    "Return a description of the color named COLOR on frame FRAME.
-The value is a list of integer RGB values--(RED GREEN BLUE).
-These values appear to range from 0 to 65280 or 65535, depending
-on the system; white is (65280 65280 65280) or (65535 65535 65535).
-If FRAME is omitted or nil, use the selected frame."
-    (color-instance-rgb-components (make-color-instance color))))
-
-;; XEmacs and Emacs have different definitions of `facep'.  
-;; The Emacs definition is the useful one, so emulate that. 
-(cond ((not (fboundp 'facep))
-       (defun custom-facep (face) 
-	 "No faces"
-	 nil))
-      ((string-match "XEmacs" emacs-version)
-       (defalias 'custom-facep 'find-face))
-      (t
-       (defalias 'custom-facep 'facep)))
+;; Originally, this did much more stuff, and cached the results.  The
+;; trouble is that, if user changes the bg color of a frame's default
+;; face, the cache wouldn't get updated.  This version should be fast
+;; enough for use without caching, I think.
+(defun get-frame-background-mode (frame)
+  "Detect background mode for FRAME."
+  (let* ((color-instance (face-background-instance 'default frame))
+	 (mode (condition-case nil
+		   (if (< (apply '+ (color-instance-rgb-components
+				     color-instance)) 65536)
+		       'dark
+		     'light)
+	     ;; We'll get an error on a TTY; TTY-s are generally dark.
+		 (error 'dark))))
+    ;(set-frame-property 'background-mode mode)
+    mode))
 
-(unless (fboundp 'make-empty-face)
-  ;; This should be moved to `faces.el'.
-  (cond
-   ((string-match "XEmacs" emacs-version)
-    ;; Give up for old XEmacs pre 19.15/20.1.
-    (defalias 'make-empty-face 'make-face))
-   ((fboundp 'internal-find-face)
-    ;; We can do faces...
-    (defun make-empty-face (name)
-      "Define a new FACE on all frames, ignoring X resources."
-      (interactive "SMake face: ")
-      (or (internal-find-face name)
-	  (let ((face (make-vector 8 nil)))
-	    (aset face 0 'face)
-	    (aset face 1 name)
-	    (let* ((frames (frame-list))
-		   (inhibit-quit t)
-		   (id (internal-next-face-id)))
-	      (make-face-internal id)
-	      (aset face 2 id)
-	      (while frames
-		(set-frame-face-alist (car frames)
-				      (cons (cons name (copy-sequence face))
-					    (frame-face-alist (car frames))))
-		(setq frames (cdr frames)))
-	      (setq global-face-data (cons (cons name face) global-face-data)))
-	    ;; add to menu
-	    (if (fboundp 'facemenu-add-new-face)
-		(facemenu-add-new-face name))
-	    face))
-      name))
-   (t
-    (fset 'make-empty-face 'ignore))))
-
+;;;###autoload
 (defcustom initialize-face-resources t
   "If non nil, allow X resources to initialize face properties.
-This only affects faces declared with `defface', and only NT or X11 frames."
-  :group 'customize
+This only affects faces declared with `defface', and only X11 frames."
+  :group 'faces
   :type 'boolean)
 
-(cond ((fboundp 'initialize-face-resources)
-       ;; Already bound, do nothing.
-       )
-      ((fboundp 'make-face-x-resource-internal)
-       ;; Emacs or new XEmacs.
-       (defun initialize-face-resources (face &optional frame)
-	 "Initialize face according to the X11 resources.
+(defun initialize-face-resources (face &optional frame)
+  "Initialize face according to the X11 resources.
 This might overwrite existing face properties.
 Does nothing when the variable initialize-face-resources is nil."
-	 (when initialize-face-resources
-	   (make-face-x-resource-internal face frame t))))
-      (t 
-       ;; Too hard to do right on XEmacs.
-       (defalias 'initialize-face-resources 'ignore)))
+  (when initialize-face-resources
+    (make-face-x-resource-internal face frame t)))
 
 ;;(if (string-match "XEmacs" emacs-version)
 ;;    ;; Xemacs.
@@ -156,106 +83,63 @@
 ;;    (interactive (list (read-face-name "Reverse face: ")))
 ;;    (let ((fg (or (face-foreground face frame)
 ;;		  (face-foreground 'default frame)
-;;		  (custom-frame-parameter (or frame (selected-frame))
+;;		  (frame-property (or frame (selected-frame))
 ;;				  'foreground-color)
 ;;		  "black"))
 ;;	  (bg (or (face-background face frame)
 ;;		  (face-background 'default frame)
-;;		  (custom-frame-parameter (or frame (selected-frame))
+;;		  (frame-property (or frame (selected-frame))
 ;;				  'background-color)
 ;;		  "white")))
 ;;      (set-face-foreground face bg frame)
 ;;      (set-face-background face fg frame))))
 
-(defcustom custom-background-mode nil
-  "The brightness of the background.
-Set this to the symbol dark if your background color is dark, light if
-your background is light, or nil (default) if you want Emacs to
-examine the brightness for you."
-  :group 'customize
-  :type '(choice (const dark) 
-		 (const light)
-		 (const :tag "default" nil)))
-
-(defun custom-background-mode (frame)
-  "Kludge to detect background mode for FRAME."
-  (let* ((bg-resource 
-	  (condition-case ()
-	      (x-get-resource ".backgroundMode" "BackgroundMode" 'string)
-	    (error nil)))
-	 color
-	 (mode (cond (bg-resource
-		      (intern (downcase bg-resource)))
-		     ((and (setq color (condition-case ()
-					   (or (custom-frame-parameter
-						frame
-						'background-color)
-					       (custom-face-background
-						'default))
-					 (error nil)))
-			   (or (string-match "XEmacs" emacs-version)
-			       window-system)
-			   (< (apply '+ (x-color-values color))
-			      (/ (apply '+ (x-color-values "white"))
-				 3)))
-		      'dark)
-		     (t 'light))))
-    (modify-frame-parameters frame (list (cons 'background-mode mode)))
-    mode))
-
-(eval-and-compile
-  (if (string-match "XEmacs" emacs-version)
-      ;; XEmacs.
-      (defun custom-extract-frame-properties (frame)
-	"Return a plist with the frame properties of FRAME used by custom."
-	(list 'type (device-type (frame-device frame))
-	      'class (device-class (frame-device frame))
-	      'background (or custom-background-mode
-			      (custom-frame-parameter frame
-					      'background-mode)
-			      (custom-background-mode frame))))
-    ;; Emacs.
-    (defun custom-extract-frame-properties (frame)
-      "Return a plist with the frame properties of FRAME used by custom."
-      (list 'type window-system
-	    'class (custom-frame-parameter frame 'display-type)
-	    'background (or custom-background-mode
-			    (custom-frame-parameter frame 'background-mode)
-			    (custom-background-mode frame))))))  
+(defun custom-extract-frame-properties (frame)
+  "Return a plist with the frame properties of FRAME used by custom."
+  (list 'type (device-type (frame-device frame))
+	'class (device-class (frame-device frame))
+	'background (or frame-background-mode
+			(frame-property frame 'background-mode)
+			(get-frame-background-mode frame))))
 
 ;;; Declaring a face.
 
 ;;;###autoload
 (defun custom-declare-face (face spec doc &rest args)
   "Like `defface', but FACE is evaluated as a normal argument."
-  (when (or (fboundp 'load-gc)		;XEmacs.
-	    ;; Emacs.
-	    (and (boundp purify-flag) purify-flag))
-    ;; This should be allowed, somehow.
+  (when (fboundp 'load-gc)
+    ;; This should be allowed, using specifiers.
     (error "Attempt to declare a face during dump"))
   (unless (get face 'face-defface-spec)
     (put face 'face-defface-spec spec)
-    (when (fboundp 'facep)
-      (unless (custom-facep face)
-	;; If the user has already created the face, respect that.
-	(let ((value (or (get face 'saved-face) spec))
-	      (frames (custom-relevant-frames))
-	      frame)
-	  ;; Create global face.
-	  (make-empty-face face)
-	  (custom-face-display-set face value)
-	  ;; Create frame local faces
-	  (while frames
-	    (setq frame (car frames)
-		  frames (cdr frames))
-	    (custom-face-display-set face value frame))
-	  (initialize-face-resources face))))
+    (unless (find-face face)
+      ;; If the user has already created the face, respect that.
+      (let ((value (or (get face 'saved-face) spec))
+	    (frames (custom-relevant-frames))
+	    frame)
+	;; Create global face.
+	(make-empty-face face)
+	(custom-face-display-set face value)
+	;; Create frame local faces
+	(while frames
+	  (setq frame (car frames)
+		frames (cdr frames))
+	  (custom-face-display-set face value frame))
+	(initialize-face-resources face)))
     (when (and doc (null (face-doc-string face)))
       (set-face-doc-string face doc))
     (custom-handle-all-keywords face args 'custom-face)
     (run-hooks 'custom-define-hook))
   face)
 
+(defun custom-face-background (face &optional frame)
+  "Return the background color name of face FACE, or nil if unspecified."
+  (color-instance-name (specifier-instance (face-background face) frame)))
+
+(defun custom-face-foreground (face &optional frame)
+  "Return the background color name of face FACE, or nil if unspecified."
+  (color-instance-name (specifier-instance (face-foreground face) frame)))
+
 ;;; Font Attributes.
 
 (defconst custom-face-attributes
@@ -338,7 +222,7 @@
 	    get (nth 3 att))
       (condition-case nil
 	  ;; This may fail if w3 doesn't exists.
-	  (when get 
+	  (when get
 	    (let ((answer (funcall get face frame)))
 	      (unless (equal answer (funcall get 'default frame))
 		(when (widget-apply (nth 1 att) :match answer)
@@ -354,7 +238,7 @@
 
 (defun custom-face-bold (face &rest args)
   "Return non-nil if the font of FACE is bold."
-  (let* ((font (apply 'custom-face-font-name face args))
+  (let* ((font (apply 'face-font-name face args))
 	 (fontobj (font-create-object font)))
     (font-bold-p fontobj)))
 
@@ -366,67 +250,60 @@
 
 (defun custom-face-italic (face &rest args)
   "Return non-nil if the font of FACE is italic."
-  (let* ((font (apply 'custom-face-font-name face args))
+  (let* ((font (apply 'face-font-name face args))
 	 (fontobj (font-create-object font)))
     (font-italic-p fontobj)))
 
 (defun custom-face-stipple (face &rest args)
   "Return the name of the stipple file used for FACE."
-  (if (string-match "XEmacs" emacs-version)
-      (let ((image  (apply 'specifier-instance 
-			   (face-background-pixmap face) args)))
-	(when image 
-	  (image-instance-file-name image)))
-    (apply 'face-stipple face args)))
-
-(when (string-match "XEmacs" emacs-version)
-  ;; Support for special XEmacs font attributes.
-  (autoload 'font-create-object "font" nil)
+  (let ((image  (apply 'specifier-instance 
+		       (face-background-pixmap face) args)))
+    (and image 
+	 (image-instance-file-name image))))
 
-  (defun custom-set-face-font-size (face size &rest args)
-    "Set the font of FACE to SIZE"
-    (let* ((font (apply 'custom-face-font-name face args))
-	   (fontobj (font-create-object font)))
-      (set-font-size fontobj size)
-      (apply 'font-set-face-font face fontobj args)))
+(defun custom-set-face-font-size (face size &rest args)
+  "Set the font of FACE to SIZE"
+  (let* ((font (apply 'face-font-name face args))
+	 (fontobj (font-create-object font)))
+    (set-font-size fontobj size)
+    (apply 'font-set-face-font face fontobj args)))
 
-  (defun custom-face-font-size (face &rest args)
-    "Return the size of the font of FACE as a string."
-    (let* ((font (apply 'custom-face-font-name face args))
-	   (fontobj (font-create-object font)))
-      (format "%s" (font-size fontobj))))
+(defun custom-face-font-size (face &rest args)
+  "Return the size of the font of FACE as a string."
+  (let* ((font (apply 'face-font-name face args))
+	 (fontobj (font-create-object font)))
+    (format "%s" (font-size fontobj))))
 
-  (defun custom-set-face-font-family (face family &rest args)
-    "Set the font of FACE to FAMILY."
-    (let* ((font (apply 'custom-face-font-name face args))
-	   (fontobj (font-create-object font)))
-      (set-font-family fontobj family)
-      (apply 'font-set-face-font face fontobj args)))
+(defun custom-set-face-font-family (face family &rest args)
+  "Set the font of FACE to FAMILY."
+  (let* ((font (apply 'face-font-name face args))
+	 (fontobj (font-create-object font)))
+    (set-font-family fontobj family)
+    (apply 'font-set-face-font face fontobj args)))
 
-  (defun custom-face-font-family (face &rest args)
-    "Return the name of the font family of FACE."
-    (let* ((font (apply 'custom-face-font-name face args))
-	   (fontobj (font-create-object font)))
-      (font-family fontobj)))
+(defun custom-face-font-family (face &rest args)
+  "Return the name of the font family of FACE."
+  (let* ((font (apply 'face-font-name face args))
+	 (fontobj (font-create-object font)))
+    (font-family fontobj)))
 
-  (setq custom-face-attributes
-	(append '((:family (editable-field :format "Font Family: %v"
-					  :help-echo "\
+(setq custom-face-attributes
+      (append '((:family (editable-field :format "Font Family: %v"
+					 :help-echo "\
 Name of font family to use (e.g. times).") 
-			  custom-set-face-font-family
-			  custom-face-font-family)
-		  (:size (editable-field :format "Size: %v"
-					 :help-echo "\
+			 custom-set-face-font-family
+			 custom-face-font-family)
+		(:size (editable-field :format "Size: %v"
+				       :help-echo "\
 Text size (e.g. 9pt or 2mm).")
-			 custom-set-face-font-size
-			 custom-face-font-size)
-		  (:strikethru (toggle :format "%[Strikethru%]: %v\n"
-				      :help-echo "\
+		       custom-set-face-font-size
+		       custom-face-font-size)
+		(:strikethru (toggle :format "%[Strikethru%]: %v\n"
+				     :help-echo "\
 Control whether the text should be strikethru.")
-			       set-face-strikethru-p
-			       face-strikethru-p))
-		custom-face-attributes)))
-
+			     set-face-strikethru-p
+			     face-strikethru-p))
+	      custom-face-attributes))
 ;;; Frames.
 
 (defun face-spec-set (face spec &optional frame)
@@ -435,27 +312,25 @@
 See `defface' for information about SPEC.
 
 Clear all existing attributes first."
-  (when (fboundp 'copy-face)
-    (copy-face 'custom-face-empty face frame))
+  (copy-face 'custom-face-empty face frame)
   (custom-face-display-set face spec frame))
 
 (defun custom-face-display-set (face spec &optional frame)
   "Set FACE to the attributes to the first matching entry in SPEC.
 Iff optional FRAME is non-nil, set it for that frame only.
 See `defface' for information about SPEC."
-  (when (fboundp 'make-face)
-    (while spec 
-      (let* ((entry (car spec))
-	     (display (nth 0 entry))
-	     (atts (nth 1 entry)))
-	(setq spec (cdr spec))
-	(when (face-spec-set-match-display display frame)
-	  ;; Avoid creating frame local duplicates of the global face.
-	  (unless (and frame (eq display (get face 'custom-face-display)))
-	    (apply 'custom-face-attributes-set face frame atts))
-	  (unless frame
-	    (put face 'custom-face-display display))
-	  (setq spec nil))))))
+  (while spec 
+    (let* ((entry (car spec))
+	   (display (nth 0 entry))
+	   (atts (nth 1 entry)))
+      (setq spec (cdr spec))
+      (when (face-spec-set-match-display display frame)
+	;; Avoid creating frame local duplicates of the global face.
+	(unless (and frame (eq display (get face 'custom-face-display)))
+	  (apply 'custom-face-attributes-set face frame atts))
+	(unless frame
+	  (put face 'custom-face-display display))
+	(setq spec nil)))))
 
 (defvar custom-default-frame-properties nil
   "The frame properties used for the global faces.
@@ -468,7 +343,7 @@
 If FRAME is nil, return the default frame properties."
   (cond (frame
 	 ;; Try to get from cache.
-	 (let ((cache (custom-frame-parameter frame 'custom-properties)))
+	 (let ((cache (frame-property frame 'custom-properties)))
 	   (unless cache
 	     ;; Oh well, get it then.
 	     (setq cache (custom-extract-frame-properties frame))
@@ -506,8 +381,8 @@
 			  ((eq req 'background)
 			   (memq background options))
 			  (t
-			   (message (format "\
-Warning: Unknown req `%S' with options `%S'" req options))
+			   (warn "Unknown req `%S' with options `%S'"
+				 req options)
 			   nil))))
       match)))
 
@@ -527,13 +402,13 @@
 (defun custom-initialize-faces (&optional frame)
   "Initialize all custom faces for FRAME.
 If FRAME is nil or omitted, initialize them for all frames."
-  (mapcar (lambda (symbol)
-	    (let ((spec (or (get symbol 'saved-face)
-			    (get symbol 'face-defface-spec))))
-	      (when spec 
-		(custom-face-display-set symbol spec frame)
-		(initialize-face-resources symbol frame))))
-	  (face-list)))
+  (mapc (lambda (symbol)
+	  (let ((spec (or (get symbol 'saved-face)
+			  (get symbol 'face-defface-spec))))
+	    (when spec 
+	      (custom-face-display-set symbol spec frame)
+	      (initialize-face-resources symbol frame))))
+	(face-list)))
 
 ;;;###autoload
 (defun custom-initialize-frame (&optional frame)
@@ -547,8 +422,7 @@
 
 ;;; Initializing.
 
-(and (fboundp 'make-face)
-     (make-face 'custom-face-empty))
+(make-face 'custom-face-empty)
 
 ;;;###autoload
 (defun custom-set-faces (&rest args)
@@ -570,7 +444,7 @@
 	    (put face 'saved-face spec)
 	    (when now
 	      (put face 'force-face t))
-	    (when (or now (custom-facep face))
+	    (when (or now (find-face face))
 	      (face-spec-set face spec))
 	    (setq args (cdr args)))
 	;; Old format, a plist of FACE SPEC pairs.