1999-03-17  Jan Vroonhof  <vroonhof@math.ethz.ch>

	* cus-face.el: Label all custom changes with the 'custom' tag.

	* cus-edit.el: idem ditto.

	* faces.el: Added suport for adding device tags to various functions.
	(custom): New device tag.
	(face-spec-set): Call reset face with tags argument. No longer do
	x-init-global-faces hack.

	* faces.el (frob-face-property): Use an anonymous specifier to map
	frob-face-property-1 over.

	* x-font-menu.el (font-menu-set-font): Always specify all
	properties to custom.

Index: lisp/faces.el
===================================================================
RCS file: /usr/CVSroot/XEmacs/xemacs-20/lisp/faces.el,v
retrieving revision 1.21
diff -u -u -r1.21 faces.el
--- faces.el	1998/12/11 10:04:10	1.21
+++ faces.el	1999/03/18 02:33:24
@@ -794,7 +794,7 @@
 ;; WE DEMAND LEXICAL SCOPING!!!
 ;; WE DEMAND LEXICAL SCOPING!!!
 ;; WE DEMAND LEXICAL SCOPING!!!
-(defun frob-face-property (face property func &optional locale)
+(defun frob-face-property (face property func &optional locale tags)
   "Change the specifier for FACE's PROPERTY according to FUNC, in LOCALE.
 This function is ugly and messy and is primarily used as an internal
 helper function for `make-face-bold' et al., so you probably don't
@@ -814,13 +814,14 @@
 the specification; otherwise, the process just outlined is
 iterated over each existing device and the concatenated results
 substituted for the specification."
-  (let ((sp (face-property face property)))
+  (let ((sp (face-property face property))
+	temp-sp)
     (if (valid-specifier-domain-p locale)
 	;; this is easy.
 	(let* ((inst (face-property-instance face property locale))
 	       (name (and inst (funcall func inst (dfw-device locale)))))
 	  (when name
-	    (add-spec-to-specifier sp name locale)))
+	    (add-spec-to-specifier sp name locale tags)))
       ;; otherwise, map over all specifications ...
       ;; but first, some further kludging:
       ;; (1) if we're frobbing the global property, make sure
@@ -832,33 +833,40 @@
       ;; (2) if we're frobbing a particular locale, nothing would
       ;;     happen if that locale has no instantiators.  So signal
       ;;     an error to indicate this.
-      (if (and (or (eq locale 'global) (eq locale 'all) (not locale))
-	       (not (face-property face property 'global)))
-	  (copy-specifier (face-property 'default property)
-			  (face-property face property)
-			  'global))
+
+      (setq temp-sp
+	    (if (and (or (eq locale 'global) (eq locale 'all) (not locale))
+		     (not (face-property face property 'global)))
+		(copy-specifier (face-property 'default property)
+				nil 'global)
+	      sp))
       (if (and (valid-specifier-locale-p locale)
-	       (not (face-property face property locale)))
+	       (not (specifier-specs temp-sp locale)))
 	  (error "Property must have a specification in locale %S" locale))
       (map-specifier
-       sp
-       (lambda (sp locale inst-list func)
+       temp-sp
+       (lambda (sp-arg locale inst-list func)
 	 (let* ((device (dfw-device locale))
 		;; if a device can be derived from the locale,
 		;; call frob-face-property-1 for that device.
 		;; Otherwise map frob-face-property-1 over each device.
 		(result
 		 (if device
-		     (list (frob-face-property-1 sp device inst-list func))
+		     (list (frob-face-property-1 sp-arg device inst-list func))
 		   (mapcar (lambda (device)
-			     (frob-face-property-1 sp device
+			     (frob-face-property-1 sp-arg device
 						   inst-list func))
 			   (device-list))))
 		new-result)
 	   ;; remove duplicates and nils from the obtained list of
-	   ;; instantiators.
+	   ;; instantiators. Also add tags amd remove 'defaults'.
 	   (mapcar (lambda (arg)
-		     (when (and arg (not (member arg new-result)))
+		     (when arg
+		       (if (not (consp arg))
+			   (setq arg (cons tags arg))
+			 (setcar arg (append tags (delete 'default
+							  (car arg))))))
+		     (when (and arg (not (member arg new-result)))		       
 		       (setq new-result (cons arg new-result))))
 		   result)
 	   ;; add back in.
@@ -886,7 +894,7 @@
       (setq inst-list (cdr inst-list)))
     (or result first-valid)))
 
-(defun frob-face-font-2 (face locale unfrobbed-face frobbed-face
+(defun frob-face-font-2 (face locale tags unfrobbed-face frobbed-face
 			      tty-thunk x-thunk standard-face-mapping)
   ;; another kludge to make things more intuitive.  If we're
   ;; inheriting from a standard face in this locale, frob the
@@ -934,9 +942,9 @@
 	    (not (equal (face-property-instance face 'font domain)
 			(face-property-instance unfrobbed-face 'font domain)))
 	    (set-face-property face 'font (vector frobbed-face)
-			       the-locale))))))
+			       the-locale tags))))))
 
-(defun make-face-bold (face &optional locale)
+(defun make-face-bold (face &optional locale tags)
   "Make FACE bold in LOCALE, if possible.
 This will attempt to make the font bold for X locales and will set the
 highlight flag for TTY locales.
@@ -965,24 +973,24 @@
 circumstances."
   (interactive (list (read-face-name "Make which face bold: ")))
   (frob-face-font-2
-   face locale 'default 'bold
+   face locale tags 'default 'bold
    (lambda ()
      ;; handle TTY specific entries
      (when (featurep 'tty)
-       (set-face-highlight-p face t locale 'tty)))
+       (set-face-highlight-p face t locale (cons 'tty tags))))
    (lambda ()
      ;; handle X specific entries
      (when (featurep 'x)
-       (frob-face-property face 'font 'x-make-font-bold locale))
+       (frob-face-property face 'font 'x-make-font-bold locale tags))
      (when (featurep 'mswindows)
-       (frob-face-property face 'font 'mswindows-make-font-bold locale))
+       (frob-face-property face 'font 'mswindows-make-font-bold locale tags))
      )
    '(([default] . [bold])
      ([bold] . t)
      ([italic] . [bold-italic])
      ([bold-italic] . t))))
 
-(defun make-face-italic (face &optional locale)
+(defun make-face-italic (face &optional locale tags)
   "Make FACE italic in LOCALE, if possible.
 This will attempt to make the font italic for X locales and will set
 the underline flag for TTY locales.
@@ -990,24 +998,24 @@
 for more specifics on exactly how this function works."
   (interactive (list (read-face-name "Make which face italic: ")))
   (frob-face-font-2
-   face locale 'default 'italic
+   face locale tags 'default 'italic
    (lambda ()
      ;; handle TTY specific entries
      (when (featurep 'tty)
-       (set-face-underline-p face t locale 'tty)))
+       (set-face-underline-p face t locale (cons 'tty tags))))
    (lambda ()
      ;; handle X specific entries
      (when (featurep 'x)
-       (frob-face-property face 'font 'x-make-font-italic locale))
+       (frob-face-property face 'font 'x-make-font-italic locale tags))
      (when (featurep 'mswindows)
-       (frob-face-property face 'font 'mswindows-make-font-italic locale))
+       (frob-face-property face 'font 'mswindows-make-font-italic locale tags))
      )
    '(([default] . [italic])
      ([bold] . [bold-italic])
      ([italic] . t)
      ([bold-italic] . t))))
 
-(defun make-face-bold-italic (face &optional locale)
+(defun make-face-bold-italic (face &optional locale tags)
   "Make FACE bold and italic in LOCALE, if possible.
 This will attempt to make the font bold-italic for X locales and will
 set the highlight and underline flags for TTY locales.
@@ -1015,25 +1023,25 @@
 for more specifics on exactly how this function works."
   (interactive (list (read-face-name "Make which face bold-italic: ")))
   (frob-face-font-2
-   face locale 'default 'bold-italic
+   face locale tags 'default 'bold-italic
    (lambda ()
      ;; handle TTY specific entries
      (when (featurep 'tty)
-       (set-face-highlight-p face t locale 'tty)
-       (set-face-underline-p face t locale 'tty)))
+       (set-face-highlight-p face t locale (cons 'tty tags))
+       (set-face-underline-p face t locale (cons 'tty tags))))
    (lambda ()
      ;; handle X specific entries
      (when (featurep 'x)
-       (frob-face-property face 'font 'x-make-font-bold-italic locale))
+       (frob-face-property face 'font 'x-make-font-bold-italic locale tags))
      (when (featurep 'mswindows)
-       (frob-face-property face 'font 'mswindows-make-font-bold-italic locale))
+       (frob-face-property face 'font 'mswindows-make-font-bold-italic locale tags))
      )
    '(([default] . [italic])
      ([bold] . [bold-italic])
      ([italic] . [bold-italic])
      ([bold-italic] . t))))
 
-(defun make-face-unbold (face &optional locale)
+(defun make-face-unbold (face &optional locale tags)
   "Make FACE non-bold in LOCALE, if possible.
 This will attempt to make the font non-bold for X locales and will
 unset the highlight flag for TTY locales.
@@ -1041,24 +1049,24 @@
 for more specifics on exactly how this function works."
   (interactive (list (read-face-name "Make which face non-bold: ")))
   (frob-face-font-2
-   face locale 'bold 'default
+   face locale tags 'bold 'default
    (lambda ()
      ;; handle TTY specific entries
      (when (featurep 'tty)
-       (set-face-highlight-p face nil locale 'tty)))
+       (set-face-highlight-p face nil locale (cons 'tty tags))))
    (lambda ()
      ;; handle X specific entries
      (when (featurep 'x)
-       (frob-face-property face 'font 'x-make-font-unbold locale))
+       (frob-face-property face 'font 'x-make-font-unbold locale tags))
      (when (featurep 'mswindows)
-       (frob-face-property face 'font 'mswindows-make-font-unbold locale))
+       (frob-face-property face 'font 'mswindows-make-font-unbold locale tags))
      )
    '(([default] . t)
      ([bold] . [default])
      ([italic] . t)
      ([bold-italic] . [italic]))))
 
-(defun make-face-unitalic (face &optional locale)
+(defun make-face-unitalic (face &optional locale tags)
   "Make FACE non-italic in LOCALE, if possible.
 This will attempt to make the font non-italic for X locales and will
 unset the underline flag for TTY locales.
@@ -1066,17 +1074,17 @@
 for more specifics on exactly how this function works."
   (interactive (list (read-face-name "Make which face non-italic: ")))
   (frob-face-font-2
-   face locale 'italic 'default
+   face locale tags 'italic 'default
    (lambda ()
      ;; handle TTY specific entries
      (when (featurep 'tty)
-       (set-face-underline-p face nil locale 'tty)))
+       (set-face-underline-p face nil locale (cons 'tty tags))))
    (lambda ()
      ;; handle X specific entries
      (when (featurep 'x)
-       (frob-face-property face 'font 'x-make-font-unitalic locale))
+       (frob-face-property face 'font 'x-make-font-unitalic locale tags))
      (when (featurep 'mswindows)
-       (frob-face-property face 'font 'mswindows-make-font-unitalic locale))
+       (frob-face-property face 'font 'mswindows-make-font-unitalic locale tags))
      )
    '(([default] . t)
      ([bold] . t)
@@ -1196,28 +1204,33 @@
 
 ;; Old name, used by custom.  Also, FSFmacs name.
 (defvaralias 'initialize-face-resources 'init-face-from-resources)
+
+;; Make sure all custom setting are added with this tag so we can
+;; identify-them
+(define-specifier-tag 'custom)
 
-(defun face-spec-set (face spec &optional frame)
+(defun face-spec-set (face spec &optional frame tags)
   "Set FACE's face attributes according to the first matching entry in SPEC.
 If optional FRAME is non-nil, set it for that frame only.
 If it is nil, then apply SPEC to each frame individually.
 See `defface' for information about SPEC."
   (if frame
       (progn
-	(reset-face face frame)
-	(face-display-set face spec frame)
+	(reset-face face frame tags)
+	(face-display-set face spec frame tags)
 	(init-face-from-resources face frame))
     (let ((frames (relevant-custom-frames)))
-      (reset-face face)
-      (if (and (eq 'default face) (featurep 'x))
-	  (x-init-global-faces))
-      (face-display-set face spec)
+      (reset-face face nil tags)
+      ;; This should not be needed. We only remove our own specifiers
+      ;; (if (and (eq 'default face) (featurep 'x))
+      ;;	  (x-init-global-faces))
+      (face-display-set face spec nil tags)
       (while frames
-	(face-display-set face spec (car frames))
+	(face-display-set face spec (car frames) tags)
 	(pop frames))
       (init-face-from-resources face))))
 
-(defun face-display-set (face spec &optional frame)
+(defun face-display-set (face spec &optional frame tags)
   "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."
@@ -1228,7 +1241,7 @@
       (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 'face-custom-attributes-set face frame atts))
+	  (apply 'face-custom-attributes-set face frame tags atts))
 	(unless frame
 	  (put face 'custom-face-display display))
 	(setq spec nil)))))
Index: lisp/cus-face.el
===================================================================
RCS file: /usr/CVSroot/XEmacs/xemacs-20/lisp/cus-face.el,v
retrieving revision 1.7
diff -u -u -r1.7 cus-face.el
--- cus-face.el	1998/11/26 11:36:29	1.7
+++ cus-face.el	1999/03/18 02:33:25
@@ -39,12 +39,12 @@
 	    frame)
 	;; Create global face.
 	(make-empty-face face)
-	(face-display-set face value)
+	(face-display-set face value nil '(custom))
 	;; Create frame local faces
 	(while frames
 	  (setq frame (car frames)
 		frames (cdr frames))
-	  (face-display-set face value frame))
+	  (face-display-set face value frame '(custom)))
 	(init-face-from-resources face)))
     (when (and doc (null (face-doc-string face)))
       (set-face-doc-string face doc))
@@ -107,7 +107,7 @@
 The GET function should take two arguments, the face to examine, and
 optonally the frame where the face should be examined.")
 
-(defun face-custom-attributes-set (face frame &rest atts)
+(defun face-custom-attributes-set (face frame tags &rest atts)
   "For FACE on FRAME set the attributes [KEYWORD VALUE]....
 Each keyword should be listed in `custom-face-attributes'.
 
@@ -118,7 +118,7 @@
 	   (fun (nth 2 (assq name custom-face-attributes))))
       (setq atts (cdr (cdr atts)))
       (condition-case nil
-	  (funcall fun face value frame)
+	  (funcall fun face value frame tags)
 	(error nil)))))
 
 (defun face-custom-attributes-get (face frame)
@@ -154,11 +154,11 @@
       (list (list t (face-custom-attributes-get
 		     symbol (selected-frame))))))
 
-(defun custom-set-face-bold (face value &optional frame)
+(defun custom-set-face-bold (face value &optional frame tags)
   "Set the bold property of FACE to VALUE."
   (if value
-      (make-face-bold face frame)
-    (make-face-unbold face frame)))
+      (make-face-bold face frame tags)
+    (make-face-unbold face frame tags)))
 
 ;; Really, we should get rid of these font.el dependencies...  They
 ;; are still presenting a problem with dumping the faces (font.el is
@@ -173,15 +173,15 @@
 	 (fontobj (font-create-object font)))
     (font-bold-p fontobj)))
 
-(defun custom-set-face-italic (face value &optional frame)
+(defun custom-set-face-italic (face value &optional frame tags)
   "Set the italic property of FACE to VALUE."
   (if value
-      (make-face-italic face frame)
-    (make-face-unitalic face frame)))
+      (make-face-italic face frame tags)
+    (make-face-unitalic face frame tags)))
 
 (defun custom-face-italic (face &rest args)
   "Return non-nil if the font of FACE is italic."
-  (let* ((font (apply 'face-font-name face args))
+  (let* ((font (apply 'face-font-name face))
 	 ;; Gag
 	 (fontobj (font-create-object font)))
     (font-italic-p fontobj)))
@@ -193,13 +193,13 @@
     (and image 
 	 (image-instance-file-name image))))
 
-(defun custom-set-face-font-size (face size &rest args)
+(defun custom-set-face-font-size (face size &optional locale tags)
   "Set the font of FACE to SIZE"
-  (let* ((font (apply 'face-font-name face args))
+  (let* ((font (apply 'face-font-name face locale))
 	 ;; Gag
 	 (fontobj (font-create-object font)))
     (set-font-size fontobj size)
-    (apply 'font-set-face-font face fontobj args)))
+    (apply 'font-set-face-font face fontobj locale tags)))
 
 (defun custom-face-font-size (face &rest args)
   "Return the size of the font of FACE as a string."
@@ -208,13 +208,13 @@
 	 (fontobj (font-create-object font)))
     (format "%s" (font-size fontobj))))
 
-(defun custom-set-face-font-family (face family &rest args)
+(defun custom-set-face-font-family (face family &optional locale tags)
   "Set the font of FACE to FAMILY."
-  (let* ((font (apply 'face-font-name face args))
+  (let* ((font (apply 'face-font-name face locale))
 	 ;; Gag
 	 (fontobj (font-create-object font)))
     (set-font-family fontobj family)
-    (apply 'font-set-face-font face fontobj args)))
+    (apply 'font-set-face-font face fontobj locale tags)))
 
 (defun custom-face-font-family (face &rest args)
   "Return the name of the font family of FACE."
@@ -230,7 +230,7 @@
   (let ((spec (face-spec-update-all-matching (custom-face-get-spec face)
 					     display plist)))
     (put face 'customized-face spec)
-    (face-spec-set face spec)))
+    (face-spec-set face spec nil '(custom))))
 
 ;;; Initializing.
 
@@ -257,7 +257,7 @@
 	    (when (or now (find-face face))
 	      (unless (find-face face)
 		(make-empty-face face))
-	      (face-spec-set face spec))
+	      (face-spec-set face spec nil '(custom)))
 	    (setq args (cdr args)))
 	;; Old format, a plist of FACE SPEC pairs.
 	(let ((face (nth 0 args))
Index: lisp/cus-edit.el
===================================================================
RCS file: /usr/CVSroot/XEmacs/xemacs-20/lisp/cus-edit.el,v
retrieving revision 1.10
diff -u -u -r1.10 cus-edit.el
--- cus-edit.el	1999/03/09 10:52:54	1.10
+++ cus-edit.el	1999/03/18 02:33:30
@@ -2288,12 +2288,7 @@
 	     (unless (widget-get widget :custom-form)
 		 (widget-put widget :custom-form custom-face-default-form))
 	     (let* ((symbol (widget-value widget))
-		    (spec (or (get symbol 'customized-face)
-			      (get symbol 'saved-face)
-			      (get symbol 'face-defface-spec)
-			      ;; Attempt to construct it.
-			      (list (list t (face-custom-attributes-get
-					     symbol (selected-frame))))))
+		    (spec (custom-face-get-spec symbol))
 		    (form (widget-get widget :custom-form))
 		    (indent (widget-get widget :indent))
 		    (edit (widget-create-child-and-convert
@@ -2392,7 +2387,7 @@
 	 (child (car (widget-get widget :children)))
 	 (value (widget-value child)))
     (put symbol 'customized-face value)
-    (face-spec-set symbol value)
+    (face-spec-set symbol value nil '(custom))
     (custom-face-state-set widget)
     (custom-redraw-magic widget)))
 
@@ -2401,7 +2396,7 @@
   (let* ((symbol (widget-value widget))
 	 (child (car (widget-get widget :children)))
 	 (value (widget-value child)))
-    (face-spec-set symbol value)
+    (face-spec-set symbol value nil '(custom))
     (put symbol 'saved-face value)
     (put symbol 'customized-face nil)
     (custom-save-all)
@@ -2416,7 +2411,7 @@
     (unless value
       (signal 'error (list "No saved value for this face" symbol)))
     (put symbol 'customized-face nil)
-    (face-spec-set symbol value)
+    (face-spec-set symbol value nil '(custom))
     (widget-value-set child value)
     (custom-face-state-set widget)
     (custom-redraw-magic widget)))
@@ -2432,7 +2427,7 @@
     (when (get symbol 'saved-face)
       (put symbol 'saved-face nil)
       (custom-save-all))
-    (face-spec-set symbol value)
+    (face-spec-set symbol value nil '(custom))
     (widget-value-set child value)
     (custom-face-state-set widget)
     (custom-redraw-magic widget)))
