;;; Code:
(eval-when-compile
- (require 'cl))
+ (require 'cl)
+ ;; Warning suppression -- can't require x-win in batch:
+ (autoload 'xw-defined-colors "x-win"))
(require 'cus-face)
(set-default symbol value)
(internal-set-font-selection-order value)))
-;; This is defined originally in {w32,x}faces.c.
+
+;; This is defined originally in xfaces.c.
(defcustom face-font-family-alternatives
'(("courier" "fixed")
("helv" "helvetica" "arial" "fixed"))
(internal-set-alternative-font-family-alist value)))
+;; This is defined originally in xfaces.c.
+(defcustom face-font-registry-alternatives
+ '(("muletibetan-2" "muletibetan-0"))
+ "*Alist of alternative font registry names.
+Each element has the the form (REGISTRY ALTERNATIVE1 ALTERNATIVE2 ...).
+If fonts of registry REGISTRY can't be loaded, try ALTERNATIVE1, then
+ALTERNATIVE2 etc."
+ :tag "Alternative font registries to try."
+ :type '(repeat (repeat string))
+ :version "21.1"
+ :group 'font-selection
+ :set #'(lambda (symbol value)
+ (set-default symbol value)
+ (internal-set-alternative-font-registry-alist value)))
+
+
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Creation, copying.
the name of a face attribute, and each ENTRY is a cons of the form
(RESOURCE . CLASS) with RESOURCE being the resource and CLASS being the
X resource class for the attribute."
- :type 'sexp
+ :type '(repeat (cons symbol (repeat (cons string string))))
:group 'faces)
(defun set-face-attributes-from-resources (face frame)
"Set attributes of FACE from X resources for FRAME."
- (when (memq (framep frame) '(x w32))
+ (when (memq (framep frame) '(x w32 mac))
(dolist (definition face-x-resources)
(let ((attribute (car definition)))
(dolist (entry (cdr definition))
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."
- (internal-get-lisp-face-attribute face :foreground frame))
+ (let ((value (internal-get-lisp-face-attribute face :foreground frame)))
+ (if (eq value 'unspecified)
+ nil
+ value)))
(defun face-background (face &optional frame)
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."
- (internal-get-lisp-face-attribute face :background frame))
+ (let ((value (internal-get-lisp-face-attribute face :background frame)))
+ (if (eq value 'unspecified)
+ nil
+ value)))
(defun face-stipple (face &optional frame)
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."
- (internal-get-lisp-face-attribute face :stipple frame))
+ (let ((value (internal-get-lisp-face-attribute face :stipple frame)))
+ (if (eq value 'unspecified)
+ nil
+ value)))
(defalias 'face-background-pixmap 'face-stipple)
(memq italic '(italic oblique))))
-
-
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Face documentation.
((:height)
'integerp)
(:stipple
- (and (memq window-system '(x w32))
+ (and (memq window-system '(x w32 mac))
(mapcar #'list
- (apply #'nconc (mapcar #'directory-files
- x-bitmap-file-path)))))
+ (apply #'nconc
+ (mapcar (lambda (dir)
+ (and (file-readable-p dir)
+ (file-directory-p dir)
+ (directory-files dir)))
+ x-bitmap-file-path)))))
(:inherit
(cons '("none" . nil)
(mapcar #'(lambda (c) (cons (symbol-name c) c))
options (cdr conjunct)
match (cond ((eq req 'type)
(or (memq window-system options)
+ ;; FIXME: This should be revisited to use
+ ;; display-graphic-p, provided that the
+ ;; color selection depends on the number
+ ;; of supported colors, and all defface's
+ ;; are changed to look at number of colors
+ ;; instead of (type graphic) etc.
(and (null window-system)
(memq 'tty options))
(and (memq 'motif options)
(defun face-spec-choose (spec &optional frame)
- "Choose the proper attributes for FRAME, out of SPEC."
+ "Choose the proper attributes for FRAME, out of SPEC.
+If SPEC is nil, return nil."
(unless 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))
+ (let* ((entry (pop tail))
+ (display (car entry))
+ (attrs (cdr entry)))
(when (face-spec-set-match-display display frame)
- (setq result attrs tail nil))))
+ (setq result (if (listp (car attrs))
+ ;; Old-style entry, the attribute list is the
+ ;; first element.
+ (car attrs)
+ attrs)
+ tail nil))))
result))
(defun face-spec-set (face spec &optional frame)
"Set FACE's attributes according to the first matching entry in SPEC.
FRAME is the frame whose frame-local face is set. FRAME nil means
-do it on all frames. See `defface' for information about SPEC."
+do it on all frames. See `defface' for information about SPEC.
+If SPEC is nil, do nothing."
(let ((attrs (face-spec-choose spec frame)))
- (face-spec-reset-face face frame)
+ (when attrs
+ (face-spec-reset-face face frame))
(while attrs
(let ((attribute (car attrs))
(value (car (cdr attrs))))
"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))
+(defsubst face-default-spec (face)
+ "Return the default face-spec for FACE, ignoring any user customization.
+If there is no default for FACE, return nil."
+ (get face 'face-defface-spec))
+
+(defsubst face-user-default-spec (face)
+ "Return the user's customized face-spec for FACE, or the default if none.
+If there is neither a user setting or a default for FACE, return nil."
+ (or (get face 'saved-face)
+ (face-default-spec face)))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
The argument FRAME specifies which frame to try.
The value may be different for frames on different display types.
If FRAME doesn't support colors, the value is nil."
- (if (memq (framep (or frame (selected-frame))) '(x w32))
+ (if (memq (framep (or frame (selected-frame))) '(x w32 mac))
(xw-defined-colors frame)
(mapcar 'car (tty-color-alist frame))))
(defalias 'x-defined-colors 'defined-colors)
If FRAME is omitted or nil, use the selected frame.
If COLOR is the symbol `unspecified' or one of the strings
\"unspecified-fg\" or \"unspecified-bg\", the value is nil."
- (if (memq color '(unspecified "unspecified-bg" "unspecified-fg"))
+ (if (member color '(unspecified "unspecified-bg" "unspecified-fg"))
nil
- (if (memq (framep (or frame (selected-frame))) '(x w32))
+ (if (member (framep (or frame (selected-frame))) '(x w32 mac))
(xw-color-defined-p color frame)
(numberp (tty-color-translate color frame)))))
(defalias 'x-color-defined-p 'color-defined-p)
(defun color-values (color &optional frame)
"Return a description of the color named COLOR on frame FRAME.
The value is a list of integer RGB values--\(RED GREEN BLUE\).
-These values appear to range from 0 to 65280 or 65535, depending
-on the system; white is \(65280 65280 65280\) or \(65535 65535 65535\).
+These values appear to range from 0 65535; white is \(65535 65535 65535\).
If FRAME is omitted or nil, use the selected frame.
If FRAME cannot display COLOR, the value is nil.
If COLOR is the symbol `unspecified' or one of the strings
\"unspecified-fg\" or \"unspecified-bg\", the value is nil."
- (if (memq color '(unspecified "unspecified-fg" "unspecified-bg"))
+ (if (member color '(unspecified "unspecified-fg" "unspecified-bg"))
nil
- (if (memq (framep (or frame (selected-frame))) '(x w32))
+ (if (memq (framep (or frame (selected-frame))) '(x w32 mac))
(xw-color-values color frame)
(tty-color-values color frame))))
(defalias 'x-color-values 'color-values)
The optional argument DISPLAY specifies which display to ask about.
DISPLAY should be either a frame or a display name (a string).
If omitted or nil, that stands for the selected frame's display."
- (if (memq (framep-on-display display) '(x w32))
+ (if (memq (framep-on-display display) '(x w32 mac))
(xw-display-color-p display)
(tty-display-color-p display)))
(defalias 'x-display-color-p 'display-color-p)
:group 'faces
:set #'(lambda (var value)
(set-default var value)
- (mapcar 'frame-set-background-mode (frame-list)))
+ (mapc 'frame-set-background-mode (frame-list)))
:initialize 'custom-initialize-changed
:type '(choice (choice-item dark)
(choice-item light)
(defun frame-set-background-mode (frame)
- "Set up the `background-mode' and `display-type' frame parameters for FRAME."
+ "Set up display-dependent faces on FRAME.
+Display-dependent faces are those which have different definitions
+according to the `background-mode' and `display-type' frame parameters."
(let* ((bg-resource
(and window-system
(x-get-resource ".backgroundMode" "BackgroundMode")))
- (params (frame-parameters frame))
- (bg-mode (cond (frame-background-mode)
- ((null window-system)
- ;; No way to determine this automatically (?).
- 'dark)
- (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)))
- (display-type (cond ((null window-system)
- (if (tty-display-color-p frame) 'color 'mono))
- ((x-display-color-p frame)
- 'color)
- ((x-display-grayscale-p frame)
- 'grayscale)
- (t 'mono))))
- (modify-frame-parameters frame
- (list (cons 'background-mode bg-mode)
- (cons 'display-type display-type))))
-
- ;; For all named faces, choose face specs matching the new frame
- ;; parameters.
- (let ((face-list (face-list)))
- (while face-list
- (let* ((face (car face-list))
- (spec (get face 'face-defface-spec)))
- (when spec
- (face-spec-set face spec frame))
- (setq face-list (cdr face-list))))))
-
-
+ (bg-color (frame-parameter frame 'background-color))
+ (bg-mode
+ (cond (frame-background-mode)
+ (bg-resource
+ (intern (downcase bg-resource)))
+ ((and (null window-system) (null bg-color))
+ ;; No way to determine this automatically (?).
+ 'dark)
+ ;; Unspecified frame background color can only happen
+ ;; on tty's.
+ ((member bg-color '(unspecified "unspecified-bg"))
+ 'dark)
+ ((equal bg-color "unspecified-fg") ; inverted colors
+ 'light)
+ ((>= (apply '+ (x-color-values bg-color 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))
+ 'light)
+ (t 'dark)))
+ (display-type
+ (cond ((null window-system)
+ (if (tty-display-color-p frame) 'color 'mono))
+ ((x-display-color-p frame)
+ 'color)
+ ((x-display-grayscale-p frame)
+ 'grayscale)
+ (t 'mono)))
+ (old-bg-mode
+ (frame-parameter frame 'background-mode))
+ (old-display-type
+ (frame-parameter frame 'display-type)))
+
+ (unless (and (eq bg-mode old-bg-mode) (eq display-type old-display-type))
+ (modify-frame-parameters frame
+ (list (cons 'background-mode bg-mode)
+ (cons 'display-type display-type)))
+ ;; For all named faces, choose face specs matching the new frame
+ ;; parameters.
+ (dolist (face (face-list))
+ (face-spec-set face (face-user-default-spec face) frame)))))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"Set frame-local faces of FRAME from face specs and resources.
Initialize colors of certain faces from frame parameters."
(dolist (face (face-list))
- (let ((spec (or (get face 'saved-face)
- (get face 'face-defface-spec))))
- (when spec
- (face-spec-set face spec frame))
- (internal-merge-in-global-face face frame)
- (when (memq window-system '(x w32))
- (make-face-x-resource-internal face frame))))
+ (face-spec-set face (face-user-default-spec face) frame)
+ (internal-merge-in-global-face face frame)
+ (when (and (memq window-system '(x w32 mac))
+ (or (not (boundp 'inhibit-default-face-x-resources))
+ (not (eq face 'default))))
+ (make-face-x-resource-internal face frame)))
;; Initialize attributes from frame parameters.
(let ((params '((foreground-color default :foreground)
(scroll-bar-foreground scroll-bar :foreground)
(scroll-bar-background scroll-bar :background)
(mouse-color mouse :background))))
- (while params
- (let ((param-name (nth 0 (car params)))
- (face (nth 1 (car params)))
- (attr (nth 2 (car params)))
- value)
- (when (setq value (frame-parameter frame param-name))
- (set-face-attribute face frame attr value)))
- (setq params (cdr params)))))
+ (dolist (param params)
+ (let ((frame-param (frame-parameter frame (nth 0 param)))
+ (face (nth 1 param))
+ (attr (nth 2 param)))
+ (when (and frame-param
+ ;; Don't override face attributes explicitly
+ ;; specified for new frames.
+ (eq (face-attribute face attr t) 'unspecified))
+ (set-face-attribute face frame attr frame-param))))))
+
+
+(defun tty-handle-reverse-video (frame parameters)
+ "Handle the reverse-video frame parameter for terminal frames."
+ (when (cdr (or (assq 'reverse parameters)
+ (assq 'reverse default-frame-alist)))
+ (if (null window-system)
+ (setq inverse-video t))
+ (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 '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)))))))
(defun tty-create-frame-with-faces (&optional parameters)
success)
(unwind-protect
(progn
+ (tty-handle-reverse-video frame (frame-parameters frame))
(frame-set-background-mode frame)
(face-set-after-frame-default frame)
(setq success t))
(defface mode-line
- '((((type x) (class color))
- (:box (:line-width 2 :style released-button)
- :background "grey75" :foreground "black"))
- (((type w32) (class color))
+ '((((type x w32 mac) (class color))
(:box (:line-width 2 :style released-button)
:background "grey75" :foreground "black"))
(t
(put 'modeline 'face-alias 'mode-line)
(defface header-line
- '((((type x) (class color))
- (:box (:line-width 2 :style released-button)
- :background "grey75" :foreground "black"))
- (((type w32) (class color))
- (:box (:line-width 2 :style released-button)
- :background "grey75" :foreground "black"))
+ '((((type tty))
+ ;; This used to be `:inverse-video t', but that doesn't look very
+ ;; good when combined with inverse-video mode-lines and multiple
+ ;; windows. Underlining looks better, and is more consistent with
+ ;; the window-system face variants, which deemphasize the
+ ;; header-line in relation to the mode-line face. If a terminal
+ ;; can't underline, then the header-line will end up without any
+ ;; highlighting; this may be too confusing in general, although it
+ ;; happens to look good with the only current use of header-lines,
+ ;; the info browser. XXX
+ :underline t)
+ (((class color grayscale) (background light))
+ :inherit mode-line
+ :background "grey90" :foreground "grey20"
+ :box nil)
+ (((class color grayscale) (background dark))
+ :inherit mode-line
+ :background "grey20" :foreground "grey90"
+ :box nil)
+ (((class mono) (background light))
+ :inherit mode-line
+ :background "white" :foreground "black"
+ :inverse-video nil
+ :box nil
+ :underline t)
+ (((class mono) (background dark))
+ :inherit mode-line
+ :background "black" :foreground "white"
+ :inverse-video nil
+ :box nil
+ :underline t)
(t
- (:inverse-video t)))
+ :inverse-video t))
"Basic header-line face."
:version "21.1"
:group 'basic-faces)
(defface tool-bar
- '((((type x) (class color))
+ '((((type x w32 mac) (class color))
(:box (:line-width 1 :style released-button)
:background "grey75" :foreground "black"))
(((type x) (class mono))
(:box (:line-width 1 :style released-button)
:background "grey" :foreground "black"))
- (((type w32) (class color))
- (:box (:line-width 1 :style released-button)
- :background "grey75" :foreground "black"))
(t
()))
"Basic tool-bar face."
(((type tty) (class mono))
(:inverse-video t))
(((class color) (background dark))
- (:background "blue"))
+ (:background "blue3"))
(((class color) (background light))
(:background "light goldenrod yellow"))
(t (:background "gray")))
"Basic face for highlighting the region."
+ :version "21.1"
:group 'basic-faces)
(defface menu
- '((((type x-toolkit)) ())
- (t (:inverse-video t)))
+ '((((type tty))
+ :inverse-video t)
+ (((type x-toolkit))
+ )
+ (t
+ :inverse-video t))
"Basic menu face."
:version "21.1"
:group 'menu
(defface secondary-selection
'((((type tty) (class color))
- (:background "cyan"))
+ (:background "cyan" :foreground "black"))
(((class color) (background light))
(:background "yellow"))
(((class color) (background dark))
- (:background "yellow"))
+ (:background "SkyBlue4"))
(t (:inverse-video t)))
"Basic face for displaying the secondary selection."
:group 'basic-faces)