;;;; Functions for manipulating face vectors.
;;; A face vector is a vector of the form:
-;;; [face NAME ID FONT FOREGROUND BACKGROUND STIPPLE UNDERLINE INVERSE]
+;;; [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) 10) (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."
If FRAME is omitted or nil, use the selected frame."
(aref (internal-get-face face frame) 3))
-(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-foreground (face &optional frame)
"Return the foreground color name of face FACE, or nil if unspecified.
If the optional argument FRAME is given, report on face FACE in that frame.
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).
- The font default for a face is either nil, or a list
- of the form (bold), (italic) or (bold italic).
If FRAME is omitted or nil, use the selected frame."
- (let ((font (face-font face frame)))
- (if (stringp font)
- (not (equal font (x-make-font-unbold font)))
- (memq 'bold font))))
+ (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).
- The font default for a face is either nil, or a list
- of the form (bold), (italic) or (bold italic).
If FRAME is omitted or nil, use the selected frame."
- (let ((font (face-font face frame)))
- (if (stringp font)
- (not (equal font (x-make-font-unitalic font)))
- (memq 'italic font))))
+ (aref (internal-get-face face frame) 11))
(defalias 'face-doc-string 'face-documentation)
(defun face-documentation (face)
(if (stringp font)
(setq font (or (and (fontset-name-p font)
(or (query-fontset font)
- (instanciate-fontset font)))
+ (instantiate-fontset font)))
(x-resolve-font-name font 'default frame))))
(internal-set-face-1 face 'font font 3 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"
"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)) color
(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))
(t value))))
(defun modify-face (face foreground background stipple
- bold-p italic-p underline-p &optional frame)
+ bold-p italic-p underline-p &optional inverse-p frame)
"Change the display attributes for face FACE.
If the optional FRAME argument is provided, change only
in that frame; otherwise change each frame.
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. If neither nil or t, means do not
-change the display attribute corresponding to that arg.
+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
(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
(and background (concat (downcase background) " background"))
(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
+ 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
(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)))
(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 internal-face-interactive-stipple (what)
If the face already exists, it is unmodified."
(interactive "SMake face: ")
(or (internal-find-face name)
- (let ((face (make-vector 10 nil)))
+ (let ((face (make-vector 12 nil)))
(aset face 0 'face)
(aset face 1 name)
(let* ((frames (frame-list))
"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))
"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))
"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 (font)
"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)
"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)
\f
;;; Setting a face based on a SPEC.
-(defun face-spec-set (face spec &optional frame)
- "Set FACE's face attributes according to the first matching entry in SPEC.
-If optional FRAME is non-nil, set it for that frame only.
-If it is nil, then apply SPEC to each frame individually.
-See `defface' for information about SPEC."
- (let ((tail spec))
- (while tail
+(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))
- ;; 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 frame)
(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 ':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)
- (setq tail nil)))))
- (if (null frame)
- (let ((frames (frame-list))
- frame)
- (while frames
- (setq frame (car frames)
- frames (cdr frames))
- (face-spec-set face (or (get face 'saved-face)
- (get face 'face-defface-spec))
- frame)
- (face-spec-set face spec frame)))))
+ '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)))
(vector 'face
(face-name (cdr elt))
(face-id (cdr elt))
- nil nil nil nil nil nil nil)))
+ nil
+ nil nil nil nil
+ nil nil nil nil)))
global-face-data))
(set-frame-face-alist frame faces)
(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))))
(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 "darkseagreen2"))
+ ((((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."
- ((t (:background "gray"))))
+ ((((class color) (background dark))
+ (:background "blue"))
+ (t (:background "gray"))))
(secondary-selection
"Used for displaying the secondary selection."
- ((((class color)) (:background "paleturquoise"))
+ ((((class color) (background light))
+ (:background "paleturquoise"))
+ (((class color) (background dark))
+ (:background "darkslateblue"))
(t (:inverse-video t))))))
entry symbol doc spec)
(while 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)))
HCoop / bpt / emacs.git / blobdiff