(x-create-frame-with-faces): Set background-mode

and display-type frame parameters.
(x-frob-font-slant, x-frob-font-weight):
Replace the adstyle field with *, if we can find it.
(set-face-background): Use face-color-supported-p.
(face-color-gray-p): New function.
(face-default-stipple): New variable.
(set-face-background): Use face-default-stipple for all grays.
(set-face-stipple): Change arg name.
(face-color-supported-p): Use face-color-gray-p.

1 files changed, 125 insertions, 80 deletions

diff --git a/lisp/faces.el b/lisp/faces.el
index 7c7acc26587..637170cc457 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -125,6 +125,23 @@ in that frame; otherwise change each frame."
   (interactive (internal-face-interactive "foreground"))
   (internal-set-face-1 face 'foreground color 4 frame))
 
+(defvar face-default-stipple "gray3" 
+  "Default stipple pattern used on monochrome displays.
+This stipple pattern is used on monochrome displays
+instead of shades of gray for a face background color.
+See `set-face-stipple' for possible values for this variable.")
+
+(defun face-color-gray-p (color &optional frame)
+  "Return t if COLOR is a shade of gray (or white or black).
+FRAME specifies the frame and thus the display for interpreting COLOR."
+  (let* ((values (x-color-values color frame))
+         (r (nth 0 values))
+         (g (nth 1 values))
+         (b (nth 2 values)))
+    (and (< (abs (- r g)) (/ (max 1 (abs r) (abs g)) 20))
+         (< (abs (- g b)) (/ (max 1 (abs g) (abs b)) 20))
+         (< (abs (- b r)) (/ (max 1 (abs b) (abs r)) 20)))))
+
 (defun set-face-background (face color &optional frame)
   "Change the background color of face FACE to COLOR (a string).
 If the optional FRAME argument is provided, change only
@@ -133,10 +150,8 @@ in that frame; otherwise change each frame."
   ;; For a specific frame, use gray stipple instead of gray color
   ;; if the display does not support a gray color.
   (if (and frame (not (eq frame t))
-           (member color '("gray" "gray1" "gray3"))
-           (not (x-display-color-p frame))
-           (not (x-display-grayscale-p frame)))
-      (set-face-stipple face color frame)
+           (not (face-color-supported-p frame color)))
+      (set-face-stipple face face-default-stipple frame)
     (if (null frame)
         (let ((frames (frame-list)))
           (while frames
@@ -146,7 +161,7 @@ in that frame; otherwise change each frame."
           color)
       (internal-set-face-1 face 'background color 5 frame))))
 
-(defun set-face-stipple (face name &optional frame)
+(defun set-face-stipple (face pixmap &optional frame)
   "Change the stipple pixmap of face FACE to PIXMAP.
 PIXMAP should be a string, the name of a file of pixmap data.
 The directories listed in the `x-bitmap-file-path' variable are searched.
@@ -158,7 +173,7 @@ and DATA is a string, containing the raw bits of the bitmap.
 If the optional FRAME argument is provided, change only
 in that frame; otherwise change each frame."
   (interactive (internal-face-interactive "stipple"))
-  (internal-set-face-1 face 'background-pixmap name 6 frame))
+  (internal-set-face-1 face 'background-pixmap pixmap 6 frame))
 
 (defalias 'set-face-background-pixmap 'set-face-stipple)
 
@@ -605,23 +620,36 @@ also the same size as FACE on FRAME, or fail."
     (cdr (assq 'font (frame-parameters (selected-frame))))))
 
 (defun x-frob-font-weight (font which)
-  (if (or (string-match x-font-regexp font)
-          (string-match x-font-regexp-head font)
-          (string-match x-font-regexp-weight font))
-      (concat (substring font 0 (match-beginning 1)) which
-              (substring font (match-end 1)))
-    nil))
+  (cond ((string-match x-font-regexp font)
+         (concat (substring font 0 (match-beginning x-font-regexp-weight-subnum))
+                 which
+                 (substring font (match-end x-font-regexp-weight-subnum)
+                            (match-beginning x-font-regexp-adstyle-subnum))
+                 ;; Replace the ADD_STYLE_NAME field with *
+                 ;; because the info in it may not be the same
+                 ;; for related fonts.
+                 "*"
+                 (substring font (match-end x-font-regexp-adstyle-subnum))))
+        ((or (string-match x-font-regexp-head font)
+             (string-match x-font-regexp-weight font))
+         (concat (substring font 0 (match-beginning 1)) which
+                 (substring font (match-end 1))))))
 
 (defun x-frob-font-slant (font which)
-  (cond ((or (string-match x-font-regexp font)
-             (string-match x-font-regexp-head font))
-         (concat (substring font 0 (match-beginning 2)) which
-                 (substring font (match-end 2))))
-        ((string-match x-font-regexp-slant font)
+  (cond ((string-match x-font-regexp font)
+         (concat (substring font 0 (match-beginning x-font-regexp-slant-subnum))
+                 which
+                 (substring font (match-end x-font-regexp-slant-subnum)
+                            (match-beginning x-font-regexp-adstyle-subnum))
+                 ;; Replace the ADD_STYLE_NAME field with *
+                 ;; because the info in it may not be the same
+                 ;; for related fonts.
+                 "*"
+                 (substring font (match-end x-font-regexp-adstyle-subnum))))
+        ((or (string-match x-font-regexp-head font)
+             (string-match x-font-regexp-slant font))
          (concat (substring font 0 (match-beginning 1)) which
-                 (substring font (match-end 1))))
-        (t nil)))
-
+                 (substring font (match-end 1))))))
 
 (defun x-make-font-bold (font)
   "Given an X font specification, make a bold version of it.
@@ -981,57 +1009,80 @@ selected frame."
           (setq parameters (append parameters
                                    default-frame-alist
                                    parsed)))))
-  (if (null global-face-data)
-      (x-create-frame parameters)
-    (let* ((visibility-spec (assq 'visibility parameters))
-           (frame (x-create-frame (cons '(visibility . nil) parameters)))
-           (faces (copy-alist global-face-data))
-           success
-           (rest faces))
-      (unwind-protect
-          (progn
-            (set-frame-face-alist frame faces)
-
-            (if (cdr (or (assq 'reverse parameters)
-                         (assq 'reverse default-frame-alist)
-                         (let ((resource (x-get-resource "reverseVideo"
-                                                         "ReverseVideo")))
-                           (if resource
-                               (cons nil (member (downcase resource)
-                                                 '("on" "true")))))))
-                (let* ((params (frame-parameters frame))
-                       (bg (cdr (assq 'foreground-color params)))
-                       (fg (cdr (assq 'background-color params))))
-                  (modify-frame-parameters frame
-                                           (list (cons 'foreground-color fg)
-                                                 (cons 'background-color bg)))
-                  (if (equal bg (cdr (assq 'border-color params)))
-                      (modify-frame-parameters frame
-                                               (list (cons 'border-color fg))))
-                  (if (equal bg (cdr (assq 'mouse-color params)))
-                      (modify-frame-parameters frame
-                                               (list (cons 'mouse-color fg))))
-                  (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.
-            (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)))
-            (if (null visibility-spec)
-                (make-frame-visible frame)
-              (modify-frame-parameters frame (list visibility-spec)))
-            (setq success t)
-            frame)
-        (or success
-            (delete-frame frame))))))
+  (let (frame)
+    (if (null global-face-data)
+        (setq frame (x-create-frame parameters))
+      (let* ((visibility-spec (assq 'visibility parameters))
+             (faces (copy-alist global-face-data))
+             success
+             (rest faces))
+        (setq frame (x-create-frame (cons '(visibility . nil) parameters)))
+        (unwind-protect
+            (progn
+              (set-frame-face-alist frame faces)
+
+              (if (cdr (or (assq 'reverse parameters)
+                           (assq 'reverse default-frame-alist)
+                           (let ((resource (x-get-resource "reverseVideo"
+                                                           "ReverseVideo")))
+                             (if resource
+                                 (cons nil (member (downcase resource)
+                                                   '("on" "true")))))))
+                  (let* ((params (frame-parameters frame))
+                         (bg (cdr (assq 'foreground-color params)))
+                         (fg (cdr (assq 'background-color params))))
+                    (modify-frame-parameters frame
+                                             (list (cons 'foreground-color fg)
+                                                   (cons 'background-color bg)))
+                    (if (equal bg (cdr (assq 'border-color params)))
+                        (modify-frame-parameters frame
+                                                 (list (cons 'border-color fg))))
+                    (if (equal bg (cdr (assq 'mouse-color params)))
+                        (modify-frame-parameters frame
+                                                 (list (cons 'mouse-color fg))))
+                    (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.
+              (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)))
+              (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))
+          (bg-mode))
+      (setq bg-mode
+            (cond (bg-resource (intern (downcase bg-resource)))
+                  ((< (apply '+ (x-color-values
+                                 (cdr (assq 'background-color params))))
+                      (/ (apply '+ (x-color-values "white")) 3))
+                   '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))
 
 ;; Update a frame's faces when we change its default font.
 (defun frame-update-faces (frame)
@@ -1125,18 +1176,12 @@ selected frame."
   (or (x-display-color-p frame)
       ;; A black-and-white display can implement these.
       (member color '("black" "white"))
-      ;; A black-and-white display can fake these for background.
+      ;; A black-and-white display can fake gray for background.
       (and background-p
-           (member color '("gray" "gray1" "gray3")))
+           (face-color-gray-p color frame))
       ;; A grayscale display can implement colors that are gray (more or less).
       (and (x-display-grayscale-p frame)
-           (let* ((values (x-color-values color frame))
-                  (r (nth 0 values))
-                  (g (nth 1 values))
-                  (b (nth 2 values)))
-             (and (< (abs (- r g)) (/ (abs (+ r g)) 20))
-                  (< (abs (- g b)) (/ (abs (+ g b)) 20))
-                  (< (abs (- b r)) (/ (abs (+ b r)) 20)))))))
+           (face-color-gray-p color frame))))
 
 ;; Use FUNCTION to store a color in FACE on FRAME.
 ;; COLORS is either a single color or a list of colors.