Mercurial > hg > xemacs-beta

comparison lisp/faces.el @ 412:697ef44129c6 r21-2-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-14
author cvs
date Mon, 13 Aug 2007 11:20:41 +0200
parents de805c49cfc1
children ebe98a74bd68
comparison
equal deleted inserted replaced
411:12e008d41344 412:697ef44129c6
29 ;;; Commentary: 29 ;;; Commentary:
30 30
31 ;; This file is dumped with XEmacs. 31 ;; This file is dumped with XEmacs.
32 32
33 ;; face implementation #1 (used Lisp vectors and parallel C vectors; 33 ;; face implementation #1 (used Lisp vectors and parallel C vectors;
34 ;; FSFmacs still uses this) authored by Jamie Zawinski <jwz@jwz.org> 34 ;; FSFmacs still uses this) authored by Jamie Zawinski <jwz@netscape.com>
35 ;; pre Lucid-Emacs 19.0. 35 ;; pre Lucid-Emacs 19.0.
36 36
37 ;; face implementation #2 (used one face object per frame per face) 37 ;; face implementation #2 (used one face object per frame per face)
38 ;; authored by Jamie Zawinski for 19.9. 38 ;; authored by Jamie Zawinski for 19.9.
39 39
290 290
291 291
292 The following symbols have predefined meanings: 292 The following symbols have predefined meanings:
293 293
294 foreground The foreground color of the face. 294 foreground The foreground color of the face.
295 For valid instantiators, see `make-color-specifier'. 295 For valid instantiators, see `color-specifier-p'.
296 296
297 background The background color of the face. 297 background The background color of the face.
298 For valid instantiators, see `make-color-specifier'. 298 For valid instantiators, see `color-specifier-p'.
299 299
300 font The font used to display text covered by this face. 300 font The font used to display text covered by this face.
301 For valid instantiators, see `make-font-specifier'. 301 For valid instantiators, see `font-specifier-p'.
302 302
303 display-table The display table of the face. 303 display-table The display table of the face.
304 This should be a vector of 256 elements. 304 This should be a vector of 256 elements.
305 305
306 background-pixmap The pixmap displayed in the background of the face. 306 background-pixmap The pixmap displayed in the background of the face.
307 Only used by faces on X devices. 307 Only used by faces on X devices.
308 For valid instantiators, see `make-image-specifier'. 308 For valid instantiators, see `image-specifier-p'.
309 309
310 underline Underline all text covered by this face. 310 underline Underline all text covered by this face.
311 For valid instantiators, see `make-face-boolean-specifier'. 311 For valid instantiators, see `face-boolean-specifier-p'.
312 312
313 strikethru Draw a line through all text covered by this face. 313 strikethru Draw a line through all text covered by this face.
314 For valid instantiators, see `make-face-boolean-specifier'. 314 For valid instantiators, see `face-boolean-specifier-p'.
315 315
316 highlight Highlight all text covered by this face. 316 highlight Highlight all text covered by this face.
317 Only used by faces on TTY devices. 317 Only used by faces on TTY devices.
318 For valid instantiators, see `make-face-boolean-specifier'. 318 For valid instantiators, see `face-boolean-specifier-p'.
319 319
320 dim Dim all text covered by this face. 320 dim Dim all text covered by this face.
321 For valid instantiators, see `make-face-boolean-specifier'. 321 For valid instantiators, see `face-boolean-specifier-p'.
322 322
323 blinking Blink all text covered by this face. 323 blinking Blink all text covered by this face.
324 Only used by faces on TTY devices. 324 Only used by faces on TTY devices.
325 For valid instantiators, see `make-face-boolean-specifier'. 325 For valid instantiators, see `face-boolean-specifier-p'.
326 326
327 reverse Reverse the foreground and background colors. 327 reverse Reverse the foreground and background colors.
328 Only used by faces on TTY devices. 328 Only used by faces on TTY devices.
329 For valid instantiators, see `make-face-boolean-specifier'. 329 For valid instantiators, see `face-boolean-specifier-p'.
330 330
331 doc-string Description of what the face's normal use is. 331 doc-string Description of what the face's normal use is.
332 NOTE: This is not a specifier, unlike all 332 NOTE: This is not a specifier, unlike all
333 the other built-in properties, and cannot 333 the other built-in properties, and cannot
334 contain locale-specific values." 334 contain locale-specific values."
431 (defun set-face-font (face font &optional locale tag-set how-to-add) 431 (defun set-face-font (face font &optional locale tag-set how-to-add)
432 "Change the font of FACE to FONT in LOCALE. 432 "Change the font of FACE to FONT in LOCALE.
433 433
434 FACE may be either a face object or a symbol representing a face. 434 FACE may be either a face object or a symbol representing a face.
435 435
436 FONT should be an instantiator (see `make-font-specifier'), a list of 436 FONT should be an instantiator (see `font-specifier-p'), a list of
437 instantiators, an alist of specifications (each mapping a 437 instantiators, an alist of specifications (each mapping a
438 locale to an instantiator list), or a font specifier object. 438 locale to an instantiator list), or a font specifier object.
439 439
440 If FONT is an alist, LOCALE must be omitted. If FONT is a 440 If FONT is an alist, LOCALE must be omitted. If FONT is a
441 specifier object, LOCALE can be a locale, a locale type, 'all, 441 specifier object, LOCALE can be a locale, a locale type, 'all,
488 (defun set-face-foreground (face color &optional locale tag-set how-to-add) 488 (defun set-face-foreground (face color &optional locale tag-set how-to-add)
489 "Change the foreground color of FACE to COLOR in LOCALE. 489 "Change the foreground color of FACE to COLOR in LOCALE.
490 490
491 FACE may be either a face object or a symbol representing a face. 491 FACE may be either a face object or a symbol representing a face.
492 492
493 COLOR should be an instantiator (see `make-color-specifier'), a list of 493 COLOR should be an instantiator (see `color-specifier-p'), a list of
494 instantiators, an alist of specifications (each mapping a locale to 494 instantiators, an alist of specifications (each mapping a locale to
495 an instantiator list), or a color specifier object. 495 an instantiator list), or a color specifier object.
496 496
497 If COLOR is an alist, LOCALE must be omitted. If COLOR is a 497 If COLOR is an alist, LOCALE must be omitted. If COLOR is a
498 specifier object, LOCALE can be a locale, a locale type, 'all, 498 specifier object, LOCALE can be a locale, a locale type, 'all,
545 (defun set-face-background (face color &optional locale tag-set how-to-add) 545 (defun set-face-background (face color &optional locale tag-set how-to-add)
546 "Change the background color of FACE to COLOR in LOCALE. 546 "Change the background color of FACE to COLOR in LOCALE.
547 547
548 FACE may be either a face object or a symbol representing a face. 548 FACE may be either a face object or a symbol representing a face.
549 549
550 COLOR should be an instantiator (see `make-color-specifier'), a list of 550 COLOR should be an instantiator (see `color-specifier-p'), a list of
551 instantiators, an alist of specifications (each mapping a locale to 551 instantiators, an alist of specifications (each mapping a locale to
552 an instantiator list), or a color specifier object. 552 an instantiator list), or a color specifier object.
553 553
554 If COLOR is an alist, LOCALE must be omitted. If COLOR is a 554 If COLOR is an alist, LOCALE must be omitted. If COLOR is a
555 specifier object, LOCALE can be a locale, a locale type, 'all, 555 specifier object, LOCALE can be a locale, a locale type, 'all,
593 "Change the background pixmap of FACE to PIXMAP in LOCALE. 593 "Change the background pixmap of FACE to PIXMAP in LOCALE.
594 This property is only used on window system devices. 594 This property is only used on window system devices.
595 595
596 FACE may be either a face object or a symbol representing a face. 596 FACE may be either a face object or a symbol representing a face.
597 597
598 PIXMAP should be an instantiator (see `make-image-specifier'), a list 598 PIXMAP should be an instantiator (see `image-specifier-p'), a list
599 of instantiators, an alist of specifications (each mapping a locale 599 of instantiators, an alist of specifications (each mapping a locale
600 to an instantiator list), or an image specifier object. 600 to an instantiator list), or an image specifier object.
601 601
602 If PIXMAP is an alist, LOCALE must be omitted. If PIXMAP is a 602 If PIXMAP is an alist, LOCALE must be omitted. If PIXMAP is a
603 specifier object, LOCALE can be a locale, a locale type, 'all, 603 specifier object, LOCALE can be a locale, a locale type, 'all,
650 650
651 (defun set-face-underline-p (face underline-p &optional locale tag-set 651 (defun set-face-underline-p (face underline-p &optional locale tag-set
652 how-to-add) 652 how-to-add)
653 "Change the underline property of FACE to UNDERLINE-P. 653 "Change the underline property of FACE to UNDERLINE-P.
654 UNDERLINE-P is normally a face-boolean instantiator; see 654 UNDERLINE-P is normally a face-boolean instantiator; see
655 `make-face-boolean-specifier'. 655 `face-boolean-specifier-p'.
656 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and 656 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
657 HOW-TO-ADD arguments." 657 HOW-TO-ADD arguments."
658 (interactive (face-interactive "underline-p" "underlined")) 658 (interactive (face-interactive "underline-p" "underlined"))
659 (set-face-property face 'underline underline-p locale tag-set how-to-add)) 659 (set-face-property face 'underline underline-p locale tag-set how-to-add))
660 660
665 665
666 (defun set-face-strikethru-p (face strikethru-p &optional locale tag-set 666 (defun set-face-strikethru-p (face strikethru-p &optional locale tag-set
667 how-to-add) 667 how-to-add)
668 "Change whether FACE is strikethru-d (i.e. struck through) in LOCALE. 668 "Change whether FACE is strikethru-d (i.e. struck through) in LOCALE.
669 STRIKETHRU-P is normally a face-boolean instantiator; see 669 STRIKETHRU-P is normally a face-boolean instantiator; see
670 `make-face-boolean-specifier'. 670 `face-boolean-specifier-p'.
671 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and 671 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
672 HOW-TO-ADD arguments." 672 HOW-TO-ADD arguments."
673 (interactive (face-interactive "strikethru-p" "strikethru-d")) 673 (interactive (face-interactive "strikethru-p" "strikethru-d"))
674 (set-face-property face 'strikethru strikethru-p locale tag-set how-to-add)) 674 (set-face-property face 'strikethru strikethru-p locale tag-set how-to-add))
675 675
680 680
681 (defun set-face-highlight-p (face highlight-p &optional locale tag-set 681 (defun set-face-highlight-p (face highlight-p &optional locale tag-set
682 how-to-add) 682 how-to-add)
683 "Change whether FACE is highlighted in LOCALE (TTY locales only). 683 "Change whether FACE is highlighted in LOCALE (TTY locales only).
684 HIGHLIGHT-P is normally a face-boolean instantiator; see 684 HIGHLIGHT-P is normally a face-boolean instantiator; see
685 `make-face-boolean-specifier'. 685 `face-boolean-specifier-p'.
686 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and 686 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
687 HOW-TO-ADD arguments." 687 HOW-TO-ADD arguments."
688 (interactive (face-interactive "highlight-p" "highlighted")) 688 (interactive (face-interactive "highlight-p" "highlighted"))
689 (set-face-property face 'highlight highlight-p locale tag-set how-to-add)) 689 (set-face-property face 'highlight highlight-p locale tag-set how-to-add))
690 690
694 (face-property-instance face 'dim domain default no-fallback)) 694 (face-property-instance face 'dim domain default no-fallback))
695 695
696 (defun set-face-dim-p (face dim-p &optional locale tag-set how-to-add) 696 (defun set-face-dim-p (face dim-p &optional locale tag-set how-to-add)
697 "Change whether FACE is dimmed in LOCALE. 697 "Change whether FACE is dimmed in LOCALE.
698 DIM-P is normally a face-boolean instantiator; see 698 DIM-P is normally a face-boolean instantiator; see
699 `make-face-boolean-specifier'. 699 `face-boolean-specifier-p'.
700 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and 700 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
701 HOW-TO-ADD arguments." 701 HOW-TO-ADD arguments."
702 (interactive (face-interactive "dim-p" "dimmed")) 702 (interactive (face-interactive "dim-p" "dimmed"))
703 (set-face-property face 'dim dim-p locale tag-set how-to-add)) 703 (set-face-property face 'dim dim-p locale tag-set how-to-add))
704 704
709 709
710 (defun set-face-blinking-p (face blinking-p &optional locale tag-set 710 (defun set-face-blinking-p (face blinking-p &optional locale tag-set
711 how-to-add) 711 how-to-add)
712 "Change whether FACE is blinking in LOCALE (TTY locales only). 712 "Change whether FACE is blinking in LOCALE (TTY locales only).
713 BLINKING-P is normally a face-boolean instantiator; see 713 BLINKING-P is normally a face-boolean instantiator; see
714 `make-face-boolean-specifier'. 714 `face-boolean-specifier-p'.
715 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and 715 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
716 HOW-TO-ADD arguments." 716 HOW-TO-ADD arguments."
717 (interactive (face-interactive "blinking-p" "blinking")) 717 (interactive (face-interactive "blinking-p" "blinking"))
718 (set-face-property face 'blinking blinking-p locale tag-set how-to-add)) 718 (set-face-property face 'blinking blinking-p locale tag-set how-to-add))
719 719
723 (face-property-instance face 'reverse domain default no-fallback)) 723 (face-property-instance face 'reverse domain default no-fallback))
724 724
725 (defun set-face-reverse-p (face reverse-p &optional locale tag-set how-to-add) 725 (defun set-face-reverse-p (face reverse-p &optional locale tag-set how-to-add)
726 "Change whether FACE is reversed in LOCALE (TTY locales only). 726 "Change whether FACE is reversed in LOCALE (TTY locales only).
727 REVERSE-P is normally a face-boolean instantiator; see 727 REVERSE-P is normally a face-boolean instantiator; see
728 `make-face-boolean-specifier'. 728 `face-boolean-specifier-p'.
729 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and 729 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
730 HOW-TO-ADD arguments." 730 HOW-TO-ADD arguments."
731 (interactive (face-interactive "reverse-p" "reversed")) 731 (interactive (face-interactive "reverse-p" "reversed"))
732 (set-face-property face 'reverse reverse-p locale tag-set how-to-add)) 732 (set-face-property face 'reverse reverse-p locale tag-set how-to-add))
733 733
792 ;; WE DEMAND LEXICAL SCOPING!!! 792 ;; WE DEMAND LEXICAL SCOPING!!!
793 ;; WE DEMAND LEXICAL SCOPING!!! 793 ;; WE DEMAND LEXICAL SCOPING!!!
794 ;; WE DEMAND LEXICAL SCOPING!!! 794 ;; WE DEMAND LEXICAL SCOPING!!!
795 ;; WE DEMAND LEXICAL SCOPING!!! 795 ;; WE DEMAND LEXICAL SCOPING!!!
796 ;; WE DEMAND LEXICAL SCOPING!!! 796 ;; WE DEMAND LEXICAL SCOPING!!!
797 (defun frob-face-property (face property func &optional locale tags) 797 (defun frob-face-property (face property func &optional locale)
798 "Change the specifier for FACE's PROPERTY according to FUNC, in LOCALE. 798 "Change the specifier for FACE's PROPERTY according to FUNC, in LOCALE.
799 This function is ugly and messy and is primarily used as an internal 799 This function is ugly and messy and is primarily used as an internal
800 helper function for `make-face-bold' et al., so you probably don't 800 helper function for `make-face-bold' et al., so you probably don't
801 want to use it or read the rest of the documentation. But if you do ... 801 want to use it or read the rest of the documentation. But if you do ...
802 802
812 until a non-nil result is found (if there is no such result, the 812 until a non-nil result is found (if there is no such result, the
813 first valid instantiator is used), and that result substituted for 813 first valid instantiator is used), and that result substituted for
814 the specification; otherwise, the process just outlined is 814 the specification; otherwise, the process just outlined is
815 iterated over each existing device and the concatenated results 815 iterated over each existing device and the concatenated results
816 substituted for the specification." 816 substituted for the specification."
817 (let ((sp (face-property face property)) 817 (let ((sp (face-property face property)))
818 temp-sp)
819 (if (valid-specifier-domain-p locale) 818 (if (valid-specifier-domain-p locale)
820 ;; this is easy. 819 ;; this is easy.
821 (let* ((inst (face-property-instance face property locale)) 820 (let* ((inst (face-property-instance face property locale))
822 (name (and inst (funcall func inst (dfw-device locale))))) 821 (name (and inst (funcall func inst (dfw-device locale)))))
823 (when name 822 (when name
824 (add-spec-to-specifier sp name locale tags))) 823 (add-spec-to-specifier sp name locale)))
825 ;; otherwise, map over all specifications ... 824 ;; otherwise, map over all specifications ...
826 ;; but first, some further kludging: 825 ;; but first, some further kludging:
827 ;; (1) if we're frobbing the global property, make sure 826 ;; (1) if we're frobbing the global property, make sure
828 ;; that something is there (copy from the default face, 827 ;; that something is there (copy from the default face,
829 ;; if necessary). Otherwise, something like 828 ;; if necessary). Otherwise, something like
831 ;; won't do anything at all if the modeline simply 830 ;; won't do anything at all if the modeline simply
832 ;; inherits its font from 'default. 831 ;; inherits its font from 'default.
833 ;; (2) if we're frobbing a particular locale, nothing would 832 ;; (2) if we're frobbing a particular locale, nothing would
834 ;; happen if that locale has no instantiators. So signal 833 ;; happen if that locale has no instantiators. So signal
835 ;; an error to indicate this. 834 ;; an error to indicate this.
836
837
838 (setq temp-sp (copy-specifier sp))
839 (if (and (or (eq locale 'global) (eq locale 'all) (not locale)) 835 (if (and (or (eq locale 'global) (eq locale 'all) (not locale))
840 (not (face-property face property 'global))) 836 (not (face-property face property 'global)))
841 (copy-specifier (face-property 'default property) 837 (copy-specifier (face-property 'default property)
842 temp-sp 'global)) 838 (face-property face property)
839 'global))
843 (if (and (valid-specifier-locale-p locale) 840 (if (and (valid-specifier-locale-p locale)
844 (not (specifier-specs temp-sp locale))) 841 (not (face-property face property locale)))
845 (error "Property must have a specification in locale %S" locale)) 842 (error "Property must have a specification in locale %S" locale))
846 (map-specifier 843 (map-specifier
847 temp-sp 844 sp
848 (lambda (sp-arg locale inst-list func) 845 (lambda (sp locale inst-list func)
849 (let* ((device (dfw-device locale)) 846 (let* ((device (dfw-device locale))
850 ;; if a device can be derived from the locale, 847 ;; if a device can be derived from the locale,
851 ;; call frob-face-property-1 for that device. 848 ;; call frob-face-property-1 for that device.
852 ;; Otherwise map frob-face-property-1 over each device. 849 ;; Otherwise map frob-face-property-1 over each device.
853 (result 850 (result
854 (if device 851 (if device
855 (list (frob-face-property-1 sp-arg device inst-list func)) 852 (list (frob-face-property-1 sp device inst-list func))
856 (mapcar (lambda (device) 853 (mapcar (lambda (device)
857 (frob-face-property-1 sp-arg device 854 (frob-face-property-1 sp device
858 inst-list func)) 855 inst-list func))
859 (device-list)))) 856 (device-list))))
860 new-result) 857 new-result)
861 ;; remove duplicates and nils from the obtained list of 858 ;; remove duplicates and nils from the obtained list of
862 ;; instantiators. Also add tags amd remove 'defaults'. 859 ;; instantiators.
863 (mapcar (lambda (arg) 860 (mapcar (lambda (arg)
864 (when arg 861 (when (and arg (not (member arg new-result)))
865 (if (not (consp arg))
866 (setq arg (cons tags arg))
867 (setcar arg (append tags (delete 'default
868 (car arg))))))
869 (when (and arg (not (member arg new-result)))
870 (setq new-result (cons arg new-result)))) 862 (setq new-result (cons arg new-result))))
871 result) 863 result)
872 ;; add back in. 864 ;; add back in.
873 (add-spec-list-to-specifier sp (list (cons locale new-result))) 865 (add-spec-list-to-specifier sp (list (cons locale new-result)))
874 ;; tell map-specifier to keep going. 866 ;; tell map-specifier to keep going.
892 (if result 884 (if result
893 (setq result (cons tag-set result)))))) 885 (setq result (cons tag-set result))))))
894 (setq inst-list (cdr inst-list))) 886 (setq inst-list (cdr inst-list)))
895 (or result first-valid))) 887 (or result first-valid)))
896 888
897 (defun frob-face-font-2 (face locale tags unfrobbed-face frobbed-face 889 (defun frob-face-font-2 (face locale unfrobbed-face frobbed-face
898 tty-thunk x-thunk standard-face-mapping) 890 tty-thunk x-thunk standard-face-mapping)
899 ;; another kludge to make things more intuitive. If we're 891 ;; another kludge to make things more intuitive. If we're
900 ;; inheriting from a standard face in this locale, frob the 892 ;; inheriting from a standard face in this locale, frob the
901 ;; inheritance as appropriate. Else, if, after the first X frobbing 893 ;; inheritance as appropriate. Else, if, after the first X frobbing
902 ;; pass, the face hasn't changed and still looks like the standard 894 ;; pass, the face hasn't changed and still looks like the standard
940 (memq (face-name (find-face face)) 932 (memq (face-name (find-face face))
941 '(default bold italic bold-italic)) 933 '(default bold italic bold-italic))
942 (not (equal (face-property-instance face 'font domain) 934 (not (equal (face-property-instance face 'font domain)
943 (face-property-instance unfrobbed-face 'font domain))) 935 (face-property-instance unfrobbed-face 'font domain)))
944 (set-face-property face 'font (vector frobbed-face) 936 (set-face-property face 'font (vector frobbed-face)
945 the-locale tags)))))) 937 the-locale))))))
946 938
947 (defun make-face-bold (face &optional locale tags) 939 (defun make-face-bold (face &optional locale)
948 "Make FACE bold in LOCALE, if possible. 940 "Make FACE bold in LOCALE, if possible.
949 This will attempt to make the font bold for X locales and will set the 941 This will attempt to make the font bold for X locales and will set the
950 highlight flag for TTY locales. 942 highlight flag for TTY locales.
951 943
952 If LOCALE is nil, omitted, or `all', this will attempt to frob all 944 If LOCALE is nil, omitted, or `all', this will attempt to frob all
971 'default face, it is set to inherit from the 'bold face. This is kludgy 963 'default face, it is set to inherit from the 'bold face. This is kludgy
972 but it makes `make-face-bold' have more intuitive behavior in many 964 but it makes `make-face-bold' have more intuitive behavior in many
973 circumstances." 965 circumstances."
974 (interactive (list (read-face-name "Make which face bold: "))) 966 (interactive (list (read-face-name "Make which face bold: ")))
975 (frob-face-font-2 967 (frob-face-font-2
976 face locale tags 'default 'bold 968 face locale 'default 'bold
977 (lambda () 969 (lambda ()
978 ;; handle TTY specific entries 970 ;; handle TTY specific entries
979 (when (featurep 'tty) 971 (when (featurep 'tty)
980 (set-face-highlight-p face t locale (cons 'tty tags)))) 972 (set-face-highlight-p face t locale 'tty)))
981 (lambda () 973 (lambda ()
982 ;; handle X specific entries 974 ;; handle X specific entries
983 (when (featurep 'x) 975 (when (featurep 'x)
984 (frob-face-property face 'font 'x-make-font-bold locale tags)) 976 (frob-face-property face 'font 'x-make-font-bold locale))
985 (when (featurep 'mswindows) 977 (when (featurep 'mswindows)
986 (frob-face-property face 'font 'mswindows-make-font-bold locale tags)) 978 (frob-face-property face 'font 'mswindows-make-font-bold locale))
987 ) 979 )
988 '(([default] . [bold]) 980 '(([default] . [bold])
989 ([bold] . t) 981 ([bold] . t)
990 ([italic] . [bold-italic]) 982 ([italic] . [bold-italic])
991 ([bold-italic] . t)))) 983 ([bold-italic] . t))))
992 984
993 (defun make-face-italic (face &optional locale tags) 985 (defun make-face-italic (face &optional locale)
994 "Make FACE italic in LOCALE, if possible. 986 "Make FACE italic in LOCALE, if possible.
995 This will attempt to make the font italic for X locales and will set 987 This will attempt to make the font italic for X locales and will set
996 the underline flag for TTY locales. 988 the underline flag for TTY locales.
997 See `make-face-bold' for the semantics of the LOCALE argument and 989 See `make-face-bold' for the semantics of the LOCALE argument and
998 for more specifics on exactly how this function works." 990 for more specifics on exactly how this function works."
999 (interactive (list (read-face-name "Make which face italic: "))) 991 (interactive (list (read-face-name "Make which face italic: ")))
1000 (frob-face-font-2 992 (frob-face-font-2
1001 face locale tags 'default 'italic 993 face locale 'default 'italic
1002 (lambda () 994 (lambda ()
1003 ;; handle TTY specific entries 995 ;; handle TTY specific entries
1004 (when (featurep 'tty) 996 (when (featurep 'tty)
1005 (set-face-underline-p face t locale (cons 'tty tags)))) 997 (set-face-underline-p face t locale 'tty)))
1006 (lambda () 998 (lambda ()
1007 ;; handle X specific entries 999 ;; handle X specific entries
1008 (when (featurep 'x) 1000 (when (featurep 'x)
1009 (frob-face-property face 'font 'x-make-font-italic locale tags)) 1001 (frob-face-property face 'font 'x-make-font-italic locale))
1010 (when (featurep 'mswindows) 1002 (when (featurep 'mswindows)
1011 (frob-face-property face 'font 'mswindows-make-font-italic locale tags)) 1003 (frob-face-property face 'font 'mswindows-make-font-italic locale))
1012 ) 1004 )
1013 '(([default] . [italic]) 1005 '(([default] . [italic])
1014 ([bold] . [bold-italic]) 1006 ([bold] . [bold-italic])
1015 ([italic] . t) 1007 ([italic] . t)
1016 ([bold-italic] . t)))) 1008 ([bold-italic] . t))))
1017 1009
1018 (defun make-face-bold-italic (face &optional locale tags) 1010 (defun make-face-bold-italic (face &optional locale)
1019 "Make FACE bold and italic in LOCALE, if possible. 1011 "Make FACE bold and italic in LOCALE, if possible.
1020 This will attempt to make the font bold-italic for X locales and will 1012 This will attempt to make the font bold-italic for X locales and will
1021 set the highlight and underline flags for TTY locales. 1013 set the highlight and underline flags for TTY locales.
1022 See `make-face-bold' for the semantics of the LOCALE argument and 1014 See `make-face-bold' for the semantics of the LOCALE argument and
1023 for more specifics on exactly how this function works." 1015 for more specifics on exactly how this function works."
1024 (interactive (list (read-face-name "Make which face bold-italic: "))) 1016 (interactive (list (read-face-name "Make which face bold-italic: ")))
1025 (frob-face-font-2 1017 (frob-face-font-2
1026 face locale tags 'default 'bold-italic 1018 face locale 'default 'bold-italic
1027 (lambda () 1019 (lambda ()
1028 ;; handle TTY specific entries 1020 ;; handle TTY specific entries
1029 (when (featurep 'tty) 1021 (when (featurep 'tty)
1030 (set-face-highlight-p face t locale (cons 'tty tags)) 1022 (set-face-highlight-p face t locale 'tty)
1031 (set-face-underline-p face t locale (cons 'tty tags)))) 1023 (set-face-underline-p face t locale 'tty)))
1032 (lambda () 1024 (lambda ()
1033 ;; handle X specific entries 1025 ;; handle X specific entries
1034 (when (featurep 'x) 1026 (when (featurep 'x)
1035 (frob-face-property face 'font 'x-make-font-bold-italic locale tags)) 1027 (frob-face-property face 'font 'x-make-font-bold-italic locale))
1036 (when (featurep 'mswindows) 1028 (when (featurep 'mswindows)
1037 (frob-face-property face 'font 'mswindows-make-font-bold-italic locale tags)) 1029 (frob-face-property face 'font 'mswindows-make-font-bold-italic locale))
1038 ) 1030 )
1039 '(([default] . [italic]) 1031 '(([default] . [italic])
1040 ([bold] . [bold-italic]) 1032 ([bold] . [bold-italic])
1041 ([italic] . [bold-italic]) 1033 ([italic] . [bold-italic])
1042 ([bold-italic] . t)))) 1034 ([bold-italic] . t))))
1043 1035
1044 (defun make-face-unbold (face &optional locale tags) 1036 (defun make-face-unbold (face &optional locale)
1045 "Make FACE non-bold in LOCALE, if possible. 1037 "Make FACE non-bold in LOCALE, if possible.
1046 This will attempt to make the font non-bold for X locales and will 1038 This will attempt to make the font non-bold for X locales and will
1047 unset the highlight flag for TTY locales. 1039 unset the highlight flag for TTY locales.
1048 See `make-face-bold' for the semantics of the LOCALE argument and 1040 See `make-face-bold' for the semantics of the LOCALE argument and
1049 for more specifics on exactly how this function works." 1041 for more specifics on exactly how this function works."
1050 (interactive (list (read-face-name "Make which face non-bold: "))) 1042 (interactive (list (read-face-name "Make which face non-bold: ")))
1051 (frob-face-font-2 1043 (frob-face-font-2
1052 face locale tags 'bold 'default 1044 face locale 'bold 'default
1053 (lambda () 1045 (lambda ()
1054 ;; handle TTY specific entries 1046 ;; handle TTY specific entries
1055 (when (featurep 'tty) 1047 (when (featurep 'tty)
1056 (set-face-highlight-p face nil locale (cons 'tty tags)))) 1048 (set-face-highlight-p face nil locale 'tty)))
1057 (lambda () 1049 (lambda ()
1058 ;; handle X specific entries 1050 ;; handle X specific entries
1059 (when (featurep 'x) 1051 (when (featurep 'x)
1060 (frob-face-property face 'font 'x-make-font-unbold locale tags)) 1052 (frob-face-property face 'font 'x-make-font-unbold locale))
1061 (when (featurep 'mswindows) 1053 (when (featurep 'mswindows)
1062 (frob-face-property face 'font 'mswindows-make-font-unbold locale tags)) 1054 (frob-face-property face 'font 'mswindows-make-font-unbold locale))
1063 ) 1055 )
1064 '(([default] . t) 1056 '(([default] . t)
1065 ([bold] . [default]) 1057 ([bold] . [default])
1066 ([italic] . t) 1058 ([italic] . t)
1067 ([bold-italic] . [italic])))) 1059 ([bold-italic] . [italic]))))
1068 1060
1069 (defun make-face-unitalic (face &optional locale tags) 1061 (defun make-face-unitalic (face &optional locale)
1070 "Make FACE non-italic in LOCALE, if possible. 1062 "Make FACE non-italic in LOCALE, if possible.
1071 This will attempt to make the font non-italic for X locales and will 1063 This will attempt to make the font non-italic for X locales and will
1072 unset the underline flag for TTY locales. 1064 unset the underline flag for TTY locales.
1073 See `make-face-bold' for the semantics of the LOCALE argument and 1065 See `make-face-bold' for the semantics of the LOCALE argument and
1074 for more specifics on exactly how this function works." 1066 for more specifics on exactly how this function works."
1075 (interactive (list (read-face-name "Make which face non-italic: "))) 1067 (interactive (list (read-face-name "Make which face non-italic: ")))
1076 (frob-face-font-2 1068 (frob-face-font-2
1077 face locale tags 'italic 'default 1069 face locale 'italic 'default
1078 (lambda () 1070 (lambda ()
1079 ;; handle TTY specific entries 1071 ;; handle TTY specific entries
1080 (when (featurep 'tty) 1072 (when (featurep 'tty)
1081 (set-face-underline-p face nil locale (cons 'tty tags)))) 1073 (set-face-underline-p face nil locale 'tty)))
1082 (lambda () 1074 (lambda ()
1083 ;; handle X specific entries 1075 ;; handle X specific entries
1084 (when (featurep 'x) 1076 (when (featurep 'x)
1085 (frob-face-property face 'font 'x-make-font-unitalic locale tags)) 1077 (frob-face-property face 'font 'x-make-font-unitalic locale))
1086 (when (featurep 'mswindows) 1078 (when (featurep 'mswindows)
1087 (frob-face-property face 'font 'mswindows-make-font-unitalic locale tags)) 1079 (frob-face-property face 'font 'mswindows-make-font-unitalic locale))
1088 ) 1080 )
1089 '(([default] . t) 1081 '(([default] . t)
1090 ([bold] . t) 1082 ([bold] . t)
1091 ([italic] . [default]) 1083 ([italic] . [default])
1092 ([bold-italic] . [bold])))) 1084 ([bold-italic] . [bold]))))
1203 :type 'boolean) 1195 :type 'boolean)
1204 1196
1205 ;; Old name, used by custom. Also, FSFmacs name. 1197 ;; Old name, used by custom. Also, FSFmacs name.
1206 (defvaralias 'initialize-face-resources 'init-face-from-resources) 1198 (defvaralias 'initialize-face-resources 'init-face-from-resources)
1207 1199
1208 ;; Make sure all custom setting are added with this tag so we can 1200 (defun face-spec-set (face spec &optional frame)
1209 ;; identify-them
1210 (define-specifier-tag 'custom)
1211
1212 (defun face-spec-set (face spec &optional frame tags)
1213 "Set FACE's face attributes according to the first matching entry in SPEC. 1201 "Set FACE's face attributes according to the first matching entry in SPEC.
1214 If optional FRAME is non-nil, set it for that frame only. 1202 If optional FRAME is non-nil, set it for that frame only.
1215 If it is nil, then apply SPEC to each frame individually. 1203 If it is nil, then apply SPEC to each frame individually.
1216 See `defface' for information about SPEC." 1204 See `defface' for information about SPEC."
1217 (if frame 1205 (if frame
1218 (progn 1206 (progn
1219 (reset-face face frame tags) 1207 (reset-face face frame)
1220 (face-display-set face spec frame tags) 1208 (face-display-set face spec frame)
1221 (init-face-from-resources face frame)) 1209 (init-face-from-resources face frame))
1222 (let ((frames (relevant-custom-frames))) 1210 (let ((frames (relevant-custom-frames)))
1223 (reset-face face nil tags) 1211 (reset-face face)
1224 ;; This should not be needed. We only remove our own specifiers 1212 (if (and (eq 'default face) (featurep 'x))
1225 ;; (if (and (eq 'default face) (featurep 'x)) 1213 (x-init-global-faces))
1226 ;; (x-init-global-faces)) 1214 (face-display-set face spec)
1227 (face-display-set face spec nil tags)
1228 (while frames 1215 (while frames
1229 (face-display-set face spec (car frames) tags) 1216 (face-display-set face spec (car frames))
1230 (pop frames)) 1217 (pop frames))
1231 (init-face-from-resources face)))) 1218 (init-face-from-resources face))))
1232 1219
1233 (defun face-display-set (face spec &optional frame tags) 1220 (defun face-display-set (face spec &optional frame)
1234 "Set FACE to the attributes to the first matching entry in SPEC. 1221 "Set FACE to the attributes to the first matching entry in SPEC.
1235 Iff optional FRAME is non-nil, set it for that frame only. 1222 Iff optional FRAME is non-nil, set it for that frame only.
1236 See `defface' for information about SPEC." 1223 See `defface' for information about SPEC."
1237 (while spec 1224 (while spec
1238 (let ((display (caar spec)) 1225 (let ((display (caar spec))
1239 (atts (cadar spec))) 1226 (atts (cadar spec)))
1240 (pop spec) 1227 (pop spec)
1241 (when (face-spec-set-match-display display frame) 1228 (when (face-spec-set-match-display display frame)
1242 ;; Avoid creating frame local duplicates of the global face. 1229 ;; Avoid creating frame local duplicates of the global face.
1243 (unless (and frame (eq display (get face 'custom-face-display))) 1230 (unless (and frame (eq display (get face 'custom-face-display)))
1244 (apply 'face-custom-attributes-set face frame tags atts)) 1231 (apply 'face-custom-attributes-set face frame atts))
1245 (unless frame 1232 (unless frame
1246 (put face 'custom-face-display display)) 1233 (put face 'custom-face-display display))
1247 (setq spec nil))))) 1234 (setq spec nil)))))
1248 1235
1249 (defvar default-custom-frame-properties nil 1236 (defvar default-custom-frame-properties nil
1358 "Initialize frame-local custom faces for FRAME if necessary." 1345 "Initialize frame-local custom faces for FRAME if necessary."
1359 (unless (equal (get-custom-frame-properties) 1346 (unless (equal (get-custom-frame-properties)
1360 (get-custom-frame-properties frame)) 1347 (get-custom-frame-properties frame))
1361 (initialize-custom-faces frame))) 1348 (initialize-custom-faces frame)))
1362 1349
1363 (defun startup-initialize-custom-faces ()
1364 "Reset faces created by defface. Only called at startup.
1365 Don't use this function in your program."
1366 (when default-custom-frame-properties
1367 ;; Reset default value to the actual frame, not stream.
1368 (setq default-custom-frame-properties
1369 (extract-custom-frame-properties (selected-frame)))
1370 ;; like initialize-custom-faces but removes property first.
1371 (mapc (lambda (symbol)
1372 (let ((spec (or (get symbol 'saved-face)
1373 (get symbol 'face-defface-spec))))
1374 (when spec
1375 ;; Reset faces created during auto-autoloads loading.
1376 (reset-face symbol)
1377 ;; And set it according to the spec.
1378 (face-display-set symbol spec nil))))
1379 (face-list))))
1380
1381 1350
1382 (defun make-empty-face (name &optional doc-string temporary) 1351 (defun make-empty-face (name &optional doc-string temporary)
1383 "Like `make-face', but doesn't query the resource database." 1352 "Like `make-face', but doesn't query the resource database."
1384 (let ((init-face-from-resources nil)) 1353 (let ((init-face-from-resources nil))
1385 (make-face name doc-string temporary))) 1354 (make-face name doc-string temporary)))
1426 (x-init-device-faces device)) 1395 (x-init-device-faces device))
1427 ((eq 'mswindows (device-type device)) 1396 ((eq 'mswindows (device-type device))
1428 (mswindows-init-device-faces device)) 1397 (mswindows-init-device-faces device))
1429 ;; Nothing to do for TTYs? 1398 ;; Nothing to do for TTYs?
1430 ) 1399 )
1431 (or (eq 'stream (device-type device)) 1400 (init-other-random-faces device)))
1432 (init-other-random-faces device))))
1433 1401
1434 (defun init-frame-faces (frame) 1402 (defun init-frame-faces (frame)
1435 (when init-face-from-resources 1403 (when init-face-from-resources
1436 ;; First, add any frame-local face resources. 1404 ;; First, add any frame-local face resources.
1437 (loop for face in (face-list) do 1405 (loop for face in (face-list) do
1537 1505
1538 ;; Similar for italic. 1506 ;; Similar for italic.
1539 ;; It's unreasonable to expect to be able to make a font italic all 1507 ;; It's unreasonable to expect to be able to make a font italic all
1540 ;; the time. For many languages, italic is an alien concept. 1508 ;; the time. For many languages, italic is an alien concept.
1541 ;; Basically, because italic is not a globally meaningful concept, 1509 ;; Basically, because italic is not a globally meaningful concept,
1542 ;; the use of the italic face should really be obsoleted. 1510 ;; the use of the italic face should really be oboleted.
1543 1511
1544 ;; I disagree with above. In many languages, the concept of capital 1512 ;; I disagree with above. In many languages, the concept of capital
1545 ;; letters is just as alien, and yet we use them. Italic is here to 1513 ;; letters is just as alien, and yet we use them. Italic is here to
1546 ;; stay. -hniksic 1514 ;; stay. -hniksic
1547 1515
1587 (face-property-equal 'text-cursor 'default 'foreground device)) 1555 (face-property-equal 'text-cursor 'default 'foreground device))
1588 (set-face-foreground 'text-cursor [default background] 'global 1556 (set-face-foreground 'text-cursor [default background] 'global
1589 nil 'append)) 1557 nil 'append))
1590 ) 1558 )
1591 1559
1592 ;; New function with 20.1, suggested by Per Abrahamsen, coded by Kyle 1560 ;; New function with 20.1, suggested by Per Abrahamsen, coded by Kyle Jones.
1593 ;; Jones and Hrvoje Niksic.
1594 (defun set-face-stipple (face pixmap &optional frame) 1561 (defun set-face-stipple (face pixmap &optional frame)
1595 "Change the stipple pixmap of FACE to PIXMAP. 1562 "Change the stipple pixmap of FACE to PIXMAP.
1596 This is an Emacs compatibility function; consider using 1563 This is an Emacs compatibility function; consider using
1597 set-face-background-pixmap instead. 1564 set-face-background-pixmap instead.
1598 1565
1599 PIXMAP should be a string, the name of a file of pixmap data. 1566 PIXMAP should be a string, the name of a file of pixmap data.
1600 The directories listed in the variables `x-bitmap-file-path' and 1567 The directories listed in the `x-bitmap-file-path' variable are searched.
1601 `mswindows-bitmap-file-path' under X and MS Windows respectively
1602 are searched.
1603 1568
1604 Alternatively, PIXMAP may be a list of the form (WIDTH HEIGHT 1569 Alternatively, PIXMAP may be a list of the form (WIDTH HEIGHT
1605 DATA) where WIDTH and HEIGHT are the size in pixels, and DATA is 1570 DATA) where WIDTH and HEIGHT are the size in pixels, and DATA is
1606 a string, containing the raw bits of the bitmap. XBM data is 1571 a string, containing the raw bits of the bitmap. XBM data is
1607 expected in this case, other types of image data will not work. 1572 expected in this case, other types of image data will not work.
1608 1573
1609 If the optional FRAME argument is provided, change only 1574 If the optional FRAME argument is provided, change only
1610 in that frame; otherwise change each frame." 1575 in that frame; otherwise change each frame."
1611 (while (not (find-face face)) 1576 (while (not (find-face face))
1612 (setq face (signal 'wrong-type-argument (list 'facep face)))) 1577 (setq face (signal 'wrong-type-argument (list 'facep face))))
1613 (let ((bitmap-path (ecase (console-type) 1578 (locate-file pixmap x-bitmap-file-path '(".xbm" ""))
1614 (x x-bitmap-file-path) 1579 (while (cond ((stringp pixmap)
1615 (mswindows mswindows-bitmap-file-path))) 1580 (unless (file-readable-p pixmap)
1616 instantiator) 1581 (setq pixmap `[xbm :file ,pixmap]))
1617 (while 1582 nil)
1618 (null 1583 ((and (consp pixmap) (= (length pixmap) 3))
1619 (setq instantiator 1584 (setq pixmap `[xbm :data ,pixmap])
1620 (cond ((stringp pixmap) 1585 nil)
1621 (let ((file (if (file-name-absolute-p pixmap) 1586 (t t))
1622 pixmap 1587 (setq pixmap (signal 'wrong-type-argument
1623 (locate-file pixmap bitmap-path 1588 (list 'stipple-pixmap-p pixmap))))
1624 '(".xbm" ""))))) 1589 (while (and frame (not (framep frame)))
1625 (and file 1590 (setq frame (signal 'wrong-type-argument (list 'framep frame))))
1626 `[xbm :file ,file]))) 1591 (set-face-background-pixmap face pixmap frame))
1627 ((and (listp pixmap) (= (length pixmap) 3))
1628 `[xbm :data ,pixmap])
1629 (t nil))))
1630 ;; We're signaling a continuable error; let's make sure the
1631 ;; function `stipple-pixmap-p' at least exists.
1632 (flet ((stipple-pixmap-p (pixmap)
1633 (or (stringp pixmap)
1634 (and (listp pixmap) (= (length pixmap) 3)))))
1635 (setq pixmap (signal 'wrong-type-argument
1636 (list 'stipple-pixmap-p pixmap)))))
1637 (while (and frame (not (framep frame)))
1638 (setq frame (signal 'wrong-type-argument (list 'framep frame))))
1639 (set-face-background-pixmap face instantiator frame)))
1640 1592
1641 1593
1642 ;; Create the remaining standard faces now. This way, packages that we dump 1594 ;; Create the remaining standard faces now. This way, packages that we dump
1643 ;; can reference these faces as parents. 1595 ;; can reference these faces as parents.
1644 ;; 1596 ;;
1651 (make-face 'underline "Underlined text.") 1603 (make-face 'underline "Underlined text.")
1652 (or (face-differs-from-default-p 'underline) 1604 (or (face-differs-from-default-p 'underline)
1653 (set-face-underline-p 'underline t 'global '(default))) 1605 (set-face-underline-p 'underline t 'global '(default)))
1654 (make-face 'zmacs-region "Used on highlightes region between point and mark.") 1606 (make-face 'zmacs-region "Used on highlightes region between point and mark.")
1655 (make-face 'isearch "Used on region matched by isearch.") 1607 (make-face 'isearch "Used on region matched by isearch.")
1656 (make-face 'isearch-secondary "Face to use for highlighting all matches.")
1657 (make-face 'list-mode-item-selected 1608 (make-face 'list-mode-item-selected
1658 "Face for the selected list item in list-mode.") 1609 "Face for the selected list item in list-mode.")
1659 (make-face 'highlight "Highlight face.") 1610 (make-face 'highlight "Highlight face.")
1660 (make-face 'primary-selection "Primary selection face.") 1611 (make-face 'primary-selection "Primary selection face.")
1661 (make-face 'secondary-selection "Secondary selection face.") 1612 (make-face 'secondary-selection "Secondary selection face.")
1741 ((x default color) . "green") 1692 ((x default color) . "green")
1742 ((mswindows default color) . "paleturquoise") 1693 ((mswindows default color) . "paleturquoise")
1743 ((mswindows default color) . "green")) 1694 ((mswindows default color) . "green"))
1744 'global) 1695 'global)
1745 1696
1746 ;; #### This should really, I mean *really*, be converted to some form
1747 ;; of `defface' one day.
1748 (set-face-foreground 'isearch-secondary
1749 '(((x default color) . "red3")
1750 ((mswindows default color) . "red3"))
1751 'global)
1752
1753 ;; Define some logical color names to be used when reading the pixmap files. 1697 ;; Define some logical color names to be used when reading the pixmap files.
1754 (if (featurep 'xpm) 1698 (if (featurep 'xpm)
1755 (setq xpm-color-symbols 1699 (setq xpm-color-symbols
1756 (list 1700 (list
1757 (purecopy '("foreground" (face-foreground 'default))) 1701 (purecopy '("foreground" (face-foreground 'default)))
1759 (purecopy '("backgroundToolBarColor" 1703 (purecopy '("backgroundToolBarColor"
1760 (or 1704 (or
1761 (and 1705 (and
1762 (featurep 'x) 1706 (featurep 'x)
1763 (x-get-resource "backgroundToolBarColor" 1707 (x-get-resource "backgroundToolBarColor"
1764 "BackgroundToolBarColor" 'string 1708 "BackgroundToolBarColor" 'string))
1765 nil nil 'warn))
1766 1709
1767 (face-background 'toolbar)))) 1710 (face-background 'toolbar))))
1768 (purecopy '("foregroundToolBarColor" 1711 (purecopy '("foregroundToolBarColor"
1769 (or 1712 (or
1770 (and 1713 (and
1771 (featurep 'x) 1714 (featurep 'x)
1772 (x-get-resource "foregroundToolBarColor" 1715 (x-get-resource "foregroundToolBarColor"
1773 "ForegroundToolBarColor" 'string 1716 "ForegroundToolBarColor" 'string))
1774 nil nil 'warn))
1775 (face-foreground 'toolbar)))) 1717 (face-foreground 'toolbar))))
1776 ))) 1718 )))
1777 1719
1778 (when (featurep 'tty) 1720 (when (featurep 'tty)
1779 (set-face-highlight-p 'bold t 'global '(default tty)) 1721 (set-face-highlight-p 'bold t 'global '(default tty))