(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.

diff --git a/lisp/faces.el b/lisp/faces.el
index 7c7acc265876fa6600e2ee438ccaa27d864a5123..637170cc457b71023fb197c8e422a7b436f4fe53 100644 (file)
--- 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.