cgit.sxemacs.org Git - sxemacs/blob - lisp/faces.el

   1 ;;; faces.el --- Lisp interface to the C "face" structure
   2
   3 ;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc.
   4 ;; Copyright (C) 1995 Board of Trustees, University of Illinois
   5 ;; Copyright (C) 1995, 1996 Ben Wing
   6
   7 ;; Author: Ben Wing <ben@xemacs.org>
   8 ;; Keywords: faces, internal, dumped
   9
  10 ;; This file is part of SXEmacs.
  11 ;; SXEmacs 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 ;; SXEmacs 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 this program.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Synched up with: Not synched with FSF.  Almost completely divergent.
  25
  26 ;;; Commentary:
  27
  28 ;; This file is dumped with SXEmacs.
  29
  30 ;; face implementation #1 (used Lisp vectors and parallel C vectors;
  31 ;; FSFmacs still uses this) authored by Jamie Zawinski <jwz@jwz.org>
  32 ;; pre Lucid-Emacs 19.0.
  33
  34 ;; face implementation #2 (used one face object per frame per face)
  35 ;; authored by Jamie Zawinski for 19.9.
  36
  37 ;; face implementation #3 (use one face object per face) originally
  38 ;; authored for 19.12 by Chuck Thompson <cthomp@cs.uiuc.edu>,
  39 ;; rewritten by Ben Wing with the advent of specifiers.
  40
  41
  42 ;;; Some stuff in FSF's faces.el is in our x-faces.el.
  43
  44 ;;; Code:
  45 (eval-when-compile (require 'font))
  46
  47 (defgroup faces nil
  48   "Support for multiple text attributes (fonts, colors, ...)
  49 Such a collection of attributes is called a \"face\"."
  50   :group 'emacs)
  51
  52
  53 (defun read-face-name (prompt)
  54   (let (face)
  55     (while (= (length face) 0) ; nil or ""
  56       (setq face (completing-read prompt
  57                                   (mapcar (lambda (x) (list (symbol-name x)))
  58                                           (face-list))
  59                                   nil t)))
  60     (intern face)))
  61
  62 (defun face-interactive (what &optional bool)
  63   (let* ((fn (intern (concat "face-" what "-instance")))
  64          (face (read-face-name (format "Set %s of face: " what)))
  65          (default (if (fboundp fn)
  66                       ;; #### we should distinguish here between
  67                       ;; explicitly setting the value to be the
  68                       ;; same as the default face's value, and
  69                       ;; not setting a value at all.
  70                       (funcall fn face)))
  71          (value (if bool
  72                     (y-or-n-p (format "Should face %s be %s? "
  73                                       (symbol-name face) bool))
  74                   (read-string (format "Set %s of face %s to: "
  75                                        what (symbol-name face))
  76                    (cond ((font-instance-p default)
  77                           (font-instance-name default))
  78                          ((color-instance-p default)
  79                           (color-instance-name default))
  80                          ((image-instance-p default)
  81                           (image-instance-file-name default))
  82                          (t default))))))
  83     (list face (if (equal value "") nil value))))
  84
  85 (defconst built-in-face-specifiers
  86   (built-in-face-specifiers)
  87   "A list of the built-in face properties that are specifiers.")
  88
  89 (defun face-property (face property &optional locale tag-set exact-p)
  90   "Return FACE's value of the given PROPERTY.
  91
  92 If LOCALE is omitted, the FACE's actual value for PROPERTY will be
  93   returned.  For built-in properties, this will be a specifier object
  94   of a type appropriate to the property (e.g. a font or color
  95   specifier).  For other properties, this could be anything.
  96
  97 If LOCALE is supplied, then instead of returning the actual value,
  98   the specification(s) for the given locale or locale type will
  99   be returned.  This will only work if the actual value of
 100   PROPERTY is a specifier (this will always be the case for built-in
 101   properties, but not or not may apply to user-defined properties).
 102   If the actual value of PROPERTY is not a specifier, this value
 103   will simply be returned regardless of LOCALE.
 104
 105 The return value will be a list of instantiators (e.g. strings
 106   specifying a font or color name), or a list of specifications, each
 107   of which is a cons of a locale and a list of instantiators.
 108   Specifically, if LOCALE is a particular locale (a buffer, window,
 109   frame, device, or 'global), a list of instantiators for that locale
 110   will be returned.  Otherwise, if LOCALE is a locale type (one of
 111   the symbols 'buffer, 'window, 'frame, or 'device), the specifications
 112   for all locales of that type will be returned.  Finally, if LOCALE is
 113   'all, the specifications for all locales of all types will be returned.
 114
 115 The specifications in a specifier determine what the value of
 116   PROPERTY will be in a particular \"domain\" or set of circumstances,
 117   which is typically a particular Emacs window along with the buffer
 118   it contains and the frame and device it lies within.  The value is
 119   derived from the instantiator associated with the most specific
 120   locale (in the order buffer, window, frame, device, and 'global)
 121   that matches the domain in question.  In other words, given a domain
 122   (i.e. an Emacs window, usually), the specifier for PROPERTY will
 123   first be searched for a specification whose locale is the buffer
 124   contained within that window; then for a specification whose locale
 125   is the window itself; then for a specification whose locale is the
 126   frame that the window is contained within; etc.  The first
 127   instantiator that is valid for the domain (usually this means that
 128   the instantiator is recognized by the device [i.e. MS Windows, the X
 129   server or TTY device] that the domain is on.  The function
 130   `face-property-instance' actually does all this, and is used to
 131   determine how to display the face.
 132
 133 See `set-face-property' for the built-in property-names."
 134
 135   (setq face (get-face face))
 136   (let ((value (get face property)))
 137     (if (and locale
 138              (or (memq property built-in-face-specifiers)
 139                  (specifierp value)))
 140         (setq value (specifier-specs value locale tag-set exact-p)))
 141     value))
 142
 143 (defun convert-face-property-into-specifier (face property)
 144   "Convert PROPERTY on FACE into a specifier, if it's not already."
 145   (setq face (get-face face))
 146   (let ((specifier (get face property)))
 147     ;; if a user-property does not have a specifier but a
 148     ;; locale was specified, put a specifier there.
 149     ;; If there was already a value there, convert it to a
 150     ;; specifier with the value as its 'global instantiator.
 151     (unless (specifierp specifier)
 152       (let ((new-specifier (make-specifier 'generic)))
 153         (if (or (not (null specifier))
 154                 ;; make sure the nil returned from `get' wasn't
 155                 ;; actually the value of the property
 156                 (null (get face property t)))
 157             (add-spec-to-specifier new-specifier specifier))
 158         (setq specifier new-specifier)
 159         (put face property specifier)))))
 160
 161 (defun face-property-instance (face property
 162                                     &optional domain default no-fallback)
 163   "Return the instance of FACE's PROPERTY in the specified DOMAIN.
 164
 165 Under most circumstances, DOMAIN will be a particular window,
 166   and the returned instance describes how the specified property
 167   actually is displayed for that window and the particular buffer
 168   in it.  Note that this may not be the same as how the property
 169   appears when the buffer is displayed in a different window or
 170   frame, or how the property appears in the same window if you
 171   switch to another buffer in that window; and in those cases,
 172   the returned instance would be different.
 173
 174 The returned instance will typically be a color-instance,
 175   font-instance, or pixmap-instance object, and you can query
 176   it using the appropriate object-specific functions.  For example,
 177   you could use `color-instance-rgb-components' to find out the
 178   RGB (red, green, and blue) components of how the 'background
 179   property of the 'highlight face is displayed in a particular
 180   window.  The results might be different from the results
 181   you would get for another window (perhaps the user
 182   specified a different color for the frame that window is on;
 183   or perhaps the same color was specified but the window is
 184   on a different X server, and that X server has different RGB
 185   values for the color from this one).
 186
 187 DOMAIN defaults to the selected window if omitted.
 188
 189 DOMAIN can be a frame or device, instead of a window.  The value
 190   returned for a such a domain is used in special circumstances
 191   when a more specific domain does not apply; for example, a frame
 192   value might be used for coloring a toolbar, which is conceptually
 193   attached to a frame rather than a particular window.  The value
 194   is also useful in determining what the value would be for a
 195   particular window within the frame or device, if it is not
 196   overridden by a more specific specification.
 197
 198 If PROPERTY does not name a built-in property, its value will
 199   simply be returned unless it is a specifier object, in which case
 200   it will be instanced using `specifier-instance'.
 201
 202 Optional arguments DEFAULT and NO-FALLBACK are the same as in
 203   `specifier-instance'."
 204
 205   (setq face (get-face face))
 206   (let ((value (get face property)))
 207     (if (specifierp value)
 208         (setq value (specifier-instance value domain default no-fallback)))
 209     value))
 210
 211 (defun face-property-matching-instance (face property matchspec
 212                                              &optional domain default
 213                                              no-fallback)
 214   "Return the instance of FACE's PROPERTY matching MATCHSPEC in DOMAIN.
 215 Currently the only useful value for MATCHSPEC is a charset, when used
 216 in conjunction with the face's font; this allows you to retrieve a
 217 font that can be used to display a particular charset, rather than just
 218 any font.
 219
 220 Other than MATCHSPEC, this function is identical to `face-property-instance'.
 221 See also `specifier-matching-instance' for a fuller description of the
 222 matching process."
 223
 224   (setq face (get-face face))
 225   (let ((value (get face property)))
 226     (if (specifierp value)
 227         (setq value (specifier-matching-instance value matchspec domain
 228                                                  default no-fallback)))
 229     value))
 230
 231 (defun set-face-property (face property value &optional locale tag-set
 232                                how-to-add)
 233   "Change a property of FACE.
 234
 235 NOTE: If you want to remove a property from a face, use `remove-face-property'
 236   rather than attempting to set a value of nil for the property.
 237
 238 For built-in properties, the actual value of the property is a
 239   specifier and you cannot change this; but you can change the
 240   specifications within the specifier, and that is what this function
 241   will do.  For user-defined properties, you can use this function
 242   to either change the actual value of the property or, if this value
 243   is a specifier, change the specifications within it.
 244
 245 If PROPERTY is a built-in property, the specifications to be added to
 246   this property can be supplied in many different ways:
 247
 248   -- If VALUE is a simple instantiator (e.g. a string naming a font or
 249      color) or a list of instantiators, then the instantiator(s) will
 250      be added as a specification of the property for the given LOCALE
 251      (which defaults to 'global if omitted).
 252   -- If VALUE is a list of specifications (each of which is a cons of
 253      a locale and a list of instantiators), then LOCALE must be nil
 254      (it does not make sense to explicitly specify a locale in this
 255      case), and specifications will be added as given.
 256   -- If VALUE is a specifier (as would be returned by `face-property'
 257      if no LOCALE argument is given), then some or all of the
 258      specifications in the specifier will be added to the property.
 259      In this case, the function is really equivalent to
 260      `copy-specifier' and LOCALE has the same semantics (if it is
 261      a particular locale, the specification for the locale will be
 262      copied; if a locale type, specifications for all locales of
 263      that type will be copied; if nil or 'all, then all
 264      specifications will be copied).
 265
 266 HOW-TO-ADD should be either nil or one of the symbols 'prepend,
 267   'append, 'remove-tag-set-prepend, 'remove-tag-set-append, 'remove-locale,
 268   'remove-locale-type, or 'remove-all.  See `copy-specifier' and
 269   `add-spec-to-specifier' for a description of what each of
 270   these means.  Most of the time, you do not need to worry about
 271   this argument; the default behavior usually is fine.
 272
 273 In general, it is OK to pass an instance object (e.g. as returned
 274   by `face-property-instance') as an instantiator in place of
 275   an actual instantiator.  In such a case, the instantiator used
 276   to create that instance object will be used (for example, if
 277   you set a font-instance object as the value of the 'font
 278   property, then the font name used to create that object will
 279   be used instead).  If some cases, however, doing this
 280   conversion does not make sense, and this will be noted in
 281   the documentation for particular types of instance objects.
 282
 283 If PROPERTY is not a built-in property, then this function will
 284   simply set its value if LOCALE is nil.  However, if LOCALE is
 285   given, then this function will attempt to add VALUE as the
 286   instantiator for the given LOCALE, using `add-spec-to-specifier'.
 287   If the value of the property is not a specifier, it will
 288   automatically be converted into a 'generic specifier.
 289
 290
 291 The following symbols have predefined meanings:
 292
 293  foreground         The foreground color of the face.
 294                     For valid instantiators, see `make-color-specifier'.
 295
 296  background         The background color of the face.
 297                     For valid instantiators, see `make-color-specifier'.
 298
 299  font               The font used to display text covered by this face.
 300                     For valid instantiators, see `make-font-specifier'.
 301
 302  display-table      The display table of the face.
 303                     This should be a vector of 256 elements.
 304
 305  background-pixmap  The pixmap displayed in the background of the face.
 306                     Only used by faces on X and MS Windows devices.
 307                     For valid instantiators, see `make-image-specifier'.
 308
 309  underline          Underline all text covered by this face.
 310                     For valid instantiators, see `make-face-boolean-specifier'.
 311
 312  strikethru         Draw a line through all text covered by this face.
 313                     For valid instantiators, see `make-face-boolean-specifier'.
 314
 315  highlight          Highlight all text covered by this face.
 316                     Only used by faces on TTY devices.
 317                     For valid instantiators, see `make-face-boolean-specifier'.
 318
 319  dim                Dim all text covered by this face.
 320                     For valid instantiators, see `make-face-boolean-specifier'.
 321
 322  blinking           Blink all text covered by this face.
 323                     Only used by faces on TTY devices.
 324                     For valid instantiators, see `make-face-boolean-specifier'.
 325
 326  reverse            Reverse the foreground and background colors.
 327                     Only used by faces on TTY devices.
 328                     For valid instantiators, see `make-face-boolean-specifier'.
 329
 330  inherit            Face name or face object from which to inherit attributes,
 331                     or a list of such elements.  Attributes from inherited
 332                     faces are merged into the face like an underlying face
 333                     would be, with higher priority than underlying faces.
 334
 335  doc-string         Description of what the face's normal use is.
 336                     NOTE: This is not a specifier, unlike all
 337                     the other built-in properties, and cannot
 338                     contain locale-specific values."
 339
 340   (setq face (get-face face))
 341   (if (memq property built-in-face-specifiers)
 342       (set-specifier (get face property) value locale tag-set how-to-add)
 343
 344     ;; This section adds user defined properties.
 345     (if (not locale)
 346         (put face property value)
 347       (convert-face-property-into-specifier face property)
 348       (add-spec-to-specifier (get face property) value locale tag-set
 349                              how-to-add)))
 350   value)
 351
 352 (defun remove-face-property (face property &optional locale tag-set exact-p)
 353   "Remove a property from FACE.
 354 For built-in properties, this is analogous to `remove-specifier'.
 355 See `remove-specifier' for the meaning of the LOCALE, TAG-SET, and EXACT-P
 356 arguments."
 357   (or locale (setq locale 'all))
 358   (if (memq property built-in-face-specifiers)
 359       (remove-specifier (face-property face property) locale tag-set exact-p)
 360     (if (eq locale 'all)
 361         (remprop (get-face face) property)
 362       (convert-face-property-into-specifier face property)
 363       (remove-specifier (face-property face property) locale tag-set
 364                         exact-p))))
 365
 366 (defun reset-face (face &optional locale tag-set exact-p)
 367   "Clear all existing built-in specifications from FACE.
 368 This makes FACE inherit all its display properties from 'default.
 369 WARNING: Be absolutely sure you want to do this!!!  It is a dangerous
 370 operation and is not undoable.
 371
 372 The arguments LOCALE, TAG-SET and EXACT-P are the same as for
 373 `remove-specifier'."
 374   (mapc (lambda (x)
 375           (remove-specifier (face-property face x) locale tag-set exact-p))
 376         built-in-face-specifiers)
 377   nil)
 378
 379 (defun set-face-parent (face parent &optional locale tag-set how-to-add)
 380   "Set the parent of FACE to PARENT, for all properties.
 381 This makes all properties of FACE inherit from PARENT."
 382   (setq parent (get-face parent))
 383   (mapcar (lambda (x)
 384             (set-face-property face x (vector parent) locale tag-set
 385                                how-to-add))
 386           (delq 'display-table
 387                 (delq 'background-pixmap
 388                       (copy-sequence built-in-face-specifiers))))
 389   (set-face-background-pixmap face (vector 'inherit ':face parent)
 390                               locale tag-set how-to-add)
 391   nil)
 392
 393 (defun face-doc-string (face)
 394   "Return the documentation string for FACE."
 395   (face-property face 'doc-string))
 396
 397 (defun set-face-doc-string (face doc-string)
 398   "Change the documentation string of FACE to DOC-STRING."
 399   (interactive (face-interactive "doc-string"))
 400   (set-face-property face 'doc-string doc-string))
 401
 402 (defun face-font-name (face &optional domain charset)
 403   "Return the font name of FACE in DOMAIN, or nil if it is unspecified.
 404 DOMAIN is as in `face-font-instance'."
 405   (let ((f (face-font-instance face domain charset)))
 406     (and f (font-instance-name f))))
 407
 408 (defun face-font (face &optional locale tag-set exact-p)
 409   "Return the font of FACE in LOCALE, or nil if it is unspecified.
 410
 411 FACE may be either a face object or a symbol representing a face.
 412
 413 LOCALE may be a locale (the instantiators for that particular locale
 414   will be returned), a locale type (the specifications for all locales
 415   of that type will be returned), 'all (all specifications will be
 416   returned), or nil (the actual specifier object will be returned).
 417
 418 See `face-property' for more information."
 419   (face-property face 'font locale tag-set exact-p))
 420
 421 (defun face-font-instance (face &optional domain charset)
 422   "Return the instance of FACE's font in DOMAIN.
 423
 424 FACE may be either a face object or a symbol representing a face.
 425
 426 Normally DOMAIN will be a window or nil (meaning the selected window),
 427   and an instance object describing how the font appears in that
 428   particular window and buffer will be returned.
 429
 430 See `face-property-instance' for more information."
 431   (if charset
 432       (face-property-matching-instance face 'font charset domain)
 433     (face-property-instance face 'font domain)))
 434
 435 (defun set-face-font (face font &optional locale tag-set how-to-add)
 436   "Change the font of FACE to FONT in LOCALE.
 437
 438 FACE may be either a face object or a symbol representing a face.
 439
 440 FONT should be an instantiator (see `make-font-specifier'), a list of
 441   instantiators, an alist of specifications (each mapping a
 442   locale to an instantiator list), or a font specifier object.
 443
 444 If FONT is an alist, LOCALE must be omitted.  If FONT is a
 445   specifier object, LOCALE can be a locale, a locale type, 'all,
 446   or nil; see `copy-specifier' for its semantics.  Otherwise LOCALE
 447   specifies the locale under which the specified instantiator(s)
 448   will be added, and defaults to 'global.
 449
 450 See `set-face-property' for more information."
 451   (interactive (face-interactive "font"))
 452   (set-face-property face 'font font locale tag-set how-to-add))
 453
 454 (defun face-foreground (face &optional locale tag-set exact-p)
 455   "Return the foreground of FACE in LOCALE, or nil if it is unspecified.
 456
 457 FACE may be either a face object or a symbol representing a face.
 458
 459 LOCALE may be a locale (the instantiators for that particular locale
 460   will be returned), a locale type (the specifications for all locales
 461   of that type will be returned), 'all (all specifications will be
 462   returned), or nil (the actual specifier object will be returned).
 463
 464 See `face-property' for more information."
 465   (face-property face 'foreground locale tag-set exact-p))
 466
 467 (defun face-foreground-instance (face &optional domain default no-fallback)
 468   "Return the instance of FACE's foreground in DOMAIN.
 469
 470 FACE may be either a face object or a symbol representing a face.
 471
 472 Normally DOMAIN will be a window or nil (meaning the selected window),
 473   and an instance object describing how the foreground appears in that
 474   particular window and buffer will be returned.
 475
 476 See `face-property-instance' for more information."
 477   (face-property-instance face 'foreground domain default no-fallback))
 478
 479 (defun face-foreground-name (face &optional domain default no-fallback)
 480   "Return the name of FACE's foreground color in DOMAIN.
 481
 482 FACE may be either a face object or a symbol representing a face.
 483
 484 Normally DOMAIN will be a window or nil (meaning the selected window),
 485   and an instance object describing how the background appears in that
 486   particular window and buffer will be returned.
 487
 488 See `face-property-instance' for more information."
 489   (color-instance-name (face-foreground-instance
 490                         face domain default no-fallback)))
 491
 492 (defun set-face-foreground (face color &optional locale tag-set how-to-add)
 493   "Change the foreground color of FACE to COLOR in LOCALE.
 494
 495 FACE may be either a face object or a symbol representing a face.
 496
 497 COLOR should be an instantiator (see `make-color-specifier'), a list of
 498   instantiators, an alist of specifications (each mapping a locale to
 499   an instantiator list), or a color specifier object.
 500
 501 If COLOR is an alist, LOCALE must be omitted.  If COLOR is a
 502   specifier object, LOCALE can be a locale, a locale type, 'all,
 503   or nil; see `copy-specifier' for its semantics.  Otherwise LOCALE
 504   specifies the locale under which the specified instantiator(s)
 505   will be added, and defaults to 'global.
 506
 507 See `set-face-property' for more information."
 508   (interactive (face-interactive "foreground"))
 509   (set-face-property face 'foreground color locale tag-set how-to-add))
 510
 511 (defun face-background (face &optional locale tag-set exact-p)
 512   "Return the background color of FACE in LOCALE, or nil if it is unspecified.
 513
 514 FACE may be either a face object or a symbol representing a face.
 515
 516 LOCALE may be a locale (the instantiators for that particular locale
 517   will be returned), a locale type (the specifications for all locales
 518   of that type will be returned), 'all (all specifications will be
 519   returned), or nil (the actual specifier object will be returned).
 520
 521 See `face-property' for more information."
 522   (face-property face 'background locale tag-set exact-p))
 523
 524 (defun face-background-instance (face &optional domain default no-fallback)
 525   "Return the instance of FACE's background in DOMAIN.
 526
 527 FACE may be either a face object or a symbol representing a face.
 528
 529 Normally DOMAIN will be a window or nil (meaning the selected window),
 530   and an instance object describing how the background appears in that
 531   particular window and buffer will be returned.
 532
 533 See `face-property-instance' for more information."
 534   (face-property-instance face 'background domain default no-fallback))
 535
 536 (defun face-background-name (face &optional domain default no-fallback)
 537   "Return the name of FACE's background color in DOMAIN.
 538
 539 FACE may be either a face object or a symbol representing a face.
 540
 541 Normally DOMAIN will be a window or nil (meaning the selected window),
 542   and an instance object describing how the background appears in that
 543   particular window and buffer will be returned.
 544
 545 See `face-property-instance' for more information."
 546   (color-instance-name (face-background-instance
 547                         face domain default no-fallback)))
 548
 549 (defun set-face-background (face color &optional locale tag-set how-to-add)
 550   "Change the background color of FACE to COLOR in LOCALE.
 551
 552 FACE may be either a face object or a symbol representing a face.
 553
 554 COLOR should be an instantiator (see `make-color-specifier'), a list of
 555   instantiators, an alist of specifications (each mapping a locale to
 556   an instantiator list), or a color specifier object.
 557
 558 If COLOR is an alist, LOCALE must be omitted.  If COLOR is a
 559   specifier object, LOCALE can be a locale, a locale type, 'all,
 560   or nil; see `copy-specifier' for its semantics.  Otherwise LOCALE
 561   specifies the locale under which the specified instantiator(s)
 562   will be added, and defaults to 'global.
 563
 564 See `set-face-property' for more information."
 565   (interactive (face-interactive "background"))
 566   (set-face-property face 'background color locale tag-set how-to-add))
 567
 568 (defun face-background-pixmap (face &optional locale tag-set exact-p)
 569   "Return the background pixmap of FACE in LOCALE, or nil if it is unspecified.
 570 This property is only used on window system devices.
 571
 572 FACE may be either a face object or a symbol representing a face.
 573
 574 LOCALE may be a locale (the instantiators for that particular locale
 575   will be returned), a locale type (the specifications for all locales
 576   of that type will be returned), 'all (all specifications will be
 577   returned), or nil (the actual specifier object will be returned).
 578
 579 See `face-property' for more information."
 580   (face-property face 'background-pixmap locale tag-set exact-p))
 581
 582 (defun face-background-pixmap-instance (face &optional domain default
 583                                              no-fallback)
 584   "Return the instance of FACE's background pixmap in DOMAIN.
 585
 586 FACE may be either a face object or a symbol representing a face.
 587
 588 Normally DOMAIN will be a window or nil (meaning the selected window),
 589   and an instance object describing how the background appears in that
 590   particular window and buffer will be returned.
 591
 592 See `face-property-instance' for more information."
 593   (face-property-instance face 'background-pixmap domain default no-fallback))
 594
 595 (defun set-face-background-pixmap (face pixmap &optional locale tag-set
 596                                         how-to-add)
 597   "Change the background pixmap of FACE to PIXMAP in LOCALE.
 598 This property is only used on window system devices.
 599
 600 FACE may be either a face object or a symbol representing a face.
 601
 602 PIXMAP should be an instantiator (see `make-image-specifier'), a list
 603   of instantiators, an alist of specifications (each mapping a locale
 604   to an instantiator list), or an image specifier object.
 605
 606 If PIXMAP is an alist, LOCALE must be omitted.  If PIXMAP is a
 607   specifier object, LOCALE can be a locale, a locale type, 'all,
 608   or nil; see `copy-specifier' for its semantics.  Otherwise LOCALE
 609   specifies the locale under which the specified instantiator(s)
 610   will be added, and defaults to 'global.
 611
 612 See `set-face-property' for more information."
 613   (interactive (face-interactive "background-pixmap"))
 614   (set-face-property face 'background-pixmap pixmap locale tag-set how-to-add))
 615
 616 (defun face-display-table (face &optional locale tag-set exact-p)
 617   "Return the display table of FACE in LOCALE.
 618
 619 A vector (as returned by `make-display-table') will be returned.
 620
 621 LOCALE may be a locale (the instantiators for that particular locale
 622   will be returned), a locale type (the specifications for all locales
 623   of that type will be returned), 'all (all specifications will be
 624   returned), or nil (the actual specifier object will be returned).
 625
 626 See `face-property' for more information."
 627   (face-property face 'display-table locale tag-set exact-p))
 628
 629 (defun face-display-table-instance (face &optional domain default no-fallback)
 630   "Return the instance of FACE's display table in DOMAIN.
 631 A vector (as returned by `make-display-table') will be returned.
 632
 633 See `face-property-instance' for the semantics of the DOMAIN argument."
 634   (face-property-instance face 'display-table domain default no-fallback))
 635
 636 (defun set-face-display-table (face display-table &optional locale tag-set
 637                                     how-to-add)
 638   "Change the display table of FACE to DISPLAY-TABLE in LOCALE.
 639 DISPLAY-TABLE should be a vector as returned by `make-display-table'.
 640
 641 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
 642   HOW-TO-ADD arguments."
 643   (interactive (face-interactive "display-table"))
 644   (set-face-property face 'display-table display-table locale tag-set
 645                      how-to-add))
 646
 647 ;; The following accessors and mutators are, IMHO, good
 648 ;; implementation.  Cf. with `make-face-bold'.
 649
 650 (defun face-underline-p (face &optional domain default no-fallback)
 651   "Return t if FACE is underlined in DOMAIN.
 652 See `face-property-instance' for the semantics of the DOMAIN argument."
 653   (face-property-instance face 'underline domain default no-fallback))
 654
 655 (defun set-face-underline-p (face underline-p &optional locale tag-set
 656                                   how-to-add)
 657   "Change the underline property of FACE to UNDERLINE-P.
 658 UNDERLINE-P is normally a face-boolean instantiator; see
 659  `make-face-boolean-specifier'.
 660 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
 661  HOW-TO-ADD arguments."
 662   (interactive (face-interactive "underline-p" "underlined"))
 663   (set-face-property face 'underline underline-p locale tag-set how-to-add))
 664
 665 (defun face-strikethru-p (face &optional domain default no-fallback)
 666   "Return t if FACE is strikethru-d (i.e. struck through) in DOMAIN.
 667 See `face-property-instance' for the semantics of the DOMAIN argument."
 668   (face-property-instance face 'strikethru domain default no-fallback))
 669
 670 (defun set-face-strikethru-p (face strikethru-p &optional locale tag-set
 671                                   how-to-add)
 672   "Change whether FACE is strikethru-d (i.e. struck through) in LOCALE.
 673 STRIKETHRU-P is normally a face-boolean instantiator; see
 674  `make-face-boolean-specifier'.
 675 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
 676  HOW-TO-ADD arguments."
 677   (interactive (face-interactive "strikethru-p" "strikethru-d"))
 678   (set-face-property face 'strikethru strikethru-p locale tag-set how-to-add))
 679
 680 (defun face-highlight-p (face &optional domain default no-fallback)
 681   "Return t if FACE is highlighted in DOMAIN (TTY domains only).
 682 See `face-property-instance' for the semantics of the DOMAIN argument."
 683   (face-property-instance face 'highlight domain default no-fallback))
 684
 685 (defun set-face-highlight-p (face highlight-p &optional locale tag-set
 686                                   how-to-add)
 687   "Change whether FACE is highlighted in LOCALE (TTY locales only).
 688 HIGHLIGHT-P is normally a face-boolean instantiator; see
 689  `make-face-boolean-specifier'.
 690 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
 691  HOW-TO-ADD arguments."
 692   (interactive (face-interactive "highlight-p" "highlighted"))
 693   (set-face-property face 'highlight highlight-p locale tag-set how-to-add))
 694
 695 (defun face-dim-p (face &optional domain default no-fallback)
 696   "Return t if FACE is dimmed in DOMAIN.
 697 See `face-property-instance' for the semantics of the DOMAIN argument."
 698   (face-property-instance face 'dim domain default no-fallback))
 699
 700 (defun set-face-dim-p (face dim-p &optional locale tag-set how-to-add)
 701   "Change whether FACE is dimmed in LOCALE.
 702 DIM-P is normally a face-boolean instantiator; see
 703  `make-face-boolean-specifier'.
 704 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
 705  HOW-TO-ADD arguments."
 706   (interactive (face-interactive "dim-p" "dimmed"))
 707   (set-face-property face 'dim dim-p locale tag-set how-to-add))
 708
 709 (defun face-blinking-p (face &optional domain default no-fallback)
 710   "Return t if FACE is blinking in DOMAIN (TTY domains only).
 711 See `face-property-instance' for the semantics of the DOMAIN argument."
 712   (face-property-instance face 'blinking domain default no-fallback))
 713
 714 (defun set-face-blinking-p (face blinking-p &optional locale tag-set
 715                                  how-to-add)
 716   "Change whether FACE is blinking in LOCALE (TTY locales only).
 717 BLINKING-P is normally a face-boolean instantiator; see
 718  `make-face-boolean-specifier'.
 719 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
 720  HOW-TO-ADD arguments."
 721   (interactive (face-interactive "blinking-p" "blinking"))
 722   (set-face-property face 'blinking blinking-p locale tag-set how-to-add))
 723
 724 (defun face-reverse-p (face &optional domain default no-fallback)
 725   "Return t if FACE is reversed in DOMAIN (TTY domains only).
 726 See `face-property-instance' for the semantics of the DOMAIN argument."
 727   (face-property-instance face 'reverse domain default no-fallback))
 728
 729 (defun set-face-reverse-p (face reverse-p &optional locale tag-set how-to-add)
 730   "Change whether FACE is reversed in LOCALE (TTY locales only).
 731 REVERSE-P is normally a face-boolean instantiator; see
 732  `make-face-boolean-specifier'.
 733 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
 734  HOW-TO-ADD arguments."
 735   (interactive (face-interactive "reverse-p" "reversed"))
 736   (set-face-property face 'reverse reverse-p locale tag-set how-to-add))
 737
 738 \f
 739 (defun face-property-equal (face1 face2 prop domain)
 740   (equal (face-property-instance face1 prop domain)
 741          (face-property-instance face2 prop domain)))
 742
 743 (defun face-equal-loop (props face1 face2 domain)
 744   (while (and props
 745               (face-property-equal face1 face2 (car props) domain))
 746     (setq props (cdr props)))
 747   (null props))
 748
 749 (defun face-equal (face1 face2 &optional domain)
 750   "Return t if FACE1 and FACE2 will display in the same way in DOMAIN.
 751 See `face-property-instance' for the semantics of the DOMAIN argument."
 752   (if (null domain) (setq domain (selected-window)))
 753   (if (not (valid-specifier-domain-p domain))
 754       (error "Invalid specifier domain"))
 755   (let ((device (dfw-device domain))
 756         (common-props '(foreground background font display-table underline
 757                                    dim))
 758         (win-props '(background-pixmap strikethru))
 759         (tty-props '(highlight blinking reverse)))
 760
 761     ;; First check the properties which are used in common between the
 762     ;; x and tty devices.  Then, check those properties specific to
 763     ;; the particular device type.
 764     (and (face-equal-loop common-props face1 face2 domain)
 765          (cond ((eq 'tty (device-type device))
 766                 (face-equal-loop tty-props face1 face2 domain))
 767                ;; #### Why isn't this (console-on-window-system-p (device-console device))?
 768                ;; #### FIXME!
 769                ((eq 'x (device-type device))
 770                 (face-equal-loop win-props face1 face2 domain))
 771                (t t)))))
 772
 773 (defun face-differs-from-default-p (face &optional domain)
 774   "Return t if FACE will display differently from the default face in DOMAIN.
 775 See `face-property-instance' for the semantics of the DOMAIN argument."
 776   (not (face-equal face 'default domain)))
 777
 778 ; moved from x-faces.el
 779 (defun try-font-name (name &optional device)
 780   ;; yes, name really should be here twice.
 781   (and name (make-font-instance name device t) name))
 782
 783 \f
 784 ;; This function is a terrible, disgusting hack!!!!  Need to
 785 ;; separate out the font elements as separate face properties!
 786
 787 ;; WE DEMAND LEXICAL SCOPING!!!
 788 ;; WE DEMAND LEXICAL SCOPING!!!
 789 ;; WE DEMAND LEXICAL SCOPING!!!
 790 ;; WE DEMAND LEXICAL SCOPING!!!
 791 ;; WE DEMAND LEXICAL SCOPING!!!
 792 ;; WE DEMAND LEXICAL SCOPING!!!
 793 ;; WE DEMAND LEXICAL SCOPING!!!
 794 ;; WE DEMAND LEXICAL SCOPING!!!
 795 ;; WE DEMAND LEXICAL SCOPING!!!
 796 ;; WE DEMAND LEXICAL SCOPING!!!
 797 ;; WE DEMAND LEXICAL SCOPING!!!
 798 ;; WE DEMAND LEXICAL SCOPING!!!
 799 ;; WE DEMAND LEXICAL SCOPING!!!
 800 ;; WE DEMAND LEXICAL SCOPING!!!
 801 ;; WE DEMAND LEXICAL SCOPING!!!
 802 (defun frob-face-property (face property func device-tags &optional
 803 locale tags)
 804   "Change the specifier for FACE's PROPERTY according to FUNC, in LOCALE.
 805 This function is ugly and messy and is primarily used as an internal
 806 helper function for `make-face-bold' et al., so you probably don't
 807 want to use it or read the rest of the documentation.  But if you do ...
 808
 809 FUNC should be a function of two arguments (an instance and a device)
 810 that returns a modified name that is valid for the given device.
 811 If LOCALE specifies a valid domain (i.e. a window, frame, or device),
 812 this function instantiates the specifier over that domain, applies FUNC
 813 to the resulting instance, and adds the result back as an instantiator
 814 for that locale.  Otherwise, LOCALE should be a locale, locale type, or
 815 'all (defaults to 'all if omitted).  For each specification thusly
 816 included: if the locale given is a valid domain, FUNC will be
 817 iterated over all valid instantiators for the device of the domain
 818 until a non-nil result is found (if there is no such result, the
 819 first valid instantiator is used), and that result substituted for
 820 the specification; otherwise, the process just outlined is
 821 iterated over each existing device and the concatenated results
 822 substituted for the specification.
 823
 824 DEVICE-TAGS is a list of tags that each device must match in order for
 825 the function to be called on it."
 826   (let ((sp (face-property face property))
 827         temp-sp)
 828     (if (valid-specifier-domain-p locale)
 829         ;; this is easy.
 830         (let* ((inst (face-property-instance face property locale))
 831                (name (and inst
 832                           (device-matches-specifier-tag-set-p
 833                            (dfw-device locale) device-tags)
 834                           (funcall func inst (dfw-device locale)))))
 835           (when name
 836             (add-spec-to-specifier sp name locale tags)))
 837       ;; otherwise, map over all specifications ...
 838       ;; but first, some further kludging:
 839       ;; (1) if we're frobbing the global property, make sure
 840       ;;     that something is there (copy from the default face,
 841       ;;     if necessary).  Otherwise, something like
 842       ;;     (make-face-larger 'modeline)
 843       ;;     won't do anything at all if the modeline simply
 844       ;;     inherits its font from 'default.
 845       ;; (2) if we're frobbing a particular locale, nothing would
 846       ;;     happen if that locale has no instantiators.  So signal
 847       ;;     an error to indicate this.
 848
 849
 850       (setq temp-sp (copy-specifier sp))
 851       (if (or (eq locale 'global) (eq locale 'all) (not locale))
 852           (when (not (specifier-specs temp-sp 'global))
 853             ;; Try fallback via the official ways and then do it "by hand"
 854             (let* ((fallback (specifier-fallback sp))
 855                    (fallback-sp
 856                     (cond ((specifierp fallback) fallback)
 857                           ;; just an inst list
 858                           (fallback
 859                            (make-specifier-and-init (specifier-type sp)
 860                                                     fallback))
 861                           ((eq (get-face face) (get-face 'default))
 862                            (error "Unable to find global specification"))
 863                           ;; If no fallback we snoop from default
 864                           (t (face-property 'default property)))))
 865               (copy-specifier fallback-sp temp-sp 'global))))
 866       (if (and (valid-specifier-locale-p locale)
 867                (not (specifier-specs temp-sp locale)))
 868           (error "Property must have a specification in locale %S" locale))
 869       (map-specifier
 870        temp-sp
 871        (lambda (sp-arg locale inst-list func)
 872          (let* ((device (dfw-device locale))
 873                 ;; if a device can be derived from the locale,
 874                 ;; call frob-face-property-1 for that device.
 875                 ;; Otherwise map frob-face-property-1 over each device.
 876                 (result
 877                  (if device
 878                      (list (and (device-matches-specifier-tag-set-p
 879                                  device device-tags)
 880                                 (frob-face-property-1 sp-arg device inst-list
 881                                                       func)))
 882                    (mapcar (lambda (device)
 883                              (and (device-matches-specifier-tag-set-p
 884                                    device device-tags)
 885                                   (frob-face-property-1 sp-arg device
 886                                                         inst-list func)))
 887                            (device-list))))
 888                 new-result)
 889            ;; remove duplicates and nils from the obtained list of
 890            ;; instantiators. Also add tags amd remove 'defaults'.
 891            (mapcar (lambda (arg)
 892                      (when arg
 893                        (if (not (consp arg))
 894                            (setq arg (cons tags arg))
 895                          (setcar arg (append tags (delete 'default
 896                                                           (car arg))))))
 897                      (when (and arg (not (member arg new-result)))
 898                        (setq new-result (cons arg new-result))))
 899                    result)
 900            ;; add back in.
 901            (add-spec-list-to-specifier sp (list (cons locale new-result)))
 902            ;; tell map-specifier to keep going.
 903            nil))
 904        locale
 905        func))))
 906
 907 (defun frob-face-property-1 (sp device inst-list func)
 908   (let
 909       (first-valid result)
 910     (while (and inst-list (not result))
 911       (let* ((inst-pair (car inst-list))
 912              (tag-set (car inst-pair))
 913              (sp-inst (specifier-instance-from-inst-list
 914                        sp device (list inst-pair))))
 915         (if sp-inst
 916             (progn
 917               (if (not first-valid)
 918                   (setq first-valid inst-pair))
 919               (setq result (funcall func sp-inst device))
 920               (if result
 921                   (setq result (cons tag-set result))))))
 922       (setq inst-list (cdr inst-list)))
 923     (or result first-valid)))
 924
 925 (defcustom face-frob-from-locale-first nil
 926   "*If non nil, use kludgy way of frobbing fonts suitable for non-mule
 927 multi-charset environments."
 928   :group 'faces
 929   :type 'boolean)
 930
 931 (defun frob-face-font-2 (face locale tags unfrobbed-face frobbed-face
 932                               tty-thunk ws-thunk standard-face-mapping)
 933   ;; another kludge to make things more intuitive.  If we're
 934   ;; inheriting from a standard face in this locale, frob the
 935   ;; inheritance as appropriate.  Else, if, after the first
 936   ;; window-system frobbing pass, the face hasn't changed and still
 937   ;; looks like the standard unfrobbed face (e.g. 'default), make it
 938   ;; inherit from the standard frobbed face (e.g. 'bold).  Regardless
 939   ;; of things, do the TTY frobbing.
 940
 941   ;; yuck -- The LOCALE argument to make-face-bold is not actually a locale,
 942   ;; but is a "locale, locale-type, or nil for all".  So ...  do our extra
 943   ;; frobbing only if it's actually a locale; or for nil, do the frobbing
 944   ;; on 'global.  This specifier stuff needs some rethinking.
 945   (let* ((the-locale (cond ((null locale) 'global)
 946                            ((valid-specifier-locale-p locale) locale)
 947                            (t nil)))
 948          (spec-list
 949           (and
 950            the-locale
 951            (specifier-spec-list (get (get-face face) 'font) the-locale tags t)))
 952          (change-it
 953           (and
 954            spec-list
 955            (cdr (assoc (cdadar spec-list) standard-face-mapping)))))
 956     (if (and change-it
 957              (not (memq (face-name (find-face face))
 958                         '(default bold italic bold-italic))))
 959         (progn
 960           (or (equal change-it t)
 961               (set-face-property face 'font change-it the-locale tags))
 962           (funcall tty-thunk))
 963       (let* ((domain (cond ((null the-locale) nil)
 964                            ((valid-specifier-domain-p the-locale) the-locale)
 965                            ;; OK, this next one is truly a kludge, but
 966                            ;; it results in more intuitive behavior most
 967                            ;; of the time. (really!)
 968                            ((or (eq the-locale 'global) (eq the-locale 'all))
 969                             (selected-device))
 970                            (t nil)))
 971              (inst (and domain (face-property-instance face 'font domain))))
 972         ;; If it's reasonable to do the inherit-from-standard-face trick,
 973         ;; and it's called for, then do it now.
 974         (if (and
 975              face-frob-from-locale-first
 976              (eq the-locale 'global)
 977              domain
 978              (equal inst (face-property-instance face 'font domain))
 979              ;; don't do it for standard faces, or you'll get inheritance loops.
 980              ;; #### This makes XEmacs seg fault! fix this bug.
 981              (not (memq (face-name (find-face face))
 982                         '(default bold italic bold-italic)))
 983              (equal (face-property-instance face 'font domain)
 984                     (face-property-instance unfrobbed-face 'font domain)))
 985             (set-face-property face 'font (vector frobbed-face)
 986                                the-locale tags)
 987           ;; and only otherwise try to build new property value artificially
 988           (funcall tty-thunk)
 989           (funcall ws-thunk)
 990           (and
 991            domain
 992            (equal inst (face-property-instance face 'font domain))
 993            ;; don't do it for standard faces, or you'll get inheritance loops.
 994            ;; #### This makes XEmacs seg fault! fix this bug.
 995            (not (memq (face-name (find-face face))
 996                       '(default bold italic bold-italic)))
 997            (equal (face-property-instance face 'font domain)
 998                   (face-property-instance unfrobbed-face 'font domain))
 999            (set-face-property face 'font (vector frobbed-face) the-locale tags)))))))
1000
1001 ;; WE DEMAND FOUNDRY FROBBING!
1002
1003 ;; Family frobbing
1004 ;; Thx Jan Vroonhof, Ref xemacs-beta <87oflypbum.fsf@petteflet.ntlworld.com>
1005 ;; Brainlessly derived from make-face-size by Stephen; don't blame Jan.
1006 ;; I'm long since flown to Rio, it does you little good to blame me, either.
1007 (defun make-face-family (face family &optional locale tags)
1008   "Set FACE's family to FAMILY in LOCALE, if possible.
1009
1010 Add/replace settings specified by TAGS only."
1011   (frob-face-property face 'font
1012                       ;; uses dynamic scope of family
1013                       #'(lambda (f d)
1014                           ;; keep the dependency on font.el for now
1015                           (let ((fo (font-create-object (font-instance-name f)
1016                                                         d)))
1017                             (set-font-family fo family)
1018                             (font-create-name fo d)))
1019                       nil locale tags))
1020
1021 ;; Style (ie, typographical face) frobbing
1022 (defun make-face-bold (face &optional locale tags)
1023   "Make FACE bold in LOCALE, if possible.
1024 This will attempt to make the font bold for X locales and will set the
1025 highlight flag for TTY locales.
1026
1027 If LOCALE is nil, omitted, or `all', this will attempt to frob all
1028 font specifications for FACE to make them appear bold.  Similarly, if
1029 LOCALE is a locale type, this frobs all font specifications for locales
1030 of that type.  If LOCALE is a particular locale, what happens depends on
1031 what sort of locale is given.  If you gave a device, frame, or window,
1032 then it's always possible to determine what the font actually will be,
1033 so this is determined and the resulting font is frobbed and added back as a
1034 specification for this locale.  If LOCALE is a buffer, however, you can't
1035 determine what the font will actually be unless there's actually a
1036 specification given for that particular buffer (otherwise, it depends
1037 on what window and frame the buffer appears in, and might not even be
1038 well-defined if the buffer appears multiple times in different places);
1039 therefore you will get an error unless there's a specification for the
1040 buffer.
1041
1042 Finally, in some cases (specifically, when LOCALE is not a locale type),
1043 if the frobbing didn't actually make the font look any different
1044 \(this happens, for example, if your font specification is already bold
1045 or has no bold equivalent), and currently looks like the font of the
1046 'default face, it is set to inherit from the 'bold face.  This is kludgy
1047 but it makes `make-face-bold' have more intuitive behavior in many
1048 circumstances."
1049   (interactive (list (read-face-name "Make which face bold: ")))
1050   (frob-face-font-2
1051    face locale tags 'default 'bold
1052    (lambda ()
1053      ;; handle TTY specific entries
1054      (when (featurep 'tty)
1055        (set-face-highlight-p face t locale (cons 'tty tags))))
1056    (lambda ()
1057      ;; handle window-system specific entries
1058      (when (featurep 'x)
1059        (frob-face-property face 'font 'x-make-font-bold
1060                            '(x) locale tags))
1061      )
1062    '(([default] . [bold])
1063      ([bold] . t)
1064      ([italic] . [bold-italic])
1065      ([bold-italic] . t))))
1066
1067 (defun make-face-italic (face &optional locale tags)
1068   "Make FACE italic in LOCALE, if possible.
1069 This will attempt to make the font italic for X/MS Windows locales and
1070 will set the underline flag for TTY locales.  See `make-face-bold' for
1071 the semantics of the LOCALE argument and for more specifics on exactly
1072 how this function works."
1073   (interactive (list (read-face-name "Make which face italic: ")))
1074   (frob-face-font-2
1075    face locale tags 'default 'italic
1076    (lambda ()
1077      ;; handle TTY specific entries
1078      (when (featurep 'tty)
1079        (set-face-underline-p face t locale (cons 'tty tags))))
1080    (lambda ()
1081      ;; handle window-system specific entries
1082      (when (featurep 'x)
1083        (frob-face-property face 'font 'x-make-font-italic
1084                            '(x) locale tags))
1085      )
1086    '(([default] . [italic])
1087      ([bold] . [bold-italic])
1088      ([italic] . t)
1089      ([bold-italic] . t))))
1090
1091 (defun make-face-bold-italic (face &optional locale tags)
1092   "Make FACE bold and italic in LOCALE, if possible.
1093 This will attempt to make the font bold-italic for X/MS Windows
1094 locales and will set the highlight and underline flags for TTY
1095 locales.  See `make-face-bold' for the semantics of the LOCALE
1096 argument and for more specifics on exactly how this function works."
1097   (interactive (list (read-face-name "Make which face bold-italic: ")))
1098   (frob-face-font-2
1099    face locale tags 'default 'bold-italic
1100    (lambda ()
1101      ;; handle TTY specific entries
1102      (when (featurep 'tty)
1103        (set-face-highlight-p face t locale (cons 'tty tags))
1104        (set-face-underline-p face t locale (cons 'tty tags))))
1105    (lambda ()
1106      ;; handle window-system specific entries
1107      (when (featurep 'x)
1108        (frob-face-property face 'font 'x-make-font-bold-italic
1109                            '(x) locale tags))
1110      )
1111    '(([default] . [italic])
1112      ([bold] . [bold-italic])
1113      ([italic] . [bold-italic])
1114      ([bold-italic] . t))))
1115
1116 (defun make-face-unbold (face &optional locale tags)
1117   "Make FACE non-bold in LOCALE, if possible.
1118 This will attempt to make the font non-bold for X/MS Windows locales
1119 and will unset the highlight flag for TTY locales.  See
1120 `make-face-bold' for the semantics of the LOCALE argument and for more
1121 specifics on exactly how this function works."
1122   (interactive (list (read-face-name "Make which face non-bold: ")))
1123   (frob-face-font-2
1124    face locale tags 'bold 'default
1125    (lambda ()
1126      ;; handle TTY specific entries
1127      (when (featurep 'tty)
1128        (set-face-highlight-p face nil locale (cons 'tty tags))))
1129    (lambda ()
1130      ;; handle window-system specific entries
1131      (when (featurep 'x)
1132        (frob-face-property face 'font 'x-make-font-unbold
1133                            '(x) locale tags))
1134      )
1135    '(([default] . t)
1136      ([bold] . [default])
1137      ([italic] . t)
1138      ([bold-italic] . [italic]))))
1139
1140 (defun make-face-unitalic (face &optional locale tags)
1141   "Make FACE non-italic in LOCALE, if possible.
1142 This will attempt to make the font non-italic for X/MS Windows locales
1143 and will unset the underline flag for TTY locales.  See
1144 `make-face-bold' for the semantics of the LOCALE argument and for more
1145 specifics on exactly how this function works."
1146   (interactive (list (read-face-name "Make which face non-italic: ")))
1147   (frob-face-font-2
1148    face locale tags 'italic 'default
1149    (lambda ()
1150      ;; handle TTY specific entries
1151      (when (featurep 'tty)
1152        (set-face-underline-p face nil locale (cons 'tty tags))))
1153    (lambda ()
1154      ;; handle window-system specific entries
1155      (when (featurep 'x)
1156        (frob-face-property face 'font 'x-make-font-unitalic
1157                            '(x) locale tags))
1158      )
1159    '(([default] . t)
1160      ([bold] . t)
1161      ([italic] . [default])
1162      ([bold-italic] . [bold]))))
1163
1164
1165 ;; Size frobbing
1166 ;; Thx Jan Vroonhof, Ref xemacs-beta <87oflypbum.fsf@petteflet.ntlworld.com>
1167 ;; Jan had a separate helper function
1168 (defun make-face-size (face size &optional locale tags)
1169   "Adjust FACE to SIZE in LOCALE, if possible.
1170
1171 Add/replace settings specified by TAGS only."
1172   (frob-face-property face 'font
1173                       ;; uses dynamic scope of size
1174                       #'(lambda (f d)
1175                           ;; keep the dependency on font.el for now
1176                           (let ((fo (font-create-object (font-instance-name f)
1177                                                         d)))
1178                             (set-font-size fo size)
1179                             (font-create-name fo d)))
1180                       nil locale tags))
1181
1182 ;; Why do the following two functions lose so badly in so many
1183 ;; circumstances?
1184
1185 (defun make-face-smaller (face &optional locale)
1186   "Make the font of FACE be smaller, if possible.
1187 LOCALE works as in `make-face-bold' et al., but the ``inheriting-
1188 from-the-bold-face'' operations described there are not done
1189 because they don't make sense in this context."
1190   (interactive (list (read-face-name "Shrink which face: ")))
1191   ;; handle X specific entries
1192   (when (featurep 'x)
1193     (frob-face-property face 'font 'x-find-smaller-font
1194                         '(x) locale)))
1195
1196 (defun make-face-larger (face &optional locale)
1197   "Make the font of FACE be larger, if possible.
1198 See `make-face-smaller' for the semantics of the LOCALE argument."
1199   (interactive (list (read-face-name "Enlarge which face: ")))
1200   ;; handle X specific entries
1201   (when (featurep 'x)
1202     (frob-face-property face 'font 'x-find-larger-font
1203                         '(x) locale)))
1204
1205 (defun invert-face (face &optional locale)
1206   "Swap the foreground and background colors of the face."
1207   (interactive (list (read-face-name "Invert face: ")))
1208   (if (valid-specifier-domain-p locale)
1209       (let ((foreface (face-foreground-instance face locale)))
1210         (set-face-foreground face (face-background-instance face locale)
1211                              locale)
1212         (set-face-background face foreface locale))
1213     (let ((forespec (copy-specifier (face-foreground face) nil locale)))
1214       (copy-specifier (face-background face) (face-foreground face) locale)
1215       (copy-specifier forespec (face-background face) locale))))
1216
1217 \f
1218 ;;; Convenience functions
1219
1220 (defun face-ascent (face &optional domain charset)
1221   "Return the ascent of FACE in DOMAIN.
1222 See `face-property-instance' for the semantics of the DOMAIN argument."
1223   (font-ascent (face-font face) domain charset))
1224
1225 (defun face-descent (face &optional domain charset)
1226   "Return the descent of FACE in DOMAIN.
1227 See `face-property-instance' for the semantics of the DOMAIN argument."
1228   (font-descent (face-font face) domain charset))
1229
1230 (defun face-width (face &optional domain charset)
1231   "Return the width of FACE in DOMAIN.
1232 See `face-property-instance' for the semantics of the DOMAIN argument."
1233   (font-width (face-font face) domain charset))
1234
1235 (defun face-height (face &optional domain charset)
1236   "Return the height of FACE in DOMAIN.
1237 See `face-property-instance' for the semantics of the DOMAIN argument."
1238   (+ (face-ascent face domain charset) (face-descent face domain charset)))
1239
1240 (defun face-proportional-p (face &optional domain charset)
1241   "Return t if FACE is proportional in DOMAIN.
1242 See `face-property-instance' for the semantics of the DOMAIN argument."
1243   (font-proportional-p (face-font face) domain charset))
1244
1245 \f
1246 ;; Functions that used to be in cus-face.el, but logically go here.
1247
1248 (defcustom frame-background-mode nil
1249   "*The brightness of the background.
1250 Set this to the symbol dark if your background color is dark, light if
1251 your background is light, or nil (default) if you want Emacs to
1252 examine the brightness for you."
1253   :group 'faces
1254   :type '(choice (choice-item dark)
1255                  (choice-item light)
1256                  (choice-item :tag "Auto" nil)))
1257
1258 ;; The old variable that many people still have in .emacs files.
1259 (define-obsolete-variable-alias 'custom-background-mode
1260   'frame-background-mode)
1261
1262 (defun get-frame-background-mode (frame)
1263   "Detect background mode for FRAME."
1264   (let* ((color-instance (face-background-instance 'default frame))
1265          (mode (condition-case nil
1266                    (if (< (apply '+ (color-instance-rgb-components
1267                                      color-instance)) 65536)
1268                        'dark 'light)
1269                  ;; Here, we get an error on a TTY.  As we don't have
1270                  ;; a good way of detecting whether a TTY is light or
1271                  ;; dark, we'll guess it's dark.
1272                  (error 'dark))))
1273     (set-frame-property frame 'background-mode mode)
1274     mode))
1275
1276 (defun extract-custom-frame-properties (frame)
1277   "Return a plist with the frame properties of FRAME used by custom."
1278   (list 'type (or (frame-property frame 'display-type)
1279                   (device-type (frame-device frame)))
1280         'class (device-class (frame-device frame))
1281         'background (or frame-background-mode
1282                         (frame-property frame 'background-mode)
1283                         (get-frame-background-mode frame))))
1284
1285 (defcustom init-face-from-resources t
1286   "If non nil, attempt to initialize faces from the resource database."
1287   :group 'faces
1288   :type 'boolean)
1289
1290 ;; Old name, used by custom.  Also, FSFmacs name.
1291 (defvaralias 'initialize-face-resources 'init-face-from-resources)
1292
1293 ;; Make sure all custom setting are added with this tag so we can
1294 ;; identify-them
1295 (define-specifier-tag 'custom)
1296
1297 (defun face-spec-set (face spec &optional frame tags)
1298   "Set FACE's face attributes according to the first matching entry in SPEC.
1299 If optional FRAME is non-nil, set it for that frame only.
1300 If it is nil, then apply SPEC to each frame individually.
1301 See `defface' for information about SPEC."
1302   (if frame
1303       (progn
1304         (reset-face face frame tags)
1305         (face-display-set face spec frame tags)
1306         (init-face-from-resources face frame))
1307     (let ((frames (relevant-custom-frames)))
1308       (reset-face face nil tags)
1309       ;; This should not be needed. We only remove our own specifiers
1310       ;; (if (and (eq 'default face) (featurep 'x))
1311       ;;          (x-init-global-faces))
1312       (face-display-set face spec nil tags)
1313       (while frames
1314         (face-display-set face spec (car frames) tags)
1315         (pop frames))
1316       (init-face-from-resources face))))
1317
1318 (defun face-display-set (face spec &optional frame tags)
1319   "Set FACE to the attributes to the first matching entry in SPEC.
1320 Iff optional FRAME is non-nil, set it for that frame only.
1321 See `defface' for information about SPEC."
1322   (while spec
1323     (let ((display (caar spec))
1324           (atts (cadar spec)))
1325       (pop spec)
1326       (when (face-spec-set-match-display display frame)
1327         ;; Avoid creating frame local duplicates of the global face.
1328         (unless (and frame (eq display (get face 'custom-face-display)))
1329           (apply 'face-custom-attributes-set face frame tags atts))
1330         (unless frame
1331           (put face 'custom-face-display display))
1332         (setq spec nil)))))
1333
1334 (defvar default-custom-frame-properties nil
1335   "The frame properties used for the global faces.
1336 Frames not matching these properties should have frame local faces.
1337 The value should be nil, if uninitialized, or a plist otherwise.
1338 See `defface' for a list of valid keys and values for the plist.")
1339
1340 (defun get-custom-frame-properties (&optional frame)
1341   "Return a plist with the frame properties of FRAME used by custom.
1342 If FRAME is nil, return the default frame properties."
1343   (cond (frame
1344          ;; Try to get from cache.
1345          (let ((cache (frame-property frame 'custom-properties)))
1346            (unless cache
1347              ;; Oh well, get it then.
1348              (setq cache (extract-custom-frame-properties frame))
1349              ;; and cache it...
1350              (set-frame-property frame 'custom-properties cache))
1351            cache))
1352         (default-custom-frame-properties)
1353         (t
1354          (setq default-custom-frame-properties
1355                (extract-custom-frame-properties (selected-frame))))))
1356
1357 (defun face-spec-update-all-matching (spec display plist)
1358   "Update all entries in the face spec that could match display to
1359 have the entries from the new plist and return the new spec."
1360   (mapcar
1361    (lambda (e)
1362      (let ((entries (car e))
1363            (options (cadr e))
1364            (match t)
1365            dplist
1366            (new-options plist)
1367            )
1368        (unless (eq display t)
1369          (mapc (lambda (arg)
1370                  (setq dplist (plist-put dplist (car arg) (cadr arg))))
1371                display))
1372        (unless (eq entries t)
1373          (mapc (lambda (arg)
1374                  (setq match (and match (eq (cadr arg)
1375                                             (plist-get
1376                                               dplist (car arg)
1377                                               (cadr arg))))))
1378                entries))
1379        (if (not match)
1380            e
1381          (while new-options
1382            (setq options
1383                  (plist-put options (car new-options) (cadr new-options)))
1384            (setq new-options (cddr new-options)))
1385          (list entries options))))
1386    (copy-sequence spec)))
1387
1388
1389
1390 (defun face-spec-set-match-display (display &optional frame)
1391   "Return non-nil if DISPLAY matches FRAME.
1392 DISPLAY is part of a spec such as can be used in `defface'.
1393 If FRAME is nil or omitted, the selected frame is used."
1394   (if (eq display t)
1395       t
1396     (let* ((props (get-custom-frame-properties frame))
1397            (type (plist-get props 'type))
1398            (class (plist-get props 'class))
1399            (background (plist-get props 'background))
1400            (match t)
1401            (entries display)
1402            entry req options)
1403       (while (and entries match)
1404         (setq entry (car entries)
1405               entries (cdr entries)
1406               req (car entry)
1407               options (cdr entry)
1408               match (case req
1409                       (type       (memq type options))
1410                       (class      (memq class options))
1411                       (background (memq background options))
1412                       (t (warn "Unknown req `%S' with options `%S'"
1413                                req options)
1414                          nil))))
1415       match)))
1416
1417 (defun relevant-custom-frames ()
1418   "List of frames whose custom properties differ from the default."
1419   (let ((relevant nil)
1420         (default (get-custom-frame-properties))
1421         (frames (frame-list))
1422         frame)
1423     (while frames
1424       (setq frame (car frames)
1425             frames (cdr frames))
1426       (unless (equal default (get-custom-frame-properties frame))
1427         (push frame relevant)))
1428     relevant))
1429
1430 (defun initialize-custom-faces (&optional frame)
1431   "Initialize all custom faces for FRAME.
1432 If FRAME is nil or omitted, initialize them for all frames."
1433   (mapc (lambda (symbol)
1434           (let ((spec (or (get symbol 'saved-face)
1435                           (get symbol 'face-defface-spec))))
1436             (when spec
1437               ;; No need to init-face-from-resources -- code in
1438               ;; `init-frame-faces' does it already.
1439               (face-display-set symbol spec frame))))
1440         (face-list)))
1441
1442 (defun custom-initialize-frame (frame)
1443   "Initialize frame-local custom faces for FRAME if necessary."
1444   (unless (equal (get-custom-frame-properties)
1445                  (get-custom-frame-properties frame))
1446     (initialize-custom-faces frame)))
1447
1448 (defun startup-initialize-custom-faces ()
1449   "Reset faces created by defface.  Only called at startup.
1450 Don't use this function in your program."
1451   (when default-custom-frame-properties
1452     ;; Reset default value to the actual frame, not stream.
1453     (setq default-custom-frame-properties
1454           (extract-custom-frame-properties (selected-frame)))
1455     ;; like initialize-custom-faces but removes property first.
1456     (mapc (lambda (symbol)
1457             (let ((spec (or (get symbol 'saved-face)
1458                             (get symbol 'face-defface-spec))))
1459               (when spec
1460                 ;; Reset faces created during auto-autoloads loading.
1461                 (reset-face symbol)
1462                 ;; And set it according to the spec.
1463                 (face-display-set symbol spec nil))))
1464           (face-list))))
1465
1466 \f
1467 (defun make-empty-face (name &optional doc-string temporary)
1468   "Like `make-face', but doesn't query the resource database."
1469   (let ((init-face-from-resources nil))
1470     (make-face name doc-string temporary)))
1471
1472 (defun init-face-from-resources (face &optional locale)
1473   "Initialize FACE from the resource database.
1474 If LOCALE is specified, it should be a frame, device, or 'global, and
1475 the face will be resourced over that locale.  Otherwise, the face will
1476 be resourced over all possible locales (i.e. all frames, all devices,
1477 and 'global)."
1478   (cond ((null init-face-from-resources)
1479          ;; Do nothing.
1480          )
1481         ((not locale)
1482          ;; Global, set for all frames.
1483          (progn
1484            (init-face-from-resources face 'global)
1485            (let ((devices (device-list)))
1486              (while devices
1487                (init-face-from-resources face (car devices))
1488                (setq devices (cdr devices))))
1489            (let ((frames (frame-list)))
1490              (while frames
1491                (init-face-from-resources face (car frames))
1492                (setq frames (cdr frames))))))
1493         (t
1494          ;; Specific.
1495          (let ((devtype (cond ((devicep locale) (device-type locale))
1496                               ((framep locale) (frame-type locale))
1497                               (t nil))))
1498            (cond ((or (and (not devtype) (featurep 'x)) (eq 'x devtype))
1499                   (x-init-face-from-resources face locale))
1500                  ((or (not devtype) (eq 'tty devtype))
1501                   ;; Nothing to do for TTYs?
1502                   ))))))
1503
1504 (defun init-device-faces (device)
1505   ;; First, add any device-local face resources.
1506   (when init-face-from-resources
1507     (loop for face in (face-list) do
1508           (init-face-from-resources face device))
1509     ;; Then do any device-specific initialization.
1510     (cond ((eq 'x (device-type device))
1511            (declare-fboundp (x-init-device-faces device)))
1512           ;; Nothing to do for TTYs?
1513           )
1514     (or (eq 'stream (device-type device))
1515         (init-other-random-faces device))))
1516
1517 (defun init-frame-faces (frame)
1518   (when init-face-from-resources
1519     ;; First, add any frame-local face resources.
1520     (loop for face in (face-list) do
1521           (init-face-from-resources face frame))
1522     ;; Then do any frame-specific initialization.
1523     (cond ((eq 'x (frame-type frame))
1524            (declare-fboundp (x-init-frame-faces frame)))
1525           ;; Is there anything which should be done for TTY's?
1526           )))
1527
1528 ;; #### This is somewhat X-specific, and is called when the first
1529 ;; X device is created (even if there were TTY devices created
1530 ;; beforehand).  The concept of resources has not been generalized
1531 ;; outside of X-specificness, so we have to live with this
1532 ;; breach of device-independence.
1533
1534 (defun init-global-faces ()
1535   ;; Look for global face resources.
1536   (loop for face in (face-list) do
1537         (init-face-from-resources face 'global))
1538   ;; Further X frobbing.
1539   (and (featurep 'x) (declare-fboundp (x-init-global-faces)))
1540
1541   ;; for bold and the like, make the global specification be bold etc.
1542   ;; if the user didn't already specify a value.  These will also be
1543   ;; frobbed further in init-other-random-faces.
1544   (unless (face-font 'bold 'global)
1545     (make-face-bold 'bold 'global))
1546   ;;
1547   (unless (face-font 'italic 'global)
1548     (make-face-italic 'italic 'global))
1549   ;;
1550   (unless (face-font 'bold-italic 'global)
1551     (make-face-bold-italic 'bold-italic 'global)
1552     (unless (face-font 'bold-italic 'global)
1553       (copy-face 'bold 'bold-italic)
1554       (make-face-italic 'bold-italic)))
1555
1556   (when (face-equal 'bold 'bold-italic)
1557     (copy-face 'italic 'bold-italic)
1558     (make-face-bold 'bold-italic))
1559   ;;
1560   ;; Nothing more to be done for X or TTY's?
1561   )
1562
1563
1564 ;; These warnings are there for a reason.  Just specify your fonts
1565 ;; correctly.  Deal with it.  Additionally, one can use
1566 ;; `log-warning-minimum-level' instead of this.
1567 ;(defvar inhibit-font-complaints nil
1568 ;  "Whether to suppress complaints about incomplete sets of fonts.")
1569
1570 (defun face-complain-about-font (face device)
1571   (if (symbolp face) (setq face (symbol-name face)))
1572 ;;  (if (not inhibit-font-complaints)
1573   ;; complaining for printers is generally annoying.
1574   (unless (device-printer-p device)
1575     (display-warning
1576         'font
1577       (let ((default-name (face-font-name 'default device)))
1578         (format "%s: couldn't deduce %s %s version of the font
1579 %S.
1580
1581 Please specify X resources to make the %s face
1582 visually distinguishable from the default face.
1583 For example, you could add one of the following to $HOME/Emacs:
1584
1585 Emacs.%s.attributeFont: -dt-*-medium-i-*
1586 or
1587 Emacs.%s.attributeForeground: hotpink\n"
1588                 invocation-name
1589                 (if (string-match "\\`[aeiouAEIOU]" face) "an" "a")
1590                 face
1591                 default-name
1592                 face
1593                 face
1594                 face
1595                 )))))
1596
1597
1598 ;; #### This is quite a mess.  We should use the custom mechanism for
1599 ;; most of this stuff.  Currently we don't do it, because Custom
1600 ;; doesn't use specifiers (yet.)  FSF does it the Right Way.
1601
1602 ;; For instance, the definition of `bold' should be something like
1603 ;; (defface bold ((t (:bold t))) "Bold text.") -- and `:bold t' should
1604 ;; make sure that everything works properly.
1605
1606 (defun init-other-random-faces (device)
1607   "Initialize the colors and fonts of the bold, italic, bold-italic,
1608 zmacs-region, list-mode-item-selected, highlight, primary-selection,
1609 secondary-selection, and isearch faces when each device is created.  If
1610 you want to add code to do stuff like this, use the create-device-hook."
1611
1612   ;; try to make 'bold look different from the default on this device.
1613   ;; If that doesn't work at all, then issue a warning.
1614   (unless (face-differs-from-default-p 'bold device)
1615     (make-face-bold 'bold device)
1616     (unless (face-differs-from-default-p 'bold device)
1617       (make-face-unbold 'bold device)
1618       (unless (face-differs-from-default-p 'bold device)
1619         ;; the luser specified one of the bogus font names
1620         (face-complain-about-font 'bold device))))
1621
1622   ;; Similar for italic.
1623   ;; It's unreasonable to expect to be able to make a font italic all
1624   ;; the time.  For many languages, italic is an alien concept.
1625   ;; Basically, because italic is not a globally meaningful concept,
1626   ;; the use of the italic face should really be obsoleted.
1627
1628   ;; I disagree with above.  In many languages, the concept of capital
1629   ;; letters is just as alien, and yet we use them.  Italic is here to
1630   ;; stay.  -hniksic
1631
1632   ;; In a Solaris Japanese environment, there just aren't any italic
1633   ;; fonts - period.  CDE recognizes this reality, and fonts
1634   ;; -dt-interface user-medium-r-normal-*-*-*-*-*-*-*-*-* don't come
1635   ;; in italic versions.  So we first try to make the font bold before
1636   ;; complaining.
1637   (unless (face-differs-from-default-p 'italic device)
1638     (make-face-italic 'italic device)
1639     (unless (face-differs-from-default-p 'italic device)
1640       (make-face-bold 'italic device)
1641       (unless (face-differs-from-default-p 'italic device)
1642         (face-complain-about-font 'italic device))))
1643
1644   ;; similar for bold-italic.
1645   (unless (face-differs-from-default-p 'bold-italic device)
1646     (make-face-bold-italic 'bold-italic device)
1647     ;; if we couldn't get a bold-italic version, try just bold.
1648     (unless (face-differs-from-default-p 'bold-italic device)
1649       (make-face-bold 'bold-italic device)
1650       ;; if we couldn't get bold or bold-italic, then that's probably because
1651       ;; the default font is bold, so make the `bold-italic' face be unbold.
1652       (unless (face-differs-from-default-p 'bold-italic device)
1653         (make-face-unbold 'bold-italic device)
1654         (make-face-italic 'bold-italic device)
1655         (unless (face-differs-from-default-p 'bold-italic device)
1656           ;; if that didn't work, try plain italic
1657           ;; (can this ever happen? what the hell.)
1658           (make-face-italic 'bold-italic device)
1659           (unless (face-differs-from-default-p 'bold-italic device)
1660             ;; then bitch and moan.
1661             (face-complain-about-font 'bold-italic device))))))
1662
1663   ;; Set the text-cursor colors unless already specified.
1664   (when (and (not (eq 'tty (device-type device)))
1665              (not (face-background 'text-cursor 'global))
1666              (face-property-equal 'text-cursor 'default 'background device))
1667     (set-face-background 'text-cursor [default foreground] 'global
1668                          nil 'append))
1669   (when (and (not (eq 'tty (device-type device)))
1670              (not (face-foreground 'text-cursor 'global))
1671              (face-property-equal 'text-cursor 'default 'foreground device))
1672     (set-face-foreground 'text-cursor [default background] 'global
1673                          nil 'append))
1674   )
1675
1676 ;; New function with 20.1, suggested by Per Abrahamsen, coded by Kyle
1677 ;; Jones and Hrvoje Niksic.
1678 (defun set-face-stipple (face pixmap &optional frame)
1679   "Change the stipple pixmap of FACE to PIXMAP.
1680 This is an Emacs compatibility function; consider using
1681 set-face-background-pixmap instead.
1682
1683 PIXMAP should be a string, the name of a file of pixmap data.
1684 The directories listed in the variable `x-bitmap-file-path'
1685 under X is searched.
1686
1687 Alternatively, PIXMAP may be a list of the form (WIDTH HEIGHT
1688 DATA) where WIDTH and HEIGHT are the size in pixels, and DATA is
1689 a string, containing the raw bits of the bitmap.  XBM data is
1690 expected in this case, other types of image data will not work.
1691
1692 If the optional FRAME argument is provided, change only
1693 in that frame; otherwise change each frame."
1694   (while (not (find-face face))
1695     (setq face (wrong-type-argument 'facep face)))
1696   (let ((bitmap-path (ecase (console-type)
1697                        (x         x-bitmap-file-path)))
1698         instantiator)
1699     (while
1700         (null
1701          (setq instantiator
1702                (cond ((stringp pixmap)
1703                       (let ((file (if (file-name-absolute-p pixmap)
1704                                       pixmap
1705                                     (locate-file pixmap bitmap-path
1706                                                  '(".xbm" "")))))
1707                         (and file
1708                              `[xbm :file ,file])))
1709                      ((and (listp pixmap) (= (length pixmap) 3))
1710                       `[xbm :data ,pixmap])
1711                      (t nil))))
1712       ;; We're signaling a continuable error; let's make sure the
1713       ;; function `stipple-pixmap-p' at least exists.
1714       (flet ((stipple-pixmap-p (pixmap)
1715                (or (stringp pixmap)
1716                    (and (listp pixmap) (= (length pixmap) 3)))))
1717         (setq pixmap (signal 'wrong-type-argument
1718                              (list 'stipple-pixmap-p pixmap)))))
1719     (check-type frame (or null frame))
1720     (set-face-background-pixmap face instantiator frame)))
1721
1722 \f
1723 ;; Create the remaining standard faces now.  This way, packages that we dump
1724 ;; can reference these faces as parents.
1725 ;;
1726 ;; The default, modeline, left-margin, right-margin, text-cursor,
1727 ;; and pointer faces are created in C.
1728
1729 (make-face 'bold "Bold text.")
1730 (make-face 'italic "Italic text.")
1731 (make-face 'bold-italic "Bold-italic text.")
1732 (make-face 'underline "Underlined text.")
1733 (or (face-differs-from-default-p 'underline)
1734     (set-face-underline-p 'underline t 'global '(default)))
1735 (make-face 'zmacs-region "Used on highlighted region between point and mark.")
1736 (make-face 'isearch "Used on region matched by isearch.")
1737 (make-face 'isearch-secondary "Face to use for highlighting all matches.")
1738 (make-face 'list-mode-item-selected
1739            "Face for the selected list item in list-mode.")
1740 (make-face 'highlight "Highlight face.")
1741 (make-face 'primary-selection "Primary selection face.")
1742 (make-face 'secondary-selection "Secondary selection face.")
1743
1744 ;; Several useful color faces.
1745 (eval-when-compile (load "cl-macs"))
1746 (dolist (color '(red green blue yellow))
1747   (make-face color (concat (symbol-name color) " text."))
1748   (set-face-foreground color (symbol-name color) nil 'color))
1749
1750 ;; Make some useful faces.  This happens very early, before creating
1751 ;; the first non-stream device.
1752
1753 (set-face-background 'text-cursor
1754                      '(((x default) . "Red3"))
1755                      'global)
1756
1757 ;; some older X servers don't recognize "darkseagreen2"
1758 (set-face-background 'highlight
1759                      '(((x default color) . "darkseagreen2")
1760                        ((x default color) . "green")
1761                        ((x default grayscale) . "gray53"))
1762                      'global)
1763 (set-face-background-pixmap 'highlight
1764                             '(((x default mono) . "gray1"))
1765                             'global)
1766
1767 (set-face-background 'zmacs-region
1768                      '(((x default color) . "gray65")
1769                        ((x default grayscale) . "gray65"))
1770                      'global)
1771 (set-face-background-pixmap 'zmacs-region
1772                             '(((x default mono) . "gray3"))
1773                             'global)
1774
1775 (set-face-background 'list-mode-item-selected
1776                      '(((x default color) . "gray68")
1777                        ((x default grayscale) . "gray68")
1778                        ((x default mono) . [default foreground]))
1779                      'global)
1780 (set-face-foreground 'list-mode-item-selected
1781                      '(((x default mono) . [default background]))
1782                      'global)
1783
1784 (set-face-background 'primary-selection
1785                      '(((x default color) . "gray65")
1786                        ((x default grayscale) . "gray65"))
1787                      'global)
1788 (set-face-background-pixmap 'primary-selection
1789                             '(((x default mono) . "gray3"))
1790                             'global)
1791
1792 (set-face-background 'secondary-selection
1793                      '(((x default color) . "paleturquoise")
1794                        ((x default color) . "green")
1795                        ((x default grayscale) . "gray53"))
1796                      'global)
1797 (set-face-background-pixmap 'secondary-selection
1798                             '(((x default mono) . "gray1"))
1799                             'global)
1800
1801 (set-face-background 'isearch
1802                      '(((x default color) . "paleturquoise")
1803                        ((x default color) . "green"))
1804                      'global)
1805
1806 ;; #### This should really, I mean *really*, be converted to some form
1807 ;; of `defface' one day.
1808 (set-face-foreground 'isearch-secondary
1809                      '(((x default color) . "red3"))
1810                      'global)
1811
1812 ;; Define some logical color names to be used when reading the pixmap files.
1813 (if (featurep 'xpm)
1814     (setq xpm-color-symbols
1815           (list
1816            '("foreground" (face-foreground 'default))
1817            '("background" (face-background 'default))
1818            '("backgroundToolBarColor"
1819              (or
1820               (and
1821                (featurep 'x)
1822                (x-get-resource "backgroundToolBarColor"
1823                                "BackgroundToolBarColor" 'string
1824                                nil nil 'warn))
1825
1826               (face-background 'toolbar)))
1827            '("foregroundToolBarColor"
1828              (or
1829               (and
1830                (featurep 'x)
1831                (x-get-resource "foregroundToolBarColor"
1832                                "ForegroundToolBarColor" 'string
1833                                nil nil 'warn))
1834               (face-foreground 'toolbar)))
1835            )))
1836
1837 (when (featurep 'tty)
1838   (set-face-highlight-p 'bold                    t 'global '(default tty))
1839   (set-face-underline-p 'italic                  t 'global '(default tty))
1840   (set-face-highlight-p 'bold-italic             t 'global '(default tty))
1841   (set-face-underline-p 'bold-italic             t 'global '(default tty))
1842   (set-face-highlight-p 'highlight               t 'global '(default tty))
1843   (set-face-reverse-p   'text-cursor             t 'global '(default tty))
1844   (set-face-reverse-p   'modeline                t 'global '(default tty))
1845   (set-face-reverse-p   'zmacs-region            t 'global '(default tty))
1846   (set-face-reverse-p   'primary-selection       t 'global '(default tty))
1847   (set-face-underline-p 'secondary-selection     t 'global '(default tty))
1848   (set-face-reverse-p   'list-mode-item-selected t 'global '(default tty))
1849   (set-face-reverse-p   'isearch                 t 'global '(default tty))
1850   )
1851
1852 ;;; faces.el ends here