Mercurial > hg > xemacs-beta

comparison lisp/faces.el @ 707:a307f9a2021d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2001-12-20 05:49:28 by andyp] sync with 21-4-6-windows
author andyp
date Thu, 20 Dec 2001 05:49:48 +0000
parents 7039e6323819
children 5be46355cc42
comparison
equal deleted inserted replaced
706:c9bf82d465b5 707:a307f9a2021d
845 ;; happen if that locale has no instantiators. So signal 845 ;; happen if that locale has no instantiators. So signal
846 ;; an error to indicate this. 846 ;; an error to indicate this.
847 847
848 848
849 (setq temp-sp (copy-specifier sp)) 849 (setq temp-sp (copy-specifier sp))
850 (if (and (or (eq locale 'global) (eq locale 'all) (not locale)) 850 (if (or (eq locale 'global) (eq locale 'all) (not locale))
851 (not (face-property face property 'global))) 851 (when (not (specifier-specs temp-sp 'global))
852 (copy-specifier (face-property 'default property) 852 ;; Try fallback via the official ways and then do it "by hand"
853 temp-sp 'global)) 853 (let* ((fallback (specifier-fallback sp))
854 (fallback-sp
855 (cond ((specifierp fallback) fallback)
856 ;; just an inst list
857 (fallback
858 (make-specifier-and-init (specifier-type sp)
859 fallback))
860 ((eq (get-face face) (get-face 'default))
861 (error "Unable to find global specification"))
862 ;; If no fallback we snoop from default
863 (t (face-property 'default property)))))
864 (copy-specifier fallback-sp temp-sp 'global))))
854 (if (and (valid-specifier-locale-p locale) 865 (if (and (valid-specifier-locale-p locale)
855 (not (specifier-specs temp-sp locale))) 866 (not (specifier-specs temp-sp locale)))
856 (error "Property must have a specification in locale %S" locale)) 867 (error "Property must have a specification in locale %S" locale))
857 (map-specifier 868 (map-specifier
858 temp-sp 869 temp-sp
984 '(default bold italic bold-italic))) 995 '(default bold italic bold-italic)))
985 (equal (face-property-instance face 'font domain) 996 (equal (face-property-instance face 'font domain)
986 (face-property-instance unfrobbed-face 'font domain)) 997 (face-property-instance unfrobbed-face 'font domain))
987 (set-face-property face 'font (vector frobbed-face) the-locale tags))))))) 998 (set-face-property face 'font (vector frobbed-face) the-locale tags)))))))
988 999
1000 ;; WE DEMAND FOUNDRY FROBBING!
1001
1002 ;; Family frobbing
1003 ;; Thx Jan Vroonhof, Ref xemacs-beta <87oflypbum.fsf@petteflet.ntlworld.com>
1004 ;; Brainlessly derived from make-face-size by Stephen; don't blame Jan.
1005 ;; I'm long since flown to Rio, it does you little good to blame me, either.
1006 (defun make-face-family (face family &optional locale tags)
1007 "Set FACE's family to FAMILY in LOCALE, if possible.
1008
1009 Add/replace settings specified by TAGS only."
1010 (frob-face-property face 'font
1011 ;; uses dynamic scope of family
1012 #'(lambda (f d)
1013 ;; keep the dependency on font.el for now
1014 (let ((fo (font-create-object (font-instance-name f)
1015 d)))
1016 (set-font-family fo family)
1017 (font-create-name fo d)))
1018 nil locale tags))
1019
1020 ;; Style (ie, typographical face) frobbing
989 (defun make-face-bold (face &optional locale tags) 1021 (defun make-face-bold (face &optional locale tags)
990 "Make FACE bold in LOCALE, if possible. 1022 "Make FACE bold in LOCALE, if possible.
991 This will attempt to make the font bold for X/MSW locales and will set the 1023 This will attempt to make the font bold for X/MSW locales and will set the
992 highlight flag for TTY locales. 1024 highlight flag for TTY locales.
993 1025
1167 ([bold] . t) 1199 ([bold] . t)
1168 ([italic] . [default]) 1200 ([italic] . [default])
1169 ([bold-italic] . [bold])))) 1201 ([bold-italic] . [bold]))))
1170 1202
1171 1203
1204 ;; Size frobbing
1205 ;; Thx Jan Vroonhof, Ref xemacs-beta <87oflypbum.fsf@petteflet.ntlworld.com>
1206 ;; Jan had a separate helper function
1207 (defun make-face-size (face size &optional locale tags)
1208 "Adjust FACE to SIZE in LOCALE, if possible.
1209
1210 Add/replace settings specified by TAGS only."
1211 (frob-face-property face 'font
1212 ;; uses dynamic scope of size
1213 #'(lambda (f d)
1214 ;; keep the dependency on font.el for now
1215 (let ((fo (font-create-object (font-instance-name f)
1216 d)))
1217 (set-font-size fo size)
1218 (font-create-name fo d)))
1219 nil locale tags))
1220
1172 ;; Why do the following two functions lose so badly in so many 1221 ;; Why do the following two functions lose so badly in so many
1173 ;; circumstances? 1222 ;; circumstances?
1174 1223
1175 (defun make-face-smaller (face &optional locale) 1224 (defun make-face-smaller (face &optional locale)
1176 "Make the font of FACE be smaller, if possible. 1225 "Make the font of FACE be smaller, if possible.
1577 ; "Whether to suppress complaints about incomplete sets of fonts.") 1626 ; "Whether to suppress complaints about incomplete sets of fonts.")
1578 1627
1579 (defun face-complain-about-font (face device) 1628 (defun face-complain-about-font (face device)
1580 (if (symbolp face) (setq face (symbol-name face))) 1629 (if (symbolp face) (setq face (symbol-name face)))
1581 ;; (if (not inhibit-font-complaints) 1630 ;; (if (not inhibit-font-complaints)
1582 (display-warning 1631 ;; complaining for printers is generally annoying.
1583 'font 1632 (unless (device-printer-p device)
1584 (let ((default-name (face-font-name 'default device))) 1633 (display-warning
1585 (format "%s: couldn't deduce %s %s version of the font 1634 'font
1635 (let ((default-name (face-font-name 'default device)))
1636 (format "%s: couldn't deduce %s %s version of the font
1586 %S. 1637 %S.
1587 1638
1588 Please specify X resources to make the %s face 1639 Please specify X resources to make the %s face
1589 visually distinguishable from the default face. 1640 visually distinguishable from the default face.
1590 For example, you could add one of the following to $HOME/Emacs: 1641 For example, you could add one of the following to $HOME/Emacs:
1591 1642
1592 Emacs.%s.attributeFont: -dt-*-medium-i-* 1643 Emacs.%s.attributeFont: -dt-*-medium-i-*
1593 or 1644 or
1594 Emacs.%s.attributeForeground: hotpink\n" 1645 Emacs.%s.attributeForeground: hotpink\n"
1595 invocation-name 1646 invocation-name
1596 (if (string-match "\\`[aeiouAEIOU]" face) "an" "a") 1647 (if (string-match "\\`[aeiouAEIOU]" face) "an" "a")
1597 face 1648 face
1598 default-name 1649 default-name
1599 face 1650 face
1600 face 1651 face
1601 face 1652 face
1602 )))) 1653 )))))
1603 1654
1604 1655
1605 ;; #### This is quite a mess. We should use the custom mechanism for 1656 ;; #### This is quite a mess. We should use the custom mechanism for
1606 ;; most of this stuff. Currently we don't do it, because Custom 1657 ;; most of this stuff. Currently we don't do it, because Custom
1607 ;; doesn't use specifiers (yet.) FSF does it the Right Way. 1658 ;; doesn't use specifiers (yet.) FSF does it the Right Way.