Mercurial > hg > xemacs-beta

comparison lisp/faces.el @ 452:3d3049ae1304 r21-2-41

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-41
author cvs
date Mon, 13 Aug 2007 11:40:21 +0200
parents 1ccc32a20af4
children 0784d089fdc9
comparison
equal deleted inserted replaced
451:8ad70c5cd5d7 452:3d3049ae1304
905 (if result 905 (if result
906 (setq result (cons tag-set result)))))) 906 (setq result (cons tag-set result))))))
907 (setq inst-list (cdr inst-list))) 907 (setq inst-list (cdr inst-list)))
908 (or result first-valid))) 908 (or result first-valid)))
909 909
910 (defcustom face-frob-from-locale-first nil
911 "*If non nil, use kludgy way of frobbing fonts suitable for non-mule
912 multi-charset environments."
913 :group 'faces
914 :type 'boolean)
915
910 (defun frob-face-font-2 (face locale tags unfrobbed-face frobbed-face 916 (defun frob-face-font-2 (face locale tags unfrobbed-face frobbed-face
911 tty-thunk ws-thunk standard-face-mapping) 917 tty-thunk ws-thunk standard-face-mapping)
912 ;; another kludge to make things more intuitive. If we're 918 ;; another kludge to make things more intuitive. If we're
913 ;; inheriting from a standard face in this locale, frob the 919 ;; inheriting from a standard face in this locale, frob the
914 ;; inheritance as appropriate. Else, if, after the first 920 ;; inheritance as appropriate. Else, if, after the first
922 ;; frobbing only if it's actually a locale; or for nil, do the frobbing 928 ;; frobbing only if it's actually a locale; or for nil, do the frobbing
923 ;; on 'global. This specifier stuff needs some rethinking. 929 ;; on 'global. This specifier stuff needs some rethinking.
924 (let* ((the-locale (cond ((null locale) 'global) 930 (let* ((the-locale (cond ((null locale) 'global)
925 ((valid-specifier-locale-p locale) locale) 931 ((valid-specifier-locale-p locale) locale)
926 (t nil))) 932 (t nil)))
927 (specs (and the-locale (face-font face the-locale nil t))) 933 (spec-list
928 (change-it (and specs (cdr (assoc specs standard-face-mapping))))) 934 (and
935 the-locale
936 (specifier-spec-list (get (get-face face) 'font) the-locale tags t)))
937 (change-it
938 (and
939 spec-list
940 (cdr (assoc (cdadar spec-list) standard-face-mapping)))))
929 (if (and change-it 941 (if (and change-it
930 (not (memq (face-name (find-face face)) 942 (not (memq (face-name (find-face face))
931 '(default bold italic bold-italic)))) 943 '(default bold italic bold-italic))))
932 (progn 944 (progn
933 (or (equal change-it t) 945 (or (equal change-it t)
934 (set-face-property face 'font change-it the-locale)) 946 (set-face-property face 'font change-it the-locale tags))
935 (funcall tty-thunk)) 947 (funcall tty-thunk))
936 (let* ((domain (cond ((null the-locale) nil) 948 (let* ((domain (cond ((null the-locale) nil)
937 ((valid-specifier-domain-p the-locale) the-locale) 949 ((valid-specifier-domain-p the-locale) the-locale)
938 ;; OK, this next one is truly a kludge, but 950 ;; OK, this next one is truly a kludge, but
939 ;; it results in more intuitive behavior most 951 ;; it results in more intuitive behavior most
940 ;; of the time. (really!) 952 ;; of the time. (really!)
941 ((or (eq the-locale 'global) (eq the-locale 'all)) 953 ((or (eq the-locale 'global) (eq the-locale 'all))
942 (selected-device)) 954 (selected-device))
943 (t nil))) 955 (t nil)))
944 (inst (and domain (face-property-instance face 'font domain)))) 956 (inst (and domain (face-property-instance face 'font domain))))
945 (funcall tty-thunk)
946 (funcall ws-thunk)
947 ;; If it's reasonable to do the inherit-from-standard-face trick, 957 ;; If it's reasonable to do the inherit-from-standard-face trick,
948 ;; and it's called for, then do it now. 958 ;; and it's called for, then do it now.
949 (or (null domain) 959 (if (and
950 (not (equal inst (face-property-instance face 'font domain))) 960 face-frob-from-locale-first
951 ;; don't do it for standard faces, or you'll get inheritance loops. 961 (eq the-locale 'global)
952 ;; #### This makes XEmacs seg fault! fix this bug. 962 domain
953 (memq (face-name (find-face face)) 963 (equal inst (face-property-instance face 'font domain))
954 '(default bold italic bold-italic)) 964 ;; don't do it for standard faces, or you'll get inheritance loops.
955 (not (equal (face-property-instance face 'font domain) 965 ;; #### This makes XEmacs seg fault! fix this bug.
956 (face-property-instance unfrobbed-face 'font domain))) 966 (not (memq (face-name (find-face face))
967 '(default bold italic bold-italic)))
968 (equal (face-property-instance face 'font domain)
969 (face-property-instance unfrobbed-face 'font domain)))
957 (set-face-property face 'font (vector frobbed-face) 970 (set-face-property face 'font (vector frobbed-face)
958 the-locale tags)))))) 971 the-locale tags)
972 ;; and only otherwise try to build new property value artificially
973 (funcall tty-thunk)
974 (funcall ws-thunk)
975 (and
976 domain
977 (equal inst (face-property-instance face 'font domain))
978 ;; don't do it for standard faces, or you'll get inheritance loops.
979 ;; #### This makes XEmacs seg fault! fix this bug.
980 (not (memq (face-name (find-face face))
981 '(default bold italic bold-italic)))
982 (equal (face-property-instance face 'font domain)
983 (face-property-instance unfrobbed-face 'font domain))
984 (set-face-property face 'font (vector frobbed-face) the-locale tags)))))))
959 985
960 (defun make-face-bold (face &optional locale tags) 986 (defun make-face-bold (face &optional locale tags)
961 "Make FACE bold in LOCALE, if possible. 987 "Make FACE bold in LOCALE, if possible.
962 This will attempt to make the font bold for X/MSW locales and will set the 988 This will attempt to make the font bold for X/MSW locales and will set the
963 highlight flag for TTY locales. 989 highlight flag for TTY locales.