(frame-set-background-mode): New function.

(frame-background-mode): New variable.
(x-create-frame-with-faces): Rearrangement of order of font processing.
Handle custom-faces here.
(face-doc-string, set-face-doc-string): New functions.
(set-face-bold-p, set-face-italic-p): New functions.
(face-bold-p, face-italic-p): New function.
(face-spec-set, face-spec-set-1, face-spec-set-match-display): New functions.

1 files changed, 188 insertions, 39 deletions

diff --git a/lisp/faces.el b/lisp/faces.el
index bb36630f87c..d65bc1b019e 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -108,6 +108,33 @@ If FRAME is t, report on the defaults for face FACE (for new frames).
 If FRAME is omitted or nil, use the selected frame."
  (aref (internal-get-face face frame) 7))
 
+(defun face-bold-p (face &optional frame)
+  "Return non-nil if the font of FACE is bold.
+If the optional argument FRAME is given, report on face FACE in that frame.
+If FRAME is t, report on the defaults for face FACE (for new frames).
+  The font default for a face is either nil, or a list
+  of the form (bold), (italic) or (bold italic).
+If FRAME is omitted or nil, use the selected frame."
+  (let ((font (face-font face frame)))
+    (if (stringp font)
+        (not (eq font (x-make-font-unbold font)))
+      (memq 'bold font))))
+
+(defun face-italic-p (face &optional frame)
+  "Return non-nil if the font of FACE is italic.
+If the optional argument FRAME is given, report on face FACE in that frame.
+If FRAME is t, report on the defaults for face FACE (for new frames).
+  The font default for a face is either nil, or a list
+  of the form (bold), (italic) or (bold italic).
+If FRAME is omitted or nil, use the selected frame."
+  (let ((font (face-font face frame)))
+    (if (stringp font)
+        (not (eq font (x-make-font-unitalic font)))
+      (memq 'italic font))))
+
+(defun face-doc-string (face)
+  "Get the documentation string for FACE."
+  (get face 'face-documentation))
 
 ;;; Mutators.
 
@@ -191,6 +218,24 @@ If the optional FRAME argument is provided, change only
 in that frame; otherwise change each frame."
   (interactive (internal-face-interactive "underline-p" "underlined"))
   (internal-set-face-1 face 'underline underline-p 7 frame))
+
+(defun set-face-bold-p (face bold-p &optional frame)
+  "Specify whether face FACE is bold.  (Yes if BOLD-P is non-nil.)
+If the optional FRAME argument is provided, change only
+in that frame; otherwise change each frame."
+  (cond ((eq bold-p nil) (make-face-unbold face frame t))
+        (t (make-face-bold face frame t))))
+
+(defun set-face-italic-p (face italic-p &optional frame)
+  "Specify whether face FACE is italic.  (Yes if ITALIC-P is non-nil.)
+If the optional FRAME argument is provided, change only
+in that frame; otherwise change each frame."
+  (cond ((eq italic-p nil) (make-face-unitalic face frame t))
+        (t (make-face-italic face frame t))))
+
+(defun set-face-doc-string (face string)
+  "Set the documentation string for FACE to STRING."
+  (put face 'face-documentation string))
 
 (defun modify-face-read-string (face default name alist)
   (let ((value
@@ -1075,7 +1120,73 @@ selected frame."
                     (face-fill-in face (cdr (car rest)) frame)))
               (setq rest (cdr rest)))))
       (setq frames (cdr frames)))))
-
+
+;;; Setting a face based on a SPEC.
+
+(defun face-spec-set (face spec &optional frame)
+  "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."
+  (let ((tail spec))
+    (while tail 
+      (let* ((entry (car tail))
+             (display (nth 0 entry))
+             (attrs (nth 1 entry)))
+        (setq tail (cdr tail))
+        (modify-face face nil nil nil nil nil nil frame)
+        (when (face-spec-set-match-display display frame)
+          (face-spec-set-1 face frame attrs ':foreground 'set-face-foreground)
+          (face-spec-set-1 face frame attrs ':background 'set-face-background)
+          (face-spec-set-1 face frame attrs ':stipple 'set-face-stipple)
+          (face-spec-set-1 face frame attrs ':bold 'set-face-bold-p)
+          (face-spec-set-1 face frame attrs ':italic 'set-face-italic-p)
+          (face-spec-set-1 face frame attrs ':underline 'set-face-underline-p)
+          (setq tail nil)))))
+  (if (null frame)
+      (let ((frames (frame-list))
+            frame)
+        (while frames
+          (setq frame (car frames)
+                frames (cdr frames))
+          (face-spec-set face (or (get face 'saved-face)
+                                  (get face 'face-defface-spec))
+                         frame)
+          (face-spec-set face spec frame)))))
+
+(defun face-spec-set-1 (face frame plist property function)
+  (while (and plist (not (eq (car plist) property)))
+    (setq plist (cdr (cdr plist))))
+  (if plist
+      (funcall function face (nth 1 plist) frame)))
+
+(defun face-spec-set-match-display (display frame)
+  "Non-nil iff DISPLAY matches FRAME.
+DISPLAY is part of a spec such as can be used in `defface'.
+If FRAME is nil, the current FRAME is used."
+  (let* ((conjuncts display)
+         conjunct req options
+         ;; t means we have succeeded against all
+         ;; the conjunts in DISPLAY that have been tested so far.
+         (match t))
+    (if (eq conjuncts t)
+        (setq conjuncts nil))
+    (while (and conjuncts match)
+      (setq conjunct (car conjuncts)
+            conjuncts (cdr conjuncts)
+            req (car conjunct)
+            options (cdr conjunct)
+            match (cond ((eq req 'type)
+                         (memq window-system options))
+                        ((eq req 'class)
+                         (memq (frame-parameter frame 'display-type) options))
+                        ((eq req 'background)
+                         (memq (frame-parameter frame 'background-mode)
+                               options))
+                        (t
+                         (error "Unknown req `%S' with options `%S'" 
+                                req options)))))
+    match))
 
 ;; Like x-create-frame but also set up the faces.
 
@@ -1098,16 +1209,30 @@ selected frame."
           (setq parameters (append parameters default-frame-alist parsed)))))
   (let (frame)
     (if (null global-face-data)
-        (setq frame (x-create-frame parameters))
+        (progn
+          (setq frame (x-create-frame parameters))
+          (frame-set-background-mode frame))
       (let* ((visibility-spec (assq 'visibility parameters))
-             (faces (copy-alist global-face-data))
-             success
-             (rest faces))
+             success faces rest)
         (setq frame (x-create-frame (cons '(visibility . nil) parameters)))
+        (frame-set-background-mode frame)
         (unwind-protect
             (progn
+
+              ;; Copy the face alist, copying the face vectors
+              ;; and emptying out their attributes.
+              (setq faces
+                    (mapcar '(lambda (elt)
+                               (cons (car elt)
+                                     (vector 'face
+                                             (face-name (cdr elt))
+                                             (face-id (cdr elt))
+                                             nil nil nil nil nil)))
+                            global-face-data))
               (set-frame-face-alist frame faces)
 
+              ;; Handle the reverse-video frame parameter
+              ;; and X resource.  x-create-frame does not handle this one.
               (if (cdr (or (assq 'reverse parameters)
                            (assq 'reverse default-frame-alist)
                            (let ((resource (x-get-resource "reverseVideo"
@@ -1130,51 +1255,75 @@ selected frame."
                     (if (equal bg (cdr (assq 'cursor-color params)))
                         (modify-frame-parameters frame
                                                  (list (cons 'cursor-color fg))))))
-              ;; Copy the vectors that represent the faces.
-              ;; Also fill them in from X resources.
+
+              ;; Set up faces from the defface information
+              (mapcar (lambda (symbol)
+                        (let ((spec (or (get symbol 'saved-face)
+                                        (get symbol 'face-defface-spec))))
+                          (when spec 
+                            (face-spec-set symbol spec frame))))
+                      (face-list))
+
+              ;; Set up faces from the global face data.
+              (setq rest faces)
+              (while rest
+                (let* ((face (car (car rest)))
+                       (global (cdr (assq face global-face-data))))
+                  (face-fill-in face global frame))
+                (setq rest (cdr rest)))
+
+              ;; Set up faces from the X resources.
+              (setq rest faces)
               (while rest
-                (let ((global (cdr (car rest))))
-                  (setcdr (car rest) (vector 'face
-                                             (face-name (cdr (car rest)))
-                                             (face-id (cdr (car rest)))
-                                             nil nil nil nil nil))
-                  (face-fill-in (car (car rest)) global frame))
                 (make-face-x-resource-internal (cdr (car rest)) frame t)
                 (setq rest (cdr rest)))
+
+              ;; Make the frame visible, if desired.
               (if (null visibility-spec)
                   (make-frame-visible frame)
                 (modify-frame-parameters frame (list visibility-spec)))
               (setq success t))
           (or success
               (delete-frame frame)))))
-    ;; Set up the background-mode frame parameter
-    ;; so that programs can decide good ways of highlighting
-    ;; on this frame.
-    (let ((bg-resource (x-get-resource ".backgroundMode"
-                                       "BackgroundMode"))
-          (params (frame-parameters frame))
-          (bg-mode))
-      (setq bg-mode
-            (cond (bg-resource (intern (downcase bg-resource)))
-                  ((< (apply '+ (x-color-values
-                                 (cdr (assq 'background-color params))
-                                 frame))
-                      ;; Just looking at the screen,
-                      ;; colors whose values add up to .6 of the white total
-                      ;; still look dark to me.
-                      (* (apply '+ (x-color-values "white" frame)) .6))
-                   'dark)
-                  (t 'light)))
-      (modify-frame-parameters frame
-                               (list (cons 'background-mode bg-mode)
-                                     (cons 'display-type
-                                           (cond ((x-display-color-p frame)
-                                                  'color)
-                                                 ((x-display-grayscale-p frame)
-                                                  'grayscale)
-                                                 (t 'mono))))))
     frame))
 
+(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 "default" nil)))
+
+(defun frame-set-background-mode (frame)
+  "Set up the `background-mode' and `display-type' frame parameters for FRAME."
+  (let ((bg-resource (x-get-resource ".backgroundMode"
+                                     "BackgroundMode"))
+        (params (frame-parameters frame))
+        (bg-mode))
+    (setq bg-mode
+          (cond (frame-background-mode)
+                (bg-resource (intern (downcase bg-resource)))
+                ((< (apply '+ (x-color-values
+                               (cdr (assq 'background-color params))
+                               frame))
+                    ;; Just looking at the screen,
+                    ;; colors whose values add up to .6 of the white total
+                    ;; still look dark to me.
+                    (* (apply '+ (x-color-values "white" frame)) .6))
+                 'dark)
+                (t 'light)))
+    (modify-frame-parameters frame
+                             (list (cons 'background-mode bg-mode)
+                                   (cons 'display-type
+                                         (cond ((x-display-color-p frame)
+                                                'color)
+                                               ((x-display-grayscale-p frame)
+                                                'grayscale)
+                                               (t 'mono)))))))
+
 ;; Update a frame's faces when we change its default font.
 (defun frame-update-faces (frame)
   (let* ((faces global-face-data)