LCOV - code coverage report
Current view: top level - lisp - faces.el (source / functions) Hit Total Coverage
Test: tramp-tests.info Lines: 168 876 19.2 %
Date: 2017-08-27 09:44:50 Functions: 19 109 17.4 %

          Line data    Source code
       1             : ;;; faces.el --- Lisp faces -*- lexical-binding: t -*-
       2             : 
       3             : ;; Copyright (C) 1992-1996, 1998-2017 Free Software Foundation, Inc.
       4             : 
       5             : ;; Maintainer: emacs-devel@gnu.org
       6             : ;; Keywords: internal
       7             : ;; Package: emacs
       8             : 
       9             : ;; This file is part of GNU Emacs.
      10             : 
      11             : ;; GNU Emacs is free software: you can redistribute it and/or modify
      12             : ;; it under the terms of the GNU General Public License as published by
      13             : ;; the Free Software Foundation, either version 3 of the License, or
      14             : ;; (at your option) any later version.
      15             : 
      16             : ;; GNU Emacs is distributed in the hope that it will be useful,
      17             : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
      18             : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
      19             : ;; GNU General Public License for more details.
      20             : 
      21             : ;; You should have received a copy of the GNU General Public License
      22             : ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
      23             : 
      24             : ;;; Commentary:
      25             : 
      26             : ;;; Code:
      27             : 
      28             : (defcustom term-file-prefix (purecopy "term/")
      29             :   "If non-nil, Emacs startup performs terminal-specific initialization.
      30             : It does this by: (load (concat term-file-prefix (getenv \"TERM\")))
      31             : 
      32             : You may set this variable to nil in your init file if you do not wish
      33             : the terminal-initialization file to be loaded."
      34             :   :type '(choice (const :tag "No terminal-specific initialization" nil)
      35             :                  (string :tag "Name of directory with term files"))
      36             :   :group 'terminals)
      37             : 
      38             : (defcustom term-file-aliases
      39             :   '(("apollo" . "vt100")
      40             :     ("vt102" . "vt100")
      41             :     ("vt125" . "vt100")
      42             :     ("vt201" . "vt200")
      43             :     ("vt220" . "vt200")
      44             :     ("vt240" . "vt200")
      45             :     ("vt300" . "vt200")
      46             :     ("vt320" . "vt200")
      47             :     ("vt400" . "vt200")
      48             :     ("vt420" . "vt200")
      49             :     )
      50             :   "Alist of terminal type aliases.
      51             : Entries are of the form (TYPE . ALIAS), where both elements are strings.
      52             : This means to treat a terminal of type TYPE as if it were of type ALIAS."
      53             :   :type '(alist :key-type (string :tag "Terminal")
      54             :                 :value-type (string :tag "Alias"))
      55             :   :group 'terminals
      56             :   :version "25.1")
      57             : 
      58             : (declare-function xw-defined-colors "term/common-win" (&optional frame))
      59             : 
      60             : (defvar help-xref-stack-item)
      61             : 
      62             : (defvar face-name-history nil
      63             :   "History list for some commands that read face names.
      64             : Maximum length of the history list is determined by the value
      65             : of `history-length', which see.")
      66             : 
      67             : 
      68             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      69             : ;;; Font selection.
      70             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      71             : 
      72             : (defgroup font-selection nil
      73             :   "Influencing face font selection."
      74             :   :group 'faces)
      75             : 
      76             : 
      77             : (defcustom face-font-selection-order
      78             :   '(:width :height :weight :slant)
      79             :   "A list specifying how face font selection chooses fonts.
      80             : Each of the four symbols `:width', `:height', `:weight', and `:slant'
      81             : must appear once in the list, and the list must not contain any other
      82             : elements.  Font selection first tries to find a best matching font
      83             : for those face attributes that appear before in the list.  For
      84             : example, if `:slant' appears before `:height', font selection first
      85             : tries to find a font with a suitable slant, even if this results in
      86             : a font height that isn't optimal."
      87             :   :tag "Font selection order"
      88             :   :type '(list symbol symbol symbol symbol)
      89             :   :group 'font-selection
      90             :   :set #'(lambda (symbol value)
      91             :            (set-default symbol value)
      92             :            (internal-set-font-selection-order value)))
      93             : 
      94             : 
      95             : ;; In the absence of Fontconfig support, Monospace and Sans Serif are
      96             : ;; unavailable, and we fall back on the courier and helv families,
      97             : ;; which are generally available.
      98             : (defcustom face-font-family-alternatives
      99             :   (mapcar (lambda (arg) (mapcar 'purecopy arg))
     100             :   '(("Monospace" "courier" "fixed")
     101             : 
     102             :     ;; Monospace Serif is an Emacs invention, intended to work around
     103             :     ;; portability problems when using Courier.  It should work well
     104             :     ;; when combined with Monospaced and with other standard fonts.
     105             :     ;; One of its uses is for 'tex-verbatim' and 'Info-quoted' faces,
     106             :     ;; so the result must be different from the default face's font,
     107             :     ;; and must be monospaced.  For 'tex-verbatim', it is desirable
     108             :     ;; that the font really is a Serif font, so as to look like
     109             :     ;; TeX's 'verbatim'.
     110             :     ("Monospace Serif"
     111             : 
     112             :      ;; This looks good on GNU/Linux.
     113             :      "Courier 10 Pitch"
     114             :      ;; This looks good on MS-Windows and OS X.  Note that this is
     115             :      ;; actually a sans-serif font, but it's here for lack of a better
     116             :      ;; alternative.
     117             :      "Consolas"
     118             :      ;; This looks good on macOS.  "Courier" looks good too, but is
     119             :      ;; jagged on GNU/Linux and so is listed later as "courier".
     120             :      "Courier Std"
     121             :      ;; Although these are anti-aliased, they are a bit faint compared
     122             :      ;; to the above.
     123             :      "FreeMono" "Nimbus Mono L"
     124             :      ;; These are aliased and look jagged.
     125             :      "courier" "fixed"
     126             :      ;; Omit Courier New, as it is the default MS-Windows font and so
     127             :      ;; would look no different, and is pretty faint on other platforms.
     128             :      )
     129             : 
     130             :     ;; This is present for backward compatibility.
     131             :     ("courier" "CMU Typewriter Text" "fixed")
     132             : 
     133             :     ("Sans Serif" "helv" "helvetica" "arial" "fixed")
     134             :     ("helv" "helvetica" "arial" "fixed")))
     135             :   "Alist of alternative font family names.
     136             : Each element has the form (FAMILY ALTERNATIVE1 ALTERNATIVE2 ...).
     137             : If fonts of family FAMILY can't be loaded, try ALTERNATIVE1, then
     138             : ALTERNATIVE2 etc."
     139             :   :tag "Alternative font families to try"
     140             :   :type '(repeat (repeat string))
     141             :   :group 'font-selection
     142             :   :set #'(lambda (symbol value)
     143             :            (set-default symbol value)
     144             :            (internal-set-alternative-font-family-alist value)))
     145             : 
     146             : 
     147             : ;; This is defined originally in xfaces.c.
     148             : (defcustom face-font-registry-alternatives
     149             :   (mapcar (lambda (arg) (mapcar 'purecopy arg))
     150             :   (if (featurep 'w32)
     151             :       '(("iso8859-1" "ms-oemlatin")
     152             :         ("gb2312.1980" "gb2312" "gbk" "gb18030")
     153             :         ("jisx0208.1990" "jisx0208.1983" "jisx0208.1978")
     154             :         ("ksc5601.1989" "ksx1001.1992" "ksc5601.1987")
     155             :         ("muletibetan-2" "muletibetan-0"))
     156             :     '(("gb2312.1980" "gb2312.80&gb8565.88" "gbk" "gb18030")
     157             :       ("jisx0208.1990" "jisx0208.1983" "jisx0208.1978")
     158             :       ("ksc5601.1989" "ksx1001.1992" "ksc5601.1987")
     159             :       ("muletibetan-2" "muletibetan-0"))))
     160             :   "Alist of alternative font registry names.
     161             : Each element has the form (REGISTRY ALTERNATIVE1 ALTERNATIVE2 ...).
     162             : If fonts of registry REGISTRY can be loaded, font selection
     163             : tries to find a best matching font among all fonts of registry
     164             : REGISTRY, ALTERNATIVE1, ALTERNATIVE2, and etc."
     165             :   :tag "Alternative font registries to try"
     166             :   :type '(repeat (repeat string))
     167             :   :version "21.1"
     168             :   :group 'font-selection
     169             :   :set #'(lambda (symbol value)
     170             :            (set-default symbol value)
     171             :            (internal-set-alternative-font-registry-alist value)))
     172             : 
     173             : 
     174             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     175             : ;;; Creation, copying.
     176             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     177             : 
     178             : 
     179             : (defun face-list ()
     180             :   "Return a list of all defined faces."
     181           3 :   (mapcar #'car face-new-frame-defaults))
     182             : 
     183             : (defun make-face (face)
     184             :   "Define a new face with name FACE, a symbol.
     185             : Do not call this directly from Lisp code; use `defface' instead.
     186             : 
     187             : If FACE is already known as a face, leave it unmodified.  Return FACE."
     188           0 :   (interactive (list (read-from-minibuffer
     189           0 :                       "Make face: " nil nil t 'face-name-history)))
     190           2 :   (unless (facep face)
     191             :     ;; Make frame-local faces (this also makes the global one).
     192           2 :     (dolist (frame (frame-list))
     193           2 :       (internal-make-lisp-face face frame))
     194             :     ;; Add the face to the face menu.
     195           2 :     (when (fboundp 'facemenu-add-new-face)
     196           2 :       (facemenu-add-new-face face))
     197             :     ;; Define frame-local faces for all frames from X resources.
     198           2 :     (make-face-x-resource-internal face))
     199           2 :   face)
     200             : 
     201             : (defun make-empty-face (face)
     202             :   "Define a new, empty face with name FACE.
     203             : Do not call this directly from Lisp code; use `defface' instead."
     204           0 :   (interactive (list (read-from-minibuffer
     205           0 :                       "Make empty face: " nil nil t 'face-name-history)))
     206           2 :   (make-face face))
     207             : 
     208             : (defun copy-face (old-face new-face &optional frame new-frame)
     209             :   "Define a face named NEW-FACE, which is a copy of OLD-FACE.
     210             : This function does not copy face customization data, so NEW-FACE
     211             : will not be made customizable.  Most Lisp code should not call
     212             : this function; use `defface' with :inherit instead.
     213             : 
     214             : If NEW-FACE already exists as a face, modify it to be like
     215             : OLD-FACE.  If NEW-FACE doesn't already exist, create it.
     216             : 
     217             : If the optional argument FRAME is a frame, change NEW-FACE on
     218             : FRAME only.  If FRAME is t, copy the frame-independent default
     219             : specification for OLD-FACE to NEW-FACE.  If FRAME is nil, copy
     220             : the defaults as well as the faces on each existing frame.
     221             : 
     222             : If the optional fourth argument NEW-FRAME is given, copy the
     223             : information from face OLD-FACE on frame FRAME to NEW-FACE on
     224             : frame NEW-FRAME.  In this case, FRAME must not be nil."
     225           0 :   (let ((inhibit-quit t))
     226           0 :     (if (null frame)
     227           0 :         (progn
     228           0 :           (when new-frame
     229           0 :             (error "Copying face %s from all frames to one frame"
     230           0 :                    old-face))
     231           0 :           (make-empty-face new-face)
     232           0 :           (dolist (frame (frame-list))
     233           0 :             (copy-face old-face new-face frame))
     234           0 :           (copy-face old-face new-face t))
     235           0 :       (make-empty-face new-face)
     236           0 :       (internal-copy-lisp-face old-face new-face frame new-frame))
     237           0 :     new-face))
     238             : 
     239             : 
     240             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     241             : ;;; Predicates, type checks.
     242             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     243             : 
     244             : (defun facep (face)
     245             :   "Return non-nil if FACE is a face name; nil otherwise.
     246             : A face name can be a string or a symbol."
     247           2 :   (internal-lisp-face-p face))
     248             : 
     249             : 
     250             : (defun check-face (face)
     251             :   "Signal an error if FACE doesn't name a face.
     252             : Value is FACE."
     253           0 :   (unless (facep face)
     254           0 :     (error "Not a face: %s" face))
     255           0 :   face)
     256             : 
     257             : 
     258             : ;; The ID returned is not to be confused with the internally used IDs
     259             : ;; of realized faces.  The ID assigned to Lisp faces is used to
     260             : ;; support faces in display table entries.
     261             : 
     262             : (defun face-id (face &optional _frame)
     263             :   "Return the internal ID of face with name FACE.
     264             : If FACE is a face-alias, return the ID of the target face.
     265             : The optional argument FRAME is ignored, since the internal face ID
     266             : of a face name is the same for all frames."
     267           0 :   (check-face face)
     268           0 :   (or (get face 'face)
     269           0 :       (face-id (get face 'face-alias))))
     270             : 
     271             : (defun face-equal (face1 face2 &optional frame)
     272             :   "Non-nil if faces FACE1 and FACE2 are equal.
     273             : Faces are considered equal if all their attributes are equal.
     274             : If the optional argument FRAME is given, report on FACE1 and FACE2 in that frame.
     275             : If FRAME is t, report on the defaults for FACE1 and FACE2 (for new frames).
     276             : If FRAME is omitted or nil, use the selected frame."
     277           0 :   (internal-lisp-face-equal-p face1 face2 frame))
     278             : 
     279             : 
     280             : (defun face-differs-from-default-p (face &optional frame)
     281             :   "Return non-nil if FACE displays differently from the default face.
     282             : If the optional argument FRAME is given, report on face FACE in that frame.
     283             : If FRAME is t, report on the defaults for face FACE (for new frames).
     284             : If FRAME is omitted or nil, use the selected frame."
     285           0 :   (let ((attrs
     286           0 :          (delq :inherit (mapcar 'car face-attribute-name-alist)))
     287             :         (differs nil))
     288           0 :     (while (and attrs (not differs))
     289           0 :       (let* ((attr (pop attrs))
     290           0 :              (attr-val (face-attribute face attr frame t)))
     291           0 :         (when (and
     292           0 :                (not (eq attr-val 'unspecified))
     293           0 :                (display-supports-face-attributes-p (list attr attr-val)
     294           0 :                                                    frame))
     295           0 :           (setq differs attr))))
     296           0 :     differs))
     297             : 
     298             : 
     299             : (defun face-nontrivial-p (face &optional frame)
     300             :   "True if face FACE has some non-nil attribute.
     301             : If the optional argument FRAME is given, report on face FACE in that frame.
     302             : If FRAME is t, report on the defaults for face FACE (for new frames).
     303             : If FRAME is omitted or nil, use the selected frame."
     304           0 :   (not (internal-lisp-face-empty-p face frame)))
     305             : 
     306             : 
     307             : (defun face-list-p (face-or-list)
     308             :   "True if FACE-OR-LIST is a list of faces.
     309             : Return nil if FACE-OR-LIST is a non-nil atom, or a cons cell whose car
     310             : is either `foreground-color', `background-color', or a keyword."
     311             :   ;; The logic of merge_face_ref (xfaces.c) is recreated here.
     312           0 :   (and (listp face-or-list)
     313           0 :        (not (memq (car face-or-list)
     314           0 :                   '(foreground-color background-color)))
     315           0 :        (not (keywordp (car face-or-list)))))
     316             : 
     317             : 
     318             : 
     319             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     320             : ;;; Setting face attributes from X resources.
     321             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     322             : 
     323             : (defcustom face-x-resources
     324             :   (mapcar
     325             :    (lambda (arg)
     326             :      ;; FIXME; can we purecopy some of the conses too?
     327             :      (cons (car arg)
     328             :            (cons (purecopy (car (cdr arg))) (purecopy (cdr (cdr arg))))))
     329             :   '((:family (".attributeFamily" . "Face.AttributeFamily"))
     330             :     (:foundry (".attributeFoundry" . "Face.AttributeFoundry"))
     331             :     (:width (".attributeWidth" . "Face.AttributeWidth"))
     332             :     (:height (".attributeHeight" . "Face.AttributeHeight"))
     333             :     (:weight (".attributeWeight" . "Face.AttributeWeight"))
     334             :     (:slant (".attributeSlant" . "Face.AttributeSlant"))
     335             :     (:foreground (".attributeForeground" . "Face.AttributeForeground"))
     336             :     (:distant-foreground
     337             :      (".attributeDistantForeground" . "Face.AttributeDistantForeground"))
     338             :     (:background (".attributeBackground" . "Face.AttributeBackground"))
     339             :     (:overline (".attributeOverline" . "Face.AttributeOverline"))
     340             :     (:strike-through (".attributeStrikeThrough" . "Face.AttributeStrikeThrough"))
     341             :     (:box (".attributeBox" . "Face.AttributeBox"))
     342             :     (:underline (".attributeUnderline" . "Face.AttributeUnderline"))
     343             :     (:inverse-video (".attributeInverse" . "Face.AttributeInverse"))
     344             :     (:stipple
     345             :      (".attributeStipple" . "Face.AttributeStipple")
     346             :      (".attributeBackgroundPixmap" . "Face.AttributeBackgroundPixmap"))
     347             :     (:bold (".attributeBold" . "Face.AttributeBold"))
     348             :     (:italic (".attributeItalic" . "Face.AttributeItalic"))
     349             :     (:font (".attributeFont" . "Face.AttributeFont"))
     350             :     (:inherit (".attributeInherit" . "Face.AttributeInherit"))))
     351             :   "List of X resources and classes for face attributes.
     352             : Each element has the form (ATTRIBUTE ENTRY1 ENTRY2...) where ATTRIBUTE is
     353             : the name of a face attribute, and each ENTRY is a cons of the form
     354             : \(RESOURCE . CLASS) with RESOURCE being the resource and CLASS being the
     355             : X resource class for the attribute."
     356             :   :type '(repeat (cons symbol (repeat (cons string string))))
     357             :   :group 'faces)
     358             : 
     359             : 
     360             : (declare-function internal-face-x-get-resource "xfaces.c"
     361             :                   (resource class &optional frame))
     362             : 
     363             : (declare-function internal-set-lisp-face-attribute-from-resource "xfaces.c"
     364             :                   (face attr value &optional frame))
     365             : 
     366             : (defun set-face-attribute-from-resource (face attribute resource class frame)
     367             :   "Set FACE's ATTRIBUTE from X resource RESOURCE, class CLASS on FRAME.
     368             : Value is the attribute value specified by the resource, or nil
     369             : if not present.  This function displays a message if the resource
     370             : specifies an invalid attribute."
     371           0 :   (let* ((face-name (face-name face))
     372           0 :          (value (internal-face-x-get-resource (concat face-name resource)
     373           0 :                                               class frame)))
     374           0 :     (when value
     375           0 :       (condition-case ()
     376           0 :           (internal-set-lisp-face-attribute-from-resource
     377           0 :            face attribute (downcase value) frame)
     378             :         (error
     379           0 :          (message "Face %s, frame %s: invalid attribute %s %s from X resource"
     380           0 :                   face-name frame attribute value))))
     381           0 :     value))
     382             : 
     383             : 
     384             : (defun set-face-attributes-from-resources (face frame)
     385             :   "Set attributes of FACE from X resources for FRAME."
     386         131 :   (when (memq (framep frame) '(x w32))
     387           0 :     (dolist (definition face-x-resources)
     388           0 :       (let ((attribute (car definition)))
     389           0 :         (dolist (entry (cdr definition))
     390           0 :           (set-face-attribute-from-resource face attribute (car entry)
     391         131 :                                             (cdr entry) frame))))))
     392             : 
     393             : 
     394             : (defun make-face-x-resource-internal (face &optional frame)
     395             :   "Fill frame-local FACE on FRAME from X resources.
     396             : FRAME nil or not specified means do it for all frames.
     397             : 
     398             : If `inhibit-x-resources' is non-nil, this function does nothing."
     399         131 :   (unless inhibit-x-resources
     400         131 :     (dolist (frame (if (null frame) (frame-list) (list frame)))
     401             :       ;; `x-create-frame' already took care of correctly handling
     402             :       ;; the reverse video case-- do _not_ touch the default face
     403         131 :       (unless (and (eq face 'default)
     404         131 :                    (frame-parameter frame 'reverse))
     405         131 :         (set-face-attributes-from-resources face frame)))))
     406             : 
     407             : 
     408             : 
     409             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     410             : ;;; Retrieving face attributes.
     411             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     412             : 
     413             : (defun face-name (face)
     414             :   "Return the name of face FACE."
     415           0 :   (symbol-name (check-face face)))
     416             : 
     417             : 
     418             : (defun face-all-attributes (face &optional frame)
     419             :   "Return an alist stating the attributes of FACE.
     420             : Each element of the result has the form (ATTR-NAME . ATTR-VALUE).
     421             : If FRAME is omitted or nil the value describes the default attributes,
     422             : but if you specify FRAME, the value describes the attributes
     423             : of FACE on FRAME."
     424           0 :   (mapcar (lambda (pair)
     425           0 :             (let ((attr (car pair)))
     426           0 :               (cons attr (face-attribute face attr (or frame t)))))
     427           0 :           face-attribute-name-alist))
     428             : 
     429             : (defun face-attribute (face attribute &optional frame inherit)
     430             :   "Return the value of FACE's ATTRIBUTE on FRAME.
     431             : If the optional argument FRAME is given, report on face FACE in that frame.
     432             : If FRAME is t, report on the defaults for face FACE (for new frames).
     433             : If FRAME is omitted or nil, use the selected frame.
     434             : 
     435             : If INHERIT is nil, only attributes directly defined by FACE are considered,
     436             :   so the return value may be `unspecified', or a relative value.
     437             : If INHERIT is non-nil, FACE's definition of ATTRIBUTE is merged with the
     438             :   faces specified by its `:inherit' attribute; however the return value
     439             :   may still be `unspecified' or relative.
     440             : If INHERIT is a face or a list of faces, then the result is further merged
     441             :   with that face (or faces), until it becomes specified and absolute.
     442             : 
     443             : To ensure that the return value is always specified and absolute, use a
     444             : value of `default' for INHERIT; this will resolve any unspecified or
     445             : relative values by merging with the `default' face (which is always
     446             : completely specified)."
     447        1912 :   (let ((value (internal-get-lisp-face-attribute face attribute frame)))
     448        1912 :     (when (and inherit (face-attribute-relative-p attribute value))
     449             :       ;; VALUE is relative, so merge with inherited faces
     450           0 :       (let ((inh-from (face-attribute face :inherit frame)))
     451           0 :         (unless (or (null inh-from) (eq inh-from 'unspecified))
     452           0 :           (condition-case nil
     453           0 :               (setq value
     454           0 :                     (face-attribute-merged-with attribute value inh-from frame))
     455             :             ;; The `inherit' attribute may point to non existent faces.
     456        1912 :             (error nil)))))
     457        1912 :     (when (and inherit
     458           0 :                (not (eq inherit t))
     459        1912 :                (face-attribute-relative-p attribute value))
     460             :       ;; We should merge with INHERIT as well
     461        1912 :       (setq value (face-attribute-merged-with attribute value inherit frame)))
     462        1912 :     value))
     463             : 
     464             : (defun face-attribute-merged-with (attribute value faces &optional frame)
     465             :   "Merges ATTRIBUTE, initially VALUE, with faces from FACES until absolute.
     466             : FACES may be either a single face or a list of faces.
     467             : [This is an internal function.]"
     468           0 :   (cond ((not (face-attribute-relative-p attribute value))
     469           0 :          value)
     470           0 :         ((null faces)
     471           0 :          value)
     472           0 :         ((consp faces)
     473           0 :          (face-attribute-merged-with
     474           0 :           attribute
     475           0 :           (face-attribute-merged-with attribute value (car faces) frame)
     476           0 :           (cdr faces)
     477           0 :           frame))
     478             :         (t
     479           0 :          (merge-face-attribute attribute
     480           0 :                                value
     481           0 :                                (face-attribute faces attribute frame t)))))
     482             : 
     483             : 
     484             : (defmacro face-attribute-specified-or (value &rest body)
     485             :   "Return VALUE, unless it's `unspecified', in which case evaluate BODY and return the result."
     486           5 :   (let ((temp (make-symbol "value")))
     487           5 :     `(let ((,temp ,value))
     488           5 :        (if (not (eq ,temp 'unspecified))
     489           5 :            ,temp
     490           5 :          ,@body))))
     491             : 
     492             : (defun face-foreground (face &optional frame inherit)
     493             :   "Return the foreground color name of FACE, or nil if unspecified.
     494             : If the optional argument FRAME is given, report on face FACE in that frame.
     495             : If FRAME is t, report on the defaults for face FACE (for new frames).
     496             : If FRAME is omitted or nil, use the selected frame.
     497             : 
     498             : If INHERIT is nil, only a foreground color directly defined by FACE is
     499             :   considered, so the return value may be nil.
     500             : If INHERIT is t, and FACE doesn't define a foreground color, then any
     501             :   foreground color that FACE inherits through its `:inherit' attribute
     502             :   is considered as well; however the return value may still be nil.
     503             : If INHERIT is a face or a list of faces, then it is used to try to
     504             :   resolve an unspecified foreground color.
     505             : 
     506             : To ensure that a valid color is always returned, use a value of
     507             : `default' for INHERIT; this will resolve any unspecified values by
     508             : merging with the `default' face (which is always completely specified)."
     509           0 :   (face-attribute-specified-or (face-attribute face :foreground frame inherit)
     510           0 :                                nil))
     511             : 
     512             : (defun face-background (face &optional frame inherit)
     513             :   "Return the background color name of FACE, or nil if unspecified.
     514             : If the optional argument FRAME is given, report on face FACE in that frame.
     515             : If FRAME is t, report on the defaults for face FACE (for new frames).
     516             : If FRAME is omitted or nil, use the selected frame.
     517             : 
     518             : If INHERIT is nil, only a background color directly defined by FACE is
     519             :   considered, so the return value may be nil.
     520             : If INHERIT is t, and FACE doesn't define a background color, then any
     521             :   background color that FACE inherits through its `:inherit' attribute
     522             :   is considered as well; however the return value may still be nil.
     523             : If INHERIT is a face or a list of faces, then it is used to try to
     524             :   resolve an unspecified background color.
     525             : 
     526             : To ensure that a valid color is always returned, use a value of
     527             : `default' for INHERIT; this will resolve any unspecified values by
     528             : merging with the `default' face (which is always completely specified)."
     529           0 :   (face-attribute-specified-or (face-attribute face :background frame inherit)
     530           0 :                                nil))
     531             : 
     532             : (defun face-stipple (face &optional frame inherit)
     533             :  "Return the stipple pixmap name of FACE, or nil if unspecified.
     534             : If the optional argument FRAME is given, report on face FACE in that frame.
     535             : If FRAME is t, report on the defaults for face FACE (for new frames).
     536             : If FRAME is omitted or nil, use the selected frame.
     537             : 
     538             : If INHERIT is nil, only a stipple directly defined by FACE is
     539             :   considered, so the return value may be nil.
     540             : If INHERIT is t, and FACE doesn't define a stipple, then any stipple
     541             :   that FACE inherits through its `:inherit' attribute is considered as
     542             :   well; however the return value may still be nil.
     543             : If INHERIT is a face or a list of faces, then it is used to try to
     544             :   resolve an unspecified stipple.
     545             : 
     546             : To ensure that a valid stipple or nil is always returned, use a value of
     547             : `default' for INHERIT; this will resolve any unspecified values by merging
     548             : with the `default' face (which is always completely specified)."
     549           0 :   (face-attribute-specified-or (face-attribute face :stipple frame inherit)
     550           0 :                                nil))
     551             : 
     552             : 
     553             : (defalias 'face-background-pixmap 'face-stipple)
     554             : 
     555             : 
     556             : (defun face-underline-p (face &optional frame inherit)
     557             :  "Return non-nil if FACE specifies a non-nil underlining.
     558             : If the optional argument FRAME is given, report on face FACE in that frame.
     559             : If FRAME is t, report on the defaults for face FACE (for new frames).
     560             : If FRAME is omitted or nil, use the selected frame.
     561             : Optional argument INHERIT is passed to `face-attribute'."
     562           0 :  (face-attribute-specified-or
     563           0 :   (face-attribute face :underline frame inherit) nil))
     564             : 
     565             : 
     566             : (defun face-inverse-video-p (face &optional frame inherit)
     567             :  "Return non-nil if FACE specifies a non-nil inverse-video.
     568             : If the optional argument FRAME is given, report on face FACE in that frame.
     569             : If FRAME is t, report on the defaults for face FACE (for new frames).
     570             : If FRAME is omitted or nil, use the selected frame.
     571             : Optional argument INHERIT is passed to `face-attribute'."
     572           0 :  (eq (face-attribute face :inverse-video frame inherit) t))
     573             : 
     574             : 
     575             : (defun face-bold-p (face &optional frame inherit)
     576             :   "Return non-nil if the font of FACE is bold on FRAME.
     577             : If the optional argument FRAME is given, report on face FACE in that frame.
     578             : If FRAME is t, report on the defaults for face FACE (for new frames).
     579             : If FRAME is omitted or nil, use the selected frame.
     580             : Optional argument INHERIT is passed to `face-attribute'.
     581             : Use `face-attribute' for finer control."
     582           0 :   (let ((bold (face-attribute face :weight frame inherit)))
     583           0 :     (memq bold '(semi-bold bold extra-bold ultra-bold))))
     584             : 
     585             : 
     586             : (defun face-italic-p (face &optional frame inherit)
     587             :   "Return non-nil if the font of FACE is italic on FRAME.
     588             : If the optional argument FRAME is given, report on face FACE in that frame.
     589             : If FRAME is t, report on the defaults for face FACE (for new frames).
     590             : If FRAME is omitted or nil, use the selected frame.
     591             : Optional argument INHERIT is passed to `face-attribute'.
     592             : Use `face-attribute' for finer control."
     593           0 :   (let ((italic (face-attribute face :slant frame inherit)))
     594           0 :     (memq italic '(italic oblique))))
     595             : 
     596             : 
     597             : 
     598             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     599             : ;;; Face documentation.
     600             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     601             : 
     602             : (defun face-documentation (face)
     603             :   "Get the documentation string for FACE.
     604             : If FACE is a face-alias, get the documentation for the target face."
     605           0 :   (let ((alias (get face 'face-alias)))
     606           0 :     (if alias
     607           0 :         (let ((doc (get alias 'face-documentation)))
     608           0 :           (format "%s is an alias for the face `%s'.%s" face alias
     609           0 :                   (if doc (format "\n%s" doc)
     610           0 :                     "")))
     611           0 :       (get face 'face-documentation))))
     612             : 
     613             : 
     614             : (defun set-face-documentation (face string)
     615             :   "Set the documentation string for FACE to STRING."
     616             :   ;; Perhaps the text should go in DOC.
     617           2 :   (put face 'face-documentation (purecopy string)))
     618             : 
     619             : 
     620             : (defalias 'face-doc-string 'face-documentation)
     621             : (defalias 'set-face-doc-string 'set-face-documentation)
     622             : 
     623             : 
     624             : 
     625             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     626             : ;; Setting face attributes.
     627             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     628             : 
     629             : 
     630             : (defun set-face-attribute (face frame &rest args)
     631             :   "Set attributes of FACE on FRAME from ARGS.
     632             : This function overrides the face attributes specified by FACE's
     633             : face spec.  It is mostly intended for internal use only.
     634             : 
     635             : If FRAME is nil, set the attributes for all existing frames, as
     636             : well as the default for new frames.  If FRAME is t, change the
     637             : default for new frames only.
     638             : 
     639             : ARGS must come in pairs ATTRIBUTE VALUE.  ATTRIBUTE must be a
     640             : valid face attribute name.  All attributes can be set to
     641             : `unspecified'; this fact is not further mentioned below.
     642             : 
     643             : The following attributes are recognized:
     644             : 
     645             : `:family'
     646             : 
     647             : VALUE must be a string specifying the font family
     648             : \(e.g. \"Monospace\") or a fontset.
     649             : 
     650             : `:foundry'
     651             : 
     652             : VALUE must be a string specifying the font foundry,
     653             : e.g., \"adobe\".  If a font foundry is specified, wild-cards `*'
     654             : and `?' are allowed.
     655             : 
     656             : `:width'
     657             : 
     658             : VALUE specifies the relative proportionate width of the font to use.
     659             : It must be one of the symbols `ultra-condensed', `extra-condensed',
     660             : `condensed', `semi-condensed', `normal', `semi-expanded', `expanded',
     661             : `extra-expanded', or `ultra-expanded'.
     662             : 
     663             : `:height'
     664             : 
     665             : VALUE specifies the relative or absolute height of the font.  An
     666             : absolute height is an integer, and specifies font height in units
     667             : of 1/10 pt.  A relative height is either a floating point number,
     668             : which specifies a scaling factor for the underlying face height;
     669             : or a function that takes a single argument (the underlying face
     670             : height) and returns the new height.  Note that for the `default'
     671             : face, you must specify an absolute height (since there is nothing
     672             : for it to be relative to).
     673             : 
     674             : `:weight'
     675             : 
     676             : VALUE specifies the weight of the font to use.  It must be one of the
     677             : symbols `ultra-bold', `extra-bold', `bold', `semi-bold', `normal',
     678             : `semi-light', `light', `extra-light', `ultra-light'.
     679             : 
     680             : `:slant'
     681             : 
     682             : VALUE specifies the slant of the font to use.  It must be one of the
     683             : symbols `italic', `oblique', `normal', `reverse-italic', or
     684             : `reverse-oblique'.
     685             : 
     686             : `:foreground', `:background'
     687             : 
     688             : VALUE must be a color name, a string.
     689             : 
     690             : `:underline'
     691             : 
     692             : VALUE specifies whether characters in FACE should be underlined.
     693             : If VALUE is t, underline with foreground color of the face.
     694             : If VALUE is a string, underline with that color.
     695             : If VALUE is nil, explicitly don't underline.
     696             : 
     697             : Otherwise, VALUE must be a property list of the form:
     698             : 
     699             : `(:color COLOR :style STYLE)'.
     700             : 
     701             : COLOR can be a either a color name string or `foreground-color'.
     702             : STYLE can be either `line' or `wave'.
     703             : If a keyword/value pair is missing from the property list, a
     704             : default value will be used for the value.
     705             : The default value of COLOR is the foreground color of the face.
     706             : The default value of STYLE is `line'.
     707             : 
     708             : `:overline'
     709             : 
     710             : VALUE specifies whether characters in FACE should be overlined.  If
     711             : VALUE is t, overline with foreground color of the face.  If VALUE is a
     712             : string, overline with that color.  If VALUE is nil, explicitly don't
     713             : overline.
     714             : 
     715             : `:strike-through'
     716             : 
     717             : VALUE specifies whether characters in FACE should be drawn with a line
     718             : striking through them.  If VALUE is t, use the foreground color of the
     719             : face.  If VALUE is a string, strike-through with that color.  If VALUE
     720             : is nil, explicitly don't strike through.
     721             : 
     722             : `:box'
     723             : 
     724             : VALUE specifies whether characters in FACE should have a box drawn
     725             : around them.  If VALUE is nil, explicitly don't draw boxes.  If
     726             : VALUE is t, draw a box with lines of width 1 in the foreground color
     727             : of the face.  If VALUE is a string, the string must be a color name,
     728             : and the box is drawn in that color with a line width of 1.  Otherwise,
     729             : VALUE must be a property list of the form `(:line-width WIDTH
     730             : :color COLOR :style STYLE)'.  If a keyword/value pair is missing from
     731             : the property list, a default value will be used for the value, as
     732             : specified below.  WIDTH specifies the width of the lines to draw; it
     733             : defaults to 1.  If WIDTH is negative, the absolute value is the width
     734             : of the lines, and draw top/bottom lines inside the characters area,
     735             : not around it.  COLOR is the name of the color to draw in, default is
     736             : the foreground color of the face for simple boxes, and the background
     737             : color of the face for 3D boxes.  STYLE specifies whether a 3D box
     738             : should be draw.  If STYLE is `released-button', draw a box looking
     739             : like a released 3D button.  If STYLE is `pressed-button' draw a box
     740             : that appears like a pressed button.  If STYLE is nil, the default if
     741             : the property list doesn't contain a style specification, draw a 2D
     742             : box.
     743             : 
     744             : `:inverse-video'
     745             : 
     746             : VALUE specifies whether characters in FACE should be displayed in
     747             : inverse video.  VALUE must be one of t or nil.
     748             : 
     749             : `:stipple'
     750             : 
     751             : If VALUE is a string, it must be the name of a file of pixmap data.
     752             : The directories listed in the `x-bitmap-file-path' variable are
     753             : searched.  Alternatively, VALUE may be a list of the form (WIDTH
     754             : HEIGHT DATA) where WIDTH and HEIGHT are the size in pixels, and DATA
     755             : is a string containing the raw bits of the bitmap.  VALUE nil means
     756             : explicitly don't use a stipple pattern.
     757             : 
     758             : For convenience, attributes `:family', `:foundry', `:width',
     759             : `:height', `:weight', and `:slant' may also be set in one step
     760             : from an X font name:
     761             : 
     762             : `:font'
     763             : 
     764             : Set font-related face attributes from VALUE.  VALUE must be a
     765             : valid font name or font object.  Setting this attribute will also
     766             : set the `:family', `:foundry', `:width', `:height', `:weight',
     767             : and `:slant' attributes.
     768             : 
     769             : `:inherit'
     770             : 
     771             : VALUE is the name of a face from which to inherit attributes, or
     772             : a list of face names.  Attributes from inherited faces are merged
     773             : into the face like an underlying face would be, with higher
     774             : priority than underlying faces.
     775             : 
     776             : For backward compatibility, the keywords `:bold' and `:italic'
     777             : can be used to specify weight and slant respectively.  This usage
     778             : is considered obsolete.  For these two keywords, the VALUE must
     779             : be either t or nil.  A value of t for `:bold' is equivalent to
     780             : setting `:weight' to `bold', and a value of t for `:italic' is
     781             : equivalent to setting `:slant' to `italic'.  But if `:weight' is
     782             : specified in the face spec, `:bold' is ignored, and if `:slant'
     783             : is specified, `:italic' is ignored."
     784         387 :   (setq args (purecopy args))
     785         387 :   (let ((where (if (null frame) 0 frame))
     786         387 :         (spec args)
     787             :         family foundry orig-family orig-foundry)
     788             :     ;; If we set the new-frame defaults, this face is modified outside Custom.
     789         387 :     (if (memq where '(0 t))
     790         387 :         (put (or (get face 'face-alias) face) 'face-modified t))
     791             :     ;; If family and/or foundry are specified, set it first.  Certain
     792             :     ;; face attributes, e.g. :weight semi-condensed, are not supported
     793             :     ;; in every font.  See bug#1127.
     794        2456 :     (while spec
     795        2069 :       (cond ((eq (car spec) :family)
     796         132 :              (setq family (cadr spec)))
     797        1937 :             ((eq (car spec) :foundry)
     798        2069 :              (setq foundry (cadr spec))))
     799        2069 :       (setq spec (cddr spec)))
     800         387 :     (when (or family foundry)
     801         132 :       (when (and (stringp family)
     802         132 :                  (string-match "\\([^-]*\\)-\\([^-]*\\)" family))
     803           0 :         (setq orig-foundry foundry
     804           0 :               orig-family family)
     805           0 :         (unless foundry
     806           0 :           (setq foundry (match-string 1 family)))
     807           0 :         (setq family (match-string 2 family))
     808             :         ;; Reject bogus "families" that are all-digits -- those are some
     809             :         ;; weird font names, like Foobar-12, that end in a number.
     810           0 :         (when (string-match "\\`[0-9]*\\'" family)
     811           0 :           (setq family orig-family)
     812         132 :           (setq foundry orig-foundry)))
     813         132 :       (when (or (stringp family) (eq family 'unspecified))
     814         132 :         (internal-set-lisp-face-attribute face :family (purecopy family)
     815         132 :                                           where))
     816         132 :       (when (or (stringp foundry) (eq foundry 'unspecified))
     817         129 :         (internal-set-lisp-face-attribute face :foundry (purecopy foundry)
     818         387 :                                           where)))
     819        2456 :     (while args
     820        2069 :       (unless (memq (car args) '(:family :foundry))
     821        1808 :         (internal-set-lisp-face-attribute face (car args)
     822        1808 :                                           (purecopy (cadr args))
     823        2069 :                                           where))
     824        2069 :       (setq args (cddr args)))))
     825             : 
     826             : (defun make-face-bold (face &optional frame _noerror)
     827             :   "Make the font of FACE be bold, if possible.
     828             : FRAME nil or not specified means change face on all frames.
     829             : Argument NOERROR is ignored and retained for compatibility.
     830             : Use `set-face-attribute' for finer control of the font weight."
     831           0 :   (interactive (list (read-face-name "Make which face bold"
     832           0 :                                      (face-at-point t))))
     833           0 :   (set-face-attribute face frame :weight 'bold))
     834             : 
     835             : 
     836             : (defun make-face-unbold (face &optional frame _noerror)
     837             :   "Make the font of FACE be non-bold, if possible.
     838             : FRAME nil or not specified means change face on all frames.
     839             : Argument NOERROR is ignored and retained for compatibility."
     840           0 :   (interactive (list (read-face-name "Make which face non-bold"
     841           0 :                                      (face-at-point t))))
     842           0 :   (set-face-attribute face frame :weight 'normal))
     843             : 
     844             : 
     845             : (defun make-face-italic (face &optional frame _noerror)
     846             :   "Make the font of FACE be italic, if possible.
     847             : FRAME nil or not specified means change face on all frames.
     848             : Argument NOERROR is ignored and retained for compatibility.
     849             : Use `set-face-attribute' for finer control of the font slant."
     850           0 :   (interactive (list (read-face-name "Make which face italic"
     851           0 :                                      (face-at-point t))))
     852           0 :   (set-face-attribute face frame :slant 'italic))
     853             : 
     854             : 
     855             : (defun make-face-unitalic (face &optional frame _noerror)
     856             :   "Make the font of FACE be non-italic, if possible.
     857             : FRAME nil or not specified means change face on all frames.
     858             : Argument NOERROR is ignored and retained for compatibility."
     859           0 :   (interactive (list (read-face-name "Make which face non-italic"
     860           0 :                                      (face-at-point t))))
     861           0 :   (set-face-attribute face frame :slant 'normal))
     862             : 
     863             : 
     864             : (defun make-face-bold-italic (face &optional frame _noerror)
     865             :   "Make the font of FACE be bold and italic, if possible.
     866             : FRAME nil or not specified means change face on all frames.
     867             : Argument NOERROR is ignored and retained for compatibility.
     868             : Use `set-face-attribute' for finer control of font weight and slant."
     869           0 :   (interactive (list (read-face-name "Make which face bold-italic"
     870           0 :                                      (face-at-point t))))
     871           0 :   (set-face-attribute face frame :weight 'bold :slant 'italic))
     872             : 
     873             : 
     874             : (defun set-face-font (face font &optional frame)
     875             :   "Change font-related attributes of FACE to those of FONT (a string).
     876             : FRAME nil or not specified means change face on all frames.
     877             : This sets the attributes `:family', `:foundry', `:width',
     878             : `:height', `:weight', and `:slant'.  When called interactively,
     879             : prompt for the face and font."
     880           0 :   (interactive (read-face-and-attribute :font))
     881           0 :   (set-face-attribute face frame :font font))
     882             : 
     883             : 
     884             : ;; Implementation note: Emulating gray background colors with a
     885             : ;; stipple pattern is now part of the face realization process, and is
     886             : ;; done in C depending on the frame on which the face is realized.
     887             : 
     888             : (defun set-face-background (face color &optional frame)
     889             :   "Change the background color of face FACE to COLOR (a string).
     890             : FRAME nil or not specified means change face on all frames.
     891             : COLOR can be a system-defined color name (see `list-colors-display')
     892             : or a hex spec of the form #RRGGBB.
     893             : When called interactively, prompts for the face and color."
     894           0 :   (interactive (read-face-and-attribute :background))
     895           0 :   (set-face-attribute face frame :background (or color 'unspecified)))
     896             : 
     897             : 
     898             : (defun set-face-foreground (face color &optional frame)
     899             :   "Change the foreground color of face FACE to COLOR (a string).
     900             : FRAME nil or not specified means change face on all frames.
     901             : COLOR can be a system-defined color name (see `list-colors-display')
     902             : or a hex spec of the form #RRGGBB.
     903             : When called interactively, prompts for the face and color."
     904           0 :   (interactive (read-face-and-attribute :foreground))
     905           0 :   (set-face-attribute face frame :foreground (or color 'unspecified)))
     906             : 
     907             : 
     908             : (defun set-face-stipple (face stipple &optional frame)
     909             :   "Change the stipple pixmap of face FACE to STIPPLE.
     910             : FRAME nil or not specified means change face on all frames.
     911             : STIPPLE should be a string, the name of a file of pixmap data.
     912             : The directories listed in the `x-bitmap-file-path' variable are searched.
     913             : 
     914             : Alternatively, STIPPLE may be a list of the form (WIDTH HEIGHT DATA)
     915             : where WIDTH and HEIGHT are the size in pixels,
     916             : and DATA is a string, containing the raw bits of the bitmap."
     917           0 :   (interactive (read-face-and-attribute :stipple))
     918           0 :   (set-face-attribute face frame :stipple (or stipple 'unspecified)))
     919             : 
     920             : 
     921             : (defun set-face-underline (face underline &optional frame)
     922             :   "Specify whether face FACE is underlined.
     923             : UNDERLINE nil means FACE explicitly doesn't underline.
     924             : UNDERLINE t means FACE underlines with its foreground color.
     925             : If UNDERLINE is a string, underline with that color.
     926             : 
     927             : UNDERLINE may also be a list of the form (:color COLOR :style STYLE),
     928             : where COLOR is a string or `foreground-color', and STYLE is either
     929             : `line' or `wave'.  :color may be omitted, which means to use the
     930             : foreground color.  :style may be omitted, which means to use a line.
     931             : 
     932             : FRAME nil or not specified means change face on all frames.
     933             : Use `set-face-attribute' to \"unspecify\" underlining."
     934           0 :   (interactive (read-face-and-attribute :underline))
     935           0 :   (set-face-attribute face frame :underline underline))
     936             : 
     937             : (define-obsolete-function-alias 'set-face-underline-p
     938             :                                 'set-face-underline "24.3")
     939             : 
     940             : 
     941             : (defun set-face-inverse-video (face inverse-video-p &optional frame)
     942             :   "Specify whether face FACE is in inverse video.
     943             : INVERSE-VIDEO-P non-nil means FACE displays explicitly in inverse video.
     944             : INVERSE-VIDEO-P nil means FACE explicitly is not in inverse video.
     945             : FRAME nil or not specified means change face on all frames.
     946             : Use `set-face-attribute' to \"unspecify\" the inverse video attribute."
     947             :   (interactive
     948           0 :    (let ((list (read-face-and-attribute :inverse-video)))
     949           0 :      (list (car list) (if (cadr list) t))))
     950           0 :   (set-face-attribute face frame :inverse-video inverse-video-p))
     951             : 
     952             : (define-obsolete-function-alias 'set-face-inverse-video-p
     953             :                                 'set-face-inverse-video "24.4")
     954             : 
     955             : (defun set-face-bold (face bold-p &optional frame)
     956             :   "Specify whether face FACE is bold.
     957             : BOLD-P non-nil means FACE should explicitly display bold.
     958             : BOLD-P nil means FACE should explicitly display non-bold.
     959             : FRAME nil or not specified means change face on all frames.
     960             : Use `set-face-attribute' or `modify-face' for finer control."
     961           0 :   (if (null bold-p)
     962           0 :       (make-face-unbold face frame)
     963           0 :     (make-face-bold face frame)))
     964             : 
     965             : (define-obsolete-function-alias 'set-face-bold-p 'set-face-bold "24.4")
     966             : 
     967             : 
     968             : (defun set-face-italic (face italic-p &optional frame)
     969             :   "Specify whether face FACE is italic.
     970             : ITALIC-P non-nil means FACE should explicitly display italic.
     971             : ITALIC-P nil means FACE should explicitly display non-italic.
     972             : FRAME nil or not specified means change face on all frames.
     973             : Use `set-face-attribute' or `modify-face' for finer control."
     974           0 :   (if (null italic-p)
     975           0 :       (make-face-unitalic face frame)
     976           0 :     (make-face-italic face frame)))
     977             : 
     978             : (define-obsolete-function-alias 'set-face-italic-p 'set-face-italic "24.4")
     979             : 
     980             : 
     981             : (defalias 'set-face-background-pixmap 'set-face-stipple)
     982             : 
     983             : 
     984             : (defun invert-face (face &optional frame)
     985             :   "Swap the foreground and background colors of FACE.
     986             : If FRAME is omitted or nil, it means change face on all frames.
     987             : If FACE specifies neither foreground nor background color,
     988             : set its foreground and background to the background and foreground
     989             : of the default face.  Value is FACE."
     990           0 :   (interactive (list (read-face-name "Invert face" (face-at-point t))))
     991           0 :   (let ((fg (face-attribute face :foreground frame))
     992           0 :         (bg (face-attribute face :background frame)))
     993           0 :     (if (not (and (eq fg 'unspecified) (eq bg 'unspecified)))
     994           0 :         (set-face-attribute face frame :foreground bg :background fg)
     995           0 :       (set-face-attribute face frame
     996             :                           :foreground
     997           0 :                           (face-attribute 'default :background frame)
     998             :                           :background
     999           0 :                           (face-attribute 'default :foreground frame))))
    1000           0 :   face)
    1001             : 
    1002             : 
    1003             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1004             : ;;; Interactively modifying faces.
    1005             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1006             : 
    1007             : (defvar crm-separator) ; from crm.el
    1008             : 
    1009             : (defun read-face-name (prompt &optional default multiple)
    1010             :   "Read one or more face names, prompting with PROMPT.
    1011             : PROMPT should not end in a space or a colon.
    1012             : 
    1013             : If DEFAULT is non-nil, it should be a face (a symbol) or a face
    1014             : name (a string).  It can also be a list of faces or face names.
    1015             : 
    1016             : If MULTIPLE is non-nil, the return value from this function is a
    1017             : list of faces.  Otherwise a single face is returned.
    1018             : 
    1019             : If the user enter the empty string at the prompt, DEFAULT is
    1020             : returned after a possible transformation according to MULTIPLE.
    1021             : That is, if DEFAULT is a list and MULTIPLE is nil, the first
    1022             : element of DEFAULT is returned.  If DEFAULT isn't a list, but
    1023             : MULTIPLE is non-nil, a one-element list containing DEFAULT is
    1024             : returned.  Otherwise, DEFAULT is returned verbatim."
    1025           0 :   (unless (listp default)
    1026           0 :     (setq default (list default)))
    1027           0 :   (when default
    1028           0 :     (setq default
    1029           0 :           (if multiple
    1030           0 :               (mapconcat (lambda (f) (if (symbolp f) (symbol-name f) f))
    1031           0 :                          default ", ")
    1032             :             ;; If we only want one, and the default is more than one,
    1033             :             ;; discard the unwanted ones.
    1034           0 :             (setq default (car default))
    1035           0 :             (if (symbolp default)
    1036           0 :                 (symbol-name default)
    1037           0 :               default))))
    1038           0 :   (when (and default (not multiple))
    1039           0 :     (require 'crm)
    1040             :     ;; For compatibility with `completing-read-multiple' use `crm-separator'
    1041             :     ;; to define DEFAULT if MULTIPLE is nil.
    1042           0 :     (setq default (car (split-string default crm-separator t))))
    1043             : 
    1044             :   ;; Older versions of `read-face-name' did not append ": " to the
    1045             :   ;; prompt, so there are third party libraries that have that in the
    1046             :   ;; prompt.  If so, remove it.
    1047           0 :   (setq prompt (replace-regexp-in-string ": ?\\'" "" prompt))
    1048           0 :   (let ((prompt (if default
    1049           0 :                     (format-message "%s (default `%s'): " prompt default)
    1050           0 :                   (format "%s: " prompt)))
    1051             :         aliasfaces nonaliasfaces faces)
    1052             :     ;; Build up the completion tables.
    1053           0 :     (mapatoms (lambda (s)
    1054           0 :                 (if (facep s)
    1055           0 :                     (if (get s 'face-alias)
    1056           0 :                         (push (symbol-name s) aliasfaces)
    1057           0 :                       (push (symbol-name s) nonaliasfaces)))))
    1058           0 :     (if multiple
    1059           0 :         (progn
    1060           0 :           (dolist (face (completing-read-multiple
    1061           0 :                          prompt
    1062           0 :                          (completion-table-in-turn nonaliasfaces aliasfaces)
    1063           0 :                          nil t nil 'face-name-history default))
    1064             :             ;; Ignore elements that are not faces
    1065             :             ;; (for example, because DEFAULT was "all faces")
    1066           0 :             (if (facep face) (push (intern face) faces)))
    1067           0 :           (nreverse faces))
    1068           0 :       (let ((face (completing-read
    1069           0 :                    prompt
    1070           0 :                    (completion-table-in-turn nonaliasfaces aliasfaces)
    1071           0 :                    nil t nil 'face-name-history default)))
    1072           0 :         (if (facep face) (intern face))))))
    1073             : 
    1074             : ;; Not defined without X, but behind window-system test.
    1075             : (defvar x-bitmap-file-path)
    1076             : 
    1077             : (defun face-valid-attribute-values (attribute &optional frame)
    1078             :   "Return valid values for face attribute ATTRIBUTE.
    1079             : The optional argument FRAME is used to determine available fonts
    1080             : and colors.  If it is nil or not specified, the selected frame is used.
    1081             : Value is an alist of (NAME . VALUE) if ATTRIBUTE expects a value out
    1082             : of a set of discrete values.  Value is `integerp' if ATTRIBUTE expects
    1083             : an integer value."
    1084           0 :   (let ((valid
    1085           0 :          (pcase attribute
    1086             :            (`:family
    1087           0 :             (if (window-system frame)
    1088           0 :                 (mapcar (lambda (x) (cons x x))
    1089           0 :                         (font-family-list))
    1090             :               ;; Only one font on TTYs.
    1091           0 :               (list (cons "default" "default"))))
    1092             :            (`:foundry
    1093           0 :             (list nil))
    1094             :            (`:width
    1095           0 :             (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1)))
    1096           0 :                     font-width-table))
    1097             :            (`:weight
    1098           0 :             (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1)))
    1099           0 :                     font-weight-table))
    1100             :            (`:slant
    1101           0 :             (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1)))
    1102           0 :                     font-slant-table))
    1103             :            (`:inverse-video
    1104           0 :             (mapcar #'(lambda (x) (cons (symbol-name x) x))
    1105           0 :                     (internal-lisp-face-attribute-values attribute)))
    1106             :            ((or `:underline `:overline `:strike-through `:box)
    1107           0 :             (if (window-system frame)
    1108           0 :                 (nconc (mapcar #'(lambda (x) (cons (symbol-name x) x))
    1109           0 :                                (internal-lisp-face-attribute-values attribute))
    1110           0 :                        (mapcar #'(lambda (c) (cons c c))
    1111           0 :                                (defined-colors frame)))
    1112           0 :               (mapcar #'(lambda (x) (cons (symbol-name x) x))
    1113           0 :                       (internal-lisp-face-attribute-values attribute))))
    1114             :            ((or `:foreground `:background)
    1115           0 :             (mapcar #'(lambda (c) (cons c c))
    1116           0 :                     (defined-colors frame)))
    1117             :            (`:height
    1118             :             'integerp)
    1119             :            (`:stipple
    1120           0 :             (and (memq (window-system frame) '(x ns)) ; No stipple on w32
    1121           0 :                  (mapcar #'list
    1122           0 :                          (apply #'nconc
    1123           0 :                                 (mapcar (lambda (dir)
    1124           0 :                                           (and (file-readable-p dir)
    1125           0 :                                                (file-directory-p dir)
    1126           0 :                                                (directory-files dir)))
    1127           0 :                                         x-bitmap-file-path)))))
    1128             :            (`:inherit
    1129           0 :             (cons '("none" . nil)
    1130           0 :                   (mapcar #'(lambda (c) (cons (symbol-name c) c))
    1131           0 :                           (face-list))))
    1132             :            (_
    1133           0 :             (error "Internal error")))))
    1134           0 :     (if (and (listp valid) (not (memq attribute '(:inherit))))
    1135           0 :         (nconc (list (cons "unspecified" 'unspecified)) valid)
    1136           0 :       valid)))
    1137             : 
    1138             : 
    1139             : (defconst face-attribute-name-alist
    1140             :   '((:family . "font family")
    1141             :     (:foundry . "font foundry")
    1142             :     (:width . "character set width")
    1143             :     (:height . "height in 1/10 pt")
    1144             :     (:weight . "weight")
    1145             :     (:slant . "slant")
    1146             :     (:underline . "underline")
    1147             :     (:overline . "overline")
    1148             :     (:strike-through . "strike-through")
    1149             :     (:box . "box")
    1150             :     (:inverse-video . "inverse-video display")
    1151             :     (:foreground . "foreground color")
    1152             :     (:background . "background color")
    1153             :     (:stipple . "background stipple")
    1154             :     (:inherit . "inheritance"))
    1155             :   "An alist of descriptive names for face attributes.
    1156             : Each element has the form (ATTRIBUTE-NAME . DESCRIPTION) where
    1157             : ATTRIBUTE-NAME is a face attribute name (a keyword symbol), and
    1158             : DESCRIPTION is a descriptive name for ATTRIBUTE-NAME.")
    1159             : 
    1160             : 
    1161             : (defun face-descriptive-attribute-name (attribute)
    1162             :   "Return a descriptive name for ATTRIBUTE."
    1163           0 :   (cdr (assq attribute face-attribute-name-alist)))
    1164             : 
    1165             : 
    1166             : (defun face-read-string (face default name &optional completion-alist)
    1167             :   "Interactively read a face attribute string value.
    1168             : FACE is the face whose attribute is read.  If non-nil, DEFAULT is the
    1169             : default string to return if no new value is entered.  NAME is a
    1170             : descriptive name of the attribute for prompting.  COMPLETION-ALIST is an
    1171             : alist of valid values, if non-nil.
    1172             : 
    1173             : Entering nothing accepts the default string DEFAULT.
    1174             : Value is the new attribute value."
    1175             :   ;; Capitalize NAME (we don't use `capitalize' because that capitalizes
    1176             :   ;; each word in a string separately).
    1177           0 :   (setq name (concat (upcase (substring name 0 1)) (substring name 1)))
    1178           0 :   (let* ((completion-ignore-case t)
    1179           0 :          (value (completing-read
    1180           0 :                  (format-message (if default
    1181             :                                      "%s for face `%s' (default %s): "
    1182           0 :                                    "%s for face `%s': ")
    1183           0 :                                  name face default)
    1184           0 :                  completion-alist nil nil nil nil default)))
    1185           0 :     (if (equal value "") default value)))
    1186             : 
    1187             : 
    1188             : (defun face-read-integer (face default name)
    1189             :   "Interactively read an integer face attribute value.
    1190             : FACE is the face whose attribute is read.  DEFAULT is the default
    1191             : value to return if no new value is entered.  NAME is a descriptive
    1192             : name of the attribute for prompting.  Value is the new attribute value."
    1193           0 :   (let ((new-value
    1194           0 :          (face-read-string face
    1195           0 :                            (format "%s" default)
    1196           0 :                            name
    1197           0 :                            (list (cons "unspecified" 'unspecified)))))
    1198           0 :     (cond ((equal new-value "unspecified")
    1199             :            'unspecified)
    1200           0 :           ((member new-value '("unspecified-fg" "unspecified-bg"))
    1201           0 :            new-value)
    1202             :           (t
    1203           0 :            (string-to-number new-value)))))
    1204             : 
    1205             : 
    1206             : ;; FIXME this does allow you to enter the list forms of :box,
    1207             : ;; :stipple, or :underline, because face-valid-attribute-values does
    1208             : ;; not return those forms.
    1209             : (defun read-face-attribute (face attribute &optional frame)
    1210             :   "Interactively read a new value for FACE's ATTRIBUTE.
    1211             : Optional argument FRAME nil or unspecified means read an attribute value
    1212             : of a global face.  Value is the new attribute value."
    1213           0 :   (let* ((old-value (face-attribute face attribute frame))
    1214           0 :          (attribute-name (face-descriptive-attribute-name attribute))
    1215           0 :          (valid (face-valid-attribute-values attribute frame))
    1216             :          new-value)
    1217             :     ;; Represent complex attribute values as strings by printing them
    1218             :     ;; out.  Stipple can be a vector; (WIDTH HEIGHT DATA).  Box can be
    1219             :     ;; a list `(:width WIDTH :color COLOR)' or `(:width WIDTH :shadow
    1220             :     ;; SHADOW)'.  Underline can be `(:color COLOR :style STYLE)'.
    1221           0 :     (and (memq attribute '(:box :stipple :underline))
    1222           0 :          (or (consp old-value)
    1223           0 :              (vectorp old-value))
    1224           0 :          (setq old-value (prin1-to-string old-value)))
    1225           0 :     (cond ((listp valid)
    1226           0 :            (let ((default
    1227           0 :                    (or (car (rassoc old-value valid))
    1228           0 :                        (format "%s" old-value))))
    1229           0 :              (setq new-value
    1230           0 :                    (face-read-string face default attribute-name valid))
    1231           0 :              (if (equal new-value default)
    1232             :                  ;; Nothing changed, so don't bother with all the stuff
    1233             :                  ;; below.  In particular, this avoids a non-tty color
    1234             :                  ;; from being canonicalized for a tty when the user
    1235             :                  ;; just uses the default.
    1236           0 :                  (setq new-value old-value)
    1237             :                ;; Terminal frames can support colors that don't appear
    1238             :                ;; explicitly in VALID, using color approximation code
    1239             :                ;; in tty-colors.el.
    1240           0 :                (when (and (memq attribute '(:foreground :background))
    1241           0 :                           (not (memq (window-system frame) '(x w32 ns)))
    1242           0 :                           (not (member new-value
    1243             :                                        '("unspecified"
    1244           0 :                                          "unspecified-fg" "unspecified-bg"))))
    1245           0 :                  (setq new-value (car (tty-color-desc new-value frame))))
    1246           0 :                (when (assoc new-value valid)
    1247           0 :                  (setq new-value (cdr (assoc new-value valid)))))))
    1248           0 :           ((eq valid 'integerp)
    1249           0 :            (setq new-value (face-read-integer face old-value attribute-name)))
    1250           0 :           (t (error "Internal error")))
    1251             :     ;; Convert stipple and box value text we read back to a list or
    1252             :     ;; vector if it looks like one.  This makes the assumption that a
    1253             :     ;; pixmap file name won't start with an open-paren.
    1254           0 :     (and (memq attribute '(:stipple :box :underline))
    1255           0 :          (stringp new-value)
    1256           0 :          (string-match-p "^[[(]" new-value)
    1257           0 :          (setq new-value (read new-value)))
    1258           0 :     new-value))
    1259             : 
    1260             : (declare-function fontset-list "fontset.c" ())
    1261             : (declare-function x-list-fonts "xfaces.c"
    1262             :                   (pattern &optional face frame maximum width))
    1263             : 
    1264             : (defun read-face-font (face &optional frame)
    1265             :   "Read the name of a font for FACE on FRAME.
    1266             : If optional argument FRAME is nil or omitted, use the selected frame."
    1267           0 :   (let ((completion-ignore-case t))
    1268           0 :     (completing-read (format-message
    1269           0 :                       "Set font attributes of face `%s' from font: " face)
    1270           0 :                      (append (fontset-list) (x-list-fonts "*" nil frame)))))
    1271             : 
    1272             : 
    1273             : (defun read-all-face-attributes (face &optional frame)
    1274             :   "Interactively read all attributes for FACE.
    1275             : If optional argument FRAME is nil or omitted, use the selected frame.
    1276             : Value is a property list of attribute names and new values."
    1277           0 :   (let (result)
    1278           0 :     (dolist (attribute face-attribute-name-alist result)
    1279           0 :       (setq result (cons (car attribute)
    1280           0 :                          (cons (read-face-attribute face (car attribute) frame)
    1281           0 :                                result))))))
    1282             : 
    1283             : (defun modify-face (&optional face foreground background stipple
    1284             :                               bold-p italic-p underline inverse-p frame)
    1285             :   "Modify attributes of faces interactively.
    1286             : If optional argument FRAME is nil or omitted, modify the face used
    1287             : for newly created frame, i.e. the global face.
    1288             : For non-interactive use, `set-face-attribute' is preferred.
    1289             : When called from Lisp, if FACE is nil, all arguments but FRAME are ignored
    1290             : and the face and its settings are obtained by querying the user."
    1291             :   (interactive)
    1292           0 :   (if face
    1293           0 :       (set-face-attribute face frame
    1294           0 :                           :foreground (or foreground 'unspecified)
    1295           0 :                           :background (or background 'unspecified)
    1296           0 :                           :stipple stipple
    1297           0 :                           :weight (if bold-p 'bold 'normal)
    1298           0 :                           :slant (if italic-p 'italic 'normal)
    1299           0 :                           :underline underline
    1300           0 :                           :inverse-video inverse-p)
    1301           0 :     (setq face (read-face-name "Modify face" (face-at-point t)))
    1302           0 :     (apply #'set-face-attribute face frame
    1303           0 :            (read-all-face-attributes face frame))))
    1304             : 
    1305             : (defun read-face-and-attribute (attribute &optional frame)
    1306             :   "Read face name and face attribute value.
    1307             : ATTRIBUTE is the attribute whose new value is read.
    1308             : FRAME nil or unspecified means read attribute value of global face.
    1309             : Value is a list (FACE NEW-VALUE) where FACE is the face read
    1310             : \(a symbol), and NEW-VALUE is value read."
    1311           0 :   (cond ((eq attribute :font)
    1312           0 :          (let* ((prompt "Set font-related attributes of face")
    1313           0 :                 (face (read-face-name prompt (face-at-point t)))
    1314           0 :                 (font (read-face-font face frame)))
    1315           0 :            (list face font)))
    1316             :         (t
    1317           0 :          (let* ((attribute-name (face-descriptive-attribute-name attribute))
    1318           0 :                 (prompt (format "Set %s of face" attribute-name))
    1319           0 :                 (face (read-face-name prompt (face-at-point t)))
    1320           0 :                 (new-value (read-face-attribute face attribute frame)))
    1321           0 :            (list face new-value)))))
    1322             : 
    1323             : 
    1324             : 
    1325             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1326             : ;;; Listing faces.
    1327             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1328             : 
    1329             : (defconst list-faces-sample-text
    1330             :   "abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    1331             :   "Text string to display as the sample text for `list-faces-display'.")
    1332             : 
    1333             : 
    1334             : ;; The name list-faces would be more consistent, but let's avoid a
    1335             : ;; conflict with Lucid, which uses that name differently.
    1336             : 
    1337             : (defvar help-xref-stack)
    1338             : (defun list-faces-display (&optional regexp)
    1339             :   "List all faces, using the same sample text in each.
    1340             : The sample text is a string that comes from the variable
    1341             : `list-faces-sample-text'.
    1342             : 
    1343             : If REGEXP is non-nil, list only those faces with names matching
    1344             : this regular expression.  When called interactively with a prefix
    1345             : argument, prompt for a regular expression using `read-regexp'."
    1346           0 :   (interactive (list (and current-prefix-arg
    1347           0 :                           (read-regexp "List faces matching regexp"))))
    1348           0 :   (let ((all-faces (zerop (length regexp)))
    1349           0 :         (frame (selected-frame))
    1350             :         (max-length 0)
    1351             :         faces line-format
    1352             :         disp-frame window face-name)
    1353             :     ;; We filter and take the max length in one pass
    1354           0 :     (setq faces
    1355           0 :           (delq nil
    1356           0 :                 (mapcar (lambda (f)
    1357           0 :                           (let ((s (symbol-name f)))
    1358           0 :                             (when (or all-faces (string-match-p regexp s))
    1359           0 :                               (setq max-length (max (length s) max-length))
    1360           0 :                               f)))
    1361           0 :                         (sort (face-list) #'string-lessp))))
    1362           0 :     (unless faces
    1363           0 :       (error "No faces matching \"%s\"" regexp))
    1364           0 :     (setq max-length (1+ max-length)
    1365           0 :           line-format (format "%%-%ds" max-length))
    1366           0 :     (with-help-window "*Faces*"
    1367           0 :       (with-current-buffer standard-output
    1368           0 :         (setq truncate-lines t)
    1369           0 :         (insert
    1370           0 :          (substitute-command-keys
    1371           0 :           (concat
    1372             :            "\\<help-mode-map>Use "
    1373           0 :            (if (display-mouse-p) "\\[help-follow-mouse] or ")
    1374             :            "\\[help-follow] on a face name to customize it\n"
    1375           0 :            "or on its sample text for a description of the face.\n\n")))
    1376           0 :         (setq help-xref-stack nil)
    1377           0 :         (dolist (face faces)
    1378           0 :           (setq face-name (symbol-name face))
    1379           0 :           (insert (format line-format face-name))
    1380             :           ;; Hyperlink to a customization buffer for the face.  Using
    1381             :           ;; the help xref mechanism may not be the best way.
    1382           0 :           (save-excursion
    1383           0 :             (save-match-data
    1384           0 :               (search-backward face-name)
    1385           0 :               (setq help-xref-stack-item `(list-faces-display ,regexp))
    1386           0 :               (help-xref-button 0 'help-customize-face face)))
    1387           0 :           (let ((beg (point))
    1388           0 :                 (line-beg (line-beginning-position)))
    1389           0 :             (insert list-faces-sample-text)
    1390             :             ;; Hyperlink to a help buffer for the face.
    1391           0 :             (save-excursion
    1392           0 :               (save-match-data
    1393           0 :                 (search-backward list-faces-sample-text)
    1394           0 :                 (help-xref-button 0 'help-face face)))
    1395           0 :             (insert "\n")
    1396           0 :             (put-text-property beg (1- (point)) 'face face)
    1397             :             ;; Make all face commands default to the proper face
    1398             :             ;; anywhere in the line.
    1399           0 :             (put-text-property line-beg (1- (point)) 'read-face-name face)
    1400             :             ;; If the sample text has multiple lines, line up all of them.
    1401           0 :             (goto-char beg)
    1402           0 :             (forward-line 1)
    1403           0 :             (while (not (eobp))
    1404           0 :               (insert-char ?\s max-length)
    1405           0 :               (forward-line 1))))
    1406           0 :         (goto-char (point-min))))
    1407             :     ;; If the *Faces* buffer appears in a different frame,
    1408             :     ;; copy all the face definitions from FRAME,
    1409             :     ;; so that the display will reflect the frame that was selected.
    1410           0 :     (setq window (get-buffer-window (get-buffer "*Faces*") t))
    1411           0 :     (setq disp-frame (if window (window-frame window)
    1412           0 :                        (car (frame-list))))
    1413           0 :     (or (eq frame disp-frame)
    1414           0 :         (dolist (face (face-list))
    1415           0 :           (copy-face face face frame disp-frame)))))
    1416             : 
    1417             : 
    1418             : (defun describe-face (face &optional frame)
    1419             :   "Display the properties of face FACE on FRAME.
    1420             : Interactively, FACE defaults to the faces of the character after point
    1421             : and FRAME defaults to the selected frame.
    1422             : 
    1423             : If the optional argument FRAME is given, report on face FACE in that frame.
    1424             : If FRAME is t, report on the defaults for face FACE (for new frames).
    1425             : If FRAME is omitted or nil, use the selected frame."
    1426           0 :   (interactive (list (read-face-name "Describe face"
    1427           0 :                                      (or (face-at-point t) 'default)
    1428           0 :                                      t)))
    1429           0 :   (let* ((attrs '((:family . "Family")
    1430             :                   (:foundry . "Foundry")
    1431             :                   (:width . "Width")
    1432             :                   (:height . "Height")
    1433             :                   (:weight . "Weight")
    1434             :                   (:slant . "Slant")
    1435             :                   (:foreground . "Foreground")
    1436             :                   (:distant-foreground . "DistantForeground")
    1437             :                   (:background . "Background")
    1438             :                   (:underline . "Underline")
    1439             :                   (:overline . "Overline")
    1440             :                   (:strike-through . "Strike-through")
    1441             :                   (:box . "Box")
    1442             :                   (:inverse-video . "Inverse")
    1443             :                   (:stipple . "Stipple")
    1444             :                   (:font . "Font")
    1445             :                   (:fontset . "Fontset")
    1446             :                   (:inherit . "Inherit")))
    1447           0 :         (max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x)))
    1448           0 :                                         attrs))))
    1449           0 :     (help-setup-xref (list #'describe-face face)
    1450           0 :                      (called-interactively-p 'interactive))
    1451           0 :     (unless face
    1452           0 :       (setq face 'default))
    1453           0 :     (if (not (listp face))
    1454           0 :         (setq face (list face)))
    1455           0 :     (with-help-window (help-buffer)
    1456           0 :       (with-current-buffer standard-output
    1457           0 :         (dolist (f face (buffer-string))
    1458           0 :           (if (stringp f) (setq f (intern f)))
    1459             :           ;; We may get called for anonymous faces (i.e., faces
    1460             :           ;; expressed using prop-value plists).  Those can't be
    1461             :           ;; usefully customized, so ignore them.
    1462           0 :           (when (symbolp f)
    1463           0 :             (insert "Face: " (symbol-name f))
    1464           0 :             (if (not (facep f))
    1465           0 :                 (insert "   undefined face.\n")
    1466           0 :               (let ((customize-label "customize this face")
    1467             :                     file-name)
    1468           0 :                 (insert (concat " (" (propertize "sample" 'font-lock-face f) ")"))
    1469           0 :                 (princ (concat " (" customize-label ")\n"))
    1470             :                 ;; FIXME not sure how much of this belongs here, and
    1471             :                 ;; how much in `face-documentation'.  The latter is
    1472             :                 ;; not used much, but needs to return nil for
    1473             :                 ;; undocumented faces.
    1474           0 :                 (let ((alias (get f 'face-alias))
    1475           0 :                       (face f)
    1476             :                       obsolete)
    1477           0 :                   (when alias
    1478           0 :                     (setq face alias)
    1479           0 :                     (insert
    1480           0 :                      (format-message
    1481             :                       "\n  %s is an alias for the face `%s'.\n%s"
    1482           0 :                       f alias
    1483           0 :                       (if (setq obsolete (get f 'obsolete-face))
    1484           0 :                           (format-message
    1485             :                            "  This face is obsolete%s; use `%s' instead.\n"
    1486           0 :                            (if (stringp obsolete)
    1487           0 :                                (format " since %s" obsolete)
    1488           0 :                              "")
    1489           0 :                            alias)
    1490           0 :                         ""))))
    1491           0 :                   (insert "\nDocumentation:\n"
    1492           0 :                           (substitute-command-keys
    1493           0 :                            (or (face-documentation face)
    1494           0 :                                "Not documented as a face."))
    1495           0 :                           "\n\n"))
    1496           0 :                 (with-current-buffer standard-output
    1497           0 :                   (save-excursion
    1498           0 :                     (re-search-backward
    1499           0 :                      (concat "\\(" customize-label "\\)") nil t)
    1500           0 :                     (help-xref-button 1 'help-customize-face f)))
    1501           0 :                 (setq file-name (find-lisp-object-file-name f 'defface))
    1502           0 :                 (when file-name
    1503           0 :                   (princ (substitute-command-keys "Defined in `"))
    1504           0 :                   (princ (file-name-nondirectory file-name))
    1505           0 :                   (princ (substitute-command-keys "'"))
    1506             :                   ;; Make a hyperlink to the library.
    1507           0 :                   (save-excursion
    1508           0 :                     (re-search-backward
    1509           0 :                      (substitute-command-keys "`\\([^`']+\\)'") nil t)
    1510           0 :                     (help-xref-button 1 'help-face-def f file-name))
    1511           0 :                   (princ ".")
    1512           0 :                   (terpri)
    1513           0 :                   (terpri))
    1514           0 :                 (dolist (a attrs)
    1515           0 :                   (let ((attr (face-attribute f (car a) frame)))
    1516           0 :                     (insert (make-string (- max-width (length (cdr a))) ?\s)
    1517           0 :                             (cdr a) ": " (format "%s" attr))
    1518           0 :                     (if (and (eq (car a) :inherit)
    1519           0 :                              (not (eq attr 'unspecified)))
    1520             :                         ;; Make a hyperlink to the parent face.
    1521           0 :                         (save-excursion
    1522           0 :                           (re-search-backward ": \\([^:]+\\)" nil t)
    1523           0 :                           (help-xref-button 1 'help-face attr)))
    1524           0 :                     (insert "\n")))))
    1525           0 :             (terpri)))))))
    1526             : 
    1527             : 
    1528             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1529             : ;;; Face specifications (defface).
    1530             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1531             : 
    1532             : ;; Parameter FRAME Is kept for call compatibility to with previous
    1533             : ;; face implementation.
    1534             : 
    1535             : (defun face-attr-construct (face &optional _frame)
    1536             :   "Return a `defface'-style attribute list for FACE.
    1537             : Value is a property list of pairs ATTRIBUTE VALUE for all specified
    1538             : face attributes of FACE where ATTRIBUTE is the attribute name and
    1539             : VALUE is the specified value of that attribute.
    1540             : Argument FRAME is ignored and retained for compatibility."
    1541           0 :   (let (result)
    1542           0 :     (dolist (entry face-attribute-name-alist result)
    1543           0 :       (let* ((attribute (car entry))
    1544           0 :              (value (face-attribute face attribute)))
    1545           0 :         (unless (eq value 'unspecified)
    1546           0 :           (setq result (nconc (list attribute value) result)))))))
    1547             : 
    1548             : 
    1549             : (defun face-spec-set-match-display (display frame)
    1550             :   "Non-nil if DISPLAY matches FRAME.
    1551             : DISPLAY is part of a spec such as can be used in `defface'.
    1552             : If FRAME is nil, the current FRAME is used."
    1553         547 :   (let* ((conjuncts display)
    1554             :          conjunct req options
    1555             :          ;; t means we have succeeded against all the conjuncts in
    1556             :          ;; DISPLAY that have been tested so far.
    1557             :          (match t))
    1558         547 :     (if (eq conjuncts t)
    1559         547 :         (setq conjuncts nil))
    1560         902 :     (while (and conjuncts match)
    1561         355 :       (setq conjunct (car conjuncts)
    1562         355 :             conjuncts (cdr conjuncts)
    1563         355 :             req (car conjunct)
    1564         355 :             options (cdr conjunct)
    1565         355 :             match (cond ((eq req 'type)
    1566          24 :                          (or (memq (window-system frame) options)
    1567          24 :                              (and (memq 'graphic options)
    1568          24 :                                   (memq (window-system frame) '(x w32 ns)))
    1569             :                              ;; FIXME: This should be revisited to use
    1570             :                              ;; display-graphic-p, provided that the
    1571             :                              ;; color selection depends on the number
    1572             :                              ;; of supported colors, and all defface's
    1573             :                              ;; are changed to look at number of colors
    1574             :                              ;; instead of (type graphic) etc.
    1575          24 :                              (if (null (window-system frame))
    1576          24 :                                  (memq 'tty options)
    1577           0 :                                (or (and (memq 'motif options)
    1578           0 :                                         (featurep 'motif))
    1579           0 :                                    (and (memq 'gtk options)
    1580           0 :                                         (featurep 'gtk))
    1581           0 :                                    (and (memq 'lucid options)
    1582           0 :                                         (featurep 'x-toolkit)
    1583           0 :                                         (not (featurep 'motif))
    1584           0 :                                         (not (featurep 'gtk)))
    1585           0 :                                    (and (memq 'x-toolkit options)
    1586          24 :                                         (featurep 'x-toolkit))))))
    1587         331 :                         ((eq req 'min-colors)
    1588           1 :                          (>= (display-color-cells frame) (car options)))
    1589         330 :                         ((eq req 'class)
    1590         306 :                          (memq (frame-parameter frame 'display-type) options))
    1591          24 :                         ((eq req 'background)
    1592          16 :                          (memq (frame-parameter frame 'background-mode)
    1593          16 :                                options))
    1594           8 :                         ((eq req 'supports)
    1595           8 :                          (display-supports-face-attributes-p options frame))
    1596           0 :                         (t (error "Unknown req `%S' with options `%S'"
    1597         547 :                                   req options)))))
    1598         547 :     match))
    1599             : 
    1600             : 
    1601             : (defun face-spec-choose (spec &optional frame no-match-retval)
    1602             :   "Return the proper attributes for FRAME, out of SPEC.
    1603             : 
    1604             : Value is a plist of face attributes in the form of attribute-value pairs.
    1605             : If no match is found or SPEC is nil, return nil, unless NO-MATCH-RETVAL
    1606             : is given, in which case return its value instead."
    1607         386 :   (unless frame
    1608         386 :     (setq frame (selected-frame)))
    1609         386 :   (let ((tail spec)
    1610             :         result defaults match-found)
    1611         979 :     (while tail
    1612        1186 :       (let* ((entry (pop tail))
    1613         593 :              (display (car entry))
    1614         593 :              (attrs (cdr entry))
    1615             :              thisval)
    1616             :         ;; Get the attributes as actually specified by this alternative.
    1617         593 :         (setq thisval
    1618         593 :               (if (null (cdr attrs)) ;; was (listp (car attrs))
    1619             :                   ;; Old-style entry, the attribute list is the
    1620             :                   ;; first element.
    1621         103 :                   (car attrs)
    1622         593 :                 attrs))
    1623             : 
    1624             :         ;; If the condition is `default', that sets the default
    1625             :         ;; for following conditions.
    1626         593 :         (if (eq display 'default)
    1627          46 :             (setq defaults thisval)
    1628             :           ;; Otherwise, if it matches, use it.
    1629         547 :           (when (face-spec-set-match-display display frame)
    1630         212 :             (setq result thisval
    1631             :                   tail nil
    1632         593 :                   match-found t)))))
    1633             :     ;; If defaults have been found, it's safe to just append those to the result
    1634             :     ;; list (which at this point will be either nil or contain actual specs) and
    1635             :     ;; return it to the caller. Since there will most definitely be something to
    1636             :     ;; return in this case, there's no need to know/check if a match was found.
    1637         386 :     (if defaults
    1638          44 :         (append result defaults)
    1639         342 :       (if match-found
    1640         204 :           result
    1641         386 :         no-match-retval))))
    1642             : 
    1643             : ;; When over 80 faces get processed at frame creation time, all but
    1644             : ;; one specifying all attributes as "unspecified", generating this
    1645             : ;; list every time means a lot of consing.
    1646             : (defconst face--attributes-unspecified
    1647             :   (apply 'append
    1648             :          (mapcar (lambda (x) (list (car x) 'unspecified))
    1649             :                  face-attribute-name-alist)))
    1650             : 
    1651             : (defun face-spec-reset-face (face &optional frame)
    1652             :   "Reset all attributes of FACE on FRAME to unspecified."
    1653         129 :   (apply 'set-face-attribute face frame
    1654         129 :          (if (eq face 'default)
    1655             :              ;; For the default face, avoid making any attribute
    1656             :              ;; unspecified.  Instead, set attributes to default values
    1657             :              ;; (see also realize_default_face in xfaces.c).
    1658           0 :              (append
    1659             :               '(:underline nil :overline nil :strike-through nil
    1660             :                 :box nil :inverse-video nil :stipple nil :inherit nil)
    1661             :               ;; `display-graphic-p' is unavailable when running
    1662             :               ;; temacs, prior to loading frame.el.
    1663           0 :               (when (fboundp 'display-graphic-p)
    1664           0 :                 (unless (display-graphic-p frame)
    1665           0 :                   `(:family "default" :foundry "default" :width normal
    1666             :                     :height 1 :weight normal :slant normal
    1667           0 :                     :foreground ,(if (frame-parameter nil 'reverse)
    1668             :                                      "unspecified-bg"
    1669           0 :                                    "unspecified-fg")
    1670           0 :                     :background ,(if (frame-parameter nil 'reverse)
    1671             :                                      "unspecified-fg"
    1672           0 :                                    "unspecified-bg")))))
    1673             :            ;; For all other faces, unspecify all attributes.
    1674         129 :            face--attributes-unspecified)))
    1675             : 
    1676             : (defun face-spec-set (face spec &optional spec-type)
    1677             :   "Set the FACE's spec SPEC, define FACE, and recalculate its attributes.
    1678             : See `defface' for the format of SPEC.
    1679             : 
    1680             : The appearance of each face is controlled by its specs (set via
    1681             : this function), and by the internal frame-specific face
    1682             : attributes (set via `set-face-attribute').
    1683             : 
    1684             : This function also defines FACE as a valid face name if it is not
    1685             : already one, and (re)calculates its attributes on existing
    1686             : frames.
    1687             : 
    1688             : The optional argument SPEC-TYPE determines which spec to set:
    1689             :   nil, omitted or `face-override-spec' means the override spec,
    1690             :     which overrides all the other types of spec mentioned below
    1691             :     (this is usually what you want if calling this function
    1692             :     outside of Custom code);
    1693             :   `customized-face' or `saved-face' means the customized spec or
    1694             :     the saved custom spec;
    1695             :   `face-defface-spec' means the default spec
    1696             :     (usually set only via `defface');
    1697             :   `reset' means to ignore SPEC, but clear the `customized-face'
    1698             :     and `face-override-spec' specs;
    1699             : Any other value means not to set any spec, but to run the
    1700             : function for defining FACE and recalculating its attributes."
    1701           2 :   (if (get face 'face-alias)
    1702           2 :       (setq face (get face 'face-alias)))
    1703             :   ;; Save SPEC to the relevant symbol property.
    1704           2 :   (unless spec-type
    1705           2 :     (setq spec-type 'face-override-spec))
    1706           2 :   (if (memq spec-type '(face-defface-spec face-override-spec
    1707           2 :                         customized-face saved-face))
    1708           2 :       (put face spec-type spec))
    1709           2 :   (if (memq spec-type '(reset saved-face))
    1710           2 :       (put face 'customized-face nil))
    1711             :   ;; Setting the face spec via Custom empties out any override spec,
    1712             :   ;; similar to how setting a variable via Custom changes its values.
    1713           2 :   (if (memq spec-type '(customized-face saved-face reset))
    1714           2 :       (put face 'face-override-spec nil))
    1715             :   ;; If we reset the face based on its custom spec, it is unmodified
    1716             :   ;; as far as Custom is concerned.
    1717           2 :   (unless (eq face 'face-override-spec)
    1718           2 :     (put face 'face-modified nil))
    1719             :   ;; Initialize the face if it does not exist, then recalculate.
    1720           2 :   (make-empty-face face)
    1721           2 :   (dolist (frame (frame-list))
    1722           2 :     (face-spec-recalc face frame)))
    1723             : 
    1724             : (defun face-spec-recalc (face frame)
    1725             :   "Reset the face attributes of FACE on FRAME according to its specs.
    1726             : The following sources are applied in this order:
    1727             : 
    1728             :   face reset to default values if it's the default face, otherwise set
    1729             :   to unspecified (through `face-spec-reset-face')
    1730             :    |
    1731             :   (theme and user customization)
    1732             :     or: if none of the above exist, and none match the current frame or
    1733             :         inherited from the defface spec instead of overwriting it
    1734             :         entirely, the following is applied instead:
    1735             :   (defface default spec)
    1736             :   (X resources (if applicable))
    1737             :    |
    1738             :   defface override spec"
    1739         129 :   (while (get face 'face-alias)
    1740         129 :     (setq face (get face 'face-alias)))
    1741         129 :   (face-spec-reset-face face frame)
    1742             :   ;; If FACE is customized or themed, set the custom spec from
    1743             :   ;; `theme-face' records.
    1744         129 :   (let ((theme-faces (get face 'theme-face))
    1745             :         (no-match-found 0)
    1746             :         face-attrs theme-face-applied)
    1747         129 :     (if theme-faces
    1748           0 :         (dolist (elt (reverse theme-faces))
    1749           0 :           (setq face-attrs (face-spec-choose (cadr elt) frame no-match-found))
    1750           0 :           (unless (eq face-attrs no-match-found)
    1751           0 :             (face-spec-set-2 face frame face-attrs)
    1752         129 :             (setq theme-face-applied t))))
    1753             :     ;; If there was a spec applicable to FRAME, that overrides the
    1754             :     ;; defface spec entirely (rather than inheriting from it).  If
    1755             :     ;; there was no spec applicable to FRAME, apply the defface spec
    1756             :     ;; as well as any applicable X resources.
    1757         129 :     (unless theme-face-applied
    1758         129 :       (setq face-attrs (face-spec-choose (face-default-spec face) frame))
    1759         129 :       (face-spec-set-2 face frame face-attrs)
    1760         129 :       (make-face-x-resource-internal face frame))
    1761         129 :     (setq face-attrs (face-spec-choose (get face 'face-override-spec) frame))
    1762         129 :     (face-spec-set-2 face frame face-attrs)))
    1763             : 
    1764             : (defun face-spec-set-2 (face frame face-attrs)
    1765             :   "Set the face attributes of FACE on FRAME according to FACE-ATTRS.
    1766             : FACE-ATTRS is a plist of face attributes in the form of attribute-value
    1767             : pairs."
    1768         258 :   (let (attrs)
    1769         392 :     (while face-attrs
    1770         134 :       (when (assq (car face-attrs) face-x-resources)
    1771         268 :         (push (car face-attrs) attrs)
    1772         268 :         (push (cadr face-attrs) attrs))
    1773         258 :       (setq face-attrs (cddr face-attrs)))
    1774         258 :     (apply 'set-face-attribute face frame (nreverse attrs))))
    1775             : 
    1776             : (defun face-attr-match-p (face attrs &optional frame)
    1777             :   "Return t if attributes of FACE match values in plist ATTRS.
    1778             : Optional parameter FRAME is the frame whose definition of FACE
    1779             : is used.  If nil or omitted, use the selected frame."
    1780         128 :   (unless frame
    1781         128 :     (setq frame (selected-frame)))
    1782         128 :   (let* ((list face-attribute-name-alist)
    1783             :          (match t)
    1784         128 :          (bold (and (plist-member attrs :bold)
    1785         128 :                     (not (plist-member attrs :weight))))
    1786         128 :          (italic (and (plist-member attrs :italic)
    1787         128 :                       (not (plist-member attrs :slant))))
    1788         128 :          (plist (if (or bold italic)
    1789           0 :                     (copy-sequence attrs)
    1790         128 :                   attrs)))
    1791             :     ;; Handle the Emacs 20 :bold and :italic properties.
    1792         128 :     (if bold
    1793         128 :         (plist-put plist :weight (if bold 'bold 'normal)))
    1794         128 :     (if italic
    1795         128 :         (plist-put plist :slant (if italic 'italic 'normal)))
    1796        2040 :     (while (and match list)
    1797        1912 :       (let* ((attr (caar list))
    1798             :              (specified-value
    1799        1912 :               (if (plist-member plist attr)
    1800         133 :                   (plist-get plist attr)
    1801        1912 :                 'unspecified))
    1802        1912 :              (value-now (face-attribute face attr frame)))
    1803        1912 :         (setq match (equal specified-value value-now))
    1804        1912 :         (setq list (cdr list))))
    1805         128 :     match))
    1806             : 
    1807             : (defsubst face-spec-match-p (face spec &optional frame)
    1808             :   "Return t if FACE, on FRAME, matches what SPEC says it should look like."
    1809           0 :   (face-attr-match-p face (face-spec-choose spec frame) frame))
    1810             : 
    1811             : (defsubst face-default-spec (face)
    1812             :   "Return the default face-spec for FACE, ignoring any user customization.
    1813             : If there is no default for FACE, return nil."
    1814         129 :   (get face 'face-defface-spec))
    1815             : 
    1816             : (defsubst face-user-default-spec (face)
    1817             :   "Return the user's customized face-spec for FACE, or the default if none.
    1818             : If there is neither a user setting nor a default for FACE, return nil."
    1819           0 :   (or (get face 'customized-face)
    1820           0 :       (get face 'saved-face)
    1821           0 :       (face-default-spec face)))
    1822             : 
    1823             : 
    1824             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1825             : ;;; Frame-type independent color support.
    1826             : ;;; We keep the old x-* names as aliases for back-compatibility.
    1827             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1828             : 
    1829             : (defun defined-colors (&optional frame)
    1830             :   "Return a list of colors supported for a particular frame.
    1831             : The argument FRAME specifies which frame to try.
    1832             : The value may be different for frames on different display types.
    1833             : If FRAME doesn't support colors, the value is nil.
    1834             : If FRAME is nil, that stands for the selected frame."
    1835           0 :   (if (memq (framep (or frame (selected-frame))) '(x w32 ns))
    1836           0 :       (xw-defined-colors frame)
    1837           0 :     (mapcar 'car (tty-color-alist frame))))
    1838             : (defalias 'x-defined-colors 'defined-colors)
    1839             : 
    1840             : (defun defined-colors-with-face-attributes (&optional frame)
    1841             :   "Return a list of colors supported for a particular frame.
    1842             : See `defined-colors' for arguments and return value. In contrast
    1843             : to `define-colors' the elements of the returned list are color
    1844             : strings with text properties, that make the color names render
    1845             : with the color they represent as background color."
    1846           0 :   (mapcar
    1847             :    (lambda (color-name)
    1848           0 :      (let ((foreground (readable-foreground-color color-name))
    1849           0 :            (color      (copy-sequence color-name)))
    1850           0 :        (propertize color 'face (list :foreground foreground
    1851           0 :                                      :background color))))
    1852           0 :    (defined-colors frame)))
    1853             : 
    1854             : (defun readable-foreground-color (color)
    1855             :   "Return a readable foreground color for background COLOR."
    1856           0 :   (let* ((rgb   (color-values color))
    1857           0 :          (max   (apply #'max rgb))
    1858           0 :          (black (car (color-values "black")))
    1859           0 :          (white (car (color-values "white"))))
    1860             :     ;; Select black or white depending on which one is less similar to
    1861             :     ;; the brightest component.
    1862           0 :     (if (> (abs (- max black)) (abs (- max white)))
    1863             :         "black"
    1864           0 :       "white")))
    1865             : 
    1866             : (declare-function xw-color-defined-p "xfns.c" (color &optional frame))
    1867             : 
    1868             : (defun color-defined-p (color &optional frame)
    1869             :   "Return non-nil if COLOR is supported on frame FRAME.
    1870             : COLOR should be a string naming a color (e.g. \"white\"), or a
    1871             : string specifying a color's RGB components (e.g. \"#ff12ec\"), or
    1872             : the symbol `unspecified'.
    1873             : 
    1874             : This function returns nil if COLOR is the symbol `unspecified',
    1875             : or one of the strings \"unspecified-fg\" or \"unspecified-bg\".
    1876             : 
    1877             : If FRAME is omitted or nil, use the selected frame."
    1878           0 :   (unless (member color '(unspecified "unspecified-bg" "unspecified-fg"))
    1879           0 :     (if (member (framep (or frame (selected-frame))) '(x w32 ns))
    1880           0 :         (xw-color-defined-p color frame)
    1881           0 :       (numberp (tty-color-translate color frame)))))
    1882             : (defalias 'x-color-defined-p 'color-defined-p)
    1883             : 
    1884             : (declare-function xw-color-values "xfns.c" (color &optional frame))
    1885             : 
    1886             : (defun color-values (color &optional frame)
    1887             :   "Return a description of the color named COLOR on frame FRAME.
    1888             : COLOR should be a string naming a color (e.g. \"white\"), or a
    1889             : string specifying a color's RGB components (e.g. \"#ff12ec\").
    1890             : 
    1891             : Return a list of three integers, (RED GREEN BLUE), each between 0
    1892             : and either 65280 or 65535 (the maximum depends on the system).
    1893             : Use `color-name-to-rgb' if you want RGB floating-point values
    1894             : normalized to 1.0.
    1895             : 
    1896             : If FRAME is omitted or nil, use the selected frame.
    1897             : If FRAME cannot display COLOR, the value is nil.
    1898             : 
    1899             : COLOR can also be the symbol `unspecified' or one of the strings
    1900             : \"unspecified-fg\" or \"unspecified-bg\", in which case the
    1901             : return value is nil."
    1902           1 :   (cond
    1903           1 :    ((member color '(unspecified "unspecified-fg" "unspecified-bg"))
    1904             :     nil)
    1905           0 :    ((memq (framep (or frame (selected-frame))) '(x w32 ns))
    1906           0 :     (xw-color-values color frame))
    1907             :    (t
    1908           1 :     (tty-color-values color frame))))
    1909             : 
    1910             : (defalias 'x-color-values 'color-values)
    1911             : 
    1912             : (declare-function xw-display-color-p "xfns.c" (&optional terminal))
    1913             : 
    1914             : (defun display-color-p (&optional display)
    1915             :   "Return t if DISPLAY supports color.
    1916             : The optional argument DISPLAY specifies which display to ask about.
    1917             : DISPLAY should be either a frame or a display name (a string).
    1918             : If omitted or nil, that stands for the selected frame's display."
    1919           0 :   (if (memq (framep-on-display display) '(x w32 ns))
    1920           0 :       (xw-display-color-p display)
    1921           0 :     (tty-display-color-p display)))
    1922             : (defalias 'x-display-color-p 'display-color-p)
    1923             : 
    1924             : (declare-function x-display-grayscale-p "xfns.c" (&optional terminal))
    1925             : 
    1926             : (defun display-grayscale-p (&optional display)
    1927             :   "Return non-nil if frames on DISPLAY can display shades of gray.
    1928             : DISPLAY should be either a frame or a display name (a string).
    1929             : If omitted or nil, that stands for the selected frame's display."
    1930           0 :   (let ((frame-type (framep-on-display display)))
    1931           0 :     (cond
    1932           0 :      ((memq frame-type '(x w32 ns))
    1933           0 :       (x-display-grayscale-p display))
    1934             :      (t
    1935           0 :       (> (tty-color-gray-shades display) 2)))))
    1936             : 
    1937             : (defun read-color (&optional prompt convert-to-RGB allow-empty-name msg)
    1938             :   "Read a color name or RGB triplet.
    1939             : Completion is available for color names, but not for RGB triplets.
    1940             : 
    1941             : RGB triplets have the form \"#RRGGBB\".  Each of the R, G, and B
    1942             : components can have one to four digits, but all three components
    1943             : must have the same number of digits.  Each digit is a hex value
    1944             : between 0 and F; either upper case or lower case for A through F
    1945             : are acceptable.
    1946             : 
    1947             : In addition to standard color names and RGB hex values, the
    1948             : following are available as color candidates.  In each case, the
    1949             : corresponding color is used.
    1950             : 
    1951             :  * `foreground at point'   - foreground under the cursor
    1952             :  * `background at point'   - background under the cursor
    1953             : 
    1954             : Optional arg PROMPT is the prompt; if nil, use a default prompt.
    1955             : 
    1956             : Interactively, or with optional arg CONVERT-TO-RGB-P non-nil,
    1957             : convert an input color name to an RGB hex string.  Return the RGB
    1958             : hex string.
    1959             : 
    1960             : If optional arg ALLOW-EMPTY-NAME is non-nil, the user is allowed
    1961             : to enter an empty color name (the empty string).
    1962             : 
    1963             : Interactively, or with optional arg MSG non-nil, print the
    1964             : resulting color name in the echo area."
    1965             :   (interactive "i\np\ni\np")    ; Always convert to RGB interactively.
    1966           0 :   (let* ((completion-ignore-case t)
    1967           0 :          (colors (or facemenu-color-alist
    1968           0 :                      (append '("foreground at point" "background at point")
    1969           0 :                              (if allow-empty-name '(""))
    1970           0 :                              (if (display-color-p)
    1971           0 :                                  (defined-colors-with-face-attributes)
    1972           0 :                                (defined-colors)))))
    1973           0 :          (color (completing-read
    1974           0 :                  (or prompt "Color (name or #RGB triplet): ")
    1975             :                  ;; Completing function for reading colors, accepting
    1976             :                  ;; both color names and RGB triplets.
    1977             :                  (lambda (string pred flag)
    1978           0 :                    (cond
    1979           0 :                     ((null flag)        ; Try completion.
    1980           0 :                      (or (try-completion string colors pred)
    1981           0 :                          (if (color-defined-p string)
    1982           0 :                              string)))
    1983           0 :                     ((eq flag t)        ; List all completions.
    1984           0 :                      (or (all-completions string colors pred)
    1985           0 :                          (if (color-defined-p string)
    1986           0 :                              (list string))))
    1987           0 :                     ((eq flag 'lambda)  ; Test completion.
    1988           0 :                      (or (member string colors)
    1989           0 :                          (color-defined-p string)))))
    1990           0 :                  nil t)))
    1991             : 
    1992             :     ;; Process named colors.
    1993           0 :     (when (member color colors)
    1994           0 :       (cond ((string-equal color "foreground at point")
    1995           0 :              (setq color (foreground-color-at-point)))
    1996           0 :             ((string-equal color "background at point")
    1997           0 :              (setq color (background-color-at-point))))
    1998           0 :       (when (and convert-to-RGB
    1999           0 :                  (not (string-equal color "")))
    2000           0 :         (let ((components (x-color-values color)))
    2001           0 :           (unless (string-match-p "^#\\(?:[a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color)
    2002           0 :             (setq color (format "#%04X%04X%04X"
    2003           0 :                                 (logand 65535 (nth 0 components))
    2004           0 :                                 (logand 65535 (nth 1 components))
    2005           0 :                                 (logand 65535 (nth 2 components))))))))
    2006           0 :     (when msg (message "Color: `%s'" color))
    2007           0 :     color))
    2008             : 
    2009             : (defun face-at-point (&optional thing multiple)
    2010             :   "Return the face of the character after point.
    2011             : If it has more than one face, return the first one.
    2012             : If THING is non-nil try first to get a face name from the buffer.
    2013             : IF MULTIPLE is non-nil, return a list of all faces.
    2014             : Return nil if there is no face."
    2015           0 :   (let (faces)
    2016           0 :     (if thing
    2017             :         ;; Try to get a face name from the buffer.
    2018           0 :         (let ((face (intern-soft (thing-at-point 'symbol))))
    2019           0 :           (if (facep face)
    2020           0 :               (push face faces))))
    2021             :     ;; Add the named faces that the `read-face-name' or `face' property uses.
    2022           0 :     (let ((faceprop (or (get-char-property (point) 'read-face-name)
    2023           0 :                         (get-char-property (point) 'face))))
    2024           0 :       (cond ((facep faceprop)
    2025           0 :              (push faceprop faces))
    2026           0 :             ((face-list-p faceprop)
    2027           0 :              (dolist (face faceprop)
    2028           0 :                (if (facep face)
    2029           0 :                    (push face faces))))))
    2030           0 :     (if multiple
    2031           0 :         (delete-dups (nreverse faces))
    2032           0 :       (car (last faces)))))
    2033             : 
    2034             : (defun faces--attribute-at-point (attribute &optional attribute-unnamed)
    2035             :   "Return the face ATTRIBUTE at point.
    2036             : ATTRIBUTE is a keyword.
    2037             : If ATTRIBUTE-UNNAMED is non-nil, it is a symbol to look for in
    2038             : unnamed faces (e.g, `foreground-color')."
    2039             :   ;; `face-at-point' alone is not sufficient.  It only gets named faces.
    2040             :   ;; Need also pick up any face properties that are not associated with named faces.
    2041           0 :   (let ((faces (or (get-char-property (point) 'read-face-name)
    2042             :                    ;; If `font-lock-mode' is on, `font-lock-face' takes precedence.
    2043           0 :                    (and font-lock-mode
    2044           0 :                         (get-char-property (point) 'font-lock-face))
    2045           0 :                    (get-char-property (point) 'face)))
    2046             :         (found nil))
    2047           0 :     (dolist (face (if (face-list-p faces)
    2048           0 :                       faces
    2049           0 :                     (list faces)))
    2050           0 :       (cond (found)
    2051           0 :             ((and face (symbolp face))
    2052           0 :              (let ((value (face-attribute-specified-or
    2053             :                            (face-attribute face attribute nil t)
    2054           0 :                            nil)))
    2055           0 :                (unless (member value '(nil "unspecified-fg" "unspecified-bg"))
    2056           0 :                  (setq found value))))
    2057           0 :             ((consp face)
    2058           0 :              (setq found (cond ((and attribute-unnamed
    2059           0 :                                      (memq attribute-unnamed face))
    2060           0 :                                 (cdr (memq attribute-unnamed face)))
    2061           0 :                                ((memq attribute face) (cadr (memq attribute face))))))))
    2062           0 :     (or found
    2063           0 :         (face-attribute 'default attribute))))
    2064             : 
    2065             : (defun foreground-color-at-point ()
    2066             :   "Return the foreground color of the character after point."
    2067           0 :   (faces--attribute-at-point :foreground 'foreground-color))
    2068             : 
    2069             : (defun background-color-at-point ()
    2070             :   "Return the background color of the character after point."
    2071           0 :   (faces--attribute-at-point :background 'background-color))
    2072             : 
    2073             : 
    2074             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    2075             : ;;; Frame creation.
    2076             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    2077             : 
    2078             : (declare-function x-display-list "xfns.c" ())
    2079             : (declare-function x-open-connection "xfns.c"
    2080             :                   (display &optional xrm-string must-succeed))
    2081             : (declare-function x-get-resource "frame.c"
    2082             :                   (attribute class &optional component subclass))
    2083             : (declare-function x-parse-geometry "frame.c" (string))
    2084             : (defvar x-display-name)
    2085             : 
    2086             : (defun x-handle-named-frame-geometry (parameters)
    2087             :   "Add geometry parameters for a named frame to parameter list PARAMETERS.
    2088             : Value is the new parameter list."
    2089             :   ;; Note that `x-resource-name' has a global meaning.
    2090           0 :   (let ((x-resource-name (cdr (assq 'name parameters))))
    2091           0 :     (when x-resource-name
    2092             :       ;; Before checking X resources, we must have an X connection.
    2093           0 :       (or (window-system)
    2094           0 :           (x-display-list)
    2095           0 :           (x-open-connection (or (cdr (assq 'display parameters))
    2096           0 :                                  x-display-name)))
    2097           0 :       (let (res-geometry parsed)
    2098           0 :         (and (setq res-geometry (x-get-resource "geometry" "Geometry"))
    2099           0 :              (setq parsed (x-parse-geometry res-geometry))
    2100           0 :              (setq parameters
    2101           0 :                    (append parameters parsed
    2102             :                            ;; If the resource specifies a position,
    2103             :                            ;; take note of that.
    2104           0 :                            (if (or (assq 'top parsed) (assq 'left parsed))
    2105           0 :                                '((user-position . t) (user-size . t)))))))))
    2106           0 :   parameters)
    2107             : 
    2108             : 
    2109             : (defun x-handle-reverse-video (frame parameters)
    2110             :   "Handle the reverse-video frame parameter and X resource.
    2111             : `x-create-frame' does not handle this one."
    2112           0 :   (when (cdr (or (assq 'reverse parameters)
    2113           0 :                  (let ((resource (x-get-resource "reverseVideo"
    2114           0 :                                                  "ReverseVideo")))
    2115           0 :                    (if resource
    2116           0 :                        (cons nil (member (downcase resource)
    2117           0 :                                          '("on" "true")))))))
    2118           0 :       (let* ((params (frame-parameters frame))
    2119           0 :              (bg (cdr (assq 'foreground-color params)))
    2120           0 :              (fg (cdr (assq 'background-color params))))
    2121           0 :         (modify-frame-parameters frame
    2122           0 :                                  (list (cons 'foreground-color fg)
    2123           0 :                                        (cons 'background-color bg)))
    2124           0 :         (if (equal bg (cdr (assq 'border-color params)))
    2125           0 :             (modify-frame-parameters frame
    2126           0 :                                      (list (cons 'border-color fg))))
    2127           0 :         (if (equal bg (cdr (assq 'mouse-color params)))
    2128           0 :             (modify-frame-parameters frame
    2129           0 :                                      (list (cons 'mouse-color fg))))
    2130           0 :         (if (equal bg (cdr (assq 'cursor-color params)))
    2131           0 :             (modify-frame-parameters frame
    2132           0 :                                      (list (cons 'cursor-color fg)))))))
    2133             : 
    2134             : (declare-function x-create-frame "xfns.c" (parms))
    2135             : (declare-function x-setup-function-keys "term/common-win" (frame))
    2136             : 
    2137             : (defun x-create-frame-with-faces (&optional parameters)
    2138             :   "Create and return a frame with frame parameters PARAMETERS.
    2139             : If PARAMETERS specify a frame name, handle X geometry resources
    2140             : for that name.  If PARAMETERS includes a `reverse' parameter, or
    2141             : the X resource \"reverseVideo\" is present, handle that."
    2142           0 :   (setq parameters (x-handle-named-frame-geometry parameters))
    2143           0 :   (let* ((params (copy-tree parameters))
    2144           0 :          (visibility-spec (assq 'visibility parameters))
    2145             :          (delayed-params '(foreground-color background-color font
    2146             :                            border-color cursor-color mouse-color
    2147             :                            visibility scroll-bar-foreground
    2148             :                            scroll-bar-background))
    2149             :          frame success)
    2150           0 :     (dolist (param delayed-params)
    2151           0 :       (setq params (assq-delete-all param params)))
    2152           0 :     (setq frame (x-create-frame `((visibility . nil) . ,params)))
    2153           0 :     (unwind-protect
    2154           0 :         (progn
    2155           0 :           (x-setup-function-keys frame)
    2156           0 :           (x-handle-reverse-video frame parameters)
    2157           0 :           (frame-set-background-mode frame t)
    2158           0 :           (face-set-after-frame-default frame parameters)
    2159           0 :           (if (null visibility-spec)
    2160           0 :               (make-frame-visible frame)
    2161           0 :             (modify-frame-parameters frame (list visibility-spec)))
    2162           0 :           (setq success t))
    2163           0 :       (unless success
    2164           0 :         (delete-frame frame)))
    2165           0 :     frame))
    2166             : 
    2167             : (defun face-set-after-frame-default (frame &optional parameters)
    2168             :   "Initialize the frame-local faces of FRAME.
    2169             : Calculate the face definitions using the face specs, custom theme
    2170             : settings, X resources, and `face-new-frame-defaults'.
    2171             : Finally, apply any relevant face attributes found amongst the
    2172             : frame parameters in PARAMETERS."
    2173             :   ;; The `reverse' is so that `default' goes first.
    2174           0 :   (dolist (face (nreverse (face-list)))
    2175           0 :     (condition-case ()
    2176           0 :         (progn
    2177             :           ;; Initialize faces from face spec and custom theme.
    2178           0 :           (face-spec-recalc face frame)
    2179             :           ;; Apply attributes specified by face-new-frame-defaults
    2180           0 :           (internal-merge-in-global-face face frame))
    2181             :       ;; Don't let invalid specs prevent frame creation.
    2182           0 :       (error nil)))
    2183             : 
    2184             :   ;; Apply attributes specified by frame parameters.
    2185           0 :   (let ((face-params '((foreground-color default :foreground)
    2186             :                        (background-color default :background)
    2187             :                        (font default :font)
    2188             :                        (border-color border :background)
    2189             :                        (cursor-color cursor :background)
    2190             :                        (scroll-bar-foreground scroll-bar :foreground)
    2191             :                        (scroll-bar-background scroll-bar :background)
    2192             :                        (mouse-color mouse :background))))
    2193           0 :     (dolist (param face-params)
    2194           0 :       (let* ((param-name (nth 0 param))
    2195           0 :              (value (cdr (assq param-name parameters))))
    2196           0 :         (if value
    2197           0 :             (set-face-attribute (nth 1 param) frame
    2198           0 :                                 (nth 2 param) value))))))
    2199             : 
    2200             : (defun tty-handle-reverse-video (frame parameters)
    2201             :   "Handle the reverse-video frame parameter for terminal frames."
    2202           0 :   (when (cdr (assq 'reverse parameters))
    2203           0 :     (let* ((params (frame-parameters frame))
    2204           0 :            (bg (cdr (assq 'foreground-color params)))
    2205           0 :            (fg (cdr (assq 'background-color params))))
    2206           0 :       (modify-frame-parameters frame
    2207           0 :                                (list (cons 'foreground-color fg)
    2208           0 :                                      (cons 'background-color bg)))
    2209           0 :       (if (equal bg (cdr (assq 'mouse-color params)))
    2210           0 :           (modify-frame-parameters frame
    2211           0 :                                    (list (cons 'mouse-color fg))))
    2212           0 :       (if (equal bg (cdr (assq 'cursor-color params)))
    2213           0 :           (modify-frame-parameters frame
    2214           0 :                                    (list (cons 'cursor-color fg)))))))
    2215             : 
    2216             : 
    2217             : (defun tty-create-frame-with-faces (&optional parameters)
    2218             :   "Create and return a frame from optional frame parameters PARAMETERS.
    2219             : If PARAMETERS contains a `reverse' parameter, handle that."
    2220           0 :   (let ((frame (make-terminal-frame parameters))
    2221             :         success)
    2222           0 :     (unwind-protect
    2223           0 :         (with-selected-frame frame
    2224           0 :           (tty-handle-reverse-video frame (frame-parameters frame))
    2225             : 
    2226           0 :           (unless (terminal-parameter frame 'terminal-initted)
    2227           0 :             (set-terminal-parameter frame 'terminal-initted t)
    2228           0 :             (set-locale-environment nil frame)
    2229           0 :             (tty-run-terminal-initialization frame nil t))
    2230           0 :           (frame-set-background-mode frame t)
    2231           0 :           (face-set-after-frame-default frame parameters)
    2232           0 :           (setq success t))
    2233           0 :       (unless success
    2234           0 :         (delete-frame frame)))
    2235           0 :     frame))
    2236             : 
    2237             : (defun tty-find-type (pred type)
    2238             :   "Return the longest prefix of TYPE to which PRED returns non-nil.
    2239             : TYPE should be a tty type name such as \"xterm-16color\".
    2240             : 
    2241             : The function tries only those prefixes that are followed by a
    2242             : dash or underscore in the original type name, like \"xterm\" in
    2243             : the above example."
    2244           0 :   (let (hyphend)
    2245           0 :     (while (and type
    2246           0 :                 (not (funcall pred type)))
    2247             :       ;; Strip off last hyphen and what follows, then try again
    2248           0 :       (setq type
    2249           0 :             (if (setq hyphend (string-match-p "[-_][^-_]+$" type))
    2250           0 :                 (substring type 0 hyphend)
    2251           0 :               nil))))
    2252           0 :   type)
    2253             : 
    2254             : (defvar tty-setup-hook nil
    2255             :   "Hook run after running the initialization function of a new text terminal.
    2256             : Specifically, `tty-run-terminal-initialization' runs this.
    2257             : This can be used to fine tune the `input-decode-map', for example.")
    2258             : 
    2259             : (defun tty-run-terminal-initialization (frame &optional type run-hook)
    2260             :   "Run the special initialization code for the terminal type of FRAME.
    2261             : The optional TYPE parameter may be used to override the autodetected
    2262             : terminal type to a different value.
    2263             : 
    2264             : This consults `term-file-aliases' to map terminal types to their aliases.
    2265             : 
    2266             : If optional argument RUN-HOOK is non-nil, then as a final step,
    2267             : this runs the hook `tty-setup-hook'.
    2268             : 
    2269             : If you set `term-file-prefix' to nil, this function does nothing."
    2270           0 :   (setq type (or type (tty-type frame)))
    2271           0 :   (let ((alias (tty-find-type
    2272           0 :                 (lambda (typ) (assoc typ term-file-aliases)) type)))
    2273           0 :     (if alias (setq type (cdr (assoc alias term-file-aliases)))))
    2274             :   ;; Load library for our terminal type.
    2275             :   ;; User init file can set term-file-prefix to nil to prevent this.
    2276           0 :   (with-selected-frame frame
    2277           0 :     (unless (null term-file-prefix)
    2278           0 :       (let* (term-init-func)
    2279             :         ;; First, load the terminal initialization file, if it is
    2280             :         ;; available and it hasn't been loaded already.
    2281           0 :         (tty-find-type #'(lambda (type)
    2282           0 :                            (let ((file (locate-library (concat term-file-prefix type))))
    2283           0 :                              (and file
    2284           0 :                                   (or (assoc file load-history)
    2285           0 :                                       (load file t t)))))
    2286           0 :                        type)
    2287             :         ;; Next, try to find a matching initialization function, and call it.
    2288           0 :         (tty-find-type #'(lambda (type)
    2289           0 :                            (fboundp (setq term-init-func
    2290           0 :                                           (intern (concat "terminal-init-" type)))))
    2291           0 :                        type)
    2292           0 :         (when (fboundp term-init-func)
    2293           0 :           (funcall term-init-func))
    2294           0 :         (set-terminal-parameter frame 'terminal-initted term-init-func)
    2295           0 :         (if run-hook (run-hooks 'tty-setup-hook))))))
    2296             : 
    2297             : ;; Called from C function init_display to initialize faces of the
    2298             : ;; dumped terminal frame on startup.
    2299             : 
    2300             : (defun tty-set-up-initial-frame-faces ()
    2301           0 :   (let ((frame (selected-frame)))
    2302           0 :     (frame-set-background-mode frame t)
    2303           0 :     (face-set-after-frame-default frame)))
    2304             : 
    2305             : 
    2306             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    2307             : ;;; Standard faces.
    2308             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    2309             : 
    2310             : (defgroup basic-faces nil
    2311             :   "The standard faces of Emacs."
    2312             :   :group 'faces)
    2313             : 
    2314             : (defface default
    2315             :   '((t nil)) ; If this were nil, face-defface-spec would not be set.
    2316             :   "Basic default face."
    2317             :   :group 'basic-faces)
    2318             : 
    2319             : (defface bold
    2320             :   '((t :weight bold))
    2321             :   "Basic bold face."
    2322             :   :group 'basic-faces)
    2323             : 
    2324             : (defface italic
    2325             :   '((((supports :slant italic))
    2326             :      :slant italic)
    2327             :     (((supports :underline t))
    2328             :      :underline t)
    2329             :     (t
    2330             :      ;; Default to italic, even if it doesn't appear to be supported,
    2331             :      ;; because in some cases the display engine will do its own
    2332             :      ;; workaround (to `dim' on ttys).
    2333             :      :slant italic))
    2334             :   "Basic italic face."
    2335             :   :group 'basic-faces)
    2336             : 
    2337             : (defface bold-italic
    2338             :   '((t :weight bold :slant italic))
    2339             :   "Basic bold-italic face."
    2340             :   :group 'basic-faces)
    2341             : 
    2342             : (defface underline
    2343             :   '((((supports :underline t))
    2344             :      :underline t)
    2345             :     (((supports :weight bold))
    2346             :      :weight bold)
    2347             :     (t :underline t))
    2348             :   "Basic underlined face."
    2349             :   :group 'basic-faces)
    2350             : 
    2351             : (defface fixed-pitch
    2352             :   '((t :family "Monospace"))
    2353             :   "The basic fixed-pitch face."
    2354             :   :group 'basic-faces)
    2355             : 
    2356             : (defface fixed-pitch-serif
    2357             :   '((t :family "Monospace Serif"))
    2358             :   "The basic fixed-pitch face with serifs."
    2359             :   :group 'basic-faces)
    2360             : 
    2361             : (defface variable-pitch
    2362             :   '((((type w32))
    2363             :      ;; This is a workaround for an issue discussed in
    2364             :      ;; http://lists.gnu.org/archive/html/emacs-devel/2016-04/msg00746.html.
    2365             :      ;; We need (a) the splash screen not to pick up bold-italics variant of
    2366             :      ;; the font, and (b) still be able to request bold/italic/larger size
    2367             :      ;; variants in the likes of EWW.
    2368             :      :family "Arial" :foundry "outline")
    2369             :   (t :family "Sans Serif"))
    2370             :   "The basic variable-pitch face."
    2371             :   :group 'basic-faces)
    2372             : 
    2373             : (defface shadow
    2374             :   '((((class color grayscale) (min-colors 88) (background light))
    2375             :      :foreground "grey50")
    2376             :     (((class color grayscale) (min-colors 88) (background dark))
    2377             :      :foreground "grey70")
    2378             :     (((class color) (min-colors 8) (background light))
    2379             :      :foreground "green")
    2380             :     (((class color) (min-colors 8) (background dark))
    2381             :      :foreground "yellow"))
    2382             :   "Basic face for shadowed text."
    2383             :   :group 'basic-faces
    2384             :   :version "22.1")
    2385             : 
    2386             : (defface link
    2387             :   '((((class color) (min-colors 88) (background light))
    2388             :      :foreground "RoyalBlue3" :underline t)
    2389             :     (((class color) (background light))
    2390             :      :foreground "blue" :underline t)
    2391             :     (((class color) (min-colors 88) (background dark))
    2392             :      :foreground "cyan1" :underline t)
    2393             :     (((class color) (background dark))
    2394             :      :foreground "cyan" :underline t)
    2395             :     (t :inherit underline))
    2396             :   "Basic face for unvisited links."
    2397             :   :group 'basic-faces
    2398             :   :version "22.1")
    2399             : 
    2400             : (defface link-visited
    2401             :   '((default :inherit link)
    2402             :     (((class color) (background light)) :foreground "magenta4")
    2403             :     (((class color) (background dark)) :foreground "violet"))
    2404             :   "Basic face for visited links."
    2405             :   :group 'basic-faces
    2406             :   :version "22.1")
    2407             : 
    2408             : (defface highlight
    2409             :   '((((class color) (min-colors 88) (background light))
    2410             :      :background "darkseagreen2")
    2411             :     (((class color) (min-colors 88) (background dark))
    2412             :      :background "darkolivegreen")
    2413             :     (((class color) (min-colors 16) (background light))
    2414             :      :background "darkseagreen2")
    2415             :     (((class color) (min-colors 16) (background dark))
    2416             :      :background "darkolivegreen")
    2417             :     (((class color) (min-colors 8))
    2418             :      :background "green" :foreground "black")
    2419             :     (t :inverse-video t))
    2420             :   "Basic face for highlighting."
    2421             :   :group 'basic-faces)
    2422             : 
    2423             : ;; Region face: under NS, default to the system-defined selection
    2424             : ;; color (optimized for the fixed white background of other apps),
    2425             : ;; if background is light.
    2426             : (defface region
    2427             :   '((((class color) (min-colors 88) (background dark))
    2428             :      :background "blue3")
    2429             :     (((class color) (min-colors 88) (background light) (type gtk))
    2430             :      :distant-foreground "gtk_selection_fg_color"
    2431             :      :background "gtk_selection_bg_color")
    2432             :     (((class color) (min-colors 88) (background light) (type ns))
    2433             :      :distant-foreground "ns_selection_fg_color"
    2434             :      :background "ns_selection_bg_color")
    2435             :     (((class color) (min-colors 88) (background light))
    2436             :      :background "lightgoldenrod2")
    2437             :     (((class color) (min-colors 16) (background dark))
    2438             :      :background "blue3")
    2439             :     (((class color) (min-colors 16) (background light))
    2440             :      :background "lightgoldenrod2")
    2441             :     (((class color) (min-colors 8))
    2442             :      :background "blue" :foreground "white")
    2443             :     (((type tty) (class mono))
    2444             :      :inverse-video t)
    2445             :     (t :background "gray"))
    2446             :   "Basic face for highlighting the region."
    2447             :   :version "21.1"
    2448             :   :group 'basic-faces)
    2449             : 
    2450             : (defface secondary-selection
    2451             :   '((((class color) (min-colors 88) (background light))
    2452             :      :background "yellow1")
    2453             :     (((class color) (min-colors 88) (background dark))
    2454             :      :background "SkyBlue4")
    2455             :     (((class color) (min-colors 16) (background light))
    2456             :      :background "yellow")
    2457             :     (((class color) (min-colors 16) (background dark))
    2458             :      :background "SkyBlue4")
    2459             :     (((class color) (min-colors 8))
    2460             :      :background "cyan" :foreground "black")
    2461             :     (t :inverse-video t))
    2462             :   "Basic face for displaying the secondary selection."
    2463             :   :group 'basic-faces)
    2464             : 
    2465             : (defface trailing-whitespace
    2466             :   '((((class color) (background light))
    2467             :      :background "red1")
    2468             :     (((class color) (background dark))
    2469             :      :background "red1")
    2470             :     (t :inverse-video t))
    2471             :   "Basic face for highlighting trailing whitespace."
    2472             :   :version "21.1"
    2473             :   :group 'basic-faces)
    2474             : 
    2475             : ;; Definition stolen from linum.el.
    2476             : (defface line-number
    2477             :   '((t :inherit (shadow default)))
    2478             :   "Face for displaying line numbers.
    2479             : This face is used when `display-line-numbers' is non-nil.
    2480             : 
    2481             : If you customize the font of this face, make sure it is a
    2482             : monospaced font, otherwise line numbers will not line up,
    2483             : and text lines might move horizontally as you move through
    2484             : the buffer."
    2485             :   :version "26.1"
    2486             :   :group 'basic-faces)
    2487             : 
    2488             : (defface line-number-current-line
    2489             :   '((t :inherit line-number))
    2490             :   "Face for displaying the current line number.
    2491             : This face is used when `display-line-numbers' is non-nil.
    2492             : 
    2493             : If you customize the font of this face, make sure it is a
    2494             : monospaced font, otherwise line numbers will not line up,
    2495             : and text lines might move horizontally as you move through
    2496             : the buffer.  Similarly, making this face's font different
    2497             : from that of the `line-number' face could produce such
    2498             : unwanted effects."
    2499             :   :version "26.1"
    2500             :   :group 'basic-faces)
    2501             : 
    2502             : (defface escape-glyph
    2503             :   '((((background dark)) :foreground "cyan")
    2504             :     ;; See the comment in minibuffer-prompt for
    2505             :     ;; the reason not to use blue on MS-DOS.
    2506             :     (((type pc)) :foreground "magenta")
    2507             :     ;; red4 is too dark, but some say blue is too loud.
    2508             :     ;; brown seems to work ok. -- rms.
    2509             :     (t :foreground "brown"))
    2510             :   "Face for characters displayed as sequences using `^' or `\\'."
    2511             :   :group 'basic-faces
    2512             :   :version "22.1")
    2513             : 
    2514             : (defface homoglyph
    2515             :   '((((background dark)) :foreground "cyan")
    2516             :     (((type pc)) :foreground "magenta")
    2517             :     (t :foreground "brown"))
    2518             :   "Face for lookalike characters."
    2519             :   :group 'basic-faces
    2520             :   :version "26.1")
    2521             : 
    2522             : (defface nobreak-space
    2523             :   '((((class color) (min-colors 88)) :inherit escape-glyph :underline t)
    2524             :     (((class color) (min-colors 8)) :background "magenta")
    2525             :     (t :inverse-video t))
    2526             :   "Face for displaying nobreak space."
    2527             :   :group 'basic-faces
    2528             :   :version "22.1")
    2529             : 
    2530             : (defface nobreak-hyphen
    2531             :   '((((background dark)) :foreground "cyan")
    2532             :     (((type pc)) :foreground "magenta")
    2533             :     (t :foreground "brown"))
    2534             :   "Face for displaying nobreak hyphens."
    2535             :   :group 'basic-faces
    2536             :   :version "26.1")
    2537             : 
    2538             : (defgroup mode-line-faces nil
    2539             :   "Faces used in the mode line."
    2540             :   :group 'mode-line
    2541             :   :group 'faces
    2542             :   :version "22.1")
    2543             : 
    2544             : (defface mode-line
    2545             :   '((((class color) (min-colors 88))
    2546             :      :box (:line-width -1 :style released-button)
    2547             :      :background "grey75" :foreground "black")
    2548             :     (t
    2549             :      :inverse-video t))
    2550             :   "Basic mode line face for selected window."
    2551             :   :version "21.1"
    2552             :   :group 'mode-line-faces
    2553             :   :group 'basic-faces)
    2554             : 
    2555             : (defface mode-line-inactive
    2556             :   '((default
    2557             :      :inherit mode-line)
    2558             :     (((class color) (min-colors 88) (background light))
    2559             :      :weight light
    2560             :      :box (:line-width -1 :color "grey75" :style nil)
    2561             :      :foreground "grey20" :background "grey90")
    2562             :     (((class color) (min-colors 88) (background dark) )
    2563             :      :weight light
    2564             :      :box (:line-width -1 :color "grey40" :style nil)
    2565             :      :foreground "grey80" :background "grey30"))
    2566             :   "Basic mode line face for non-selected windows."
    2567             :   :version "22.1"
    2568             :   :group 'mode-line-faces
    2569             :   :group 'basic-faces)
    2570             : 
    2571             : (defface mode-line-highlight
    2572             :   '((((class color) (min-colors 88))
    2573             :      :box (:line-width 2 :color "grey40" :style released-button))
    2574             :     (t
    2575             :      :inherit highlight))
    2576             :   "Basic mode line face for highlighting."
    2577             :   :version "22.1"
    2578             :   :group 'mode-line-faces
    2579             :   :group 'basic-faces)
    2580             : 
    2581             : (defface mode-line-emphasis
    2582             :   '((t (:weight bold)))
    2583             :   "Face used to emphasize certain mode line features.
    2584             : Use the face `mode-line-highlight' for features that can be selected."
    2585             :   :version "23.1"
    2586             :   :group 'mode-line-faces
    2587             :   :group 'basic-faces)
    2588             : 
    2589             : (defface mode-line-buffer-id
    2590             :   '((t (:weight bold)))
    2591             :   "Face used for buffer identification parts of the mode line."
    2592             :   :version "22.1"
    2593             :   :group 'mode-line-faces
    2594             :   :group 'basic-faces)
    2595             : 
    2596             : (defface header-line
    2597             :   '((default
    2598             :      :inherit mode-line)
    2599             :     (((type tty))
    2600             :      ;; This used to be `:inverse-video t', but that doesn't look very
    2601             :      ;; good when combined with inverse-video mode-lines and multiple
    2602             :      ;; windows.  Underlining looks better, and is more consistent with
    2603             :      ;; the window-system face variants, which deemphasize the
    2604             :      ;; header-line in relation to the mode-line face.  If a terminal
    2605             :      ;; can't underline, then the header-line will end up without any
    2606             :      ;; highlighting; this may be too confusing in general, although it
    2607             :      ;; happens to look good with the only current use of header-lines,
    2608             :      ;; the info browser. XXX
    2609             :      :inverse-video nil        ;Override the value inherited from mode-line.
    2610             :      :underline t)
    2611             :     (((class color grayscale) (background light))
    2612             :      :background "grey90" :foreground "grey20"
    2613             :      :box nil)
    2614             :     (((class color grayscale) (background dark))
    2615             :      :background "grey20" :foreground "grey90"
    2616             :      :box nil)
    2617             :     (((class mono) (background light))
    2618             :      :background "white" :foreground "black"
    2619             :      :inverse-video nil
    2620             :      :box nil
    2621             :      :underline t)
    2622             :     (((class mono) (background dark))
    2623             :      :background "black" :foreground "white"
    2624             :      :inverse-video nil
    2625             :      :box nil
    2626             :      :underline t))
    2627             :   "Basic header-line face."
    2628             :   :version "21.1"
    2629             :   :group 'basic-faces)
    2630             : 
    2631             : (defface header-line-highlight '((t :inherit highlight))
    2632             :   "Basic header line face for highlighting."
    2633             :   :version "26.1"
    2634             :   :group 'basic-faces)
    2635             : 
    2636             : (defface vertical-border
    2637             :   '((((type tty)) :inherit mode-line-inactive))
    2638             :   "Face used for vertical window dividers on ttys."
    2639             :   :version "22.1"
    2640             :   :group 'basic-faces)
    2641             : 
    2642             : (defface window-divider '((t :foreground "gray60"))
    2643             :   "Basic face for window dividers.
    2644             : When a divider is less than 3 pixels wide, it is drawn solidly
    2645             : with the foreground of this face.  For larger dividers this face
    2646             : is used for the inner part while the first pixel line/column is
    2647             : drawn with the `window-divider-first-pixel' face and the last
    2648             : pixel line/column with the `window-divider-last-pixel' face."
    2649             :   :version "24.4"
    2650             :   :group 'window-divider
    2651             :   :group 'basic-faces)
    2652             : 
    2653             : (defface window-divider-first-pixel
    2654             :   '((t :foreground "gray80"))
    2655             :   "Basic face for first pixel line/column of window dividers.
    2656             : When a divider is at least 3 pixels wide, its first pixel
    2657             : line/column is drawn with the foreground of this face.  If you do
    2658             : not want to accentuate the first pixel line/column, set this to
    2659             : the same as `window-divider' face."
    2660             :   :version "24.4"
    2661             :   :group 'window-divider
    2662             :   :group 'basic-faces)
    2663             : 
    2664             : (defface window-divider-last-pixel
    2665             :   '((t :foreground "gray40"))
    2666             :   "Basic face for last pixel line/column of window dividers.
    2667             : When a divider is at least 3 pixels wide, its last pixel
    2668             : line/column is drawn with the foreground of this face.  If you do
    2669             : not want to accentuate the last pixel line/column, set this to
    2670             : the same as `window-divider' face."
    2671             :   :version "24.4"
    2672             :   :group 'window-divider
    2673             :   :group 'basic-faces)
    2674             : 
    2675             : (defface internal-border
    2676             :     '((t nil))
    2677             :   "Basic face for the internal border."
    2678             :   :version "26.1"
    2679             :   :group 'frames
    2680             :   :group 'basic-faces)
    2681             : 
    2682             : (defface minibuffer-prompt
    2683             :   '((((background dark)) :foreground "cyan")
    2684             :     ;; Don't use blue because many users of the MS-DOS port customize
    2685             :     ;; their foreground color to be blue.
    2686             :     (((type pc)) :foreground "magenta")
    2687             :     (t :foreground "medium blue"))
    2688             :   "Face for minibuffer prompts.
    2689             : By default, Emacs automatically adds this face to the value of
    2690             : `minibuffer-prompt-properties', which is a list of text properties
    2691             : used to display the prompt text."
    2692             :   :version "22.1"
    2693             :   :group 'basic-faces)
    2694             : 
    2695             : (setq minibuffer-prompt-properties
    2696             :       (append minibuffer-prompt-properties (list 'face 'minibuffer-prompt)))
    2697             : 
    2698             : (defface fringe
    2699             :   '((((class color) (background light))
    2700             :      :background "grey95")
    2701             :     (((class color) (background dark))
    2702             :      :background "grey10")
    2703             :     (t
    2704             :      :background "gray"))
    2705             :   "Basic face for the fringes to the left and right of windows under X."
    2706             :   :version "21.1"
    2707             :   :group 'frames
    2708             :   :group 'basic-faces)
    2709             : 
    2710             : (defface scroll-bar '((t nil))
    2711             :   "Basic face for the scroll bar colors under X."
    2712             :   :version "21.1"
    2713             :   :group 'frames
    2714             :   :group 'basic-faces)
    2715             : 
    2716             : (defface border '((t nil))
    2717             :   "Basic face for the frame border under X."
    2718             :   :version "21.1"
    2719             :   :group 'frames
    2720             :   :group 'basic-faces)
    2721             : 
    2722             : (defface cursor
    2723             :   '((((background light)) :background "black")
    2724             :     (((background dark))  :background "white"))
    2725             :   "Basic face for the cursor color under X.
    2726             : Currently, only the `:background' attribute is meaningful; all
    2727             : other attributes are ignored.  The cursor foreground color is
    2728             : taken from the background color of the underlying text.
    2729             : 
    2730             : Note: Other faces cannot inherit from the cursor face."
    2731             :   :version "21.1"
    2732             :   :group 'cursor
    2733             :   :group 'basic-faces)
    2734             : 
    2735             : (put 'cursor 'face-no-inherit t)
    2736             : 
    2737             : (defface mouse '((t nil))
    2738             :   "Basic face for the mouse color under X."
    2739             :   :version "21.1"
    2740             :   :group 'mouse
    2741             :   :group 'basic-faces)
    2742             : 
    2743             : (defface tool-bar
    2744             :   '((default
    2745             :      :box (:line-width 1 :style released-button)
    2746             :      :foreground "black")
    2747             :     (((type x w32 ns) (class color))
    2748             :      :background "grey75")
    2749             :     (((type x) (class mono))
    2750             :      :background "grey"))
    2751             :   "Basic tool-bar face."
    2752             :   :version "21.1"
    2753             :   :group 'basic-faces)
    2754             : 
    2755             : (defface menu
    2756             :   '((((type tty))
    2757             :      :inverse-video t)
    2758             :     (((type x-toolkit))
    2759             :      )
    2760             :     (t
    2761             :      :inverse-video t))
    2762             :   "Basic face for the font and colors of the menu bar and popup menus."
    2763             :   :version "21.1"
    2764             :   :group 'menu
    2765             :   :group 'basic-faces)
    2766             : 
    2767             : (defface help-argument-name '((t :inherit italic))
    2768             :   "Face to highlight argument names in *Help* buffers."
    2769             :   :group 'help)
    2770             : 
    2771             : (defface glyphless-char
    2772             :   '((((type tty)) :inherit underline)
    2773             :     (((type pc)) :inherit escape-glyph)
    2774             :     (t :height 0.6))
    2775             :   "Face for displaying non-graphic characters (e.g. U+202A (LRE)).
    2776             : It is used for characters of no fonts too."
    2777             :   :version "24.1"
    2778             :   :group 'basic-faces)
    2779             : 
    2780             : (defface error
    2781             :   '((default :weight bold)
    2782             :     (((class color) (min-colors 88) (background light)) :foreground "Red1")
    2783             :     (((class color) (min-colors 88) (background dark))  :foreground "Pink")
    2784             :     (((class color) (min-colors 16) (background light)) :foreground "Red1")
    2785             :     (((class color) (min-colors 16) (background dark))  :foreground "Pink")
    2786             :     (((class color) (min-colors 8)) :foreground "red")
    2787             :     (t :inverse-video t))
    2788             :   "Basic face used to highlight errors and to denote failure."
    2789             :   :version "24.1"
    2790             :   :group 'basic-faces)
    2791             : 
    2792             : (defface warning
    2793             :   '((default :weight bold)
    2794             :     (((class color) (min-colors 16)) :foreground "DarkOrange")
    2795             :     (((class color)) :foreground "yellow"))
    2796             :   "Basic face used to highlight warnings."
    2797             :   :version "24.1"
    2798             :   :group 'basic-faces)
    2799             : 
    2800             : (defface success
    2801             :   '((default :weight bold)
    2802             :     (((class color) (min-colors 16) (background light)) :foreground "ForestGreen")
    2803             :     (((class color) (min-colors 88) (background dark))  :foreground "Green1")
    2804             :     (((class color) (min-colors 16) (background dark))  :foreground "Green")
    2805             :     (((class color)) :foreground "green"))
    2806             :   "Basic face used to indicate successful operation."
    2807             :   :version "24.1"
    2808             :   :group 'basic-faces)
    2809             : 
    2810             : (defface read-multiple-choice-face
    2811             :   '((t (:inherit underline
    2812             :         :weight bold)))
    2813             :   "Face for the symbol name in `read-multiple-choice' output."
    2814             :   :group 'basic-faces
    2815             :   :version "26.1")
    2816             : 
    2817             : ;; Faces for TTY menus.
    2818             : (defface tty-menu-enabled-face
    2819             :   '((t
    2820             :      :foreground "yellow" :background "blue" :weight bold))
    2821             :   "Face for displaying enabled items in TTY menus."
    2822             :   :group 'basic-faces)
    2823             : 
    2824             : (defface tty-menu-disabled-face
    2825             :   '((((class color) (min-colors 16))
    2826             :      :foreground "lightgray" :background "blue")
    2827             :     (t
    2828             :      :foreground "white" :background "blue"))
    2829             :   "Face for displaying disabled items in TTY menus."
    2830             :   :group 'basic-faces)
    2831             : 
    2832             : (defface tty-menu-selected-face
    2833             :   '((t :background "red"))
    2834             :   "Face for displaying the currently selected item in TTY menus."
    2835             :   :group 'basic-faces)
    2836             : 
    2837             : (defgroup paren-showing-faces nil
    2838             :   "Faces used to highlight paren matches."
    2839             :   :group 'paren-showing
    2840             :   :group 'faces
    2841             :   :version "22.1")
    2842             : 
    2843             : (defface show-paren-match
    2844             :   '((((class color) (background light))
    2845             :      :background "turquoise")         ; looks OK on tty (becomes cyan)
    2846             :     (((class color) (background dark))
    2847             :      :background "steelblue3")                ; looks OK on tty (becomes blue)
    2848             :     (((background dark) (min-colors 4))
    2849             :      :background "grey50")
    2850             :     (((background light) (min-colors 4))
    2851             :      :background "gray")
    2852             :     (t
    2853             :      :inherit underline))
    2854             :   "Face used for a matching paren."
    2855             :   :group 'paren-showing-faces)
    2856             : 
    2857             : (defface show-paren-match-expression
    2858             :   '((t :inherit show-paren-match))
    2859             :   "Face used for a matching paren when highlighting the whole expression.
    2860             : This face is used by `show-paren-mode'."
    2861             :   :group 'paren-showing-faces
    2862             :   :version "26.1")
    2863             : 
    2864             : (defface show-paren-mismatch
    2865             :   '((((class color)) (:foreground "white" :background "purple"))
    2866             :     (t (:inverse-video t)))
    2867             :   "Face used for a mismatching paren."
    2868             :   :group 'paren-showing-faces)
    2869             : 
    2870             : 
    2871             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    2872             : ;;; Manipulating font names.
    2873             : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    2874             : 
    2875             : ;; This is here for compatibility with Emacs 20.2.  For example,
    2876             : ;; international/fontset.el uses x-resolve-font-name.  The following
    2877             : ;; functions are not used in the face implementation itself.
    2878             : 
    2879             : (defvar x-font-regexp nil)
    2880             : (defvar x-font-regexp-head nil)
    2881             : (defvar x-font-regexp-weight nil)
    2882             : (defvar x-font-regexp-slant nil)
    2883             : 
    2884             : (defconst x-font-regexp-weight-subnum 1)
    2885             : (defconst x-font-regexp-slant-subnum 2)
    2886             : (defconst x-font-regexp-swidth-subnum 3)
    2887             : (defconst x-font-regexp-adstyle-subnum 4)
    2888             : 
    2889             : ;;; Regexps matching font names in "Host Portable Character Representation."
    2890             : ;;;
    2891             : (let ((-                "[-?]")
    2892             :       (foundry          "[^-]+")
    2893             :       (family           "[^-]+")
    2894             :       (weight           "\\(bold\\|demibold\\|medium\\)")             ; 1
    2895             : ;     (weight\?         "\\(\\*\\|bold\\|demibold\\|medium\\|\\)")    ; 1
    2896             :       (weight\?         "\\([^-]*\\)")                                        ; 1
    2897             :       (slant            "\\([ior]\\)")                                        ; 2
    2898             : ;     (slant\?          "\\([ior?*]?\\)")                             ; 2
    2899             :       (slant\?          "\\([^-]?\\)")                                        ; 2
    2900             : ;     (swidth           "\\(\\*\\|normal\\|semicondensed\\|\\)")      ; 3
    2901             :       (swidth           "\\([^-]*\\)")                                        ; 3
    2902             : ;     (adstyle          "\\(\\*\\|sans\\|\\)")                                ; 4
    2903             :       (adstyle          "\\([^-]*\\)")                                        ; 4
    2904             :       (pixelsize        "[0-9]+")
    2905             :       (pointsize        "[0-9][0-9]+")
    2906             :       (resx             "[0-9][0-9]+")
    2907             :       (resy             "[0-9][0-9]+")
    2908             :       (spacing          "[cmp?*]")
    2909             :       (avgwidth         "[0-9]+")
    2910             :       (registry         "[^-]+")
    2911             :       (encoding         "[^-]+")
    2912             :       )
    2913             :   (setq x-font-regexp
    2914             :         (purecopy (concat "\\`\\*?[-?*]"
    2915             :                 foundry - family - weight\? - slant\? - swidth - adstyle -
    2916             :                 pixelsize - pointsize - resx - resy - spacing - avgwidth -
    2917             :                 registry - encoding "\\*?\\'"
    2918             :                 )))
    2919             :   (setq x-font-regexp-head
    2920             :         (purecopy (concat "\\`[-?*]" foundry - family - weight\? - slant\?
    2921             :                 "\\([-*?]\\|\\'\\)")))
    2922             :   (setq x-font-regexp-slant (purecopy (concat - slant -)))
    2923             :   (setq x-font-regexp-weight (purecopy (concat - weight -)))
    2924             :   nil)
    2925             : 
    2926             : 
    2927             : (defun x-resolve-font-name (pattern &optional face frame)
    2928             :   "Return a font name matching PATTERN.
    2929             : All wildcards in PATTERN are instantiated.
    2930             : If PATTERN is nil, return the name of the frame's base font, which never
    2931             : contains wildcards.
    2932             : Given optional arguments FACE and FRAME, return a font which is
    2933             : also the same size as FACE on FRAME, or fail."
    2934           0 :   (and (eq frame t)
    2935           0 :        (setq frame nil))
    2936           0 :   (if pattern
    2937             :       ;; Note that x-list-fonts has code to handle a face with nil as its font.
    2938           0 :       (let ((fonts (x-list-fonts pattern face frame 1)))
    2939           0 :         (or fonts
    2940           0 :             (if face
    2941           0 :                 (if (string-match-p "\\*" pattern)
    2942           0 :                     (if (null (face-font face))
    2943           0 :                         (error "No matching fonts are the same height as the frame default font")
    2944           0 :                       (error "No matching fonts are the same height as face `%s'" face))
    2945           0 :                   (if (null (face-font face))
    2946           0 :                       (error "Height of font `%s' doesn't match the frame default font"
    2947           0 :                              pattern)
    2948           0 :                     (error "Height of font `%s' doesn't match face `%s'"
    2949           0 :                            pattern face)))
    2950           0 :               (error "No fonts match `%s'" pattern)))
    2951           0 :         (car fonts))
    2952           0 :     (frame-parameter nil 'font)))
    2953             : 
    2954             : (defcustom font-list-limit 100
    2955             :   "This variable is obsolete and has no effect."
    2956             :   :type 'integer
    2957             :   :group 'display)
    2958             : (make-obsolete-variable 'font-list-limit nil "24.3")
    2959             : 
    2960             : (provide 'faces)
    2961             : 
    2962             : ;;; faces.el ends here

Generated by: LCOV version 1.12