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