;;; 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.
(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))
\f
;;;; Functions for manipulating face vectors.
(defsubst internal-facep (x)
(and (vectorp x) (= (length x) 8) (eq (aref x 0) 'face)))
+(defun facep (x)
+ "Return t if X is a face name or an internal face vector."
+ (and (or (internal-facep x)
+ (and (symbolp x) (assq x global-face-data)))
+ t))
+
(defmacro internal-check-face (face)
- (` (while (not (internal-facep (, face)))
- (setq (, face) (signal 'wrong-type-argument (list 'internal-facep (, face)))))))
+ (` (or (internal-facep (, face))
+ (signal 'wrong-type-argument (list 'internal-facep (, face))))))
;;; Accessors.
(defun face-name (face)
(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)))
+ (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 name &optional frame)
"Change the stipple pixmap of face FACE to PIXMAP.
(interactive (internal-face-interactive "underline-p" "underlined"))
(internal-set-face-1 face 'underline underline-p 7 frame))
\f
-(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)
"Change the display attributes for face FACE.
-FOREGROUND and BACKGROUND should be color strings. (Default color if nil.)
+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."
(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 "))))
(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)))
+ (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)
A face is considered to be ``the same'' as the default face if it is
actually specified in the same way (equivalent fonts, etc) or if it is
fully unspecified, and thus inherits the attributes of any face it
-is displayed on top of."
+is displayed on top of.
+
+The optional argument FRAME specifies which frame to test;
+if FRAME is t, test the default for new frames.
+If FRAME is nil or omitted, test the selected frame."
(let ((default (internal-get-face 'default frame)))
(setq face (internal-get-face face frame))
(not (and (or (equal (face-foreground default frame)
(face-underline-p face frame))
))))
+(defun face-nontrivial-p (face &optional frame)
+ "True if face FACE has some non-nil attribute.
+The optional argument FRAME specifies which frame to test;
+if FRAME is t, test the default for new frames.
+If FRAME is nil or omitted, test the selected frame."
+ (setq face (internal-get-face face frame))
+ (or (face-foreground face frame)
+ (face-background face frame)
+ (face-font face frame)
+ (face-stipple face frame)
+ (face-underline-p face frame)))
+
(defun invert-face (face &optional frame)
"Swap the foreground and background colors of face FACE.
(let ((fonts (x-list-fonts pattern face frame)))
(or fonts
(if face
- (error "No fonts matching pattern are the same size as `%s'"
- (if (null (face-font face))
- (cdr (assq 'font (frame-parameters frame)))
- face))
+ (if (string-match "\\*" pattern)
+ (if (null (face-font face))
+ (error "No matching fonts are the same height as the frame default font")
+ (error "No matching fonts are the same height as face `%s'" face))
+ (if (null (face-font face))
+ (error "Height of font `%s' doesn't match the frame default font"
+ pattern)
+ (error "Height of font `%s' doesn't match face `%s'"
+ pattern face)))
(error "No fonts match `%s'" pattern)))
(car fonts))
(cdr (assq 'font (frame-parameters (selected-frame))))))
;; Like x-create-frame but also set up the faces.
(defun x-create-frame-with-faces (&optional parameters)
+ ;; 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)))))
(if (null global-face-data)
(x-create-frame parameters)
(let* ((visibility-spec (assq 'visibility parameters))
(if resource
(cons nil (member (downcase resource)
'("on" "true")))))))
- (let ((params (frame-parameters frame)))
- (modify-frame-parameters
- frame
- (list (cons 'foreground-color (cdr (assq 'background-color params)))
- (cons 'background-color (cdr (assq 'foreground-color params)))
- (cons 'mouse-color (cdr (assq 'background-color params)))
- (cons 'border-color (cdr (assq 'background-color params)))))
- (modify-frame-parameters
- frame
- (list (cons 'cursor-color (cdr (assq 'background-color params)))))))
-
+ (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
(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
(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,
HCoop / bpt / emacs.git / blobdiff