Mercurial > hg > xemacs-beta

comparison lisp/faces.el @ 416:ebe98a74bd68 r21-2-16

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-16
author cvs
date Mon, 13 Aug 2007 11:22:23 +0200
parents 697ef44129c6
children 11054d720c21
comparison
equal deleted inserted replaced
415:a27f76b40c83 416:ebe98a74bd68
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) 797 (defun frob-face-property (face property func &optional locale tags)
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)
818 (if (valid-specifier-domain-p locale) 819 (if (valid-specifier-domain-p locale)
819 ;; this is easy. 820 ;; this is easy.
820 (let* ((inst (face-property-instance face property locale)) 821 (let* ((inst (face-property-instance face property locale))
821 (name (and inst (funcall func inst (dfw-device locale))))) 822 (name (and inst (funcall func inst (dfw-device locale)))))
822 (when name 823 (when name
823 (add-spec-to-specifier sp name locale))) 824 (add-spec-to-specifier sp name locale tags)))
824 ;; otherwise, map over all specifications ... 825 ;; otherwise, map over all specifications ...
825 ;; but first, some further kludging: 826 ;; but first, some further kludging:
826 ;; (1) if we're frobbing the global property, make sure 827 ;; (1) if we're frobbing the global property, make sure
827 ;; that something is there (copy from the default face, 828 ;; that something is there (copy from the default face,
828 ;; if necessary). Otherwise, something like 829 ;; if necessary). Otherwise, something like
830 ;; won't do anything at all if the modeline simply 831 ;; won't do anything at all if the modeline simply
831 ;; inherits its font from 'default. 832 ;; inherits its font from 'default.
832 ;; (2) if we're frobbing a particular locale, nothing would 833 ;; (2) if we're frobbing a particular locale, nothing would
833 ;; happen if that locale has no instantiators. So signal 834 ;; happen if that locale has no instantiators. So signal
834 ;; an error to indicate this. 835 ;; an error to indicate this.
835 (if (and (or (eq locale 'global) (eq locale 'all) (not locale)) 836
836 (not (face-property face property 'global))) 837 (setq temp-sp
837 (copy-specifier (face-property 'default property) 838 (if (and (or (eq locale 'global) (eq locale 'all) (not locale))
838 (face-property face property) 839 (not (face-property face property 'global)))
839 'global)) 840 (copy-specifier (face-property 'default property)
841 nil 'global)
842 sp))
840 (if (and (valid-specifier-locale-p locale) 843 (if (and (valid-specifier-locale-p locale)
841 (not (face-property face property locale))) 844 (not (specifier-specs temp-sp locale)))
842 (error "Property must have a specification in locale %S" locale)) 845 (error "Property must have a specification in locale %S" locale))
843 (map-specifier 846 (map-specifier
844 sp 847 temp-sp
845 (lambda (sp locale inst-list func) 848 (lambda (sp-arg locale inst-list func)
846 (let* ((device (dfw-device locale)) 849 (let* ((device (dfw-device locale))
847 ;; if a device can be derived from the locale, 850 ;; if a device can be derived from the locale,
848 ;; call frob-face-property-1 for that device. 851 ;; call frob-face-property-1 for that device.
849 ;; Otherwise map frob-face-property-1 over each device. 852 ;; Otherwise map frob-face-property-1 over each device.
850 (result 853 (result
851 (if device 854 (if device
852 (list (frob-face-property-1 sp device inst-list func)) 855 (list (frob-face-property-1 sp-arg device inst-list func))
853 (mapcar (lambda (device) 856 (mapcar (lambda (device)
854 (frob-face-property-1 sp device 857 (frob-face-property-1 sp-arg device
855 inst-list func)) 858 inst-list func))
856 (device-list)))) 859 (device-list))))
857 new-result) 860 new-result)
858 ;; remove duplicates and nils from the obtained list of 861 ;; remove duplicates and nils from the obtained list of
859 ;; instantiators. 862 ;; instantiators. Also add tags amd remove 'defaults'.
860 (mapcar (lambda (arg) 863 (mapcar (lambda (arg)
861 (when (and arg (not (member arg new-result))) 864 (when arg
865 (if (not (consp arg))
866 (setq arg (cons tags arg))
867 (setcar arg (append tags (delete 'default
868 (car arg))))))
869 (when (and arg (not (member arg new-result)))
862 (setq new-result (cons arg new-result)))) 870 (setq new-result (cons arg new-result))))
863 result) 871 result)
864 ;; add back in. 872 ;; add back in.
865 (add-spec-list-to-specifier sp (list (cons locale new-result))) 873 (add-spec-list-to-specifier sp (list (cons locale new-result)))
866 ;; tell map-specifier to keep going. 874 ;; tell map-specifier to keep going.
884 (if result 892 (if result
885 (setq result (cons tag-set result)))))) 893 (setq result (cons tag-set result))))))
886 (setq inst-list (cdr inst-list))) 894 (setq inst-list (cdr inst-list)))
887 (or result first-valid))) 895 (or result first-valid)))
888 896
889 (defun frob-face-font-2 (face locale unfrobbed-face frobbed-face 897 (defun frob-face-font-2 (face locale tags unfrobbed-face frobbed-face
890 tty-thunk x-thunk standard-face-mapping) 898 tty-thunk x-thunk standard-face-mapping)
891 ;; another kludge to make things more intuitive. If we're 899 ;; another kludge to make things more intuitive. If we're
892 ;; inheriting from a standard face in this locale, frob the 900 ;; inheriting from a standard face in this locale, frob the
893 ;; inheritance as appropriate. Else, if, after the first X frobbing 901 ;; inheritance as appropriate. Else, if, after the first X frobbing
894 ;; pass, the face hasn't changed and still looks like the standard 902 ;; pass, the face hasn't changed and still looks like the standard
932 (memq (face-name (find-face face)) 940 (memq (face-name (find-face face))
933 '(default bold italic bold-italic)) 941 '(default bold italic bold-italic))
934 (not (equal (face-property-instance face 'font domain) 942 (not (equal (face-property-instance face 'font domain)
935 (face-property-instance unfrobbed-face 'font domain))) 943 (face-property-instance unfrobbed-face 'font domain)))
936 (set-face-property face 'font (vector frobbed-face) 944 (set-face-property face 'font (vector frobbed-face)
937 the-locale)))))) 945 the-locale tags))))))
938 946
939 (defun make-face-bold (face &optional locale) 947 (defun make-face-bold (face &optional locale tags)
940 "Make FACE bold in LOCALE, if possible. 948 "Make FACE bold in LOCALE, if possible.
941 This will attempt to make the font bold for X locales and will set the 949 This will attempt to make the font bold for X locales and will set the
942 highlight flag for TTY locales. 950 highlight flag for TTY locales.
943 951
944 If LOCALE is nil, omitted, or `all', this will attempt to frob all 952 If LOCALE is nil, omitted, or `all', this will attempt to frob all
963 'default face, it is set to inherit from the 'bold face. This is kludgy 971 'default face, it is set to inherit from the 'bold face. This is kludgy
964 but it makes `make-face-bold' have more intuitive behavior in many 972 but it makes `make-face-bold' have more intuitive behavior in many
965 circumstances." 973 circumstances."
966 (interactive (list (read-face-name "Make which face bold: "))) 974 (interactive (list (read-face-name "Make which face bold: ")))
967 (frob-face-font-2 975 (frob-face-font-2
968 face locale 'default 'bold 976 face locale tags 'default 'bold
969 (lambda () 977 (lambda ()
970 ;; handle TTY specific entries 978 ;; handle TTY specific entries
971 (when (featurep 'tty) 979 (when (featurep 'tty)
972 (set-face-highlight-p face t locale 'tty))) 980 (set-face-highlight-p face t locale (cons 'tty tags))))
973 (lambda () 981 (lambda ()
974 ;; handle X specific entries 982 ;; handle X specific entries
975 (when (featurep 'x) 983 (when (featurep 'x)
976 (frob-face-property face 'font 'x-make-font-bold locale)) 984 (frob-face-property face 'font 'x-make-font-bold locale tags))
977 (when (featurep 'mswindows) 985 (when (featurep 'mswindows)
978 (frob-face-property face 'font 'mswindows-make-font-bold locale)) 986 (frob-face-property face 'font 'mswindows-make-font-bold locale tags))
979 ) 987 )
980 '(([default] . [bold]) 988 '(([default] . [bold])
981 ([bold] . t) 989 ([bold] . t)
982 ([italic] . [bold-italic]) 990 ([italic] . [bold-italic])
983 ([bold-italic] . t)))) 991 ([bold-italic] . t))))
984 992
985 (defun make-face-italic (face &optional locale) 993 (defun make-face-italic (face &optional locale tags)
986 "Make FACE italic in LOCALE, if possible. 994 "Make FACE italic in LOCALE, if possible.
987 This will attempt to make the font italic for X locales and will set 995 This will attempt to make the font italic for X locales and will set
988 the underline flag for TTY locales. 996 the underline flag for TTY locales.
989 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
990 for more specifics on exactly how this function works." 998 for more specifics on exactly how this function works."
991 (interactive (list (read-face-name "Make which face italic: "))) 999 (interactive (list (read-face-name "Make which face italic: ")))
992 (frob-face-font-2 1000 (frob-face-font-2
993 face locale 'default 'italic 1001 face locale tags 'default 'italic
994 (lambda () 1002 (lambda ()
995 ;; handle TTY specific entries 1003 ;; handle TTY specific entries
996 (when (featurep 'tty) 1004 (when (featurep 'tty)
997 (set-face-underline-p face t locale 'tty))) 1005 (set-face-underline-p face t locale (cons 'tty tags))))
998 (lambda () 1006 (lambda ()
999 ;; handle X specific entries 1007 ;; handle X specific entries
1000 (when (featurep 'x) 1008 (when (featurep 'x)
1001 (frob-face-property face 'font 'x-make-font-italic locale)) 1009 (frob-face-property face 'font 'x-make-font-italic locale tags))
1002 (when (featurep 'mswindows) 1010 (when (featurep 'mswindows)
1003 (frob-face-property face 'font 'mswindows-make-font-italic locale)) 1011 (frob-face-property face 'font 'mswindows-make-font-italic locale tags))
1004 ) 1012 )
1005 '(([default] . [italic]) 1013 '(([default] . [italic])
1006 ([bold] . [bold-italic]) 1014 ([bold] . [bold-italic])
1007 ([italic] . t) 1015 ([italic] . t)
1008 ([bold-italic] . t)))) 1016 ([bold-italic] . t))))
1009 1017
1010 (defun make-face-bold-italic (face &optional locale) 1018 (defun make-face-bold-italic (face &optional locale tags)
1011 "Make FACE bold and italic in LOCALE, if possible. 1019 "Make FACE bold and italic in LOCALE, if possible.
1012 This will attempt to make the font bold-italic for X locales and will 1020 This will attempt to make the font bold-italic for X locales and will
1013 set the highlight and underline flags for TTY locales. 1021 set the highlight and underline flags for TTY locales.
1014 See `make-face-bold' for the semantics of the LOCALE argument and 1022 See `make-face-bold' for the semantics of the LOCALE argument and
1015 for more specifics on exactly how this function works." 1023 for more specifics on exactly how this function works."
1016 (interactive (list (read-face-name "Make which face bold-italic: "))) 1024 (interactive (list (read-face-name "Make which face bold-italic: ")))
1017 (frob-face-font-2 1025 (frob-face-font-2
1018 face locale 'default 'bold-italic 1026 face locale tags 'default 'bold-italic
1019 (lambda () 1027 (lambda ()
1020 ;; handle TTY specific entries 1028 ;; handle TTY specific entries
1021 (when (featurep 'tty) 1029 (when (featurep 'tty)
1022 (set-face-highlight-p face t locale 'tty) 1030 (set-face-highlight-p face t locale (cons 'tty tags))
1023 (set-face-underline-p face t locale 'tty))) 1031 (set-face-underline-p face t locale (cons 'tty tags))))
1024 (lambda () 1032 (lambda ()
1025 ;; handle X specific entries 1033 ;; handle X specific entries
1026 (when (featurep 'x) 1034 (when (featurep 'x)
1027 (frob-face-property face 'font 'x-make-font-bold-italic locale)) 1035 (frob-face-property face 'font 'x-make-font-bold-italic locale tags))
1028 (when (featurep 'mswindows) 1036 (when (featurep 'mswindows)
1029 (frob-face-property face 'font 'mswindows-make-font-bold-italic locale)) 1037 (frob-face-property face 'font 'mswindows-make-font-bold-italic locale tags))
1030 ) 1038 )
1031 '(([default] . [italic]) 1039 '(([default] . [italic])
1032 ([bold] . [bold-italic]) 1040 ([bold] . [bold-italic])
1033 ([italic] . [bold-italic]) 1041 ([italic] . [bold-italic])
1034 ([bold-italic] . t)))) 1042 ([bold-italic] . t))))
1035 1043
1036 (defun make-face-unbold (face &optional locale) 1044 (defun make-face-unbold (face &optional locale tags)
1037 "Make FACE non-bold in LOCALE, if possible. 1045 "Make FACE non-bold in LOCALE, if possible.
1038 This will attempt to make the font non-bold for X locales and will 1046 This will attempt to make the font non-bold for X locales and will
1039 unset the highlight flag for TTY locales. 1047 unset the highlight flag for TTY locales.
1040 See `make-face-bold' for the semantics of the LOCALE argument and 1048 See `make-face-bold' for the semantics of the LOCALE argument and
1041 for more specifics on exactly how this function works." 1049 for more specifics on exactly how this function works."
1042 (interactive (list (read-face-name "Make which face non-bold: "))) 1050 (interactive (list (read-face-name "Make which face non-bold: ")))
1043 (frob-face-font-2 1051 (frob-face-font-2
1044 face locale 'bold 'default 1052 face locale tags 'bold 'default
1045 (lambda () 1053 (lambda ()
1046 ;; handle TTY specific entries 1054 ;; handle TTY specific entries
1047 (when (featurep 'tty) 1055 (when (featurep 'tty)
1048 (set-face-highlight-p face nil locale 'tty))) 1056 (set-face-highlight-p face nil locale (cons 'tty tags))))
1049 (lambda () 1057 (lambda ()
1050 ;; handle X specific entries 1058 ;; handle X specific entries
1051 (when (featurep 'x) 1059 (when (featurep 'x)
1052 (frob-face-property face 'font 'x-make-font-unbold locale)) 1060 (frob-face-property face 'font 'x-make-font-unbold locale tags))
1053 (when (featurep 'mswindows) 1061 (when (featurep 'mswindows)
1054 (frob-face-property face 'font 'mswindows-make-font-unbold locale)) 1062 (frob-face-property face 'font 'mswindows-make-font-unbold locale tags))
1055 ) 1063 )
1056 '(([default] . t) 1064 '(([default] . t)
1057 ([bold] . [default]) 1065 ([bold] . [default])
1058 ([italic] . t) 1066 ([italic] . t)
1059 ([bold-italic] . [italic])))) 1067 ([bold-italic] . [italic]))))
1060 1068
1061 (defun make-face-unitalic (face &optional locale) 1069 (defun make-face-unitalic (face &optional locale tags)
1062 "Make FACE non-italic in LOCALE, if possible. 1070 "Make FACE non-italic in LOCALE, if possible.
1063 This will attempt to make the font non-italic for X locales and will 1071 This will attempt to make the font non-italic for X locales and will
1064 unset the underline flag for TTY locales. 1072 unset the underline flag for TTY locales.
1065 See `make-face-bold' for the semantics of the LOCALE argument and 1073 See `make-face-bold' for the semantics of the LOCALE argument and
1066 for more specifics on exactly how this function works." 1074 for more specifics on exactly how this function works."
1067 (interactive (list (read-face-name "Make which face non-italic: "))) 1075 (interactive (list (read-face-name "Make which face non-italic: ")))
1068 (frob-face-font-2 1076 (frob-face-font-2
1069 face locale 'italic 'default 1077 face locale tags 'italic 'default
1070 (lambda () 1078 (lambda ()
1071 ;; handle TTY specific entries 1079 ;; handle TTY specific entries
1072 (when (featurep 'tty) 1080 (when (featurep 'tty)
1073 (set-face-underline-p face nil locale 'tty))) 1081 (set-face-underline-p face nil locale (cons 'tty tags))))
1074 (lambda () 1082 (lambda ()
1075 ;; handle X specific entries 1083 ;; handle X specific entries
1076 (when (featurep 'x) 1084 (when (featurep 'x)
1077 (frob-face-property face 'font 'x-make-font-unitalic locale)) 1085 (frob-face-property face 'font 'x-make-font-unitalic locale tags))
1078 (when (featurep 'mswindows) 1086 (when (featurep 'mswindows)
1079 (frob-face-property face 'font 'mswindows-make-font-unitalic locale)) 1087 (frob-face-property face 'font 'mswindows-make-font-unitalic locale tags))
1080 ) 1088 )
1081 '(([default] . t) 1089 '(([default] . t)
1082 ([bold] . t) 1090 ([bold] . t)
1083 ([italic] . [default]) 1091 ([italic] . [default])
1084 ([bold-italic] . [bold])))) 1092 ([bold-italic] . [bold]))))
1195 :type 'boolean) 1203 :type 'boolean)
1196 1204
1197 ;; Old name, used by custom. Also, FSFmacs name. 1205 ;; Old name, used by custom. Also, FSFmacs name.
1198 (defvaralias 'initialize-face-resources 'init-face-from-resources) 1206 (defvaralias 'initialize-face-resources 'init-face-from-resources)
1199 1207
1200 (defun face-spec-set (face spec &optional frame) 1208 ;; Make sure all custom setting are added with this tag so we can
1209 ;; identify-them
1210 (define-specifier-tag 'custom)
1211
1212 (defun face-spec-set (face spec &optional frame tags)
1201 "Set FACE's face attributes according to the first matching entry in SPEC. 1213 "Set FACE's face attributes according to the first matching entry in SPEC.
1202 If optional FRAME is non-nil, set it for that frame only. 1214 If optional FRAME is non-nil, set it for that frame only.
1203 If it is nil, then apply SPEC to each frame individually. 1215 If it is nil, then apply SPEC to each frame individually.
1204 See `defface' for information about SPEC." 1216 See `defface' for information about SPEC."
1205 (if frame 1217 (if frame
1206 (progn 1218 (progn
1207 (reset-face face frame) 1219 (reset-face face frame tags)
1208 (face-display-set face spec frame) 1220 (face-display-set face spec frame tags)
1209 (init-face-from-resources face frame)) 1221 (init-face-from-resources face frame))
1210 (let ((frames (relevant-custom-frames))) 1222 (let ((frames (relevant-custom-frames)))
1211 (reset-face face) 1223 (reset-face face nil tags)
1212 (if (and (eq 'default face) (featurep 'x)) 1224 ;; This should not be needed. We only remove our own specifiers
1213 (x-init-global-faces)) 1225 ;; (if (and (eq 'default face) (featurep 'x))
1214 (face-display-set face spec) 1226 ;; (x-init-global-faces))
1227 (face-display-set face spec nil tags)
1215 (while frames 1228 (while frames
1216 (face-display-set face spec (car frames)) 1229 (face-display-set face spec (car frames) tags)
1217 (pop frames)) 1230 (pop frames))
1218 (init-face-from-resources face)))) 1231 (init-face-from-resources face))))
1219 1232
1220 (defun face-display-set (face spec &optional frame) 1233 (defun face-display-set (face spec &optional frame tags)
1221 "Set FACE to the attributes to the first matching entry in SPEC. 1234 "Set FACE to the attributes to the first matching entry in SPEC.
1222 Iff optional FRAME is non-nil, set it for that frame only. 1235 Iff optional FRAME is non-nil, set it for that frame only.
1223 See `defface' for information about SPEC." 1236 See `defface' for information about SPEC."
1224 (while spec 1237 (while spec
1225 (let ((display (caar spec)) 1238 (let ((display (caar spec))
1226 (atts (cadar spec))) 1239 (atts (cadar spec)))
1227 (pop spec) 1240 (pop spec)
1228 (when (face-spec-set-match-display display frame) 1241 (when (face-spec-set-match-display display frame)
1229 ;; Avoid creating frame local duplicates of the global face. 1242 ;; Avoid creating frame local duplicates of the global face.
1230 (unless (and frame (eq display (get face 'custom-face-display))) 1243 (unless (and frame (eq display (get face 'custom-face-display)))
1231 (apply 'face-custom-attributes-set face frame atts)) 1244 (apply 'face-custom-attributes-set face frame tags atts))
1232 (unless frame 1245 (unless frame
1233 (put face 'custom-face-display display)) 1246 (put face 'custom-face-display display))
1234 (setq spec nil))))) 1247 (setq spec nil)))))
1235 1248
1236 (defvar default-custom-frame-properties nil 1249 (defvar default-custom-frame-properties nil