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