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 tags)
 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         temp-sp)
 819     (if (valid-specifier-domain-p locale)
 820         ;; this is easy.
 821         (let* ((inst (face-property-instance face property locale))
 822                (name (and inst (funcall func inst (dfw-device locale)))))
 823           (when name
 824             (add-spec-to-specifier sp name locale tags)))
 825       ;; otherwise, map over all specifications ...
 826       ;; but first, some further kludging:
 827       ;; (1) if we're frobbing the global property, make sure
 828       ;;     that something is there (copy from the default face,
 829       ;;     if necessary).  Otherwise, something like
 830       ;;     (make-face-larger 'modeline)
 831       ;;     won't do anything at all if the modeline simply
 832       ;;     inherits its font from 'default.
 833       ;; (2) if we're frobbing a particular locale, nothing would
 834       ;;     happen if that locale has no instantiators.  So signal
 835       ;;     an error to indicate this.
 836
 837       (setq temp-sp
 838             (if (and (or (eq locale 'global) (eq locale 'all) (not locale))
 839                      (not (face-property face property 'global)))
 840                 (copy-specifier (face-property 'default property)
 841                                 nil 'global)
 842               sp))
 843       (if (and (valid-specifier-locale-p locale)
 844                (not (specifier-specs temp-sp locale)))
 845           (error "Property must have a specification in locale %S" locale))
 846       (map-specifier
 847        temp-sp
 848        (lambda (sp-arg locale inst-list func)
 849          (let* ((device (dfw-device locale))
 850                 ;; if a device can be derived from the locale,
 851                 ;; call frob-face-property-1 for that device.
 852                 ;; Otherwise map frob-face-property-1 over each device.
 853                 (result
 854                  (if device
 855                      (list (frob-face-property-1 sp-arg device inst-list func))
 856                    (mapcar (lambda (device)
 857                              (frob-face-property-1 sp-arg device
 858                                                    inst-list func))
 859                            (device-list))))
 860                 new-result)
 861            ;; remove duplicates and nils from the obtained list of
 862            ;; instantiators. Also add tags amd remove 'defaults'.
 863            (mapcar (lambda (arg)
 864                      (when arg
 865                        (if (not (consp arg))
 866                            (setq arg (cons tags arg))
 867                          (setcar arg (append tags (delete 'default
 868                                                           (car arg))))))
 869                      (when (and arg (not (member arg new-result)))
 870                        (setq new-result (cons arg new-result))))
 871                    result)
 872            ;; add back in.
 873            (add-spec-list-to-specifier sp (list (cons locale new-result)))
 874            ;; tell map-specifier to keep going.
 875            nil))
 876        locale
 877        func))))
 878
 879 (defun frob-face-property-1 (sp device inst-list func)
 880   (let
 881       (first-valid result)
 882     (while (and inst-list (not result))
 883       (let* ((inst-pair (car inst-list))
 884              (tag-set (car inst-pair))
 885              (sp-inst (specifier-instance-from-inst-list
 886                        sp device (list inst-pair))))
 887         (if sp-inst
 888             (progn
 889               (if (not first-valid)
 890                   (setq first-valid inst-pair))
 891               (setq result (funcall func sp-inst device))
 892               (if result
 893                   (setq result (cons tag-set result))))))
 894       (setq inst-list (cdr inst-list)))
 895     (or result first-valid)))
 896
 897 (defun frob-face-font-2 (face locale tags unfrobbed-face frobbed-face
 898                               tty-thunk x-thunk standard-face-mapping)
 899   ;; another kludge to make things more intuitive.  If we're
 900   ;; inheriting from a standard face in this locale, frob the
 901   ;; inheritance as appropriate.  Else, if, after the first X frobbing
 902   ;; pass, the face hasn't changed and still looks like the standard
 903   ;; unfrobbed face (e.g. 'default), make it inherit from the standard
 904   ;; frobbed face (e.g. 'bold).  Regardless of things, do the TTY
 905   ;; frobbing.
 906
 907   ;; yuck -- The LOCALE argument to make-face-bold is not actually a locale,
 908   ;; but is a "locale, locale-type, or nil for all".  So ...  do our extra
 909   ;; frobbing only if it's actually a locale; or for nil, do the frobbing
 910   ;; on 'global.  This specifier stuff needs some rethinking.
 911   (let* ((the-locale (cond ((null locale) 'global)
 912                            ((valid-specifier-locale-p locale) locale)
 913                            (t nil)))
 914          (specs (and the-locale (face-font face the-locale nil t)))
 915          (change-it (and specs (cdr (assoc specs standard-face-mapping)))))
 916     (if (and change-it
 917              (not (memq (face-name (find-face face))
 918                         '(default bold italic bold-italic))))
 919         (progn
 920           (or (equal change-it t)
 921               (set-face-property face 'font change-it the-locale))
 922           (funcall tty-thunk))
 923       (let* ((domain (cond ((null the-locale) nil)
 924                            ((valid-specifier-domain-p the-locale) the-locale)
 925                            ;; OK, this next one is truly a kludge, but
 926                            ;; it results in more intuitive behavior most
 927                            ;; of the time. (really!)
 928                            ((or (eq the-locale 'global) (eq the-locale 'all))
 929                             (selected-device))
 930                            (t nil)))
 931              (inst (and domain (face-property-instance face 'font domain))))
 932         (funcall tty-thunk)
 933         (funcall x-thunk)
 934         ;; If it's reasonable to do the inherit-from-standard-face trick,
 935         ;; and it's called for, then do it now.
 936         (or (null domain)
 937             (not (equal inst (face-property-instance face 'font domain)))
 938             ;; don't do it for standard faces, or you'll get inheritance loops.
 939             ;; #### This makes XEmacs seg fault! fix this bug.
 940             (memq (face-name (find-face face))
 941                   '(default bold italic bold-italic))
 942             (not (equal (face-property-instance face 'font domain)
 943                         (face-property-instance unfrobbed-face 'font domain)))
 944             (set-face-property face 'font (vector frobbed-face)
 945                                the-locale tags))))))
 946
 947 (defun make-face-bold (face &optional locale tags)
 948   "Make FACE bold in LOCALE, if possible.
 949 This will attempt to make the font bold for X locales and will set the
 950 highlight flag for TTY locales.
 951
 952 If LOCALE is nil, omitted, or `all', this will attempt to frob all
 953 font specifications for FACE to make them appear bold.  Similarly, if
 954 LOCALE is a locale type, this frobs all font specifications for locales
 955 of that type.  If LOCALE is a particular locale, what happens depends on
 956 what sort of locale is given.  If you gave a device, frame, or window,
 957 then it's always possible to determine what the font actually will be,
 958 so this is determined and the resulting font is frobbed and added back as a
 959 specification for this locale.  If LOCALE is a buffer, however, you can't
 960 determine what the font will actually be unless there's actually a
 961 specification given for that particular buffer (otherwise, it depends
 962 on what window and frame the buffer appears in, and might not even be
 963 well-defined if the buffer appears multiple times in different places);
 964 therefore you will get an error unless there's a specification for the
 965 buffer.
 966
 967 Finally, in some cases (specifically, when LOCALE is not a locale type),
 968 if the frobbing didn't actually make the font look any different
 969 \(this happens, for example, if your font specification is already bold
 970 or has no bold equivalent), and currently looks like the font of the
 971 'default face, it is set to inherit from the 'bold face.  This is kludgy
 972 but it makes `make-face-bold' have more intuitive behavior in many
 973 circumstances."
 974   (interactive (list (read-face-name "Make which face bold: ")))
 975   (frob-face-font-2
 976    face locale tags 'default 'bold
 977    (lambda ()
 978      ;; handle TTY specific entries
 979      (when (featurep 'tty)
 980        (set-face-highlight-p face t locale (cons 'tty tags))))
 981    (lambda ()
 982      ;; handle X specific entries
 983      (when (featurep 'x)
 984        (frob-face-property face 'font 'x-make-font-bold locale tags))
 985      (when (featurep 'mswindows)
 986        (frob-face-property face 'font 'mswindows-make-font-bold locale tags))
 987      )
 988    '(([default] . [bold])
 989      ([bold] . t)
 990      ([italic] . [bold-italic])
 991      ([bold-italic] . t))))
 992
 993 (defun make-face-italic (face &optional locale tags)
 994   "Make FACE italic in LOCALE, if possible.
 995 This will attempt to make the font italic for X locales and will set
 996 the underline flag for TTY locales.
 997 See `make-face-bold' for the semantics of the LOCALE argument and
 998 for more specifics on exactly how this function works."
 999   (interactive (list (read-face-name "Make which face italic: ")))
1000   (frob-face-font-2
1001    face locale tags 'default 'italic
1002    (lambda ()
1003      ;; handle TTY specific entries
1004      (when (featurep 'tty)
1005        (set-face-underline-p face t locale (cons 'tty tags))))
1006    (lambda ()
1007      ;; handle X specific entries
1008      (when (featurep 'x)
1009        (frob-face-property face 'font 'x-make-font-italic locale tags))
1010      (when (featurep 'mswindows)
1011        (frob-face-property face 'font 'mswindows-make-font-italic locale tags))
1012      )
1013    '(([default] . [italic])
1014      ([bold] . [bold-italic])
1015      ([italic] . t)
1016      ([bold-italic] . t))))
1017
1018 (defun make-face-bold-italic (face &optional locale tags)
1019   "Make FACE bold and italic in LOCALE, if possible.
1020 This will attempt to make the font bold-italic for X locales and will
1021 set the highlight and underline flags for TTY locales.
1022 See `make-face-bold' for the semantics of the LOCALE argument and
1023 for more specifics on exactly how this function works."
1024   (interactive (list (read-face-name "Make which face bold-italic: ")))
1025   (frob-face-font-2
1026    face locale tags 'default 'bold-italic
1027    (lambda ()
1028      ;; handle TTY specific entries
1029      (when (featurep 'tty)
1030        (set-face-highlight-p face t locale (cons 'tty tags))
1031        (set-face-underline-p face t locale (cons 'tty tags))))
1032    (lambda ()
1033      ;; handle X specific entries
1034      (when (featurep 'x)
1035        (frob-face-property face 'font 'x-make-font-bold-italic locale tags))
1036      (when (featurep 'mswindows)
1037        (frob-face-property face 'font 'mswindows-make-font-bold-italic locale tags))
1038      )
1039    '(([default] . [italic])
1040      ([bold] . [bold-italic])
1041      ([italic] . [bold-italic])
1042      ([bold-italic] . t))))
1043
1044 (defun make-face-unbold (face &optional locale tags)
1045   "Make FACE non-bold in LOCALE, if possible.
1046 This will attempt to make the font non-bold for X locales and will
1047 unset the highlight flag for TTY locales.
1048 See `make-face-bold' for the semantics of the LOCALE argument and
1049 for more specifics on exactly how this function works."
1050   (interactive (list (read-face-name "Make which face non-bold: ")))
1051   (frob-face-font-2
1052    face locale tags 'bold 'default
1053    (lambda ()
1054      ;; handle TTY specific entries
1055      (when (featurep 'tty)
1056        (set-face-highlight-p face nil locale (cons 'tty tags))))
1057    (lambda ()
1058      ;; handle X specific entries
1059      (when (featurep 'x)
1060        (frob-face-property face 'font 'x-make-font-unbold locale tags))
1061      (when (featurep 'mswindows)
1062        (frob-face-property face 'font 'mswindows-make-font-unbold locale tags))
1063      )
1064    '(([default] . t)
1065      ([bold] . [default])
1066      ([italic] . t)
1067      ([bold-italic] . [italic]))))
1068
1069 (defun make-face-unitalic (face &optional locale tags)
1070   "Make FACE non-italic in LOCALE, if possible.
1071 This will attempt to make the font non-italic for X locales and will
1072 unset the underline flag for TTY locales.
1073 See `make-face-bold' for the semantics of the LOCALE argument and
1074 for more specifics on exactly how this function works."
1075   (interactive (list (read-face-name "Make which face non-italic: ")))
1076   (frob-face-font-2
1077    face locale tags 'italic 'default
1078    (lambda ()
1079      ;; handle TTY specific entries
1080      (when (featurep 'tty)
1081        (set-face-underline-p face nil locale (cons 'tty tags))))
1082    (lambda ()
1083      ;; handle X specific entries
1084      (when (featurep 'x)
1085        (frob-face-property face 'font 'x-make-font-unitalic locale tags))
1086      (when (featurep 'mswindows)
1087        (frob-face-property face 'font 'mswindows-make-font-unitalic locale tags))
1088      )
1089    '(([default] . t)
1090      ([bold] . t)
1091      ([italic] . [default])
1092      ([bold-italic] . [bold]))))
1093
1094
1095 ;; Why do the following two functions lose so badly in so many
1096 ;; circumstances?
1097
1098 (defun make-face-smaller (face &optional locale)
1099   "Make the font of FACE be smaller, if possible.
1100 LOCALE works as in `make-face-bold' et al., but the ``inheriting-
1101 from-the-bold-face'' operations described there are not done
1102 because they don't make sense in this context."
1103   (interactive (list (read-face-name "Shrink which face: ")))
1104   ;; handle X specific entries
1105   (when (featurep 'x)
1106     (frob-face-property face 'font 'x-find-smaller-font locale))
1107   (when (featurep 'mswindows)
1108     (frob-face-property face 'font 'mswindows-find-smaller-font locale)))
1109
1110 (defun make-face-larger (face &optional locale)
1111   "Make the font of FACE be larger, if possible.
1112 See `make-face-smaller' for the semantics of the LOCALE argument."
1113   (interactive (list (read-face-name "Enlarge which face: ")))
1114   ;; handle X specific entries
1115   (when (featurep 'x)
1116     (frob-face-property face 'font 'x-find-larger-font locale))
1117   (when (featurep 'mswindows)
1118     (frob-face-property face 'font 'mswindows-find-larger-font locale)))
1119
1120 (defun invert-face (face &optional locale)
1121   "Swap the foreground and background colors of the face."
1122   (interactive (list (read-face-name "Invert face: ")))
1123   (if (valid-specifier-domain-p locale)
1124       (let ((foreface (face-foreground-instance face locale)))
1125         (set-face-foreground face (face-background-instance face locale)
1126                              locale)
1127         (set-face-background face foreface locale))
1128     (let ((forespec (copy-specifier (face-foreground face) nil locale)))
1129       (copy-specifier (face-background face) (face-foreground face) locale)
1130       (copy-specifier forespec (face-background face) locale))))
1131
1132 \f
1133 ;;; Convenience functions
1134
1135 (defun face-ascent (face &optional domain charset)
1136   "Return the ascent of FACE in DOMAIN.
1137 See `face-property-instance' for the semantics of the DOMAIN argument."
1138   (font-ascent (face-font face) domain charset))
1139
1140 (defun face-descent (face &optional domain charset)
1141   "Return the descent of FACE in DOMAIN.
1142 See `face-property-instance' for the semantics of the DOMAIN argument."
1143   (font-descent (face-font face) domain charset))
1144
1145 (defun face-width (face &optional domain charset)
1146   "Return the width of FACE in DOMAIN.
1147 See `face-property-instance' for the semantics of the DOMAIN argument."
1148   (font-width (face-font face) domain charset))
1149
1150 (defun face-height (face &optional domain charset)
1151   "Return the height of FACE in DOMAIN.
1152 See `face-property-instance' for the semantics of the DOMAIN argument."
1153   (+ (face-ascent face domain charset) (face-descent face domain charset)))
1154
1155 (defun face-proportional-p (face &optional domain charset)
1156   "Return t if FACE is proportional in DOMAIN.
1157 See `face-property-instance' for the semantics of the DOMAIN argument."
1158   (font-proportional-p (face-font face) domain charset))
1159
1160 \f
1161 ;; Functions that used to be in cus-face.el, but logically go here.
1162
1163 (defcustom frame-background-mode nil
1164   "*The brightness of the background.
1165 Set this to the symbol dark if your background color is dark, light if
1166 your background is light, or nil (default) if you want Emacs to
1167 examine the brightness for you."
1168   :group 'faces
1169   :type '(choice (choice-item dark)
1170                  (choice-item light)
1171                  (choice-item :tag "Auto" nil)))
1172
1173 ;; The old variable that many people still have in .emacs files.
1174 (define-obsolete-variable-alias 'custom-background-mode
1175   'frame-background-mode)
1176
1177 (defun get-frame-background-mode (frame)
1178   "Detect background mode for FRAME."
1179   (let* ((color-instance (face-background-instance 'default frame))
1180          (mode (condition-case nil
1181                    (if (< (apply '+ (color-instance-rgb-components
1182                                      color-instance)) 65536)
1183                        'dark 'light)
1184                  ;; Here, we get an error on a TTY.  As we don't have
1185                  ;; a good way of detecting whether a TTY is light or
1186                  ;; dark, we'll guess it's dark.
1187                  (error 'dark))))
1188     (set-frame-property frame 'background-mode mode)
1189     mode))
1190
1191 (defun extract-custom-frame-properties (frame)
1192   "Return a plist with the frame properties of FRAME used by custom."
1193   (list 'type (or (frame-property frame 'display-type)
1194                   (device-type (frame-device frame)))
1195         'class (device-class (frame-device frame))
1196         'background (or frame-background-mode
1197                         (frame-property frame 'background-mode)
1198                         (get-frame-background-mode frame))))
1199
1200 (defcustom init-face-from-resources t
1201   "If non nil, attempt to initialize faces from the resource database."
1202   :group 'faces
1203   :type 'boolean)
1204
1205 ;; Old name, used by custom.  Also, FSFmacs name.
1206 (defvaralias 'initialize-face-resources 'init-face-from-resources)
1207
1208 ;; Make sure all custom setting are added with this tag so we can
1209 ;; identify-them
1210 (define-specifier-tag 'custom)
1211
1212 (defun face-spec-set (face spec &optional frame tags)
1213   "Set FACE's face attributes according to the first matching entry in SPEC.
1214 If optional FRAME is non-nil, set it for that frame only.
1215 If it is nil, then apply SPEC to each frame individually.
1216 See `defface' for information about SPEC."
1217   (if frame
1218       (progn
1219         (reset-face face frame tags)
1220         (face-display-set face spec frame tags)
1221         (init-face-from-resources face frame))
1222     (let ((frames (relevant-custom-frames)))
1223       (reset-face face nil tags)
1224       ;; This should not be needed. We only remove our own specifiers
1225       ;; (if (and (eq 'default face) (featurep 'x))
1226       ;;          (x-init-global-faces))
1227       (face-display-set face spec nil tags)
1228       (while frames
1229         (face-display-set face spec (car frames) tags)
1230         (pop frames))
1231       (init-face-from-resources face))))
1232
1233 (defun face-display-set (face spec &optional frame tags)
1234   "Set FACE to the attributes to the first matching entry in SPEC.
1235 Iff optional FRAME is non-nil, set it for that frame only.
1236 See `defface' for information about SPEC."
1237   (while spec
1238     (let ((display (caar spec))
1239           (atts (cadar spec)))
1240       (pop spec)
1241       (when (face-spec-set-match-display display frame)
1242         ;; Avoid creating frame local duplicates of the global face.
1243         (unless (and frame (eq display (get face 'custom-face-display)))
1244           (apply 'face-custom-attributes-set face frame tags atts))
1245         (unless frame
1246           (put face 'custom-face-display display))
1247         (setq spec nil)))))
1248
1249 (defvar default-custom-frame-properties nil
1250   "The frame properties used for the global faces.
1251 Frames not matching these propertiess should have frame local faces.
1252 The value should be nil, if uninitialized, or a plist otherwise.
1253 See `defface' for a list of valid keys and values for the plist.")
1254
1255 (defun get-custom-frame-properties (&optional frame)
1256   "Return a plist with the frame properties of FRAME used by custom.
1257 If FRAME is nil, return the default frame properties."
1258   (cond (frame
1259          ;; Try to get from cache.
1260          (let ((cache (frame-property frame 'custom-properties)))
1261            (unless cache
1262              ;; Oh well, get it then.
1263              (setq cache (extract-custom-frame-properties frame))
1264              ;; and cache it...
1265              (set-frame-property frame 'custom-properties cache))
1266            cache))
1267         (default-custom-frame-properties)
1268         (t
1269          (setq default-custom-frame-properties
1270                (extract-custom-frame-properties (selected-frame))))))
1271
1272 (defun face-spec-update-all-matching (spec display plist)
1273   "Update all entries in the face spec that could match display to
1274 have the entries from the new plist and return the new spec"
1275   (mapcar
1276    (lambda (e)
1277      (let ((entries (car e))
1278            (options (cadr e))
1279            (match t)
1280            dplist
1281            (new-options plist)
1282            )
1283        (unless (eq display t)
1284          (mapc (lambda (arg)
1285                  (setq dplist (plist-put dplist (car arg) (cadr arg))))
1286                display))
1287        (unless (eq entries t)
1288          (mapc (lambda (arg)
1289                  (setq match (and match (eq (cadr arg)
1290                                             (plist-get
1291                                               dplist (car arg)
1292                                               (cadr arg))))))
1293                entries))
1294        (if (not match)
1295            e
1296          (while new-options
1297            (setq options
1298                  (plist-put options (car new-options) (cadr new-options)))
1299            (setq new-options (cddr new-options)))
1300          (list entries options))))
1301    (copy-sequence spec)))
1302
1303
1304
1305 (defun face-spec-set-match-display (display &optional frame)
1306   "Return non-nil if DISPLAY matches FRAME.
1307 DISPLAY is part of a spec such as can be used in `defface'.
1308 If FRAME is nil or omitted, the selected frame is used."
1309   (if (eq display t)
1310       t
1311     (let* ((props (get-custom-frame-properties frame))
1312            (type (plist-get props 'type))
1313            (class (plist-get props 'class))
1314            (background (plist-get props 'background))
1315            (match t)
1316            (entries display)
1317            entry req options)
1318       (while (and entries match)
1319         (setq entry (car entries)
1320               entries (cdr entries)
1321               req (car entry)
1322               options (cdr entry)
1323               match (case req
1324                       (type       (memq type options))
1325                       (class      (memq class options))
1326                       (background (memq background options))
1327                       (t (warn "Unknown req `%S' with options `%S'"
1328                                req options)
1329                          nil))))
1330       match)))
1331
1332 (defun relevant-custom-frames ()
1333   "List of frames whose custom properties differ from the default."
1334   (let ((relevant nil)
1335         (default (get-custom-frame-properties))
1336         (frames (frame-list))
1337         frame)
1338     (while frames
1339       (setq frame (car frames)
1340             frames (cdr frames))
1341       (unless (equal default (get-custom-frame-properties frame))
1342         (push frame relevant)))
1343     relevant))
1344
1345 (defun initialize-custom-faces (&optional frame)
1346   "Initialize all custom faces for FRAME.
1347 If FRAME is nil or omitted, initialize them for all frames."
1348   (mapc (lambda (symbol)
1349           (let ((spec (or (get symbol 'saved-face)
1350                           (get symbol 'face-defface-spec))))
1351             (when spec
1352               ;; No need to init-face-from-resources -- code in
1353               ;; `init-frame-faces' does it already.
1354               (face-display-set symbol spec frame))))
1355         (face-list)))
1356
1357 (defun custom-initialize-frame (frame)
1358   "Initialize frame-local custom faces for FRAME if necessary."
1359   (unless (equal (get-custom-frame-properties)
1360                  (get-custom-frame-properties frame))
1361     (initialize-custom-faces frame)))
1362
1363 \f
1364 (defun make-empty-face (name &optional doc-string temporary)
1365   "Like `make-face', but doesn't query the resource database."
1366   (let ((init-face-from-resources nil))
1367     (make-face name doc-string temporary)))
1368
1369 (defun init-face-from-resources (face &optional locale)
1370   "Initialize FACE from the resource database.
1371 If LOCALE is specified, it should be a frame, device, or 'global, and
1372 the face will be resourced over that locale.  Otherwise, the face will
1373 be resourced over all possible locales (i.e. all frames, all devices,
1374 and 'global)."
1375   (cond ((null init-face-from-resources)
1376          ;; Do nothing.
1377          )
1378         ((not locale)
1379          ;; Global, set for all frames.
1380          (progn
1381            (init-face-from-resources face 'global)
1382            (let ((devices (device-list)))
1383              (while devices
1384                (init-face-from-resources face (car devices))
1385                (setq devices (cdr devices))))
1386            (let ((frames (frame-list)))
1387              (while frames
1388                (init-face-from-resources face (car frames))
1389                (setq frames (cdr frames))))))
1390         (t
1391          ;; Specific.
1392          (let ((devtype (cond ((devicep locale) (device-type locale))
1393                               ((framep locale) (frame-type locale))
1394                               (t nil))))
1395            (cond ((or (and (not devtype) (featurep 'x)) (eq 'x devtype))
1396                   (x-init-face-from-resources face locale))
1397                  ((or (not devtype) (eq 'tty devtype))
1398                   ;; Nothing to do for TTYs?
1399                   ))))))
1400
1401 (defun init-device-faces (device)
1402   ;; First, add any device-local face resources.
1403   (when init-face-from-resources
1404     (loop for face in (face-list) do
1405           (init-face-from-resources face device))
1406     ;; Then do any device-specific initialization.
1407     (cond ((eq 'x (device-type device))
1408            (x-init-device-faces device))
1409           ((eq 'mswindows (device-type device))
1410            (mswindows-init-device-faces device))
1411           ;; Nothing to do for TTYs?
1412           )
1413     (init-other-random-faces device)))
1414
1415 (defun init-frame-faces (frame)
1416   (when init-face-from-resources
1417     ;; First, add any frame-local face resources.
1418     (loop for face in (face-list) do
1419           (init-face-from-resources face frame))
1420     ;; Then do any frame-specific initialization.
1421     (cond ((eq 'x (frame-type frame))
1422            (x-init-frame-faces frame))
1423           ((eq 'mswindows (frame-type frame))
1424            (mswindows-init-frame-faces frame))
1425           ;; Is there anything which should be done for TTY's?
1426           )))
1427
1428 ;; #### This is somewhat X-specific, and is called when the first
1429 ;; X device is created (even if there were TTY devices created
1430 ;; beforehand).  The concept of resources has not been generalized
1431 ;; outside of X-specificness, so we have to live with this
1432 ;; breach of device-independence.
1433
1434 (defun init-global-faces ()
1435   ;; Look for global face resources.
1436   (loop for face in (face-list) do
1437         (init-face-from-resources face 'global))
1438   ;; Further X frobbing.
1439   (x-init-global-faces)
1440   ;; for bold and the like, make the global specification be bold etc.
1441   ;; if the user didn't already specify a value.  These will also be
1442   ;; frobbed further in init-other-random-faces.
1443   (unless (face-font 'bold 'global)
1444     (make-face-bold 'bold 'global))
1445   ;;
1446   (unless (face-font 'italic 'global)
1447     (make-face-italic 'italic 'global))
1448   ;;
1449   (unless (face-font 'bold-italic 'global)
1450     (make-face-bold-italic 'bold-italic 'global)
1451     (unless (face-font 'bold-italic 'global)
1452       (copy-face 'bold 'bold-italic)
1453       (make-face-italic 'bold-italic)))
1454
1455   (when (face-equal 'bold 'bold-italic)
1456     (copy-face 'italic 'bold-italic)
1457     (make-face-bold 'bold-italic))
1458   ;;
1459   ;; Nothing more to be done for X or TTY's?
1460   )
1461
1462
1463 ;; These warnings are there for a reason.  Just specify your fonts
1464 ;; correctly.  Deal with it.  Additionally, one can use
1465 ;; `log-warning-minimum-level' instead of this.
1466 ;(defvar inhibit-font-complaints nil
1467 ;  "Whether to suppress complaints about incomplete sets of fonts.")
1468
1469 (defun face-complain-about-font (face device)
1470   (if (symbolp face) (setq face (symbol-name face)))
1471 ;;  (if (not inhibit-font-complaints)
1472   (display-warning
1473    'font
1474    (let ((default-name (face-font-name 'default device)))
1475      (format "%s: couldn't deduce %s %s version of the font
1476 %S.
1477
1478 Please specify X resources to make the %s face
1479 visually distinguishable from the default face.
1480 For example, you could add one of the following to $HOME/Emacs:
1481
1482 Emacs.%s.attributeFont: -dt-*-medium-i-*
1483 or
1484 Emacs.%s.attributeForeground: hotpink\n"
1485              invocation-name
1486              (if (string-match "\\`[aeiouAEIOU]" face) "an" "a")
1487              face
1488              default-name
1489              face
1490              face
1491              face
1492              ))))
1493
1494
1495 ;; #### This is quite a mess.  We should use the custom mechanism for
1496 ;; most of this stuff.  Currently we don't do it, because Custom
1497 ;; doesn't use specifiers (yet.)  FSF does it the Right Way.
1498
1499 ;; For instance, the definition of `bold' should be something like
1500 ;; (defface bold ((t (:bold t))) "Bold text.") -- and `:bold t' should
1501 ;; make sure that everything works properly.
1502
1503 (defun init-other-random-faces (device)
1504   "Initialize the colors and fonts of the bold, italic, bold-italic,
1505 zmacs-region, list-mode-item-selected, highlight, primary-selection,
1506 secondary-selection, and isearch faces when each device is created.  If
1507 you want to add code to do stuff like this, use the create-device-hook."
1508
1509   ;; try to make 'bold look different from the default on this device.
1510   ;; If that doesn't work at all, then issue a warning.
1511   (unless (face-differs-from-default-p 'bold device)
1512     (make-face-bold 'bold device)
1513     (unless (face-differs-from-default-p 'bold device)
1514       (make-face-unbold 'bold device)
1515       (unless (face-differs-from-default-p 'bold device)
1516         ;; the luser specified one of the bogus font names
1517         (face-complain-about-font 'bold device))))
1518
1519   ;; Similar for italic.
1520   ;; It's unreasonable to expect to be able to make a font italic all
1521   ;; the time.  For many languages, italic is an alien concept.
1522   ;; Basically, because italic is not a globally meaningful concept,
1523   ;; the use of the italic face should really be oboleted.
1524
1525   ;; I disagree with above.  In many languages, the concept of capital
1526   ;; letters is just as alien, and yet we use them.  Italic is here to
1527   ;; stay.  -hniksic
1528
1529   ;; In a Solaris Japanese environment, there just aren't any italic
1530   ;; fonts - period.  CDE recognizes this reality, and fonts
1531   ;; -dt-interface user-medium-r-normal-*-*-*-*-*-*-*-*-* don't come
1532   ;; in italic versions.  So we first try to make the font bold before
1533   ;; complaining.
1534   (unless (face-differs-from-default-p 'italic device)
1535     (make-face-italic 'italic device)
1536     (unless (face-differs-from-default-p 'italic device)
1537       (make-face-bold 'italic device)
1538       (unless (face-differs-from-default-p 'italic device)
1539         (face-complain-about-font 'italic device))))
1540
1541   ;; similar for bold-italic.
1542   (unless (face-differs-from-default-p 'bold-italic device)
1543     (make-face-bold-italic 'bold-italic device)
1544     ;; if we couldn't get a bold-italic version, try just bold.
1545     (unless (face-differs-from-default-p 'bold-italic device)
1546       (make-face-bold 'bold-italic device)
1547       ;; if we couldn't get bold or bold-italic, then that's probably because
1548       ;; the default font is bold, so make the `bold-italic' face be unbold.
1549       (unless (face-differs-from-default-p 'bold-italic device)
1550         (make-face-unbold 'bold-italic device)
1551         (make-face-italic 'bold-italic device)
1552         (unless (face-differs-from-default-p 'bold-italic device)
1553           ;; if that didn't work, try plain italic
1554           ;; (can this ever happen? what the hell.)
1555           (make-face-italic 'bold-italic device)
1556           (unless (face-differs-from-default-p 'bold-italic device)
1557             ;; then bitch and moan.
1558             (face-complain-about-font 'bold-italic device))))))
1559
1560   ;; Set the text-cursor colors unless already specified.
1561   (when (and (not (eq 'tty (device-type device)))
1562              (not (face-background 'text-cursor 'global))
1563              (face-property-equal 'text-cursor 'default 'background device))
1564     (set-face-background 'text-cursor [default foreground] 'global
1565                          nil 'append))
1566   (when (and (not (eq 'tty (device-type device)))
1567              (not (face-foreground 'text-cursor 'global))
1568              (face-property-equal 'text-cursor 'default 'foreground device))
1569     (set-face-foreground 'text-cursor [default background] 'global
1570                          nil 'append))
1571   )
1572
1573 ;; New function with 20.1, suggested by Per Abrahamsen, coded by Kyle Jones.
1574 (defun set-face-stipple (face pixmap &optional frame)
1575   "Change the stipple pixmap of FACE to PIXMAP.
1576 This is an Emacs compatibility function; consider using
1577 set-face-background-pixmap instead.
1578
1579 PIXMAP should be a string, the name of a file of pixmap data.
1580 The directories listed in the `x-bitmap-file-path' variable are searched.
1581
1582 Alternatively, PIXMAP may be a list of the form (WIDTH HEIGHT
1583 DATA) where WIDTH and HEIGHT are the size in pixels, and DATA is
1584 a string, containing the raw bits of the bitmap.  XBM data is
1585 expected in this case, other types of image data will not work.
1586
1587 If the optional FRAME argument is provided, change only
1588 in that frame; otherwise change each frame."
1589   (while (not (find-face face))
1590     (setq face (signal 'wrong-type-argument (list 'facep face))))
1591   (locate-file pixmap x-bitmap-file-path '(".xbm" ""))
1592   (while (cond ((stringp pixmap)
1593                 (unless (file-readable-p pixmap)
1594                   (setq pixmap `[xbm :file ,pixmap]))
1595                 nil)
1596                ((and (consp pixmap) (= (length pixmap) 3))
1597                 (setq pixmap `[xbm :data ,pixmap])
1598                 nil)
1599                (t t))
1600     (setq pixmap (signal 'wrong-type-argument
1601                          (list 'stipple-pixmap-p pixmap))))
1602   (while (and frame (not (framep frame)))
1603     (setq frame (signal 'wrong-type-argument (list 'framep frame))))
1604   (set-face-background-pixmap face pixmap frame))
1605
1606 \f
1607 ;; Create the remaining standard faces now.  This way, packages that we dump
1608 ;; can reference these faces as parents.
1609 ;;
1610 ;; The default, modeline, left-margin, right-margin, text-cursor,
1611 ;; and pointer faces are created in C.
1612
1613 (make-face 'bold "Bold text.")
1614 (make-face 'italic "Italic text.")
1615 (make-face 'bold-italic "Bold-italic text.")
1616 (make-face 'underline "Underlined text.")
1617 (or (face-differs-from-default-p 'underline)
1618     (set-face-underline-p 'underline t 'global '(default)))
1619 (make-face 'zmacs-region "Used on highlightes region between point and mark.")
1620 (make-face 'isearch "Used on region matched by isearch.")
1621 (make-face 'list-mode-item-selected
1622            "Face for the selected list item in list-mode.")
1623 (make-face 'highlight "Highlight face.")
1624 (make-face 'primary-selection "Primary selection face.")
1625 (make-face 'secondary-selection "Secondary selection face.")
1626
1627 ;; Several useful color faces.
1628 (eval-when-compile (load "cl-macs"))
1629 (dolist (color '(red green blue yellow))
1630   (make-face color (concat (symbol-name color) " text."))
1631   (set-face-foreground color (symbol-name color) nil 'color))
1632
1633 ;; Make some useful faces.  This happens very early, before creating
1634 ;; the first non-stream device.
1635
1636 (set-face-background 'text-cursor
1637                      '(((x default) . "Red3")
1638                        ((mswindows default) . "Red3"))
1639                      'global)
1640
1641 ;; some older X servers don't recognize "darkseagreen2"
1642 (set-face-background 'highlight
1643                      '(((x default color) . "darkseagreen2")
1644                        ((x default color) . "green")
1645                        ((x default grayscale) . "gray53")
1646                        ((mswindows default color) . "darkseagreen2")
1647                        ((mswindows default color) . "green")
1648                        ((mswindows default grayscale) . "gray53"))
1649                      'global)
1650 (set-face-background-pixmap 'highlight
1651                             '(((x default mono) . "gray1")
1652                               ((mswindows default mono) . "gray1"))
1653                             'global)
1654
1655 (set-face-background 'zmacs-region
1656                      '(((x default color) . "gray65")
1657                        ((x default grayscale) . "gray65")
1658                        ((mswindows default color) . "gray65")
1659                        ((mswindows default grayscale) . "gray65"))
1660                      'global)
1661 (set-face-background-pixmap 'zmacs-region
1662                             '(((x default mono) . "gray3")
1663                               ((mswindows default mono) . "gray3"))
1664                             'global)
1665
1666 (set-face-background 'list-mode-item-selected
1667                      '(((x default color) . "gray68")
1668                        ((x default grayscale) . "gray68")
1669                        ((x default mono) . [default foreground])
1670                        ((mswindows default color) . "gray68")
1671                        ((mswindows default grayscale) . "gray68")
1672                        ((mswindows default mono) . [default foreground]))
1673                      'global)
1674 (set-face-foreground 'list-mode-item-selected
1675                      '(((x default mono) . [default background])
1676                        ((mswindows default mono) . [default background]))
1677                      'global)
1678
1679 (set-face-background 'primary-selection
1680                      '(((x default color) . "gray65")
1681                        ((x default grayscale) . "gray65")
1682                        ((mswindows default color) . "gray65")
1683                        ((mswindows default grayscale) . "gray65"))
1684                      'global)
1685 (set-face-background-pixmap 'primary-selection
1686                             '(((x default mono) . "gray3")
1687                               ((mswindows default mono) . "gray3"))
1688                             'global)
1689
1690 (set-face-background 'secondary-selection
1691                      '(((x default color) . "paleturquoise")
1692                        ((x default color) . "green")
1693                        ((x default grayscale) . "gray53")
1694                        ((mswindows default color) . "paleturquoise")
1695                        ((mswindows default color) . "green")
1696                        ((mswindows default grayscale) . "gray53"))
1697                      'global)
1698 (set-face-background-pixmap 'secondary-selection
1699                             '(((x default mono) . "gray1")
1700                               ((mswindows default mono) . "gray1"))
1701                             'global)
1702
1703 (set-face-background 'isearch
1704                      '(((x default color) . "paleturquoise")
1705                        ((x default color) . "green")
1706                        ((mswindows default color) . "paleturquoise")
1707                        ((mswindows default color) . "green"))
1708                      'global)
1709
1710 ;; Define some logical color names to be used when reading the pixmap files.
1711 (if (featurep 'xpm)
1712     (setq xpm-color-symbols
1713           (list
1714            (purecopy '("foreground" (face-foreground 'default)))
1715            (purecopy '("background" (face-background 'default)))
1716            (purecopy '("backgroundToolBarColor"
1717                        (or
1718                         (and
1719                          (featurep 'x)
1720                          (x-get-resource "backgroundToolBarColor"
1721                                          "BackgroundToolBarColor" 'string))
1722
1723                         (face-background 'toolbar))))
1724            (purecopy '("foregroundToolBarColor"
1725                        (or
1726                         (and
1727                          (featurep 'x)
1728                          (x-get-resource "foregroundToolBarColor"
1729                                          "ForegroundToolBarColor" 'string))
1730                         (face-foreground 'toolbar))))
1731            )))
1732
1733 (when (featurep 'tty)
1734   (set-face-highlight-p 'bold                    t 'global '(default tty))
1735   (set-face-underline-p 'italic                  t 'global '(default tty))
1736   (set-face-highlight-p 'bold-italic             t 'global '(default tty))
1737   (set-face-underline-p 'bold-italic             t 'global '(default tty))
1738   (set-face-highlight-p 'highlight               t 'global '(default tty))
1739   (set-face-reverse-p   'text-cursor             t 'global '(default tty))
1740   (set-face-reverse-p   'modeline                t 'global '(default tty))
1741   (set-face-reverse-p   'zmacs-region            t 'global '(default tty))
1742   (set-face-reverse-p   'primary-selection       t 'global '(default tty))
1743   (set-face-underline-p 'secondary-selection     t 'global '(default tty))
1744   (set-face-reverse-p   'list-mode-item-selected t 'global '(default tty))
1745   (set-face-reverse-p   'isearch                 t 'global '(default tty))
1746   )
1747
1748 ;;; faces.el ends here