Mercurial > hg > xemacs-beta

comparison lisp/prim/faces.el @ 86:364816949b59 r20-0b93

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b93
author cvs
date Mon, 13 Aug 2007 09:09:02 +0200
parents c7528f8e288d
children 4be1180a9e89
comparison
equal deleted inserted replaced
85:c661705957e0 86:364816949b59
10 ;; face implementation #1 (used Lisp vectors and parallel C vectors; 10 ;; face implementation #1 (used Lisp vectors and parallel C vectors;
11 ;; FSFmacs still uses this) authored by Jamie Zawinski <jwz@netscape.com> 11 ;; FSFmacs still uses this) authored by Jamie Zawinski <jwz@netscape.com>
12 ;; pre Lucid-Emacs 19.0. 12 ;; pre Lucid-Emacs 19.0.
13 ;; 13 ;;
14 ;; face implementation #2 (used one face object per frame per face) 14 ;; face implementation #2 (used one face object per frame per face)
15 ;; authored by Jamie Zawinkski for 19.9. 15 ;; authored by Jamie Zawinski for 19.9.
16 ;; 16 ;;
17 ;; face implementation #3 (use one face object per face) originally 17 ;; face implementation #3 (use one face object per face) originally
18 ;; authored for 19.12 by Chuck Thompson <cthomp@cs.uiuc.edu>, 18 ;; authored for 19.12 by Chuck Thompson <cthomp@cs.uiuc.edu>,
19 ;; rewritten by Ben Wing with the advent of specifiers. 19 ;; rewritten by Ben Wing with the advent of specifiers.
20 20
117 domain is on. The function `face-property-instance' actually does 117 domain is on. The function `face-property-instance' actually does
118 all this, and is used to determine how to display the face. 118 all this, and is used to determine how to display the face.
119 119
120 See `set-face-property' for the built-in property-names." 120 See `set-face-property' for the built-in property-names."
121 121
122 (or (facep face) (setq face (get-face face))) 122 (setq face (get-face face))
123 (let ((value (get face property))) 123 (let ((value (get face property)))
124 (if (and locale 124 (if (and locale
125 (or (memq property built-in-face-specifiers) 125 (or (memq property built-in-face-specifiers)
126 (specifierp value))) 126 (specifierp value)))
127 (setq value (specifier-specs value locale tag-set exact-p))) 127 (setq value (specifier-specs value locale tag-set exact-p)))
133 (let ((specifier (get face property))) 133 (let ((specifier (get face property)))
134 ;; if a user-property does not have a specifier but a 134 ;; if a user-property does not have a specifier but a
135 ;; locale was specified, put a specifier there. 135 ;; locale was specified, put a specifier there.
136 ;; If there was already a value there, convert it to a 136 ;; If there was already a value there, convert it to a
137 ;; specifier with the value as its 'global instantiator. 137 ;; specifier with the value as its 'global instantiator.
138 (if (not (specifierp specifier)) 138 (unless (specifierp specifier)
139 (let ((new-specifier (make-specifier 'generic))) 139 (let ((new-specifier (make-specifier 'generic)))
140 (if (or (not (null specifier)) 140 (if (or (not (null specifier))
141 ;; make sure the nil returned from `get' wasn't 141 ;; make sure the nil returned from `get' wasn't
142 ;; actually the value of the property 142 ;; actually the value of the property
143 (null (get face property t))) 143 (null (get face property t)))
144 (add-spec-to-specifier new-specifier specifier)) 144 (add-spec-to-specifier new-specifier specifier))
145 (setq specifier new-specifier) 145 (setq specifier new-specifier)
146 (put face property specifier))))) 146 (put face property specifier)))))
147 147
148 (defun face-property-instance (face property 148 (defun face-property-instance (face property
149 &optional domain default no-fallback) 149 &optional domain default no-fallback)
150 "Return the instance of FACE's PROPERTY in the specified DOMAIN. 150 "Return the instance of FACE's PROPERTY in the specified DOMAIN.
151 151
187 it will be instanced using `specifier-instance'. 187 it will be instanced using `specifier-instance'.
188 188
189 Optional arguments DEFAULT and NO-FALLBACK are the same as in 189 Optional arguments DEFAULT and NO-FALLBACK are the same as in
190 `specifier-instance'." 190 `specifier-instance'."
191 191
192 (or (facep face) (setq face (get-face face))) 192 (setq face (get-face face))
193 (let ((value (get face property))) 193 (let ((value (get face property)))
194 (if (specifierp value) 194 (if (specifierp value)
195 (setq value (specifier-instance value domain default no-fallback))) 195 (setq value (specifier-instance value domain default no-fallback)))
196 value)) 196 value))
197 197
206 206
207 Other than MATCHSPEC, this function is identical to `face-property-instance'. 207 Other than MATCHSPEC, this function is identical to `face-property-instance'.
208 See also `specifier-matching-instance' for a fuller description of the 208 See also `specifier-matching-instance' for a fuller description of the
209 matching process." 209 matching process."
210 210
211 (or (facep face) (setq face (get-face face))) 211 (setq face (get-face face))
212 (let ((value (get face property))) 212 (let ((value (get face property)))
213 (if (specifierp value) 213 (if (specifierp value)
214 (setq value (specifier-matching-instance value matchspec domain 214 (setq value (specifier-matching-instance value matchspec domain
215 default no-fallback))) 215 default no-fallback)))
216 value)) 216 value))
318 doc-string Description of what the face's normal use is. 318 doc-string Description of what the face's normal use is.
319 NOTE: This is not a specifier, unlike all 319 NOTE: This is not a specifier, unlike all
320 the other built-in properties, and cannot 320 the other built-in properties, and cannot
321 contain locale-specific values." 321 contain locale-specific values."
322 322
323 (or (facep face) (setq face (get-face face))) 323 (setq face (get-face face))
324 (if (memq property built-in-face-specifiers) 324 (if (memq property built-in-face-specifiers)
325 (set-specifier (get face property) value locale tag-set how-to-add) 325 (set-specifier (get face property) value locale tag-set how-to-add)
326 326
327 ;; This section adds user defined properties. 327 ;; This section adds user defined properties.
328 (if (not locale) 328 (if (not locale)
349 (defun reset-face (face) 349 (defun reset-face (face)
350 "Clear all existing built-in specifications from FACE. 350 "Clear all existing built-in specifications from FACE.
351 This makes FACE inherit all its display properties from 'default. 351 This makes FACE inherit all its display properties from 'default.
352 WARNING: Be absolutely sure you want to do this!!! It is a dangerous 352 WARNING: Be absolutely sure you want to do this!!! It is a dangerous
353 operation and is not undoable." 353 operation and is not undoable."
354 (mapcar #'(lambda (x) 354 (mapcar (lambda (x)
355 (remove-specifier (face-property face x))) 355 (remove-specifier (face-property face x)))
356 built-in-face-specifiers) 356 built-in-face-specifiers)
357 nil) 357 nil)
358 358
359 (defun set-face-parent (face parent &optional locale tag-set how-to-add) 359 (defun set-face-parent (face parent &optional locale tag-set how-to-add)
360 "Set the parent of FACE to PARENT, for all properties. 360 "Set the parent of FACE to PARENT, for all properties.
361 This makes all properties of FACE inherit from PARENT." 361 This makes all properties of FACE inherit from PARENT."
362 (setq parent (get-face parent)) 362 (setq parent (get-face parent))
363 (mapcar #'(lambda (x) 363 (mapcar (lambda (x)
364 (set-face-property face x (vector parent) locale tag-set 364 (set-face-property face x (vector parent) locale tag-set
365 how-to-add)) 365 how-to-add))
366 (delq 'display-table 366 (delq 'display-table
367 (delq 'background-pixmap 367 (delq 'background-pixmap
368 (copy-sequence built-in-face-specifiers)))) 368 (copy-sequence built-in-face-specifiers))))
369 (set-face-background-pixmap face (vector 'inherit ':face parent) 369 (set-face-background-pixmap face (vector 'inherit ':face parent)
370 locale tag-set how-to-add) 370 locale tag-set how-to-add)
371 nil) 371 nil)
372 372
373 (defun face-doc-string (face) 373 (defun face-doc-string (face)
765 (let ((sp (face-property face property))) 765 (let ((sp (face-property face property)))
766 (if (valid-specifier-domain-p locale) 766 (if (valid-specifier-domain-p locale)
767 ;; this is easy. 767 ;; this is easy.
768 (let* ((inst (face-property-instance face property locale)) 768 (let* ((inst (face-property-instance face property locale))
769 (name (and inst (funcall func inst (dfw-device locale))))) 769 (name (and inst (funcall func inst (dfw-device locale)))))
770 (if name 770 (when name
771 (add-spec-to-specifier sp name locale))) 771 (add-spec-to-specifier sp name locale)))
772 ;; otherwise, map over all specifications ... 772 ;; otherwise, map over all specifications ...
773 ;; but first, some further kludging: 773 ;; but first, some further kludging:
774 ;; (1) if we're frobbing the global property, make sure 774 ;; (1) if we're frobbing the global property, make sure
775 ;; that something is there (copy from the default face, 775 ;; that something is there (copy from the default face,
776 ;; if necessary). Otherwise, something like 776 ;; if necessary). Otherwise, something like
788 (if (and (valid-specifier-locale-p locale) 788 (if (and (valid-specifier-locale-p locale)
789 (not (face-property face property locale))) 789 (not (face-property face property locale)))
790 (error "Property must have a specification in locale %S" locale)) 790 (error "Property must have a specification in locale %S" locale))
791 (map-specifier 791 (map-specifier
792 sp 792 sp
793 #'(lambda (sp locale inst-list func) 793 (lambda (sp locale inst-list func)
794 (let* ((device (dfw-device locale)) 794 (let* ((device (dfw-device locale))
795 ;; if a device can be derived from the locale, 795 ;; if a device can be derived from the locale,
796 ;; call frob-face-property-1 for that device. 796 ;; call frob-face-property-1 for that device.
797 ;; Otherwise map frob-face-property-1 over each device. 797 ;; Otherwise map frob-face-property-1 over each device.
798 (result 798 (result
799 (if device 799 (if device
800 (list (frob-face-property-1 sp device inst-list func)) 800 (list (frob-face-property-1 sp device inst-list func))
801 (mapcar #'(lambda (device) 801 (mapcar (lambda (device)
802 (frob-face-property-1 sp device 802 (frob-face-property-1 sp device
803 inst-list func)) 803 inst-list func))
804 (device-list)))) 804 (device-list))))
805 new-result) 805 new-result)
806 ;; remove duplicates and nils from the obtained list of 806 ;; remove duplicates and nils from the obtained list of
807 ;; instantiators. 807 ;; instantiators.
808 (mapcar #'(lambda (arg) 808 (mapcar (lambda (arg)
809 (if (and arg (not (member arg new-result))) 809 (when (and arg (not (member arg new-result)))
810 (setq new-result (cons arg new-result)))) 810 (setq new-result (cons arg new-result))))
811 result) 811 result)
812 ;; add back in. 812 ;; add back in.
813 (add-spec-list-to-specifier sp 813 (add-spec-list-to-specifier sp (list (cons locale new-result)))
814 (list (cons locale new-result))) 814 ;; tell map-specifier to keep going.
815 ;; tell map-specifier to keep going. 815 nil))
816 nil))
817 locale 816 locale
818 func)))) 817 func))))
819 818
820 (defun frob-face-property-1 (sp device inst-list func) 819 (defun frob-face-property-1 (sp device inst-list func)
821 (let 820 (let
913 but it makes `make-face-bold' have more intuitive behavior in many 912 but it makes `make-face-bold' have more intuitive behavior in many
914 circumstances." 913 circumstances."
915 (interactive (list (read-face-name "Make which face bold: "))) 914 (interactive (list (read-face-name "Make which face bold: ")))
916 (frob-face-font-2 915 (frob-face-font-2
917 face locale 'default 'bold 916 face locale 'default 'bold
918 #'(lambda () 917 (lambda ()
919 ;; handle TTY specific entries 918 ;; handle TTY specific entries
920 (if (featurep 'tty) 919 (when (featurep 'tty)
921 (set-face-highlight-p face t locale 'tty))) 920 (set-face-highlight-p face t locale 'tty)))
922 #'(lambda () 921 (lambda ()
923 ;; handle X specific entries 922 ;; handle X specific entries
924 (frob-face-property face 'font 'x-make-font-bold locale)) 923 (frob-face-property face 'font 'x-make-font-bold locale))
925 '(([default] . [bold]) 924 '(([default] . [bold])
926 ([bold] . t) 925 ([bold] . t)
927 ([italic] . [bold-italic]) 926 ([italic] . [bold-italic])
928 ([bold-italic] . t)))) 927 ([bold-italic] . t))))
929 928
934 See `make-face-bold' for the semantics of the LOCALE argument and 933 See `make-face-bold' for the semantics of the LOCALE argument and
935 for more specifics on exactly how this function works." 934 for more specifics on exactly how this function works."
936 (interactive (list (read-face-name "Make which face italic: "))) 935 (interactive (list (read-face-name "Make which face italic: ")))
937 (frob-face-font-2 936 (frob-face-font-2
938 face locale 'default 'italic 937 face locale 'default 'italic
939 #'(lambda () 938 (lambda ()
940 ;; handle TTY specific entries 939 ;; handle TTY specific entries
941 (if (featurep 'tty) 940 (when (featurep 'tty)
942 (set-face-underline-p face t locale 'tty))) 941 (set-face-underline-p face t locale 'tty)))
943 #'(lambda () 942 (lambda ()
944 ;; handle X specific entries 943 ;; handle X specific entries
945 (frob-face-property face 'font 'x-make-font-italic locale)) 944 (frob-face-property face 'font 'x-make-font-italic locale))
946 '(([default] . [italic]) 945 '(([default] . [italic])
947 ([bold] . [bold-italic]) 946 ([bold] . [bold-italic])
948 ([italic] . t) 947 ([italic] . t)
949 ([bold-italic] . t)))) 948 ([bold-italic] . t))))
950 949
955 See `make-face-bold' for the semantics of the LOCALE argument and 954 See `make-face-bold' for the semantics of the LOCALE argument and
956 for more specifics on exactly how this function works." 955 for more specifics on exactly how this function works."
957 (interactive (list (read-face-name "Make which face bold-italic: "))) 956 (interactive (list (read-face-name "Make which face bold-italic: ")))
958 (frob-face-font-2 957 (frob-face-font-2
959 face locale 'default 'bold-italic 958 face locale 'default 'bold-italic
960 #'(lambda () 959 (lambda ()
961 ;; handle TTY specific entries 960 ;; handle TTY specific entries
962 (if (featurep 'tty) 961 (when (featurep 'tty)
963 (progn 962 (set-face-highlight-p face t locale 'tty)
964 (set-face-highlight-p face t locale 'tty) 963 (set-face-underline-p face t locale 'tty)))
965 (set-face-underline-p face t locale 'tty)))) 964 (lambda ()
966 #'(lambda () 965 ;; handle X specific entries
967 ;; handle X specific entries 966 (frob-face-property face 'font 'x-make-font-bold-italic locale))
968 (frob-face-property face 'font 'x-make-font-bold-italic locale))
969 '(([default] . [italic]) 967 '(([default] . [italic])
970 ([bold] . [bold-italic]) 968 ([bold] . [bold-italic])
971 ([italic] . [bold-italic]) 969 ([italic] . [bold-italic])
972 ([bold-italic] . t)))) 970 ([bold-italic] . t))))
973 971
978 See `make-face-bold' for the semantics of the LOCALE argument and 976 See `make-face-bold' for the semantics of the LOCALE argument and
979 for more specifics on exactly how this function works." 977 for more specifics on exactly how this function works."
980 (interactive (list (read-face-name "Make which face non-bold: "))) 978 (interactive (list (read-face-name "Make which face non-bold: ")))
981 (frob-face-font-2 979 (frob-face-font-2
982 face locale 'bold 'default 980 face locale 'bold 'default
983 #'(lambda () 981 (lambda ()
984 ;; handle TTY specific entries 982 ;; handle TTY specific entries
985 (if (featurep 'tty) 983 (when (featurep 'tty)
986 (set-face-highlight-p face nil locale 'tty))) 984 (set-face-highlight-p face nil locale 'tty)))
987 #'(lambda () 985 (lambda ()
988 ;; handle X specific entries 986 ;; handle X specific entries
989 (frob-face-property face 'font 'x-make-font-unbold locale)) 987 (frob-face-property face 'font 'x-make-font-unbold locale))
990 '(([default] . t) 988 '(([default] . t)
991 ([bold] . [default]) 989 ([bold] . [default])
992 ([italic] . t) 990 ([italic] . t)
993 ([bold-italic] . [italic])))) 991 ([bold-italic] . [italic]))))
994 992
999 See `make-face-bold' for the semantics of the LOCALE argument and 997 See `make-face-bold' for the semantics of the LOCALE argument and
1000 for more specifics on exactly how this function works." 998 for more specifics on exactly how this function works."
1001 (interactive (list (read-face-name "Make which face non-italic: "))) 999 (interactive (list (read-face-name "Make which face non-italic: ")))
1002 (frob-face-font-2 1000 (frob-face-font-2
1003 face locale 'italic 'default 1001 face locale 'italic 'default
1004 #'(lambda () 1002 (lambda ()
1005 ;; handle TTY specific entries 1003 ;; handle TTY specific entries
1006 (if (featurep 'tty) 1004 (when (featurep 'tty)
1007 (set-face-underline-p face nil locale 'tty))) 1005 (set-face-underline-p face nil locale 'tty)))
1008 #'(lambda () 1006 (lambda ()
1009 ;; handle X specific entries 1007 ;; handle X specific entries
1010 (frob-face-property face 'font 'x-make-font-unitalic locale)) 1008 (frob-face-property face 'font 'x-make-font-unitalic locale))
1011 '(([default] . t) 1009 '(([default] . t)
1012 ([bold] . t) 1010 ([bold] . t)
1013 ([italic] . [default]) 1011 ([italic] . [default])
1014 ([bold-italic] . [bold])))) 1012 ([bold-italic] . [bold]))))
1015 1013
1095 ;; Nothing to do for TTYs? 1093 ;; Nothing to do for TTYs?
1096 ))))) 1094 )))))
1097 1095
1098 (defun init-device-faces (device) 1096 (defun init-device-faces (device)
1099 ;; First, add any device-local face resources. 1097 ;; First, add any device-local face resources.
1100 (let ((faces (face-list))) 1098 (loop for face in (face-list) do
1101 (while faces 1099 (init-face-from-resources face device))
1102 (init-face-from-resources (car faces) device)
1103 (setq faces (cdr faces))))
1104 ;; Then do any device-specific initialization. 1100 ;; Then do any device-specific initialization.
1105 (cond ((eq 'x (device-type device)) 1101 (cond ((eq 'x (device-type device))
1106 (x-init-device-faces device)) 1102 (x-init-device-faces device))
1107 ;; Nothing to do for TTYs? 1103 ;; Nothing to do for TTYs?
1108 ) 1104 )
1109 (init-other-random-faces device)) 1105 (init-other-random-faces device))
1110 1106
1111 (defun init-frame-faces (frame) 1107 (defun init-frame-faces (frame)
1112 ;; First, add any frame-local face resources. 1108 ;; First, add any frame-local face resources.
1113 (let ((faces (face-list))) 1109 (loop for face in (face-list) do
1114 (while faces 1110 (init-face-from-resources face frame))
1115 (init-face-from-resources (car faces) frame)
1116 (setq faces (cdr faces))))
1117 ;; Then do any frame-specific initialization. 1111 ;; Then do any frame-specific initialization.
1118 (cond ((eq 'x (frame-type frame)) 1112 (cond ((eq 'x (frame-type frame))
1119 (x-init-frame-faces frame)) 1113 (x-init-frame-faces frame))
1120 ;; Is there anything which should be done for TTY's? 1114 ;; Is there anything which should be done for TTY's?
1121 )) 1115 ))
1126 ;; outside of X-specificness, so we have to live with this 1120 ;; outside of X-specificness, so we have to live with this
1127 ;; breach of device-independence. 1121 ;; breach of device-independence.
1128 1122
1129 (defun init-global-faces () 1123 (defun init-global-faces ()
1130 ;; Look for global face resources. 1124 ;; Look for global face resources.
1131 (let ((faces (face-list))) 1125 (loop for face in (face-list) do
1132 (while faces 1126 (init-face-from-resources face 'global))
1133 (init-face-from-resources (car faces) 'global)
1134 (setq faces (cdr faces))))
1135 ;; Further X frobbing. 1127 ;; Further X frobbing.
1136 (x-init-global-faces) 1128 (x-init-global-faces)
1137 ;; for bold and the like, make the global specification be bold etc. 1129 ;; for bold and the like, make the global specification be bold etc.
1138 ;; if the user didn't already specify a value. These will also be 1130 ;; if the user didn't already specify a value. These will also be
1139 ;; frobbed further in init-other-random-faces. 1131 ;; frobbed further in init-other-random-faces.
1140 (or (face-font 'bold 'global) 1132 (unless (face-font 'bold 'global)
1141 (make-face-bold 'bold 'global)) 1133 (make-face-bold 'bold 'global))
1142 ;; 1134 ;;
1143 (or (face-font 'italic 'global) 1135 (unless (face-font 'italic 'global)
1144 (make-face-italic 'italic 'global)) 1136 (make-face-italic 'italic 'global))
1145 ;; 1137 ;;
1146 (or (face-font 'bold-italic 'global) 1138 (unless (face-font 'bold-italic 'global)
1147 (make-face-bold-italic 'bold-italic 'global)) 1139 (make-face-bold-italic 'bold-italic 'global)
1148 1140 (unless (face-font 'bold-italic 'global)
1149 (if (not (face-font 'bold-italic 'global)) 1141 (copy-face 'bold 'bold-italic)
1150 (progn 1142 (make-face-italic 'bold-italic)))
1151 (copy-face 'bold 'bold-italic) 1143
1152 (make-face-italic 'bold-italic))) 1144 (when (face-equal 'bold 'bold-italic)
1153 1145 (copy-face 'italic 'bold-italic)
1154 (if (face-equal 'bold 'bold-italic) 1146 (make-face-bold 'bold-italic))
1155 (progn
1156 (copy-face 'italic 'bold-italic)
1157 (make-face-bold 'bold-italic)))
1158 ;; 1147 ;;
1159 ;; Nothing more to be done for X or TTY's? 1148 ;; Nothing more to be done for X or TTY's?
1160 ) 1149 )
1161 1150
1162 1151
1196 secondary-selection, and isearch faces when each device is created. If 1185 secondary-selection, and isearch faces when each device is created. If
1197 you want to add code to do stuff like this, use the create-device-hook." 1186 you want to add code to do stuff like this, use the create-device-hook."
1198 1187
1199 ;; try to make 'bold look different from the default on this device. 1188 ;; try to make 'bold look different from the default on this device.
1200 ;; If that doesn't work at all, then issue a warning. 1189 ;; If that doesn't work at all, then issue a warning.
1201 (or (face-differs-from-default-p 'bold device) 1190 (unless (face-differs-from-default-p 'bold device)
1202 (make-face-bold 'bold device)) 1191 (make-face-bold 'bold device)
1203 (or (face-differs-from-default-p 'bold device) 1192 (unless (face-differs-from-default-p 'bold device)
1204 (make-face-unbold 'bold device)) 1193 (make-face-unbold 'bold device)
1205 (or (face-differs-from-default-p 'bold device) 1194 (unless (face-differs-from-default-p 'bold device)
1206 ;; otherwise the luser specified one of the bogus font names 1195 ;; the luser specified one of the bogus font names
1207 (face-complain-about-font 'bold device)) 1196 (face-complain-about-font 'bold device))))
1208 1197
1209 ;; similar for italic. 1198 ;; Similar for italic.
1210 (or (face-differs-from-default-p 'italic device) 1199 ;; It's unreasonable to expect to be able to make a font italic all
1211 (make-face-italic 'italic device)) 1200 ;; the time. For many languages, italic is an alien concept.
1212 (or (face-differs-from-default-p 'italic device) 1201 ;; Basically, because italic is not a globally meaningful concept,
1213 (progn 1202 ;; the use of the italic face should really be oboleted.
1214 (make-face-bold 'italic device) ; bold if possible, then complain 1203
1215 (face-complain-about-font 'italic device))) 1204 ;; In a Solaris Japanese environment, there just aren't any italic
1205 ;; fonts - period. CDE recognizes this reality, and fonts
1206 ;; -dt-interface user-medium-r-normal-*-*-*-*-*-*-*-*-* don't come
1207 ;; in italic versions. So we first try to make the font bold before
1208 ;; complaining.
1209 (unless (face-differs-from-default-p 'italic device)
1210 (make-face-italic 'italic device)
1211 (unless (face-differs-from-default-p 'italic device)
1212 (make-face-bold 'italic device)
1213 (unless (face-differs-from-default-p 'italic device)
1214 (face-complain-about-font 'italic device))))
1216 1215
1217 ;; similar for bold-italic. 1216 ;; similar for bold-italic.
1218 (or (face-differs-from-default-p 'bold-italic device) 1217 (unless (face-differs-from-default-p 'bold-italic device)
1219 (make-face-bold-italic 'bold-italic device)) 1218 (make-face-bold-italic 'bold-italic device)
1220 ;; if we couldn't get a bold-italic version, try just bold. 1219 ;; if we couldn't get a bold-italic version, try just bold.
1221 (or (face-differs-from-default-p 'bold-italic device) 1220 (unless (face-differs-from-default-p 'bold-italic device)
1222 (make-face-bold-italic 'bold-italic device)) 1221 (make-face-bold-italic 'bold-italic device)
1223 ;; if we couldn't get bold or bold-italic, then that's probably because 1222 ;; if we couldn't get bold or bold-italic, then that's probably because
1224 ;; the default font is bold, so make the `bold-italic' face be unbold. 1223 ;; the default font is bold, so make the `bold-italic' face be unbold.
1225 (or (face-differs-from-default-p 'bold-italic device) 1224 (unless (face-differs-from-default-p 'bold-italic device)
1226 (progn
1227 (make-face-unbold 'bold-italic device) 1225 (make-face-unbold 'bold-italic device)
1228 (make-face-italic 'bold-italic device)))
1229 (or (face-differs-from-default-p 'bold-italic device)
1230 (progn
1231 ;; if that didn't work, try italic (can this ever happen? what the hell.)
1232 (make-face-italic 'bold-italic device) 1226 (make-face-italic 'bold-italic device)
1233 ;; then bitch and moan. 1227 (unless (face-differs-from-default-p 'bold-italic device)
1234 (face-complain-about-font 'bold-italic device))) 1228 ;; if that didn't work, try plain italic
1235 1229 ;; (can this ever happen? what the hell.)
1236 ;; first time through, set the text-cursor colors if not already 1230 (make-face-italic 'bold-italic device)
1237 ;; specified. 1231 (unless (face-differs-from-default-p 'bold-italic device)
1238 (if (and (not (face-background 'text-cursor 'global)) 1232 ;; then bitch and moan.
1239 (face-property-equal 'text-cursor 'default 'background device)) 1233 (face-complain-about-font 'bold-italic device))))))
1240 (set-face-background 'text-cursor [default foreground] 'global 1234
1241 nil 'append)) 1235 ;; Set the text-cursor colors unless already specified.
1242 (if (and (not (face-foreground 'text-cursor 'global)) 1236 (when (and (not (face-background 'text-cursor 'global))
1243 (face-property-equal 'text-cursor 'default 'foreground device)) 1237 (face-property-equal 'text-cursor 'default 'background device))
1244 (set-face-foreground 'text-cursor [default background] 'global 1238 (set-face-background 'text-cursor [default foreground] 'global
1245 nil 'append)) 1239 nil 'append))
1246 1240 (when (and (not (face-foreground 'text-cursor 'global))
1247 ;; first time through, set the secondary-selection color if it's not already 1241 (face-property-equal 'text-cursor 'default 'foreground device))
1248 ;; specified. 1242 (set-face-foreground 'text-cursor [default background] 'global
1249 (if (and (not (face-differs-from-default-p 'highlight device)) 1243 nil 'append))
1250 (not (face-background 'highlight 'global))) 1244
1251 (progn 1245 ;; Set the secondary-selection color unless already specified.
1252 ;; some older servers don't recognize "darkseagreen2" 1246 (unless (or (face-differs-from-default-p 'highlight device)
1253 (set-face-background 'highlight 1247 (face-background 'highlight 'global))
1254 '((color . "darkseagreen2") 1248 ;; some older servers don't recognize "darkseagreen2"
1255 (color . "green")) 1249 (set-face-background 'highlight
1256 'global nil 'append) 1250 '((color . "darkseagreen2")
1257 (set-face-background 'highlight "gray53" 'global 'grayscale 'append))) 1251 (color . "green"))
1258 (if (and (not (face-differs-from-default-p 'highlight device)) 1252 'global nil 'append)
1259 (not (face-background-pixmap 'highlight 'global))) 1253 (set-face-background 'highlight "gray53" 'global 'grayscale 'append))
1260 (progn 1254 (unless (or (face-differs-from-default-p 'highlight device)
1261 (set-face-background-pixmap 'highlight [nothing] 'global 'color 1255 (face-background-pixmap 'highlight 'global))
1262 'append) 1256 (set-face-background-pixmap 'highlight [nothing] 'global 'color 'append)
1263 (set-face-background-pixmap 'highlight [nothing] 'global 'grayscale 1257 (set-face-background-pixmap 'highlight [nothing] 'global 'grayscale 'append)
1264 'append) 1258 (set-face-background-pixmap 'highlight "gray1" 'global 'mono 'append))
1265 (set-face-background-pixmap 'highlight "gray1" 'global 'mono 'append)))
1266 ;; if the highlight face isn't distinguished on this device, 1259 ;; if the highlight face isn't distinguished on this device,
1267 ;; at least try inverting it. 1260 ;; at least try inverting it.
1268 (or (face-differs-from-default-p 'highlight device) 1261 (unless (face-differs-from-default-p 'highlight device)
1269 (invert-face 'highlight device)) 1262 (invert-face 'highlight device))
1270 1263
1271 ;; first time through, set the zmacs-region color if it's not already 1264 ;; first time through, set the zmacs-region color if it's not already
1272 ;; specified. 1265 ;; specified.
1273 (if (and (not (face-differs-from-default-p 'zmacs-region device)) 1266 (unless (or (face-differs-from-default-p 'zmacs-region device)
1274 (not (face-background 'zmacs-region 'global))) 1267 (face-background 'zmacs-region 'global))
1275 (progn 1268 (set-face-background 'zmacs-region "gray" 'global 'color)
1276 (set-face-background 'zmacs-region "gray" 'global 'color) 1269 (set-face-background 'zmacs-region "gray80" 'global 'grayscale))
1277 (set-face-background 'zmacs-region "gray80" 'global 'grayscale))) 1270 (unless (or (face-differs-from-default-p 'zmacs-region device)
1278 (if (and (not (face-differs-from-default-p 'zmacs-region device)) 1271 (face-background-pixmap 'zmacs-region 'global))
1279 (not (face-background-pixmap 'zmacs-region 'global))) 1272 (set-face-background-pixmap 'zmacs-region [nothing] 'global 'color)
1280 (progn 1273 (set-face-background-pixmap 'zmacs-region [nothing] 'global 'grayscale)
1281 (set-face-background-pixmap 'zmacs-region [nothing] 'global 'color) 1274 (set-face-background-pixmap 'zmacs-region "gray3" 'global 'mono))
1282 (set-face-background-pixmap 'zmacs-region [nothing] 'global 'grayscale)
1283 (set-face-background-pixmap 'zmacs-region "gray3" 'global 'mono)))
1284 ;; if the zmacs-region face isn't distinguished on this device, 1275 ;; if the zmacs-region face isn't distinguished on this device,
1285 ;; at least try inverting it. 1276 ;; at least try inverting it.
1286 (or (face-differs-from-default-p 'zmacs-region device) 1277 (unless (face-differs-from-default-p 'zmacs-region device)
1287 (invert-face 'zmacs-region device)) 1278 (invert-face 'zmacs-region device))
1288 1279
1289 ;; first time through, set the list-mode-item-selected color if it's 1280 ;; first time through, set the list-mode-item-selected color if it's
1290 ;; not already specified. 1281 ;; not already specified.
1291 (if (and (not (face-differs-from-default-p 'list-mode-item-selected device)) 1282 (unless (or (face-differs-from-default-p 'list-mode-item-selected device)
1292 (not (face-background 'list-mode-item-selected 'global))) 1283 (face-background 'list-mode-item-selected 'global))
1293 (progn 1284 (set-face-background 'list-mode-item-selected "gray68" 'global 'color)
1294 (set-face-background 'list-mode-item-selected "gray68" 'global 'color) 1285 (set-face-background 'list-mode-item-selected "gray68" 'global 'grayscale)
1295 (set-face-background 'list-mode-item-selected "gray68" 'global 1286 (unless (face-foreground 'list-mode-item-selected 'global)
1296 'grayscale) 1287 (set-face-background 'list-mode-item-selected
1297 (if (not (face-foreground 'list-mode-item-selected 'global)) 1288 [default foreground] 'global '(mono x))
1298 (progn 1289 (set-face-foreground 'list-mode-item-selected
1299 (set-face-background 'list-mode-item-selected 1290 [default background] 'global '(mono x))))
1300 [default foreground] 'global '(mono x))
1301 (set-face-foreground 'list-mode-item-selected
1302 [default background] 'global '(mono x))))))
1303 ;; if the list-mode-item-selected face isn't distinguished on this device, 1291 ;; if the list-mode-item-selected face isn't distinguished on this device,
1304 ;; at least try inverting it. 1292 ;; at least try inverting it.
1305 (or (face-differs-from-default-p 'list-mode-item-selected device) 1293 (unless (face-differs-from-default-p 'list-mode-item-selected device)
1306 (invert-face 'list-mode-item-selected device)) 1294 (invert-face 'list-mode-item-selected device))
1307 1295
1308 ;; first time through, set the primary-selection color if it's not already 1296 ;; Set the primary-selection color unless already specified.
1309 ;; specified. 1297 (unless (or (face-differs-from-default-p 'primary-selection device)
1310 (if (and (not (face-differs-from-default-p 'primary-selection device)) 1298 (face-background 'primary-selection 'global))
1311 (not (face-background 'primary-selection 'global))) 1299 (set-face-background 'primary-selection "gray" 'global 'color)
1312 (progn 1300 (set-face-background 'primary-selection "gray80" 'global 'grayscale))
1313 (set-face-background 'primary-selection "gray" 'global 'color) 1301 (unless (or (face-differs-from-default-p 'secondary-selection device)
1314 (set-face-background 'primary-selection "gray80" 'global 'grayscale))) 1302 (face-background-pixmap 'primary-selection 'global))
1315 (if (and (not (face-differs-from-default-p 'secondary-selection device)) 1303 (set-face-background-pixmap 'primary-selection "gray3" 'global 'mono))
1316 (not (face-background-pixmap 'primary-selection 'global))) 1304 ;; If the primary-selection face isn't distinguished on this device,
1317 (set-face-background-pixmap 'primary-selection "gray3" 'global 'mono))
1318 ;; if the primary-selection face isn't distinguished on this device,
1319 ;; at least try inverting it. 1305 ;; at least try inverting it.
1320 (or (face-differs-from-default-p 'primary-selection device) 1306 (unless (face-differs-from-default-p 'primary-selection device)
1321 (invert-face 'primary-selection device)) 1307 (invert-face 'primary-selection device))
1322 1308
1323 ;; first time through, set the secondary-selection color if it's not already 1309 ;; Set the secondary-selection color unless already specified.
1324 ;; specified. 1310 (unless (or (face-differs-from-default-p 'secondary-selection device)
1325 (if (and (not (face-differs-from-default-p 'secondary-selection device)) 1311 (face-background 'secondary-selection 'global))
1326 (not (face-background 'secondary-selection 'global))) 1312 (set-face-background 'secondary-selection
1327 (progn 1313 '((color . "paleturquoise")
1328 (set-face-background 'secondary-selection 1314 (color . "green"))
1329 '((color . "paleturquoise") 1315 'global)
1330 (color . "green")) 1316 (set-face-background 'secondary-selection "gray53" 'global
1331 'global) 1317 'grayscale))
1332 (set-face-background 'secondary-selection "gray53" 'global 1318 (unless (or (face-differs-from-default-p 'secondary-selection device)
1333 'grayscale))) 1319 (face-background-pixmap 'secondary-selection 'global))
1334 (if (and (not (face-differs-from-default-p 'secondary-selection device)) 1320 (set-face-background-pixmap 'secondary-selection "gray1" 'global 'mono))
1335 (not (face-background-pixmap 'secondary-selection 'global))) 1321 ;; If the secondary-selection face isn't distinguished on this device,
1336 (set-face-background-pixmap 'secondary-selection "gray1" 'global 'mono))
1337 ;; if the secondary-selection face isn't distinguished on this device,
1338 ;; at least try inverting it. 1322 ;; at least try inverting it.
1339 (or (face-differs-from-default-p 'secondary-selection device) 1323 (unless (face-differs-from-default-p 'secondary-selection device)
1340 (invert-face 'secondary-selection device)) 1324 (invert-face 'secondary-selection device))
1341 1325
1342 ;; set the isearch color if it's not already specified. 1326 ;; Set the isearch color if unless already specified.
1343 (if (not (face-differs-from-default-p 'isearch device)) 1327 (unless (or (face-differs-from-default-p 'isearch device)
1344 (or (face-background 'isearch 'global) 1328 (face-background 'isearch 'global))
1345 ;; TTY's and some older X servers don't recognize "paleturquoise" 1329 ;; TTY's and some older X servers don't recognize "paleturquoise"
1346 (set-face-background 'isearch 1330 (set-face-background 'isearch
1347 '((color . "paleturquoise") 1331 '((color . "paleturquoise")
1348 (color . "green")) 1332 (color . "green"))
1349 'global))) 1333 'global))
1350 ;; if the isearch face isn't distinguished (e.g. we're not on a color 1334 ;; if the isearch face isn't distinguished (e.g. we're not on a color
1351 ;; display), at least try making it bold. 1335 ;; display), at least try making it bold.
1352 (or (face-differs-from-default-p 'isearch device) 1336 (unless (face-differs-from-default-p 'isearch device)
1353 (set-face-font 'isearch [bold])) 1337 (set-face-font 'isearch [bold]))
1354 1338
1355 ;; set the modeline face colors/fonts if not already specified. 1339 ;; Set the modeline face colors/fonts unless already specified.
1356 1340
1357 ;; modeline-buffer-id: 1341 ;; modeline-buffer-id:
1358 (if (not (face-differs-from-default-p 'modeline-buffer-id device)) 1342 (unless (face-differs-from-default-p 'modeline-buffer-id device)
1359 (let ((fg (face-foreground 'modeline-buffer-id 'global)) 1343 (let ((fg (face-foreground 'modeline-buffer-id 'global))
1360 (font (face-font 'modeline-buffer-id 'global))) 1344 (font (face-font 'modeline-buffer-id 'global)))
1361 (and (featurep 'x) 1345 (when (and (null fg) (featurep 'x))
1362 (or fg 1346 (set-face-foreground 'modeline-buffer-id "blue" 'global '(color x)))
1363 (set-face-foreground 'modeline-buffer-id "blue" 'global 1347 (unless font
1364 '(color x)))) 1348 (when (featurep 'x)
1365 (if font 1349 (set-face-font 'modeline-buffer-id [bold-italic] nil '(mono x))
1366 nil 1350 (set-face-font 'modeline-buffer-id [bold-italic] nil '(grayscale x)))
1367 (if (featurep 'x) 1351 (when (featurep 'tty)
1368 (progn 1352 (set-face-font 'modeline-buffer-id [bold-italic] nil 'tty)))))
1369 (set-face-font 'modeline-buffer-id [bold-italic] nil '(mono x))
1370 (set-face-font 'modeline-buffer-id [bold-italic] nil
1371 '(grayscale x))))
1372 (if (featurep 'tty)
1373 (set-face-font 'modeline-buffer-id [bold-italic] nil 'tty)))))
1374 (set-face-parent 'modeline-buffer-id 'modeline nil nil 'append) 1353 (set-face-parent 'modeline-buffer-id 'modeline nil nil 'append)
1375 1354
1376 ;; modeline-mousable: 1355 ;; modeline-mousable:
1377 (if (not (face-differs-from-default-p 'modeline-mousable device)) 1356 (unless (face-differs-from-default-p 'modeline-mousable device)
1378 (let ((fg (face-foreground 'modeline-mousable 'global)) 1357 (let ((fg (face-foreground 'modeline-mousable 'global))
1379 (font (face-font 'modeline-mousable 'global))) 1358 (font (face-font 'modeline-mousable 'global)))
1380 (and (featurep 'x) 1359 (when (and (null fg) (featurep 'x))
1381 (or fg 1360 (set-face-foreground 'modeline-mousable "red" 'global '(color x)))
1382 (set-face-foreground 'modeline-mousable "red" 'global 1361 (unless font
1383 '(color x)))) 1362 (when (featurep 'x)
1384 (if font 1363 (set-face-font 'modeline-mousable [bold] nil '(mono x))
1385 nil 1364 (set-face-font 'modeline-mousable [bold] nil '(grayscale x))))))
1386 (if (featurep 'x)
1387 (progn
1388 (set-face-font 'modeline-mousable [bold] nil '(mono x))
1389 (set-face-font 'modeline-mousable [bold] nil
1390 '(grayscale x)))))))
1391 (set-face-parent 'modeline-mousable 'modeline nil nil 'append) 1365 (set-face-parent 'modeline-mousable 'modeline nil nil 'append)
1392 1366
1393 ;; modeline-mousable-minor-mode: 1367 ;; modeline-mousable-minor-mode:
1394 (if (not (face-differs-from-default-p 'modeline-mousable-minor-mode device)) 1368 (unless (face-differs-from-default-p 'modeline-mousable-minor-mode device)
1395 (let ((fg (face-foreground 'modeline-mousable-minor-mode 'global))) 1369 (let ((fg (face-foreground 'modeline-mousable-minor-mode 'global)))
1396 (and (featurep 'x) 1370 (when (and (null fg) (featurep 'x))
1397 (or fg 1371 (set-face-foreground 'modeline-mousable-minor-mode
1398 (set-face-foreground 'modeline-mousable-minor-mode 1372 '(((color x) . "green4")
1399 '(((color x) . "green4") 1373 ((color x) . "green")) 'global))))
1400 ((color x) . "green")) 'global)))))
1401 (set-face-parent 'modeline-mousable-minor-mode 'modeline-mousable 1374 (set-face-parent 'modeline-mousable-minor-mode 'modeline-mousable
1402 nil nil 'append) 1375 nil nil 'append)
1403 ) 1376 )
1404 1377
1405 1378
1421 "Face for the selected list item in list-mode.") 1394 "Face for the selected list item in list-mode.")
1422 (make-face 'highlight "highlight face") 1395 (make-face 'highlight "highlight face")
1423 (make-face 'primary-selection) 1396 (make-face 'primary-selection)
1424 (make-face 'secondary-selection) 1397 (make-face 'secondary-selection)
1425 1398
1426 (make-face 'red "red text") 1399 (loop for color in '("red" "green" "blue" "yellow") do
1427 (set-face-foreground 'red "red" nil 'color) 1400 (make-face (intern color) (concat color " text"))
1428 (make-face 'green "green text") 1401 (set-face-foreground (intern color) color nil 'color))
1429 (set-face-foreground 'green "green" nil 'color) 1402
1430 (make-face 'blue "blue text")
1431 (set-face-foreground 'blue "blue" nil 'color)
1432 (make-face 'yellow "yellow text")
1433 (set-face-foreground 'yellow "yellow" nil 'color)
1434
1435 ;;
1436 ;; Make some useful faces. This happens very early, before creating 1403 ;; Make some useful faces. This happens very early, before creating
1437 ;; the first non-stream device. We initialize the tty global values here. 1404 ;; the first non-stream device. We initialize the tty global values here.
1438 ;; We cannot initialize the X global values here because they depend 1405 ;; We cannot initialize the X global values here because they depend
1439 ;; on having already resourced the global face specs, which happens 1406 ;; on having already resourced the global face specs, which happens
1440 ;; when the first X device is created. 1407 ;; when the first X device is created.
1441 ;; 1408
1442
1443 (if (featurep 'tty)
1444 (set-face-reverse-p 'modeline t 'global 'tty))
1445 (set-face-background-pixmap 'modeline [nothing]) 1409 (set-face-background-pixmap 'modeline [nothing])
1446 ;; 1410
1447 (if (featurep 'tty) 1411 (when (featurep 'tty)
1448 (set-face-highlight-p 'highlight t 'global 'tty)) 1412 (set-face-highlight-p 'bold t 'global 'tty)
1449 ;; 1413 (set-face-underline-p 'italic t 'global 'tty)
1450 (if (featurep 'tty) 1414 (set-face-highlight-p 'bold-italic t 'global 'tty)
1451 (set-face-reverse-p 'text-cursor t 'global 'tty)) 1415 (set-face-underline-p 'bold-italic t 'global 'tty)
1452 ;; 1416 (set-face-highlight-p 'highlight t 'global 'tty)
1453 (if (featurep 'tty) 1417 (set-face-reverse-p 'text-cursor t 'global 'tty)
1454 (set-face-highlight-p 'bold t 'global 'tty)) 1418 (set-face-reverse-p 'modeline t 'global 'tty)
1455 ;; 1419 (set-face-reverse-p 'zmacs-region t 'global 'tty)
1456 (if (featurep 'tty) 1420 (set-face-reverse-p 'list-mode-item-selected t 'global 'tty)
1457 (set-face-underline-p 'italic t 'global 'tty)) 1421 (set-face-reverse-p 'isearch t 'global 'tty)
1458 ;; 1422 )
1459 (if (featurep 'tty)
1460 (progn
1461 (set-face-highlight-p 'bold-italic t 'global 'tty)
1462 (set-face-underline-p 'bold-italic t 'global 'tty)))
1463 ;;
1464 (if (featurep 'tty)
1465 (set-face-reverse-p 'zmacs-region t 'global 'tty))
1466 ;;
1467 (if (featurep 'tty)
1468 (set-face-reverse-p 'list-mode-item-selected t 'global 'tty))
1469 ;;
1470 (if (featurep 'tty)
1471 (set-face-reverse-p 'isearch t 'global 'tty))
1472
1473 ;;; faces.el ends here