X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/6e4aafdc8a5bf0bcbe758e2790309ffe3541f05e..a081a529397af02bd9fc274065fcd982733e1d8b:/lisp/faces.el diff --git a/lisp/faces.el b/lisp/faces.el index aa14e62b72..4c938f2e1b 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, 1995 Free Software Foundation, Inc. +;; Copyright (C) 1992, 1993, 1994, 1995, 1996 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -15,8 +15,9 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Commentary: @@ -30,11 +31,13 @@ (put 'face-name 'byte-optimizer nil) (put 'face-id 'byte-optimizer nil) (put 'face-font 'byte-optimizer nil) + (put 'face-font-explicit 'byte-optimizer nil) (put 'face-foreground 'byte-optimizer nil) (put 'face-background 'byte-optimizer nil) (put 'face-stipple 'byte-optimizer nil) (put 'face-underline-p 'byte-optimizer nil) (put 'set-face-font 'byte-optimizer nil) + (put 'set-face-font-auto 'byte-optimizer nil) (put 'set-face-foreground 'byte-optimizer nil) (put 'set-face-background 'byte-optimizer nil) (put 'set-face-stipple 'byte-optimizer nil) @@ -43,11 +46,12 @@ ;;;; Functions for manipulating face vectors. ;;; A face vector is a vector of the form: -;;; [face NAME ID FONT FOREGROUND BACKGROUND STIPPLE UNDERLINE] +;;; [face NAME ID FONT FOREGROUND BACKGROUND STIPPLE +;;; UNDERLINE-P INVERSE-VIDEO-P FONT-EXPLICIT-P BOLD-P ITALIC-P] ;;; Type checkers. (defsubst internal-facep (x) - (and (vectorp x) (= (length x) 8) (eq (aref x 0) 'face))) + (and (vectorp x) (= (length x) 12) (eq (aref x 0) 'face))) (defun facep (x) "Return t if X is a face name or an internal face vector." @@ -107,6 +111,35 @@ 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-inverse-video-p (face &optional frame) + "Return t if face FACE is in inverse video. +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). +If FRAME is omitted or nil, use the selected frame." + (aref (internal-get-face face frame) 8)) + +(defun face-font-explicit (face &optional frame) + "Return non-nil if this face's font was explicitly specified." + (aref (internal-get-face face frame) 9)) + +(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). +If FRAME is omitted or nil, use the selected frame." + (aref (internal-get-face face frame) 10)) + +(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). +If FRAME is omitted or nil, use the selected frame." + (aref (internal-get-face face frame) 11)) + +(defalias 'face-doc-string 'face-documentation) +(defun face-documentation (face) + "Get the documentation string for FACE." + (get face 'face-documentation)) ;;; Mutators. @@ -115,28 +148,71 @@ If FRAME is omitted or nil, use the selected frame." If the optional FRAME argument is provided, change only in that frame; otherwise change each frame." (interactive (internal-face-interactive "font")) - (if (stringp font) (setq font (x-resolve-font-name font 'default frame))) + (if (stringp font) + (setq font (or (resolve-fontset-name font) + (x-resolve-font-name font 'default frame)))) + (internal-set-face-1 face 'font font 3 frame) + ;; Record that this face's font was set explicitly, not automatically, + ;; unless we are setting it to nil. + (internal-set-face-1 face nil (not (null font)) 9 frame)) + +(defun set-face-font-auto (face font &optional frame) + "Change the font of face FACE to FONT (a string), for an automatic change. +An automatic change means that we don't change the \"explicit\" flag; +if the font was derived from the frame font before, it is now. +If the optional FRAME argument is provided, change only +in that frame; otherwise change each frame." + (interactive (internal-face-interactive "font")) + (if (stringp font) + (setq font (or (resolve-fontset-name font) + (x-resolve-font-name font 'default frame)))) (internal-set-face-1 face 'font font 3 frame)) +(defun set-face-font-explicit (face flag &optional frame) + "Set the explicit-font flag of face FACE to FLAG. +If the optional FRAME argument is provided, change only +in that frame; otherwise change each frame." + (internal-set-face-1 face nil flag 9 frame)) + (defun set-face-foreground (face color &optional frame) "Change the foreground color of face FACE to COLOR (a string). If the optional FRAME argument is provided, change only in that frame; otherwise change each frame." - (interactive (internal-face-interactive "foreground")) + (interactive (internal-face-interactive "foreground" 'color)) (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 values + (< (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 in that frame; otherwise change each frame." - (interactive (internal-face-interactive "background")) + (interactive (internal-face-interactive "background" 'color)) ;; 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) + (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 @@ -146,7 +222,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. @@ -157,8 +233,8 @@ 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)) + (interactive (internal-face-interactive-stipple "stipple")) + (internal-set-face-1 face 'background-pixmap pixmap 6 frame)) (defalias 'set-face-background-pixmap 'set-face-stipple) @@ -168,6 +244,33 @@ 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-inverse-video-p (face inverse-video-p &optional frame) + "Specify whether face FACE is in inverse video. +\(Yes if INVERSE-VIDEO-P is non-nil.) +If the optional FRAME argument is provided, change only +in that frame; otherwise change each frame." + (interactive (internal-face-interactive "inverse-video-p" "inverse-video")) + (internal-set-face-1 face 'inverse-video inverse-video-p 8 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)))) + +(defalias 'set-face-doc-string 'set-face-documentation) +(defun set-face-documentation (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 @@ -178,55 +281,114 @@ in that frame; otherwise change each frame." (format "Set face %s %s: " face name)) alist))) (cond ((equal value "none") - nil) + '(nil)) ((equal value "") default) (t value)))) (defun modify-face (face foreground background stipple - bold-p italic-p underline-p) + bold-p italic-p underline-p &optional inverse-p frame) "Change the display attributes for face FACE. -FOREGROUND and BACKGROUND should be color strings or nil. -STIPPLE should be a stipple pattern name or nil. -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." +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. +If (nil), that means clear out the attribute. + +BOLD-P, ITALIC-P, UNDERLINE-P, and INVERSE-P specify whether +the face should be set bold, italic, underlined or in inverse-video, +respectively. If one of these arguments is neither nil or t, it means do not +change the display attribute corresponding to that argument. + +If called interactively, prompts for a face name and face attributes." (interactive (let* ((completion-ignore-case t) - (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 ")))) + (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)) + ;; If the stipple value is a list (WIDTH HEIGHT DATA), + ;; represent that as a string by printing it out. + (old-stipple-string + (if (stringp (face-stipple (intern face))) + (face-stipple (intern face)) + (if (face-stipple (intern face)) + (prin1-to-string (face-stipple (intern face)))))) + (new-stipple-string + (modify-face-read-string + face old-stipple-string + "stipple" stipples)) + ;; Convert the stipple value text we read + ;; back to a list if it looks like one. + ;; This makes the assumption that a pixmap file name + ;; won't start with an open-paren. + (stipple + (and new-stipple-string + (if (string-match "^(" new-stipple-string) + (read new-stipple-string) + new-stipple-string))) + (bold-p (y-or-n-p (concat "Should face " face " be bold "))) + (italic-p (y-or-n-p (concat "Should face " face " be italic "))) + (underline-p (y-or-n-p (concat "Should face " face " be underlined "))) + (inverse-p (y-or-n-p (concat "Should face " face " be inverse-video "))) + (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")) + (list (if (equal foreground '(nil)) + " no foreground" + (and foreground (concat (downcase foreground) " foreground"))) + (if (equal background '(nil)) + " no background" + (and background (concat (downcase background) " background"))) + (if (equal stipple '(nil)) + " no stipple" + (and stipple (concat (downcase new-stipple-string) " stipple"))) (and bold-p "bold") (and italic-p "italic") + (and inverse-p "inverse") (and underline-p "underline"))) ", ")) (list (intern face) foreground background stipple - 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)) - (condition-case nil (set-face-stipple face stipple) (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) + bold-p italic-p underline-p inverse-p + (if all-frames-p nil (selected-frame))))) + ;; Clear this before we install the new foreground and background; + ;; otherwise, clearing it after would swap them! + (when (and (or foreground background) (face-inverse-video-p face)) + (set-face-inverse-video-p face nil frame) + ;; Arrange to restore it after, if we are not setting it now. + (or (memq inverse-p '(t nil)) + (setq inverse-p t))) + (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)) + ;; Now that we have the new colors, + (if (memq inverse-p '(nil t)) + (set-face-inverse-video-p face inverse-p frame)) + (cond ((eq bold-p nil) + (if (face-font face frame) + (make-face-unbold face frame t))) + ((eq bold-p t) + (make-face-bold face frame t))) + (cond ((eq italic-p nil) + (if (face-font face frame) + (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. @@ -276,9 +438,15 @@ If NAME is already a face, it is simply returned." (aset (internal-get-face (if (symbolp face) face (face-name face)) t) index value) value) - (or (eq frame t) - (set-face-attribute-internal (face-id face) name value frame)) - (aset (internal-get-face face frame) index value)))) + (let ((internal-face (internal-get-face face frame))) + (or (eq frame t) + (if (eq name 'inverse-video) + (or (eq value (aref internal-face index)) + (invert-face face frame)) + (and name (fboundp 'set-face-attribute-internal) + (set-face-attribute-internal (face-id face) + name value frame)))) + (aset internal-face index value))))) (defun read-face-name (prompt) @@ -297,28 +465,68 @@ If NAME is already a face, it is simply returned." (default (if (fboundp fn) (or (funcall fn face (selected-frame)) (funcall fn 'default (selected-frame))))) - (value (if bool - (y-or-n-p (concat "Should face " (symbol-name face) - " be " bool "? ")) - (read-string (concat prompt " " (symbol-name face) " to: ") - default)))) + value) + (setq value + (cond ((eq bool 'color) + (completing-read (concat prompt " " (symbol-name face) " to: ") + (mapcar (function (lambda (color) + (cons color color))) + x-colors) + nil nil nil nil default)) + (bool + (y-or-n-p (concat "Should face " (symbol-name face) + " be " bool "? "))) + (t + (read-string (concat prompt " " (symbol-name face) " to: ") + nil nil default)))) (list face (if (equal value "") nil value)))) - - -(defun make-face (name) +(defun internal-face-interactive-stipple (what) + (let* ((fn (intern (concat "face-" what))) + (prompt (concat "Set " what " of face")) + (face (read-face-name (concat prompt ": "))) + (default (if (fboundp fn) + (or (funcall fn face (selected-frame)) + (funcall fn 'default (selected-frame))))) + ;; If the stipple value is a list (WIDTH HEIGHT DATA), + ;; represent that as a string by printing it out. + (old-stipple-string + (if (stringp (face-stipple face)) + (face-stipple face) + (if (null (face-stipple face)) + nil + (prin1-to-string (face-stipple face))))) + (new-stipple-string + (read-string + (concat prompt " " (symbol-name face) " to: ") + old-stipple-string)) + ;; Convert the stipple value text we read + ;; back to a list if it looks like one. + ;; This makes the assumption that a pixmap file name + ;; won't start with an open-paren. + (stipple + (if (string-match "^(" new-stipple-string) + (read new-stipple-string) + new-stipple-string))) + (list face (if (equal stipple "") nil stipple)))) + +(defun make-face (name &optional no-resources) "Define a new FACE on all frames. You can modify the font, color, etc of this face with the set-face- functions. +If NO-RESOURCES is non-nil, then we ignore X resources +and always make a face whose attributes are all nil. + If the face already exists, it is unmodified." (interactive "SMake face: ") (or (internal-find-face name) - (let ((face (make-vector 8 nil))) + (let ((face (make-vector 12 nil))) (aset face 0 'face) (aset face 1 name) (let* ((frames (frame-list)) (inhibit-quit t) (id (internal-next-face-id))) - (make-face-internal id) + (if (fboundp 'make-face-internal) + (make-face-internal id)) (aset face 2 id) (while frames (set-frame-face-alist (car frames) @@ -326,22 +534,30 @@ If the face already exists, it is unmodified." (frame-face-alist (car frames)))) (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) - (make-face-x-resource-internal face)) - ;; add to menu + ;; When making a face after frames already exist + (or no-resources + (if (memq window-system '(x w32)) + (make-face-x-resource-internal face))) + ;; Add to menu of faces. (if (fboundp 'facemenu-add-new-face) (facemenu-add-new-face name)) face)) name) +(defun make-empty-face (face) + "Define a new FACE on all frames, which initially reflects the defaults. +You can modify the font, color, etc of this face with the set-face- functions. +If the face already exists, it is unmodified." + (interactive "SMake empty face: ") + (make-face face t)) + ;; Fill in a face by default based on X resources, for all existing frames. ;; This has to be done when a new face is made. (defun make-face-x-resource-internal (face &optional frame set-anyway) (cond ((null frame) (let ((frames (frame-list))) (while frames - (if (eq (framep (car frames)) 'x) + (if (memq (framep (car frames)) '(x w32)) (make-face-x-resource-internal (face-name face) (car frames) set-anyway)) (setq frames (cdr frames))))) @@ -383,8 +599,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) @@ -434,6 +660,8 @@ to NEW-FACE on frame NEW-FRAME." (set-face-font new-face (face-font old-face frame) new-frame) (error (set-face-font new-face nil new-frame))) + (set-face-font-explicit new-face (face-font-explicit old-face frame) + new-frame) (set-face-foreground new-face (face-foreground old-face frame) new-frame) (set-face-background new-face (face-background old-face frame) new-frame) (set-face-stipple new-face @@ -472,8 +700,11 @@ If FRAME is nil or omitted, test the selected frame." (or (equal (face-background default frame) (face-background face frame)) (null (face-background face frame))) - (or (equal (face-font default frame) (face-font face frame)) - (null (face-font face frame))) + (or (null (face-font face frame)) + (equal (face-font face frame) + (or (face-font default frame) + (downcase + (cdr (assq 'font (frame-parameters frame))))))) (or (equal (face-stipple default frame) (face-stipple face frame)) (null (face-stipple face frame))) @@ -506,27 +737,34 @@ set its foreground and background to the default background and foreground." (progn (set-face-foreground face bg frame) (set-face-background face fg frame)) - (set-face-foreground face (or (face-background 'default frame) - (cdr (assq 'background-color (frame-parameters frame)))) - frame) - (set-face-background face (or (face-foreground 'default frame) - (cdr (assq 'foreground-color (frame-parameters frame)))) - frame))) + (let* ((frame-bg (cdr (assq 'background-color (frame-parameters frame)))) + (default-bg (or (face-background 'default frame) + frame-bg)) + (frame-fg (cdr (assq 'foreground-color (frame-parameters frame)))) + (default-fg (or (face-foreground 'default frame) + frame-fg))) + (set-face-foreground face default-bg frame) + (set-face-background face default-fg frame)))) face) (defun internal-try-face-font (face font &optional frame) "Like set-face-font, but returns nil on failure instead of an error." (condition-case () - (set-face-font face font frame) + (set-face-font-auto face font frame) (error nil))) ;; Manipulating font names. -(defconst x-font-regexp nil) -(defconst x-font-regexp-head nil) -(defconst x-font-regexp-weight nil) -(defconst x-font-regexp-slant nil) +(defvar x-font-regexp nil) +(defvar x-font-regexp-head nil) +(defvar x-font-regexp-weight nil) +(defvar 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." ;;; @@ -542,7 +780,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]+") @@ -555,8 +793,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\? @@ -578,7 +816,7 @@ also the same size as FACE on FRAME, or fail." (setq frame nil)) (if pattern ;; Note that x-list-fonts has code to handle a face with nil as its font. - (let ((fonts (x-list-fonts pattern face frame))) + (let ((fonts (x-list-fonts pattern face frame 1))) (or fonts (if face (if (string-match "\\*" pattern) @@ -595,23 +833,44 @@ 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)))) + ((string-match x-font-regexp-head font) + (concat (substring font 0 (match-beginning 1)) which + (substring font (match-end 1)))) + ((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)))) + ((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))))))) (defun x-make-font-bold (font) "Given an X font specification, make a bold version of it. @@ -642,6 +901,12 @@ If that can't be done, return nil." "Given an X font specification, make a non-italic version of it. If that can't be done, return nil." (x-frob-font-slant font "r")) + +(defun x-make-font-bold-italic (font) + "Given an X font specification, make a bold and italic version of it. +If that can't be done, return nil." + (and (setq font (x-make-font-bold font)) + (x-make-font-italic font))) ;;; non-X-specific interface @@ -649,12 +914,13 @@ If that can't be done, return nil." "Make the font of the given face be bold, if possible. If NOERROR is non-nil, return nil on failure." (interactive (list (read-face-name "Make which face bold: "))) + ;; Set the bold-p flag, first of all. + (internal-set-face-1 face nil t 10 frame) (if (and (eq frame t) (listp (face-font face t))) (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. @@ -671,10 +937,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) @@ -687,12 +953,13 @@ If NOERROR is non-nil, return nil on failure." "Make the font of the given face be italic, if possible. If NOERROR is non-nil, return nil on failure." (interactive (list (read-face-name "Make which face italic: "))) + ;; Set the italic-p flag, first of all. + (internal-set-face-1 face nil t 11 frame) (if (and (eq frame t) (listp (face-font face t))) (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. @@ -709,10 +976,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) @@ -725,10 +992,12 @@ If NOERROR is non-nil, return nil on failure." "Make the font of the given face be bold and italic, if possible. If NOERROR is non-nil, return nil on failure." (interactive (list (read-face-name "Make which face bold-italic: "))) + ;; Set the bold-p and italic-p flags, first of all. + (internal-set-face-1 face nil t 10 frame) + (internal-set-face-1 face nil t 11 frame) (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. @@ -745,10 +1014,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) @@ -777,12 +1046,13 @@ If NOERROR is non-nil, return nil on failure." "Make the font of the given face be non-bold, if possible. If NOERROR is non-nil, return nil on failure." (interactive (list (read-face-name "Make which face non-bold: "))) + ;; Clear the bold-p flag, first of all. + (internal-set-face-1 face nil nil 10 frame) (if (and (eq frame t) (listp (face-font face t))) (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. @@ -800,21 +1070,21 @@ 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. If NOERROR is non-nil, return nil on failure." (interactive (list (read-face-name "Make which face non-italic: "))) + ;; Clear the italic-p flag, first of all. + (internal-set-face-1 face nil nil 11 frame) (if (and (eq frame t) (listp (face-font face t))) (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. @@ -832,10 +1102,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" @@ -855,7 +1124,11 @@ selected frame." (let ((faces (sort (face-list) (function string-lessp))) (face nil) (frame (selected-frame)) - disp-frame window) + disp-frame window + (face-name-max-length + (car (sort (mapcar (function string-width) + (mapcar (function symbol-name) (face-list))) + (function >))))) (with-output-to-temp-buffer "*Faces*" (save-excursion (set-buffer standard-output) @@ -863,7 +1136,10 @@ selected frame." (while faces (setq face (car faces)) (setq faces (cdr faces)) - (insert (format "%25s " (symbol-name face))) + (insert (format + (format "%%-%ds " + face-name-max-length) + (symbol-name face))) (let ((beg (point))) (insert list-faces-sample-text) (insert "\n") @@ -872,9 +1148,10 @@ selected frame." (goto-char beg) (forward-line 1) (while (not (eobp)) - (insert " ") + (insert-char ? (1+ face-name-max-length)) (forward-line 1)))) - (goto-char (point-min)))) + (goto-char (point-min))) + (print-help-return-message)) ;; If the *Faces* buffer appears in a different frame, ;; copy all the face definitions from FRAME, ;; so that the display will reflect the frame that was selected. @@ -886,54 +1163,182 @@ selected frame." (while faces (copy-face (car faces) (car faces) frame disp-frame) (setq faces (cdr faces))))))) - -;;; Make the standard faces. -;;; The C code knows the default and modeline faces as faces 0 and 1, -;;; so they must be the first two faces made. -(defun face-initialize () - (make-face 'default) - (make-face 'modeline) - (make-face 'highlight) - - ;; These aren't really special in any way, but they're nice to have around. - - (make-face 'bold) - (make-face 'italic) - (make-face 'bold-italic) - (make-face 'region) - (make-face 'secondary-selection) - (make-face 'underline) - - (setq region-face (face-id 'region)) - - ;; Specify the global properties of these faces - ;; so they will come out right on new frames. - - (make-face-bold 'bold t) - (make-face-italic 'italic t) - (make-face-bold-italic 'bold-italic t) - - (set-face-background 'highlight '("darkseagreen2" "green" t) t) - (set-face-background 'region '("gray" underline) t) - (set-face-background 'secondary-selection '("paleturquoise" "green" t) t) - (set-face-background 'modeline '(t) t) - (set-face-underline-p 'underline t t) - - ;; Set up the faces of all existing X Window frames - ;; from those global properties, unless already set in a given frame. - - (let ((frames (frame-list))) - (while frames - (if (not (memq (framep (car frames)) '(t nil))) - (let ((frame (car frames)) - (rest global-face-data)) - (while rest - (let ((face (car (car rest)))) - (or (face-differs-from-default-p face) - (face-fill-in face (cdr (car rest)) frame))) - (setq rest (cdr rest))))) - (setq frames (cdr frames))))) +(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")) (terpri) + (terpri) + (princ "Documentation:") (terpri) + (let ((doc (face-documentation face))) + (if doc + (princ doc) + (princ "not documented as a face."))) + (print-help-return-message))) + +;;; Setting a face based on a SPEC. + +(defun face-attr-match-p (face attrs &optional frame) + (or frame (setq frame (selected-frame))) + (and (face-attr-match-1 face frame attrs ':inverse-video + 'face-inverse-video-p) + (if (face-inverse-video-p face frame) + (and + (face-attr-match-1 face frame attrs + ':foreground 'face-background + (cdr (assq 'foreground-color + (frame-parameters frame)))) + (face-attr-match-1 face frame attrs + ':background 'face-foreground + (cdr (assq 'background-color + (frame-parameters frame))))) + (and + (face-attr-match-1 face frame attrs ':foreground 'face-foreground) + (face-attr-match-1 face frame attrs ':background 'face-background))) + (face-attr-match-1 face frame attrs ':stipple 'face-stipple) + (face-attr-match-1 face frame attrs ':bold 'face-bold-p) + (face-attr-match-1 face frame attrs ':italic 'face-italic-p) + (face-attr-match-1 face frame attrs ':underline 'face-underline-p) +)) + +(defun face-attr-match-1 (face frame plist property function + &optional defaultval) + (while (and plist (not (eq (car plist) property))) + (setq plist (cdr (cdr plist)))) + (eq (funcall function face frame) + (if plist + (nth 1 plist) + (or defaultval + (funcall function 'default frame))))) + +(defun face-spec-match-p (face spec &optional frame) + "Return t if FACE, on FRAME, matches what SPEC says it should look like." + (face-attr-match-p face (face-spec-choose spec frame) frame)) + +(defun face-attr-construct (face &optional frame) + "Return a defface-style attribute list for FACE, as it exists on FRAME." + (let (result) + (if (face-inverse-video-p face frame) + (progn + (setq result (cons ':inverse-video (cons t result))) + (or (face-attr-match-1 face frame nil + ':foreground 'face-background + (cdr (assq 'foreground-color + (frame-parameters frame)))) + (setq result (cons ':foreground + (cons (face-foreground face frame) result)))) + (or (face-attr-match-1 face frame nil + ':background 'face-foreground + (cdr (assq 'background-color + (frame-parameters frame)))) + (setq result (cons ':background + (cons (face-background face frame) result))))) + (if (face-foreground face frame) + (setq result (cons ':foreground + (cons (face-foreground face frame) result)))) + (if (face-background face frame) + (setq result (cons ':background + (cons (face-background face frame) result))))) + (if (face-stipple face frame) + (setq result (cons ':stipple + (cons (face-stipple face frame) result)))) + (if (face-bold-p face frame) + (setq result (cons ':bold + (cons (face-bold-p face frame) result)))) + (if (face-italic-p face frame) + (setq result (cons ':italic + (cons (face-italic-p face frame) result)))) + (if (face-underline-p face frame) + (setq result (cons ':underline + (cons (face-underline-p face frame) result)))) + result)) + +;; Choose the proper attributes for FRAME, out of SPEC. +(defun face-spec-choose (spec &optional frame) + (or frame (setq frame (selected-frame))) + (let ((tail spec) + result) + (while tail + (let* ((entry (car tail)) + (display (nth 0 entry)) + (attrs (nth 1 entry))) + (setq tail (cdr tail)) + (when (face-spec-set-match-display display frame) + (setq result attrs tail nil)))) + result)) + +(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." + (if frame + (let ((attrs (face-spec-choose spec frame))) + (when attrs + ;; If the font was set automatically, clear it out + ;; to allow it to be set it again. + (unless (face-font-explicit face frame) + (set-face-font face nil frame)) + (modify-face face '(nil) '(nil) nil nil nil nil nil 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) + (face-spec-set-1 face frame attrs ':inverse-video + 'set-face-inverse-video-p))) + (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. @@ -941,99 +1346,163 @@ selected 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)) - (cdr (assq 'name initial-frame-alist)))) + (cdr (assq 'name default-frame-alist)))) (x-resource-name name) - (res-geometry (x-get-resource "geometry" "Geometry")) - parsed) + (res-geometry (if name (x-get-resource "geometry" "Geometry")))) (if res-geometry - (progn - (setq parsed (x-parse-geometry res-geometry)) + (let ((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)))) - ;; All geometry parms apply to the initial frame. - (setq parameters (append parameters 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)))))) - -;; Update a frame's faces when we change its default font. -(defun frame-update-faces (frame) - (let* ((faces global-face-data) - (rest faces)) + (setq parsed (append '((user-position . t) (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))))) + + (if default-enable-multibyte-characters + ;; If an ASCII font is specified in PARAMETERS, we try to create + ;; a fontset from it, and use it for the new frame. + (condition-case nil + (let ((font (cdr (assq 'font parameters)))) + (if (and font + (not (query-fontset font))) + (setq parameters + (cons (cons 'font (create-fontset-from-ascii-font font)) + parameters)))) + (error nil))) + + (let (frame) + (if (null global-face-data) + (progn + (setq frame (x-create-frame parameters)) + (frame-set-background-mode frame)) + (let* ((visibility-spec (assq 'visibility parameters)) + success faces rest) + (setq frame (x-create-frame (cons '(visibility . nil) parameters))) + (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 + 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" + "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)))))) + + (frame-set-background-mode frame) + + (face-set-after-frame-default frame) + + ;; 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))))) + frame)) + +;; Update a frame's faces after the frame font changes. +;; This is called from modify-frame-parameters +;; as well as from elsewhere in this file. +(defun face-set-after-frame-default (frame) + (let ((rest (frame-face-alist frame))) (while rest + ;; Set up each face, first from the defface information, + ;; then the global face data, and then the X resources. (let* ((face (car (car rest))) - (font (face-font face t))) - (if (listp font) - (let ((bold (memq 'bold font)) - (italic (memq 'italic font))) - ;; Ignore any previous (string-valued) font, it might not even - ;; be the right size anymore. - (set-face-font face nil frame) - (cond ((and bold italic) - (make-face-bold-italic face frame t)) - (bold - (make-face-bold face frame t)) - (italic - (make-face-italic face frame t))))) - (setq rest (cdr rest))) - frame))) + (spec (or (get face 'saved-face) + (get face 'face-defface-spec))) + (global (cdr (assq face global-face-data))) + (local (cdr (car rest)))) + (when spec + (face-spec-set face spec frame)) + (face-fill-in face global frame) + (make-face-x-resource-internal local frame)) + (setq rest (cdr rest))))) + +(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 + :set #'(lambda (var value) + (set var value) + (mapcar 'frame-set-background-mode (frame-list))) + :initialize 'custom-initialize-changed + :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." + (unless (eq (framep frame) t) + (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) nil) ;; Update the colors of FACE, after FRAME's own colors have been changed. ;; This applies only to faces with global color specifications ;; that are not simple constants. (defun frame-update-face-colors (frame) + (frame-set-background-mode frame) (let ((faces global-face-data)) (while faces (condition-case nil @@ -1072,7 +1541,8 @@ selected frame." (background (face-background data)) (font (face-font data)) (stipple (face-stipple data))) - (set-face-underline-p face (face-underline-p data) frame) + (if (face-underline-p data) + (set-face-underline-p face (face-underline-p data) frame)) (if foreground (face-try-color-list 'set-face-foreground face foreground frame)) @@ -1097,21 +1567,16 @@ selected frame." ;; 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. @@ -1125,10 +1590,10 @@ selected frame." (eq function 'set-face-background)) (funcall function face colors frame)) (if (eq colors t) - (invert-face face frame) + (set-face-inverse-video-p face t frame) (let (done) (while (and colors (not done)) - (if (or (memq (car colors) '(t underline)) + (if (or (memq (car colors) '(t underline nil)) (face-color-supported-p frame (car colors) (eq function 'set-face-background))) (if (cdr colors) @@ -1137,7 +1602,7 @@ selected frame." (condition-case nil (progn (cond ((eq (car colors) t) - (invert-face face frame)) + (set-face-inverse-video-p face t frame)) ((eq (car colors) 'underline) (set-face-underline-p face t frame)) (t @@ -1147,16 +1612,71 @@ selected frame." ;; If this is the last color, let the error get out if it fails. ;; If it succeeds, we will exit anyway after this iteration. (cond ((eq (car colors) t) - (invert-face face frame)) + (set-face-inverse-video-p face t frame)) ((eq (car colors) 'underline) (set-face-underline-p face t frame)) (t (funcall function face (car colors) frame))))) (setq colors (cdr colors))))))) -;; If we are already using x-window frames, initialize faces for them. -(if (eq (framep (selected-frame)) 'x) - (face-initialize)) +;;; Make the standard faces. +;;; The C code knows the default and modeline faces as faces 0 and 1, +;;; so they must be the first two faces made. +(make-face 'default) +(make-face 'modeline) +(make-face 'highlight) + +;; These aren't really special in any way, but they're nice to have around. + +(make-face 'bold) +(make-face 'italic) +(make-face 'bold-italic) +(make-face 'region) +(make-face 'secondary-selection) +(make-face 'underline) + +(setq region-face (face-id 'region)) + +(defgroup basic-faces nil + "The standard faces of Emacs." + :prefix "huh" + :group 'faces) + +;; Specify how these faces look, and their documentation. +(let ((all '((bold "Use bold font." ((t (:bold t)))) + (bold-italic "Use bold italic font." ((t (:bold t :italic t)))) + (italic "Use italic font." ((t (:italic t)))) + (underline "Underline text." ((t (:underline t)))) + (default "Used for text not covered by other faces." ((t nil))) + (highlight "Highlight text in some way." + ((((class color) (background light)) + (:background "darkseagreen2")) + (((class color) (background dark)) + (:background "darkolivegreen")) + (t (:inverse-video t)))) + (modeline "Used for displaying the modeline." + ((t (:inverse-video t)))) + (region "Used for displaying the region." + ((((class color) (background dark)) + (:background "blue")) + (t (:background "gray")))) + (secondary-selection + "Used for displaying the secondary selection." + ((((class color) (background light)) + (:background "paleturquoise")) + (((class color) (background dark)) + (:background "darkslateblue")) + (t (:inverse-video t)))))) + entry symbol doc spec) + (while all + (setq entry (car all) + all (cdr all) + symbol (nth 0 entry) + doc (nth 1 entry) + spec (nth 2 entry)) + (custom-add-to-group 'basic-faces symbol 'custom-face) + (put symbol 'face-documentation doc) + (put symbol 'face-defface-spec spec))) (provide 'faces)