X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/66cf1bd7bc531951ac1f68ad009215cb088f45cb..9afa72e8e6c422cc02cca010e9c07a03a87bdfd8:/lisp/faces.el diff --git a/lisp/faces.el b/lisp/faces.el index 75b12fb03e..ea298db1c6 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -1,6 +1,6 @@ ;;; faces.el --- Lisp interface to the c "face" structure -;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. +;; Copyright (C) 1992, 1993, 1994, 1995 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -37,7 +37,7 @@ (put 'set-face-font 'byte-optimizer nil) (put 'set-face-foreground 'byte-optimizer nil) (put 'set-face-background 'byte-optimizer nil) - (put 'set-stipple 'byte-optimizer nil) + (put 'set-face-stipple 'byte-optimizer nil) (put 'set-face-underline-p 'byte-optimizer nil)) ;;;; Functions for manipulating face vectors. @@ -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 @@ -132,14 +149,23 @@ in that frame; otherwise change each frame." (interactive (internal-face-interactive "background")) ;; 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) - (internal-set-face-1 face 'background color 5 frame))) - -(defun set-face-stipple (face name &optional frame) + (if (and frame (not (eq frame t)) color + ;; Check for support for foreground, not for background! + ;; face-color-supported-p is smart enough to know + ;; that grays are "supported" as background + ;; because we are supposed to use stipple for them! + (not (face-color-supported-p frame color nil))) + (set-face-stipple face face-default-stipple frame) + (if (null frame) + (let ((frames (frame-list))) + (while frames + (set-face-background (face-name face) color (car frames)) + (setq frames (cdr frames))) + (set-face-background face color t) + color) + (internal-set-face-1 face 'background color 5 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. @@ -151,7 +177,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) @@ -162,43 +188,81 @@ 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 modify-face (face foreground background bold-p italic-p underline-p) +(defun modify-face-read-string (face default name alist) + (let ((value + (completing-read + (if default + (format "Set face %s %s (default %s): " + face name (downcase default)) + (format "Set face %s %s: " face name)) + alist))) + (cond ((equal value "none") + nil) + ((equal value "") + default) + (t value)))) + +(defun modify-face (face foreground background stipple + bold-p italic-p underline-p &optional frame) "Change the display attributes for face FACE. -FOREGROUND and BACKGROUND should be color strings. (Default color if nil.) +If the optional FRAME argument is provided, change only +in that frame; otherwise change each frame. + +FOREGROUND and BACKGROUND should be a colour name string (or list of strings to +try) or nil. STIPPLE should be a stipple pattern name string or nil. +If nil, means do not change the display attribute corresponding to that arg. + BOLD-P, ITALIC-P, and UNDERLINE-P specify whether the face should be set bold, -in italic, and underlined, respectively. (Yes if non-nil.) -If called interactively, prompts for a face and face attributes." +in italic, and underlined, respectively. If neither nil or t, means do not +change the display attribute corresponding to that arg. + +If called interactively, prompts for a face name and face attributes." (interactive (let* ((completion-ignore-case t) - (face (symbol-name (read-face-name "Face: "))) - (foreground (completing-read - (format "Face %s set foreground (default %s): " face - (downcase (or (face-foreground (intern face)) - "foreground"))) - (mapcar 'list (x-defined-colors)))) - (background (completing-read - (format "Face %s set background (default %s): " face - (downcase (or (face-background (intern face)) - "background"))) - (mapcar 'list (x-defined-colors)))) - (bold-p (y-or-n-p (concat "Face " face ": set bold "))) - (italic-p (y-or-n-p (concat "Face " face ": set italic "))) - (underline-p (y-or-n-p (concat "Face " face ": set underline ")))) - (if (string-equal background "") (setq background nil)) - (if (string-equal foreground "") (setq foreground nil)) + (face (symbol-name (read-face-name "Modify face: "))) + (colors (mapcar 'list x-colors)) + (stipples (mapcar 'list (apply 'nconc + (mapcar 'directory-files + x-bitmap-file-path)))) + (foreground (modify-face-read-string + face (face-foreground (intern face)) + "foreground" colors)) + (background (modify-face-read-string + face (face-background (intern face)) + "background" colors)) + (stipple (modify-face-read-string + face (face-stipple (intern face)) + "stipple" stipples)) + (bold-p (y-or-n-p (concat "Set face " face " bold "))) + (italic-p (y-or-n-p (concat "Set face " face " italic "))) + (underline-p (y-or-n-p (concat "Set face " face " underline "))) + (all-frames-p (y-or-n-p (concat "Modify face " face " in all frames ")))) (message "Face %s: %s" face (mapconcat 'identity (delq nil (list (and foreground (concat (downcase foreground) " foreground")) (and background (concat (downcase background) " background")) + (and stipple (concat (downcase stipple) " stipple")) (and bold-p "bold") (and italic-p "italic") (and underline-p "underline"))) ", ")) - (list (intern face) foreground background bold-p italic-p underline-p))) - (condition-case nil (set-face-foreground face foreground) (error nil)) - (condition-case nil (set-face-background face background) (error nil)) - (funcall (if bold-p 'make-face-bold 'make-face-unbold) face nil t) - (funcall (if italic-p 'make-face-italic 'make-face-unitalic) face nil t) - (set-face-underline-p face underline-p) + (list (intern face) foreground background stipple + bold-p italic-p underline-p + (if all-frames-p nil (selected-frame))))) + (condition-case nil + (face-try-color-list 'set-face-foreground face foreground frame) + (error nil)) + (condition-case nil + (face-try-color-list 'set-face-background face background frame) + (error nil)) + (condition-case nil + (set-face-stipple face stipple frame) + (error nil)) + (cond ((eq bold-p nil) (make-face-unbold face frame t)) + ((eq bold-p t) (make-face-bold face frame t))) + (cond ((eq italic-p nil) (make-face-unitalic face frame t)) + ((eq italic-p t) (make-face-italic face frame t))) + (if (memq underline-p '(nil t)) + (set-face-underline-p face underline-p frame)) (and (interactive-p) (redraw-display))) ;;;; Associating face names (symbols) with their face vectors. @@ -299,7 +363,7 @@ If the face already exists, it is unmodified." (setq frames (cdr frames))) (setq global-face-data (cons (cons name face) global-face-data))) ;; when making a face after frames already exist - (if (eq window-system 'x) + (if (or (eq window-system 'x) (eq window-system 'win32)) (make-face-x-resource-internal face)) ;; add to menu (if (fboundp 'facemenu-add-new-face) @@ -313,7 +377,7 @@ If the face already exists, it is unmodified." (cond ((null frame) (let ((frames (frame-list))) (while frames - (if (eq (framep (car frames)) 'x) + (if (or (eq (framep (car frames)) 'x) (eq (framep (car frames)) 'win32)) (make-face-x-resource-internal (face-name face) (car frames) set-anyway)) (setq frames (cdr frames))))) @@ -355,8 +419,18 @@ If the face already exists, it is unmodified." ) (if fn (condition-case () - (set-face-font face fn frame) - (error (message "font `%s' not found for face `%s'" fn name)))) + (cond ((string= fn "italic") + (make-face-italic face)) + ((string= fn "bold") + (make-face-bold face)) + ((string= fn "bold-italic") + (make-face-bold-italic face)) + (t + (set-face-font face fn frame))) + (error + (if (member fn '("italic" "bold" "bold-italic")) + (message "no %s version found for face `%s'" fn name) + (message "font `%s' not found for face `%s'" fn name))))) (if fg (condition-case () (set-face-foreground face fg frame) @@ -500,6 +574,11 @@ set its foreground and background to the default background and foreground." (defconst x-font-regexp-weight nil) (defconst x-font-regexp-slant nil) +(defconst x-font-regexp-weight-subnum 1) +(defconst x-font-regexp-slant-subnum 2) +(defconst x-font-regexp-swidth-subnum 3) +(defconst x-font-regexp-adstyle-subnum 4) + ;;; Regexps matching font names in "Host Portable Character Representation." ;;; (let ((- "[-?]") @@ -514,7 +593,7 @@ set its foreground and background to the default background and foreground." ; (swidth "\\(\\*\\|normal\\|semicondensed\\|\\)") ; 3 (swidth "\\([^-]*\\)") ; 3 ; (adstyle "\\(\\*\\|sans\\|\\)") ; 4 - (adstyle "[^-]*") ; 4 + (adstyle "\\([^-]*\\)") ; 4 (pixelsize "[0-9]+") (pointsize "[0-9][0-9]+") (resx "[0-9][0-9]+") @@ -527,8 +606,8 @@ set its foreground and background to the default background and foreground." (setq x-font-regexp (concat "\\`\\*?[-?*]" foundry - family - weight\? - slant\? - swidth - adstyle - - pixelsize - pointsize - resx - resy - spacing - registry - - encoding "[-?*]\\*?\\'" + pixelsize - pointsize - resx - resy - spacing - avgwidth - + registry - encoding "\\*?\\'" )) (setq x-font-regexp-head (concat "\\`[-?*]" foundry - family - weight\? - slant\? @@ -567,23 +646,40 @@ 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)) + (let ((case-fold-search t)) + (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) - (concat (substring font 0 (match-beginning 1)) which - (substring font (match-end 1)))) - (t nil))) - + (let ((case-fold-search t)) + (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))))))) (defun x-make-font-bold (font) "Given an X font specification, make a bold version of it. @@ -625,8 +721,7 @@ If NOERROR is non-nil, return nil on failure." (set-face-font face (if (memq 'italic (face-font face t)) '(bold italic) '(bold)) t) - (let ((ofont (face-font face frame)) - font) + (let (font) (if (null frame) (let ((frames (frame-list))) ;; Make this face bold in global-face-data. @@ -643,10 +738,10 @@ If NOERROR is non-nil, return nil on failure." (setq font (or font (face-font 'default frame) (cdr (assq 'font (frame-parameters frame))))) - (and font (make-face-bold-internal face frame font))) - (or (not (equal ofont (face-font face))) - (and (not noerror) - (error "No bold version of %S" font)))))) + (or (and font (make-face-bold-internal face frame font)) + ;; We failed to find a bold version of the font. + noerror + (error "No bold version of %S" font)))))) (defun make-face-bold-internal (face frame font) (let (f2) @@ -663,8 +758,7 @@ If NOERROR is non-nil, return nil on failure." (set-face-font face (if (memq 'bold (face-font face t)) '(bold italic) '(italic)) t) - (let ((ofont (face-font face frame)) - font) + (let (font) (if (null frame) (let ((frames (frame-list))) ;; Make this face italic in global-face-data. @@ -681,10 +775,10 @@ If NOERROR is non-nil, return nil on failure." (setq font (or font (face-font 'default frame) (cdr (assq 'font (frame-parameters frame))))) - (and font (make-face-italic-internal face frame font))) - (or (not (equal ofont (face-font face))) - (and (not noerror) - (error "No italic version of %S" font)))))) + (or (and font (make-face-italic-internal face frame font)) + ;; We failed to find an italic version of the font. + noerror + (error "No italic version of %S" font)))))) (defun make-face-italic-internal (face frame font) (let (f2) @@ -699,8 +793,7 @@ If NOERROR is non-nil, return nil on failure." (interactive (list (read-face-name "Make which face bold-italic: "))) (if (and (eq frame t) (listp (face-font face t))) (set-face-font face '(bold italic) t) - (let ((ofont (face-font face frame)) - font) + (let (font) (if (null frame) (let ((frames (frame-list))) ;; Make this face bold-italic in global-face-data. @@ -717,10 +810,10 @@ If NOERROR is non-nil, return nil on failure." (setq font (or font (face-font 'default frame) (cdr (assq 'font (frame-parameters frame))))) - (and font (make-face-bold-italic-internal face frame font))) - (or (not (equal ofont (face-font face))) - (and (not noerror) - (error "No bold italic version of %S" font)))))) + (or (and font (make-face-bold-italic-internal face frame font)) + ;; We failed to find a bold italic version. + noerror + (error "No bold italic version of %S" font)))))) (defun make-face-bold-italic-internal (face frame font) (let (f2 f3) @@ -753,8 +846,7 @@ If NOERROR is non-nil, return nil on failure." (set-face-font face (if (memq 'italic (face-font face t)) '(italic) nil) t) - (let ((ofont (face-font face frame)) - font font1) + (let (font font1) (if (null frame) (let ((frames (frame-list))) ;; Make this face unbold in global-face-data. @@ -772,10 +864,9 @@ If NOERROR is non-nil, return nil on failure." (face-font 'default frame) (cdr (assq 'font (frame-parameters frame))))) (setq font (and font1 (x-make-font-unbold font1))) - (if font (internal-try-face-font face font frame))) - (or (not (equal ofont (face-font face))) - (and (not noerror) - (error "No unbold version of %S" font1)))))) + (or (if font (internal-try-face-font face font frame)) + noerror + (error "No unbold version of %S" font1)))))) (defun make-face-unitalic (face &optional frame noerror) "Make the font of the given face be non-italic, if possible. @@ -785,8 +876,7 @@ If NOERROR is non-nil, return nil on failure." (set-face-font face (if (memq 'bold (face-font face t)) '(bold) nil) t) - (let ((ofont (face-font face frame)) - font font1) + (let (font font1) (if (null frame) (let ((frames (frame-list))) ;; Make this face unitalic in global-face-data. @@ -804,10 +894,9 @@ If NOERROR is non-nil, return nil on failure." (face-font 'default frame) (cdr (assq 'font (frame-parameters frame))))) (setq font (and font1 (x-make-font-unitalic font1))) - (if font (internal-try-face-font face font frame))) - (or (not (equal ofont (face-font face))) - (and (not noerror) - (error "No unitalic version of %S" font1)))))) + (or (if font (internal-try-face-font face font frame)) + noerror + (error "No unitalic version of %S" font1)))))) (defvar list-faces-sample-text "abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ" @@ -858,6 +947,19 @@ selected frame." (while faces (copy-face (car faces) (car faces) frame disp-frame) (setq faces (cdr faces))))))) + +(defun describe-face (face) + "Display the properties of face FACE." + (interactive (list (read-face-name "Describe face: "))) + (with-output-to-temp-buffer "*Help*" + (princ "Properties of face `") + (princ (face-name face)) + (princ "':") (terpri) + (princ "Foreground: ") (princ (face-foreground face)) (terpri) + (princ "Background: ") (princ (face-background face)) (terpri) + (princ " Font: ") (princ (face-font face)) (terpri) + (princ "Underlined: ") (princ (if (face-underline-p face) "yes" "no")) (terpri) + (princ " Stipple: ") (princ (or (face-stipple face) "none")))) ;;; Make the standard faces. ;;; The C code knows the default and modeline faces as faces 0 and 1, @@ -910,57 +1012,101 @@ selected frame." ;; Like x-create-frame but also set up the faces. (defun x-create-frame-with-faces (&optional parameters) - (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)))))) + ;; Read this frame's geometry resource, if it has an explicit name, + ;; and put the specs into PARAMETERS. + (let* ((name (or (cdr (assq 'name parameters)) + (cdr (assq 'name default-frame-alist)))) + (x-resource-name name) + (res-geometry (if name (x-get-resource "geometry" "Geometry"))) + parsed) + (if res-geometry + (progn + (setq parsed (x-parse-geometry res-geometry)) + ;; If the resource specifies a position, + ;; call the position and size "user-specified". + (if (or (assq 'top parsed) (assq 'left parsed)) + (setq parsed (cons '(user-position . t) + (cons '(user-size . t) parsed)))) + ;; Put the geometry parameters at the end. + ;; Copy default-frame-alist so that they go after it. + (setq parameters (append parameters + default-frame-alist + parsed))))) + (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 frame)) + (bg-mode)) + (setq bg-mode + (cond (bg-resource (intern (downcase bg-resource))) + ((< (apply '+ (x-color-values + (cdr (assq 'background-color params)) + frame)) + (/ (apply '+ (x-color-values "white" frame)) 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) @@ -1024,7 +1170,8 @@ selected frame." (condition-case nil (let ((foreground (face-foreground data)) (background (face-background data)) - (font (face-font data))) + (font (face-font data)) + (stipple (face-stipple data))) (set-face-underline-p face (face-underline-p data) frame) (if foreground (face-try-color-list 'set-face-foreground @@ -1042,27 +1189,24 @@ selected frame." (italic (make-face-italic face frame)))) (if font - (set-face-font face font frame)))) + (set-face-font face font frame))) + (if stipple + (set-face-stipple face stipple frame))) (error nil))) ;; Assuming COLOR is a valid color name, ;; return t if it can be displayed on FRAME. (defun face-color-supported-p (frame color background-p) - (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. - (and background-p - (member color '("gray" "gray1" "gray3"))) - ;; 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))))))) + (and window-system + (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 gray for background. + (and background-p + (face-color-gray-p color frame)) + ;; A grayscale display can implement colors that are gray (more or less). + (and (x-display-grayscale-p frame) + (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. @@ -1106,7 +1250,7 @@ selected frame." (setq colors (cdr colors))))))) ;; If we are already using x-window frames, initialize faces for them. -(if (eq (framep (selected-frame)) 'x) +(if (or (eq (framep (selected-frame)) 'x) (eq (framep (selected-frame)) 'win32)) (face-initialize)) (provide 'faces)