Mercurial > hg > xemacs-beta

comparison lisp/faces.el @ 5118:e0db3c197671 ben-lisp-object

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
merge up to latest default branch, doesn't compile yet
author Ben Wing <ben@xemacs.org>
date Sat, 26 Dec 2009 21:18:49 -0600
parents e29fcfd8df5f
children 5502045ec510
comparison
equal deleted inserted replaced
5117:3742ea8250b5 5118:e0db3c197671
47 ;;; Code: 47 ;;; Code:
48 48
49 ;; To elude the warnings for font functions. (Normally autoloaded when 49 ;; To elude the warnings for font functions. (Normally autoloaded when
50 ;; font-create-object is called) 50 ;; font-create-object is called)
51 (eval-when-compile 51 (eval-when-compile
52 (require 'font)) 52 (require 'font)
53 (load "cl-macs"))
53 54
54 (defgroup faces nil 55 (defgroup faces nil
55 "Support for multiple text attributes (fonts, colors, ...) 56 "Support for multiple text attributes (fonts, colors, ...)
56 Such a collection of attributes is called a \"face\"." 57 Such a collection of attributes is called a \"face\"."
57 :group 'emacs) 58 :group 'emacs)
247 See also `specifier-matching-instance' for a fuller description of the 248 See also `specifier-matching-instance' for a fuller description of the
248 matching process." 249 matching process."
249 250
250 (setq face (get-face face)) 251 (setq face (get-face face))
251 (let ((value (get face property))) 252 (let ((value (get face property)))
252 (if (specifierp value) 253 (when (specifierp value)
253 (setq value (if (or (charsetp matchspec) 254 (setq value (specifier-matching-instance value matchspec domain
254 (and (symbolp matchspec) 255 default no-fallback)))
255 (find-charset matchspec)))
256 (or
257 (specifier-matching-instance
258 value (cons matchspec nil) domain default
259 no-fallback)
260 (specifier-matching-instance
261 value (cons matchspec t) domain default
262 no-fallback))
263 (specifier-matching-instance value matchspec domain
264 default no-fallback))))
265 value)) 256 value))
266 257
267 (defun set-face-property (face property value &optional locale tag-set 258 (defun set-face-property (face property value &optional locale tag-set
268 how-to-add) 259 how-to-add)
269 "Change a property of FACE. 260 "Change a property of FACE.
405 WARNING: Be absolutely sure you want to do this!!! It is a dangerous 396 WARNING: Be absolutely sure you want to do this!!! It is a dangerous
406 operation and is not undoable. 397 operation and is not undoable.
407 398
408 The arguments LOCALE, TAG-SET and EXACT-P are the same as for 399 The arguments LOCALE, TAG-SET and EXACT-P are the same as for
409 `remove-specifier'." 400 `remove-specifier'."
410 (mapc (lambda (x) 401 ;; Don't reset the default face.
411 (remove-specifier (face-property face x) locale tag-set exact-p)) 402 (unless (eq 'default face)
412 built-in-face-specifiers) 403 (dolist (x built-in-face-specifiers nil)
413 nil) 404 (remove-specifier (face-property face x) locale tag-set exact-p))))
414 405
415 (defun set-face-parent (face parent &optional locale tag-set how-to-add) 406 (defun set-face-parent (face parent &optional locale tag-set how-to-add)
416 "Set the parent of FACE to PARENT, for all properties. 407 "Set the parent of FACE to PARENT, for all properties.
417 This makes all properties of FACE inherit from PARENT." 408 This makes all properties of FACE inherit from PARENT."
418 (setq parent (get-face parent)) 409 (setq parent (get-face parent))
419 (mapcar (lambda (x) 410 (mapc (lambda (x)
420 (set-face-property face x (vector parent) locale tag-set 411 (set-face-property face x (vector parent) locale tag-set
421 how-to-add)) 412 how-to-add))
422 (set-difference built-in-face-specifiers 413 (set-difference built-in-face-specifiers
423 '(display-table background-pixmap inherit))) 414 '(display-table background-pixmap inherit)))
424 (set-face-background-pixmap face (vector 'inherit ':face parent) 415 (set-face-background-pixmap face (vector 'inherit ':face parent)
425 locale tag-set how-to-add) 416 locale tag-set how-to-add)
426 nil) 417 nil)
427 418
428 (defun face-doc-string (face) 419 (defun face-doc-string (face)
470 461
471 Normally DOMAIN will be a window or nil (meaning the selected window), 462 Normally DOMAIN will be a window or nil (meaning the selected window),
472 and an instance object describing how the font appears in that 463 and an instance object describing how the font appears in that
473 particular window and buffer will be returned. 464 particular window and buffer will be returned.
474 465
466 CHARSET is a Mule charset (meaning return the font used for that charset) or
467 nil (meaning return the font used for ASCII.)
468
475 See `face-property-instance' for more information." 469 See `face-property-instance' for more information."
476 (if charset 470 (if (null charset)
477 (face-property-matching-instance face 'font charset domain) 471 (face-property-instance face 'font domain)
478 (face-property-instance face 'font domain))) 472 (let (matchspec)
473 ;; get-charset signals an error if its argument doesn't have an
474 ;; associated charset.
475 (setq charset (if-fboundp #'get-charset
476 (get-charset charset)
477 (error 'unimplemented "Charset support not available"))
478 matchspec (cons charset nil))
479 (or (null (setcdr matchspec 'initial))
480 (face-property-matching-instance
481 face 'font matchspec domain)
482 (null (setcdr matchspec 'final))
483 (face-property-matching-instance
484 face 'font matchspec domain)))))
479 485
480 (defun set-face-font (face font &optional locale tag-set how-to-add) 486 (defun set-face-font (face font &optional locale tag-set how-to-add)
481 "Change the font of FACE to FONT in LOCALE. 487 "Change the font of FACE to FONT in LOCALE.
482 488
483 FACE may be either a face object or a symbol representing a face. 489 FACE may be either a face object or a symbol representing a face.
484 490
485 FONT should be an instantiator (see `make-font-specifier'), a list of 491 FONT should be an instantiator (see `make-font-specifier'; a common
486 instantiators, an alist of specifications (each mapping a 492 instantiator is a platform-dependent string naming the font), a list
487 locale to an instantiator list), or a font specifier object. 493 of instantiators, an alist of specifications (each mapping a locale
488 494 to an instantiator list), or a font specifier object.
489 If FONT is an alist, LOCALE must be omitted. If FONT is a 495
490 specifier object, LOCALE can be a locale, a locale type, `all', 496 If FONT is an alist, LOCALE must be omitted. If FONT is a specifier
491 or nil; see `copy-specifier' for its semantics. Otherwise LOCALE 497 object, LOCALE can be a locale, a locale type, `all', or nil; see
492 specifies the locale under which the specified instantiator(s) 498 `copy-specifier' for its semantics. Common LOCALEs are buffer
493 will be added, and defaults to `global'. 499 objects, window objects, device objects and `global'. Otherwise
500 LOCALE specifies the locale under which the specified
501 instantiator(s) will be added, and defaults to `global'.
494 502
495 See `set-face-property' for more information." 503 See `set-face-property' for more information."
496 (interactive (face-interactive "font")) 504 (interactive (face-interactive "font"))
497 (set-face-property face 'font font locale tag-set how-to-add)) 505 (set-face-property face 'font font locale tag-set how-to-add))
498 506
696 This function is a simplified version of `set-face-background-pixmap', 704 This function is a simplified version of `set-face-background-pixmap',
697 designed for interactive use." 705 designed for interactive use."
698 (interactive 706 (interactive
699 (let* ((face (read-face-name "Set background pixmap of face: ")) 707 (let* ((face (read-face-name "Set background pixmap of face: "))
700 (default (and (face-background-pixmap-instance face) 708 (default (and (face-background-pixmap-instance face)
701 ((image-instance-file-name 709 (image-instance-file-name
702 (face-background-pixmap-instance face))))) 710 (face-background-pixmap-instance face))))
703 (file (read-file-name 711 (file (read-file-name
704 (format "Set background pixmap of face %s to: " 712 (format "Set background pixmap of face %s to: "
705 (symbol-name face)) 713 (symbol-name face))
706 nil default t nil 714 nil default t nil
707 'background-pixmap-file-history))) 715 'background-pixmap-file-history)))
923 frob-mapping standard-face-mapping) 931 frob-mapping standard-face-mapping)
924 ;; implement the semantics of `make-face-bold' et al. FACE, LOCALE, TAG-SET 932 ;; implement the semantics of `make-face-bold' et al. FACE, LOCALE, TAG-SET
925 ;; and EXACT-P are as in that call. UNFROBBED-FACE and FROBBED-FACE are 933 ;; and EXACT-P are as in that call. UNFROBBED-FACE and FROBBED-FACE are
926 ;; what we expect the original face and the result to look like, 934 ;; what we expect the original face and the result to look like,
927 ;; respectively. TTY-PROPS is a list of face properties to frob in place 935 ;; respectively. TTY-PROPS is a list of face properties to frob in place
928 ;; of `font' for TTY's. FROB-MAPPING is either a plist mapping device 936 ;; of `font' for TTYs. FROB-MAPPING is either a plist mapping device
929 ;; types to functions of two args (NAME DEVICE) that will frob the 937 ;; types to functions of two args (NAME DEVICE) that will frob the
930 ;; instantiator as appropriate for the device type (this includes TTY's), 938 ;; instantiator to NAME as appropriate for DEVICE's type (this includes
931 ;; or a function to handle the mapping for all device types. 939 ;; TTYs #### TTYs are not passed the device, just the symbol 'tty), or a
940 ;; function to handle the mapping for all device types.
932 ;; STANDARD-FACE-MAPPING is an alist of mappings of inheritance 941 ;; STANDARD-FACE-MAPPING is an alist of mappings of inheritance
933 ;; instantiators to be replaced with other inheritance instantiators, meant 942 ;; instantiators to be replaced with other inheritance instantiators, meant
934 ;; for e.g. converting [bold] into [bold-italic]. 943 ;; for e.g. converting [bold] into [bold-italic].
935 944
936 ;; #### it would be nice if this function could be generalized to be 945 ;; #### it would be nice if this function could be generalized to be
987 (loop for (tag-set . x) in inst-list 996 (loop for (tag-set . x) in inst-list
988 for devtype = (derive-device-type-from-locale-and-tag-set 997 for devtype = (derive-device-type-from-locale-and-tag-set
989 locale tag-set devtype-spec ffpdev) 998 locale tag-set devtype-spec ffpdev)
990 ;; devtype may be nil if it fails to match DEVTYPE-SPEC 999 ;; devtype may be nil if it fails to match DEVTYPE-SPEC
991 if devtype 1000 if devtype
992 if (let* ((mapper (if (functionp frob-mapping) frob-mapping 1001 if (let* ((mapper
993 (plist-get frob-mapping devtype))) 1002 (cond ((functionp frob-mapping) frob-mapping)
1003 ((plist-get frob-mapping devtype))
1004 (t (error 'unimplemented "mapper" devtype))))
994 (result 1005 (result
995 (cond 1006 (cond
996 ;; if a vector ... 1007 ;; if a vector ...
997 ((vectorp x) 1008 ((vectorp x)
998 (let ((change-to 1009 (let ((change-to
1026 tag-set)))))) 1037 tag-set))))))
1027 ;; (3) not a vector. just process it. 1038 ;; (3) not a vector. just process it.
1028 (t 1039 (t
1029 (let ((value 1040 (let ((value
1030 (if (eq devtype-spec 'tty) 1041 (if (eq devtype-spec 'tty)
1031 (funcall mapper x) 1042 ;; #### not quite right but need
1043 ;; two args to match documentation
1044 ;; mostly we just ignore TTYs so
1045 ;; for now just pass the devtype
1046 (funcall mapper x 'tty)
1032 (funcall mapper x 1047 (funcall mapper x
1033 (derive-domain-from-locale 1048 (derive-domain-from-locale
1034 locale devtype-spec 1049 locale devtype-spec
1035 ffpdev))))) 1050 ffpdev)))))
1036 (and (nil-instantiator-ok value devtype-spec) 1051 (and (nil-instantiator-ok value devtype-spec)
1181 (interactive (list (read-face-name "Set family of which face: ") 1196 (interactive (list (read-face-name "Set family of which face: ")
1182 (read-string "Family to set: "))) 1197 (read-string "Family to set: ")))
1183 1198
1184 (Face-frob-property face locale tags exact-p 1199 (Face-frob-property face locale tags exact-p
1185 nil nil 'font nil 1200 nil nil 'font nil
1201 ;; #### this code is duplicated in make-face-size
1186 `(lambda (f d) 1202 `(lambda (f d)
1187 ;; keep the dependency on font.el for now 1203 ;; keep the dependency on font.el for now
1188 (let ((fo (font-create-object f d))) 1204 ;; #### The filter on null d is a band-aid.
1189 (set-font-family fo ,family) 1205 ;; Frob-face-property should not be passing in
1190 (font-create-name fo d))) 1206 ;; null devices.
1207 (unless (or (null d) (eq d 'tty))
1208 (let ((fo (font-create-object f d)))
1209 (set-font-family fo ,family)
1210 (font-create-name fo d))))
1191 nil)) 1211 nil))
1192 1212
1193 ;; Style (ie, typographical face) frobbing 1213 ;; Style (ie, typographical face) frobbing
1194 (defun make-face-bold (face &optional locale tags exact-p) 1214 (defun make-face-bold (face &optional locale tags exact-p)
1195 "Make FACE bold in LOCALE, if possible. 1215 "Make FACE bold in LOCALE, if possible.
1299 make-face-unitalic italic default underline nil 1319 make-face-unitalic italic default underline nil
1300 " 1320 "
1301 (interactive (list (read-face-name "Make which face bold: "))) 1321 (interactive (list (read-face-name "Make which face bold: ")))
1302 (Face-frob-property face locale tags exact-p 1322 (Face-frob-property face locale tags exact-p
1303 'default 'bold 'font '(highlight) 1323 'default 'bold 'font '(highlight)
1304 '(tty (lambda (x) t) 1324 '(tty (lambda (f d) t)
1305 x x-make-font-bold 1325 x x-make-font-bold
1306 gtk gtk-make-font-bold 1326 gtk gtk-make-font-bold
1307 mswindows mswindows-make-font-bold 1327 mswindows mswindows-make-font-bold
1308 msprinter mswindows-make-font-bold) 1328 msprinter mswindows-make-font-bold)
1309 '(([default] . [bold]) 1329 '(([default] . [bold])
1318 the semantics of the LOCALE argument and for more specifics on exactly 1338 the semantics of the LOCALE argument and for more specifics on exactly
1319 how this function works." 1339 how this function works."
1320 (interactive (list (read-face-name "Make which face italic: "))) 1340 (interactive (list (read-face-name "Make which face italic: ")))
1321 (Face-frob-property face locale tags exact-p 1341 (Face-frob-property face locale tags exact-p
1322 'default 'italic 'font '(underline) 1342 'default 'italic 'font '(underline)
1323 '(tty (lambda (x) t) 1343 '(tty (lambda (f d) t)
1324 x x-make-font-italic 1344 x x-make-font-italic
1325 gtk gtk-make-font-italic 1345 gtk gtk-make-font-italic
1326 mswindows mswindows-make-font-italic 1346 mswindows mswindows-make-font-italic
1327 msprinter mswindows-make-font-italic) 1347 msprinter mswindows-make-font-italic)
1328 '(([default] . [italic]) 1348 '(([default] . [italic])
1337 locales. See `make-face-bold' for the semantics of the LOCALE 1357 locales. See `make-face-bold' for the semantics of the LOCALE
1338 argument and for more specifics on exactly how this function works." 1358 argument and for more specifics on exactly how this function works."
1339 (interactive (list (read-face-name "Make which face bold-italic: "))) 1359 (interactive (list (read-face-name "Make which face bold-italic: ")))
1340 (Face-frob-property face locale tags exact-p 1360 (Face-frob-property face locale tags exact-p
1341 'default 'bold-italic 'font '(underline highlight) 1361 'default 'bold-italic 'font '(underline highlight)
1342 '(tty (lambda (x) t) 1362 '(tty (lambda (f d) t)
1343 x x-make-font-bold-italic 1363 x x-make-font-bold-italic
1344 gtk gtk-make-font-bold-italic 1364 gtk gtk-make-font-bold-italic
1345 mswindows mswindows-make-font-bold-italic 1365 mswindows mswindows-make-font-bold-italic
1346 msprinter mswindows-make-font-bold-italic) 1366 msprinter mswindows-make-font-bold-italic)
1347 '(([default] . [italic]) 1367 '(([default] . [italic])
1357 `make-face-bold' for the semantics of the LOCALE argument and for more 1377 `make-face-bold' for the semantics of the LOCALE argument and for more
1358 specifics on exactly how this function works." 1378 specifics on exactly how this function works."
1359 (interactive (list (read-face-name "Make which face non-bold: "))) 1379 (interactive (list (read-face-name "Make which face non-bold: ")))
1360 (Face-frob-property face locale tags exact-p 1380 (Face-frob-property face locale tags exact-p
1361 'bold 'default 'font '(highlight) 1381 'bold 'default 'font '(highlight)
1362 '(tty (lambda (x) nil) 1382 '(tty (lambda (f d) nil)
1363 x x-make-font-unbold 1383 x x-make-font-unbold
1364 gtk gtk-make-font-unbold 1384 gtk gtk-make-font-unbold
1365 mswindows mswindows-make-font-unbold 1385 mswindows mswindows-make-font-unbold
1366 msprinter mswindows-make-font-unbold) 1386 msprinter mswindows-make-font-unbold)
1367 '(([default] . t) 1387 '(([default] . t)
1376 `make-face-bold' for the semantics of the LOCALE argument and for more 1396 `make-face-bold' for the semantics of the LOCALE argument and for more
1377 specifics on exactly how this function works." 1397 specifics on exactly how this function works."
1378 (interactive (list (read-face-name "Make which face non-italic: "))) 1398 (interactive (list (read-face-name "Make which face non-italic: ")))
1379 (Face-frob-property face locale tags exact-p 1399 (Face-frob-property face locale tags exact-p
1380 'italic 'default 'font '(underline) 1400 'italic 'default 'font '(underline)
1381 '(tty (lambda (x) nil) 1401 '(tty (lambda (f d) nil)
1382 x x-make-font-unitalic 1402 x x-make-font-unitalic
1383 gtk gtk-make-font-unitalic 1403 gtk gtk-make-font-unitalic
1384 mswindows mswindows-make-font-unitalic 1404 mswindows mswindows-make-font-unitalic
1385 msprinter mswindows-make-font-unitalic) 1405 msprinter mswindows-make-font-unitalic)
1386 '(([default] . t) 1406 '(([default] . t)
1396 "Adjust FACE to SIZE in LOCALE, if possible." 1416 "Adjust FACE to SIZE in LOCALE, if possible."
1397 (interactive (list (read-face-name "Set size of which face: ") 1417 (interactive (list (read-face-name "Set size of which face: ")
1398 (read-number "Size to set: " t 10))) 1418 (read-number "Size to set: " t 10)))
1399 (Face-frob-property face locale tags exact-p 1419 (Face-frob-property face locale tags exact-p
1400 nil nil 'font nil 1420 nil nil 'font nil
1421 ;; #### this code is duplicated in make-face-family
1401 `(lambda (f d) 1422 `(lambda (f d)
1402 ;; keep the dependency on font.el for now 1423 ;; keep the dependency on font.el for now
1403 (let ((fo (font-create-object f d))) 1424 ;; #### The filter on null d is a band-aid.
1404 (set-font-size fo ,size) 1425 ;; Frob-face-property should not be passing in
1405 (font-create-name fo d))) 1426 ;; null devices.
1427 (unless (or (null d) (eq d 'tty))
1428 (let ((fo (font-create-object f d)))
1429 (set-font-size fo ,size)
1430 (font-create-name fo d))))
1406 nil)) 1431 nil))
1407 1432
1408 ;; Why do the following two functions lose so badly in so many 1433 ;; Why do the following two functions lose so badly in so many
1409 ;; circumstances? 1434 ;; circumstances?
1410 1435
1908 (when (and (not (eq 'tty (device-type device))) 1933 (when (and (not (eq 'tty (device-type device)))
1909 (not (face-foreground 'text-cursor 'global)) 1934 (not (face-foreground 'text-cursor 'global))
1910 (face-property-equal 'text-cursor 'default 'foreground device)) 1935 (face-property-equal 'text-cursor 'default 'foreground device))
1911 (set-face-foreground 'text-cursor [default background] 'global 1936 (set-face-foreground 'text-cursor [default background] 'global
1912 nil 'append)) 1937 nil 'append))
1913 ) 1938
1939 ;; The faces buffers-tab, modeline-mousable and modeline-buffer-id all
1940 ;; inherit directly from modeline; they require that modeline's details be
1941 ;; specified, that it not use fallbacks, otherwise *they* use the general
1942 ;; fallback of the default face instead, which clashes with the gui
1943 ;; element faces. So take the modeline face information from its
1944 ;; fallbacks, themselves ultimately set up in faces.c:
1945 (loop
1946 for face-property in '(foreground background background-pixmap)
1947 do (when (and (setq face-property (face-property 'modeline face-property))
1948 (null (specifier-instance face-property device nil t))
1949 (specifier-instance face-property device))
1950 (set-specifier face-property
1951 (or (specifier-specs (specifier-fallback
1952 face-property))
1953 ;; This will error at startup if the
1954 ;; corresponding C fallback doesn't exist,
1955 ;; which is well and good.
1956 (specifier-fallback (specifier-fallback
1957 face-property))))))
1958 nil)
1914 1959
1915 ;; New function with 20.1, suggested by Per Abrahamsen, coded by Kyle 1960 ;; New function with 20.1, suggested by Per Abrahamsen, coded by Kyle
1916 ;; Jones and Hrvoje Niksic. 1961 ;; Jones and Hrvoje Niksic.
1917 (defun set-face-stipple (face pixmap &optional frame) 1962 (defun set-face-stipple (face pixmap &optional frame)
1918 "Change the stipple pixmap of FACE to PIXMAP. 1963 "Change the stipple pixmap of FACE to PIXMAP.
2049 (set-face-foreground 'isearch-secondary 2094 (set-face-foreground 'isearch-secondary
2050 '(((win default color) . "red3")) 2095 '(((win default color) . "red3"))
2051 'global) 2096 'global)
2052 2097
2053 ;; Define some logical color names to be used when reading the pixmap files. 2098 ;; Define some logical color names to be used when reading the pixmap files.
2054 (if (featurep 'xpm) 2099 (and-boundp
2055 (setq xpm-color-symbols 2100 'xpm-color-symbols
2056 (list 2101 (featurep 'xpm)
2057 '("foreground" (face-foreground 'default)) 2102 (setq xpm-color-symbols
2058 '("background" (face-background 'default)) 2103 (list
2059 '("backgroundToolBarColor" 2104 '("foreground" (face-foreground 'default))
2060 (or 2105 '("background" (face-background 'default))
2061 (and 2106 `("backgroundToolBarColor"
2062 (featurep 'x) 2107 ,(if (featurep 'x)
2063 (x-get-resource "backgroundToolBarColor" 2108 '(or (x-get-resource "backgroundToolBarColor"
2064 "BackgroundToolBarColor" 'string 2109 "BackgroundToolBarColor" 'string
2065 nil nil 'warn)) 2110 nil nil 'warn)
2066 2111 (face-background 'toolbar))
2067 (face-background 'toolbar))) 2112 '(face-background 'toolbar)))
2068 '("foregroundToolBarColor" 2113 `("foregroundToolBarColor"
2069 (or 2114 ,(if (featurep 'x)
2070 (and 2115 '(or (x-get-resource "foregroundToolBarColor"
2071 (featurep 'x) 2116 "ForegroundToolBarColor" 'string
2072 (x-get-resource "foregroundToolBarColor" 2117 nil nil 'warn)
2073 "ForegroundToolBarColor" 'string 2118 (face-foreground 'toolbar))
2074 nil nil 'warn)) 2119 '(face-foreground 'toolbar))))))
2075 (face-foreground 'toolbar)))
2076 )))
2077 2120
2078 (when (featurep 'tty) 2121 (when (featurep 'tty)
2079 (set-face-highlight-p 'bold t 'global '(default tty)) 2122 (set-face-highlight-p 'bold t 'global '(default tty))
2080 (set-face-underline-p 'italic t 'global '(default tty)) 2123 (set-face-underline-p 'italic t 'global '(default tty))
2081 (set-face-highlight-p 'bold-italic t 'global '(default tty)) 2124 (set-face-highlight-p 'bold-italic t 'global '(default tty))