Mercurial > hg > xemacs-beta
annotate lisp/faces.el @ 5576:071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
lisp/ChangeLog addition:
2011-10-03 Aidan Kehoe <kehoea@parhasard.net>
* simple.el (handle-pre-motion-command-current-command-is-motion):
Implement #'keysyms-equal with #'labels + (declare (inline ...)),
instead of abusing macrolet to the same end.
* specifier.el (let-specifier):
* mule/mule-cmds.el (describe-language-environment):
* mule/mule-cmds.el (set-language-environment-coding-systems):
* mule/mule-x-init.el (x-use-halfwidth-roman-font):
* faces.el (Face-frob-property):
* keymap.el (key-sequence-list-description):
* lisp-mode.el (construct-lisp-mode-menu):
* loadhist.el (unload-feature):
* mouse.el (default-mouse-track-check-for-activation):
Declare various labels inline in dumped files when that reduces
the size of the dumped image. Declaring labels inline is normally
only worthwhile for inner loops and so on, but it's reasonable
exercise of the related code to have these changes in core.
tests/ChangeLog addition:
2011-10-03 Aidan Kehoe <kehoea@parhasard.net>
* automated/case-tests.el (uni-mappings):
* automated/database-tests.el (delete-database-files):
* automated/hash-table-tests.el (iterations):
* automated/lisp-tests.el (test1):
* automated/lisp-tests.el (a):
* automated/lisp-tests.el (cl-floor):
* automated/lisp-tests.el (foo):
* automated/lisp-tests.el (list-nreverse):
* automated/lisp-tests.el (needs-lexical-context):
* automated/mule-tests.el (featurep):
* automated/os-tests.el (original-string):
* automated/os-tests.el (with):
* automated/symbol-tests.el (check-weak-list-unique):
Replace #'flet with #'labels where appropriate in these tests,
following my own advice on style in the docstrings of those
functions.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Mon, 03 Oct 2011 20:16:14 +0100 |
| parents | 3bc58dc9d688 |
| children | 79a1a759ec3d |
| rev | line source |
|---|---|
| 428 | 1 ;;; faces.el --- Lisp interface to the C "face" structure |
| 2 | |
| 3 ;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc. | |
| 4 ;; Copyright (C) 1995 Board of Trustees, University of Illinois | |
| 3027 | 5 ;; Copyright (C) 1995, 1996, 2002, 2005 Ben Wing |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
6 ;; Copyright (C) 2010 Didier Verna |
| 428 | 7 |
| 8 ;; Author: Ben Wing <ben@xemacs.org> | |
| 9 ;; Keywords: faces, internal, dumped | |
| 10 | |
| 11 ;; This file is part of XEmacs. | |
| 12 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5080
diff
changeset
|
13 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5080
diff
changeset
|
14 ;; under the terms of the GNU General Public License as published by the |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5080
diff
changeset
|
15 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5080
diff
changeset
|
16 ;; option) any later version. |
| 428 | 17 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5080
diff
changeset
|
18 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5080
diff
changeset
|
19 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5080
diff
changeset
|
20 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5080
diff
changeset
|
21 ;; for more details. |
| 428 | 22 |
| 23 ;; You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5080
diff
changeset
|
24 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 428 | 25 |
| 26 ;;; Synched up with: Not synched with FSF. Almost completely divergent. | |
| 27 | |
| 28 ;;; Commentary: | |
| 29 | |
| 30 ;; This file is dumped with XEmacs. | |
| 31 | |
| 32 ;; face implementation #1 (used Lisp vectors and parallel C vectors; | |
| 33 ;; FSFmacs still uses this) authored by Jamie Zawinski <jwz@jwz.org> | |
| 34 ;; pre Lucid-Emacs 19.0. | |
| 35 | |
| 36 ;; face implementation #2 (used one face object per frame per face) | |
| 37 ;; authored by Jamie Zawinski for 19.9. | |
| 38 | |
| 39 ;; face implementation #3 (use one face object per face) originally | |
| 40 ;; authored for 19.12 by Chuck Thompson <cthomp@cs.uiuc.edu>, | |
| 41 ;; rewritten by Ben Wing with the advent of specifiers. | |
| 42 | |
| 43 | |
| 44 ;;; Some stuff in FSF's faces.el is in our x-faces.el. | |
| 45 | |
| 46 ;;; Code: | |
| 47 | |
| 771 | 48 ;; To elude the warnings for font functions. (Normally autoloaded when |
| 49 ;; font-create-object is called) | |
|
5284
d27c1ee1943b
Make the order of preloaded-file-list more sane.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5080
diff
changeset
|
50 (eval-when-compile (require 'font)) |
| 771 | 51 |
| 428 | 52 (defgroup faces nil |
| 53 "Support for multiple text attributes (fonts, colors, ...) | |
| 54 Such a collection of attributes is called a \"face\"." | |
| 55 :group 'emacs) | |
| 56 | |
| 57 | |
| 58 (defun read-face-name (prompt) | |
| 59 (let (face) | |
|
5366
f00192e1cd49
Examining the result of #'length: `eql', not `=', it's better style & cheaper
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
60 (while (eql (length face) 0) ; nil or "" |
| 428 | 61 (setq face (completing-read prompt |
| 62 (mapcar (lambda (x) (list (symbol-name x))) | |
| 63 (face-list)) | |
| 64 nil t))) | |
| 65 (intern face))) | |
| 66 | |
| 67 (defun face-interactive (what &optional bool) | |
| 68 (let* ((fn (intern (concat "face-" what "-instance"))) | |
| 69 (face (read-face-name (format "Set %s of face: " what))) | |
| 70 (default (if (fboundp fn) | |
| 71 ;; #### we should distinguish here between | |
| 72 ;; explicitly setting the value to be the | |
| 73 ;; same as the default face's value, and | |
| 74 ;; not setting a value at all. | |
| 75 (funcall fn face))) | |
| 76 (value (if bool | |
| 77 (y-or-n-p (format "Should face %s be %s? " | |
| 78 (symbol-name face) bool)) | |
| 79 (read-string (format "Set %s of face %s to: " | |
| 80 what (symbol-name face)) | |
| 81 (cond ((font-instance-p default) | |
| 82 (font-instance-name default)) | |
| 83 ((color-instance-p default) | |
| 84 (color-instance-name default)) | |
| 85 ((image-instance-p default) | |
| 86 (image-instance-file-name default)) | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
87 ((face-background-placement-instance-p default) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
88 (symbol-name default)) |
| 428 | 89 (t default)))))) |
| 90 (list face (if (equal value "") nil value)))) | |
| 91 | |
| 92 (defconst built-in-face-specifiers | |
| 93 (built-in-face-specifiers) | |
| 94 "A list of the built-in face properties that are specifiers.") | |
| 95 | |
| 96 (defun face-property (face property &optional locale tag-set exact-p) | |
| 97 "Return FACE's value of the given PROPERTY. | |
| 98 | |
| 3027 | 99 NOTE: If you are looking for the \"value\" of a built-in face property |
| 100 (`foreground', `background', `font', `background-pixmap', etc.), you | |
| 101 are probably better off calling `face-property-instance'. The return | |
| 102 value of `face-property' for built-in properties describes the original | |
| 103 specification used to determine the face property, which may be nil, | |
| 104 a list of instantiators, or something else that is unexpected. For | |
| 105 example, if you ask for a face property in a particular buffer (by | |
| 106 specifying a buffer for LOCALE), you will get a non-nil return value | |
| 107 only if a buffer-local specification for that particular buffer had | |
| 108 previously been given. | |
| 109 | |
| 110 For a full list of built-in property names and their semantics, see | |
| 111 `set-face-property'. | |
| 428 | 112 |
| 3027 | 113 If LOCALE is omitted, the FACE's actual value for PROPERTY will be |
| 114 returned. In this case, this function appears to behave rather | |
| 115 differently depending on whether PROPERTY is a built-in face property of | |
| 116 a user-defined face property. This is because the most basic value of a | |
| 117 user-defined property is simply whatever was set using | |
| 118 `set-face-property', but for a built-in property it's always a specifier, | |
| 119 which is an abstract object encapsulating all the specifications for that | |
| 120 particular property. | |
| 121 | |
| 122 LOCALE, if supplied, will generally be a buffer, frame or | |
| 123 `global' (for the global value), but there are other possibilities -- see | |
| 124 the following paragraph. This mostly applies to built-in properties. In | |
| 125 this case, the return value will not be a specifier object but the | |
| 126 specification(s) for the given locale or locale type will be returned | |
| 127 (equivalent to calling `specifier-specs' on the specifier). | |
| 128 (Technically, the same thing happens if the basic value of a user- | |
| 129 defined property is a specifier, although this usage is rare.) | |
| 428 | 130 |
| 131 The return value will be a list of instantiators (e.g. strings | |
| 132 specifying a font or color name), or a list of specifications, each | |
| 133 of which is a cons of a locale and a list of instantiators. | |
| 134 Specifically, if LOCALE is a particular locale (a buffer, window, | |
| 3027 | 135 frame, device, or `global'), a list of instantiators for that locale |
| 428 | 136 will be returned. Otherwise, if LOCALE is a locale type (one of |
| 3027 | 137 the symbols `buffer', `window', `frame', or `device'), the specifications |
| 428 | 138 for all locales of that type will be returned. Finally, if LOCALE is |
| 3027 | 139 `all', the specifications for all locales of all types will be returned. |
| 428 | 140 |
| 141 The specifications in a specifier determine what the value of | |
| 142 PROPERTY will be in a particular \"domain\" or set of circumstances, | |
| 3027 | 143 which is typically a particular Emacs window -- which in turn defines |
| 144 a buffer (the buffer in the window), a frame (the frame that the window | |
| 145 is in), and a device (the device that the frame is in). The value is | |
| 442 | 146 derived from the instantiator associated with the most specific |
| 3027 | 147 locale (in the order buffer, window, frame, device, and `global') |
| 428 | 148 that matches the domain in question. In other words, given a domain |
| 442 | 149 (i.e. an Emacs window, usually), the specifier for PROPERTY will |
| 150 first be searched for a specification whose locale is the buffer | |
| 151 contained within that window; then for a specification whose locale | |
| 152 is the window itself; then for a specification whose locale is the | |
| 153 frame that the window is contained within; etc. The first | |
| 154 instantiator that is valid for the domain (usually this means that | |
| 155 the instantiator is recognized by the device [i.e. MS Windows, the X | |
| 3027 | 156 server or TTY device]) will be \"instantiated\", which generates |
| 157 a Lisp object encapsulating the original instantiator and the underlying | |
| 158 window-system object describing the property. The function | |
| 159 `face-property-instance' actually does all this." | |
| 428 | 160 |
| 161 (setq face (get-face face)) | |
| 162 (let ((value (get face property))) | |
| 163 (if (and locale | |
| 164 (or (memq property built-in-face-specifiers) | |
| 165 (specifierp value))) | |
| 166 (setq value (specifier-specs value locale tag-set exact-p))) | |
| 167 value)) | |
| 168 | |
| 169 (defun convert-face-property-into-specifier (face property) | |
| 170 "Convert PROPERTY on FACE into a specifier, if it's not already." | |
| 171 (setq face (get-face face)) | |
| 172 (let ((specifier (get face property))) | |
| 173 ;; if a user-property does not have a specifier but a | |
| 174 ;; locale was specified, put a specifier there. | |
| 175 ;; If there was already a value there, convert it to a | |
| 3027 | 176 ;; specifier with the value as its `global' instantiator. |
| 428 | 177 (unless (specifierp specifier) |
| 178 (let ((new-specifier (make-specifier 'generic))) | |
| 179 (if (or (not (null specifier)) | |
| 180 ;; make sure the nil returned from `get' wasn't | |
| 181 ;; actually the value of the property | |
| 182 (null (get face property t))) | |
| 183 (add-spec-to-specifier new-specifier specifier)) | |
| 184 (setq specifier new-specifier) | |
| 185 (put face property specifier))))) | |
| 186 | |
| 187 (defun face-property-instance (face property | |
| 872 | 188 &optional domain default no-fallback) |
| 428 | 189 "Return the instance of FACE's PROPERTY in the specified DOMAIN. |
| 190 | |
| 191 Under most circumstances, DOMAIN will be a particular window, | |
| 192 and the returned instance describes how the specified property | |
| 193 actually is displayed for that window and the particular buffer | |
| 194 in it. Note that this may not be the same as how the property | |
| 195 appears when the buffer is displayed in a different window or | |
| 196 frame, or how the property appears in the same window if you | |
| 197 switch to another buffer in that window; and in those cases, | |
| 198 the returned instance would be different. | |
| 199 | |
| 200 The returned instance will typically be a color-instance, | |
| 3027 | 201 font-instance, or image-instance object, and you can query |
| 428 | 202 it using the appropriate object-specific functions. For example, |
| 203 you could use `color-instance-rgb-components' to find out the | |
| 3027 | 204 RGB (red, green, and blue) components of how the `background' |
| 205 property of the `highlight' face is displayed in a particular | |
| 428 | 206 window. The results might be different from the results |
| 207 you would get for another window (perhaps the user | |
| 208 specified a different color for the frame that window is on; | |
| 209 or perhaps the same color was specified but the window is | |
| 210 on a different X server, and that X server has different RGB | |
| 211 values for the color from this one). | |
| 212 | |
| 213 DOMAIN defaults to the selected window if omitted. | |
| 214 | |
| 215 DOMAIN can be a frame or device, instead of a window. The value | |
| 216 returned for a such a domain is used in special circumstances | |
| 217 when a more specific domain does not apply; for example, a frame | |
| 218 value might be used for coloring a toolbar, which is conceptually | |
| 219 attached to a frame rather than a particular window. The value | |
| 220 is also useful in determining what the value would be for a | |
| 221 particular window within the frame or device, if it is not | |
| 222 overridden by a more specific specification. | |
| 223 | |
| 224 If PROPERTY does not name a built-in property, its value will | |
| 225 simply be returned unless it is a specifier object, in which case | |
| 226 it will be instanced using `specifier-instance'. | |
| 227 | |
| 228 Optional arguments DEFAULT and NO-FALLBACK are the same as in | |
| 229 `specifier-instance'." | |
| 230 | |
| 231 (setq face (get-face face)) | |
| 232 (let ((value (get face property))) | |
| 233 (if (specifierp value) | |
| 234 (setq value (specifier-instance value domain default no-fallback))) | |
| 235 value)) | |
| 236 | |
| 237 (defun face-property-matching-instance (face property matchspec | |
| 872 | 238 &optional domain default |
| 239 no-fallback) | |
| 428 | 240 "Return the instance of FACE's PROPERTY matching MATCHSPEC in DOMAIN. |
| 5484 | 241 Currently MATCHSPEC is used only for the 'font property, when its value |
| 242 should be a cons \(CHARSET . STAGE) \(see `specifier-matching-instance' | |
| 243 for a full description of the matching process). This allows you to | |
| 244 retrieve a font that can be used to display a particular charset, rather | |
| 245 than just any font. For backward compatibility, MATCHSPEC may be a | |
| 246 charset, which is interpreted as \(CHARSET . final). | |
| 428 | 247 |
| 5484 | 248 See `face-property-instance' for usage of the other arguments." |
| 428 | 249 |
| 250 (setq face (get-face face)) | |
| 5484 | 251 ;; For compatibility with 21.4-oriented code, eg, x-symbol-mule.el. |
| 252 (when (charsetp matchspec) | |
| 253 (setq matchspec (cons matchspec 'final))) | |
| 428 | 254 (let ((value (get face property))) |
| 3659 | 255 (when (specifierp value) |
| 256 (setq value (specifier-matching-instance value matchspec domain | |
| 257 default no-fallback))) | |
| 428 | 258 value)) |
| 259 | |
| 260 (defun set-face-property (face property value &optional locale tag-set | |
| 872 | 261 how-to-add) |
| 428 | 262 "Change a property of FACE. |
| 263 | |
| 264 NOTE: If you want to remove a property from a face, use `remove-face-property' | |
| 265 rather than attempting to set a value of nil for the property. | |
| 266 | |
| 267 For built-in properties, the actual value of the property is a | |
| 268 specifier and you cannot change this; but you can change the | |
| 269 specifications within the specifier, and that is what this function | |
| 270 will do. For user-defined properties, you can use this function | |
| 271 to either change the actual value of the property or, if this value | |
| 272 is a specifier, change the specifications within it. | |
| 273 | |
| 274 If PROPERTY is a built-in property, the specifications to be added to | |
| 275 this property can be supplied in many different ways: | |
| 276 | |
| 277 -- If VALUE is a simple instantiator (e.g. a string naming a font or | |
| 278 color) or a list of instantiators, then the instantiator(s) will | |
| 279 be added as a specification of the property for the given LOCALE | |
| 3027 | 280 (which defaults to `global' if omitted). |
| 428 | 281 -- If VALUE is a list of specifications (each of which is a cons of |
| 282 a locale and a list of instantiators), then LOCALE must be nil | |
| 283 (it does not make sense to explicitly specify a locale in this | |
| 284 case), and specifications will be added as given. | |
| 285 -- If VALUE is a specifier (as would be returned by `face-property' | |
| 286 if no LOCALE argument is given), then some or all of the | |
| 287 specifications in the specifier will be added to the property. | |
| 288 In this case, the function is really equivalent to | |
| 289 `copy-specifier' and LOCALE has the same semantics (if it is | |
| 290 a particular locale, the specification for the locale will be | |
| 291 copied; if a locale type, specifications for all locales of | |
| 3027 | 292 that type will be copied; if nil or `all', then all |
| 428 | 293 specifications will be copied). |
| 294 | |
| 3027 | 295 HOW-TO-ADD should be either nil or one of the symbols `prepend', |
| 296 `append', `remove-tag-set-prepend', `remove-tag-set-append', `remove-locale', | |
| 297 `remove-locale-type', or `remove-all'. See `copy-specifier' and | |
| 428 | 298 `add-spec-to-specifier' for a description of what each of |
| 299 these means. Most of the time, you do not need to worry about | |
| 300 this argument; the default behavior usually is fine. | |
| 301 | |
| 302 In general, it is OK to pass an instance object (e.g. as returned | |
| 303 by `face-property-instance') as an instantiator in place of | |
| 304 an actual instantiator. In such a case, the instantiator used | |
| 305 to create that instance object will be used (for example, if | |
| 3027 | 306 you set a font-instance object as the value of the `font' |
| 428 | 307 property, then the font name used to create that object will |
| 308 be used instead). If some cases, however, doing this | |
| 309 conversion does not make sense, and this will be noted in | |
| 310 the documentation for particular types of instance objects. | |
| 311 | |
| 312 If PROPERTY is not a built-in property, then this function will | |
| 313 simply set its value if LOCALE is nil. However, if LOCALE is | |
| 314 given, then this function will attempt to add VALUE as the | |
| 315 instantiator for the given LOCALE, using `add-spec-to-specifier'. | |
| 316 If the value of the property is not a specifier, it will | |
| 3027 | 317 automatically be converted into a `generic' specifier. |
| 428 | 318 |
| 319 | |
| 320 The following symbols have predefined meanings: | |
| 321 | |
| 322 foreground The foreground color of the face. | |
| 442 | 323 For valid instantiators, see `make-color-specifier'. |
| 428 | 324 |
| 325 background The background color of the face. | |
| 442 | 326 For valid instantiators, see `make-color-specifier'. |
| 428 | 327 |
| 328 font The font used to display text covered by this face. | |
| 442 | 329 For valid instantiators, see `make-font-specifier'. |
| 428 | 330 |
| 331 display-table The display table of the face. | |
| 332 This should be a vector of 256 elements. | |
| 333 | |
| 334 background-pixmap The pixmap displayed in the background of the face. | |
| 442 | 335 Only used by faces on X and MS Windows devices. |
| 336 For valid instantiators, see `make-image-specifier'. | |
| 428 | 337 |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
338 background-placement The placement of the face's background pixmap. |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
339 Only used by faces on X devices. |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
340 For valid instantiators, |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
341 see `make-face-background-placement-specifier'. |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
342 |
| 428 | 343 underline Underline all text covered by this face. |
| 442 | 344 For valid instantiators, see `make-face-boolean-specifier'. |
| 428 | 345 |
| 346 strikethru Draw a line through all text covered by this face. | |
| 442 | 347 For valid instantiators, see `make-face-boolean-specifier'. |
| 428 | 348 |
| 349 highlight Highlight all text covered by this face. | |
| 350 Only used by faces on TTY devices. | |
| 442 | 351 For valid instantiators, see `make-face-boolean-specifier'. |
| 428 | 352 |
| 353 dim Dim all text covered by this face. | |
| 442 | 354 For valid instantiators, see `make-face-boolean-specifier'. |
| 428 | 355 |
| 356 blinking Blink all text covered by this face. | |
| 357 Only used by faces on TTY devices. | |
| 442 | 358 For valid instantiators, see `make-face-boolean-specifier'. |
| 428 | 359 |
| 360 reverse Reverse the foreground and background colors. | |
| 361 Only used by faces on TTY devices. | |
| 442 | 362 For valid instantiators, see `make-face-boolean-specifier'. |
| 428 | 363 |
| 3027 | 364 inherit Face name or face object from which to inherit attributes, |
| 365 or a list of such elements. Attributes from inherited | |
| 366 faces are merged into the face like an underlying face | |
| 367 would be, with higher priority than underlying faces. | |
| 368 | |
| 428 | 369 doc-string Description of what the face's normal use is. |
| 370 NOTE: This is not a specifier, unlike all | |
| 371 the other built-in properties, and cannot | |
| 372 contain locale-specific values." | |
| 373 | |
| 374 (setq face (get-face face)) | |
| 375 (if (memq property built-in-face-specifiers) | |
| 376 (set-specifier (get face property) value locale tag-set how-to-add) | |
| 377 | |
| 378 ;; This section adds user defined properties. | |
| 379 (if (not locale) | |
| 380 (put face property value) | |
| 381 (convert-face-property-into-specifier face property) | |
| 382 (add-spec-to-specifier (get face property) value locale tag-set | |
| 383 how-to-add))) | |
| 384 value) | |
| 385 | |
| 386 (defun remove-face-property (face property &optional locale tag-set exact-p) | |
| 387 "Remove a property from FACE. | |
| 388 For built-in properties, this is analogous to `remove-specifier'. | |
| 389 See `remove-specifier' for the meaning of the LOCALE, TAG-SET, and EXACT-P | |
| 390 arguments." | |
| 391 (or locale (setq locale 'all)) | |
| 392 (if (memq property built-in-face-specifiers) | |
| 393 (remove-specifier (face-property face property) locale tag-set exact-p) | |
| 394 (if (eq locale 'all) | |
| 395 (remprop (get-face face) property) | |
| 396 (convert-face-property-into-specifier face property) | |
| 397 (remove-specifier (face-property face property) locale tag-set | |
| 398 exact-p)))) | |
| 399 | |
| 400 (defun reset-face (face &optional locale tag-set exact-p) | |
| 401 "Clear all existing built-in specifications from FACE. | |
| 3027 | 402 This makes FACE inherit all its display properties from `default'. |
| 428 | 403 WARNING: Be absolutely sure you want to do this!!! It is a dangerous |
| 404 operation and is not undoable. | |
| 405 | |
| 406 The arguments LOCALE, TAG-SET and EXACT-P are the same as for | |
| 407 `remove-specifier'." | |
| 3918 | 408 ;; Don't reset the default face. |
| 409 (unless (eq 'default face) | |
| 410 (dolist (x built-in-face-specifiers nil) | |
| 411 (remove-specifier (face-property face x) locale tag-set exact-p)))) | |
| 428 | 412 |
| 413 (defun set-face-parent (face parent &optional locale tag-set how-to-add) | |
| 414 "Set the parent of FACE to PARENT, for all properties. | |
| 415 This makes all properties of FACE inherit from PARENT." | |
| 416 (setq parent (get-face parent)) | |
|
4783
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4764
diff
changeset
|
417 (mapc (lambda (x) |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4764
diff
changeset
|
418 (set-face-property face x (vector parent) locale tag-set |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4764
diff
changeset
|
419 how-to-add)) |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4764
diff
changeset
|
420 (set-difference built-in-face-specifiers |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4764
diff
changeset
|
421 '(display-table background-pixmap inherit))) |
|
5344
2a54dfbe434f
Don't quote keywords, they've been self-quoting for well over a decade.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5284
diff
changeset
|
422 (set-face-background-pixmap face (vector 'inherit :face parent) |
| 428 | 423 locale tag-set how-to-add) |
| 424 nil) | |
| 425 | |
| 426 (defun face-doc-string (face) | |
| 427 "Return the documentation string for FACE." | |
| 428 (face-property face 'doc-string)) | |
| 429 | |
| 430 (defun set-face-doc-string (face doc-string) | |
| 431 "Change the documentation string of FACE to DOC-STRING." | |
| 432 (interactive (face-interactive "doc-string")) | |
| 433 (set-face-property face 'doc-string doc-string)) | |
| 434 | |
| 435 (defun face-font-name (face &optional domain charset) | |
| 436 "Return the font name of FACE in DOMAIN, or nil if it is unspecified. | |
| 3027 | 437 DOMAIN is as in `face-font-instance'. |
| 438 | |
| 439 Font names are strings, as described in `make-font-specifier'." | |
| 428 | 440 (let ((f (face-font-instance face domain charset))) |
| 441 (and f (font-instance-name f)))) | |
| 442 | |
| 443 (defun face-font (face &optional locale tag-set exact-p) | |
| 3027 | 444 "Return the font spec of FACE in LOCALE, or nil if it is unspecified. |
| 445 | |
| 446 NOTE: This returns a locale-specific specification, not any sort of value | |
| 447 corresponding to the actual font being used. If you want to know the | |
| 448 actual font used in a particular domain, use `face-font-instance', or | |
| 449 `face-font-name' for its name (i.e. the instantiator used to create it). | |
| 428 | 450 |
| 451 FACE may be either a face object or a symbol representing a face. | |
| 452 | |
| 453 LOCALE may be a locale (the instantiators for that particular locale | |
| 454 will be returned), a locale type (the specifications for all locales | |
| 3027 | 455 of that type will be returned), `all' (all specifications will be |
| 428 | 456 returned), or nil (the actual specifier object will be returned). |
| 457 | |
| 458 See `face-property' for more information." | |
| 459 (face-property face 'font locale tag-set exact-p)) | |
| 460 | |
| 461 (defun face-font-instance (face &optional domain charset) | |
| 462 "Return the instance of FACE's font in DOMAIN. | |
| 463 | |
| 3027 | 464 Return value will be a font instance object; query its properties using |
| 465 `font-instance-name', `font-instance-height', `font-instance-width', etc. | |
| 466 | |
| 428 | 467 FACE may be either a face object or a symbol representing a face. |
| 468 | |
| 469 Normally DOMAIN will be a window or nil (meaning the selected window), | |
| 470 and an instance object describing how the font appears in that | |
| 471 particular window and buffer will be returned. | |
| 472 | |
| 3659 | 473 CHARSET is a Mule charset (meaning return the font used for that charset) or |
| 474 nil (meaning return the font used for ASCII.) | |
| 475 | |
| 428 | 476 See `face-property-instance' for more information." |
| 3659 | 477 (if (null charset) |
| 478 (face-property-instance face 'font domain) | |
| 479 (let (matchspec) | |
| 480 ;; get-charset signals an error if its argument doesn't have an | |
| 481 ;; associated charset. | |
|
5368
ed74d2ca7082
Use ', not #', when a given symbol may not have a function binding at read time
Aidan Kehoe <kehoea@parhasard.net>
parents:
5366
diff
changeset
|
482 (setq charset (if-fboundp 'get-charset |
| 4222 | 483 (get-charset charset) |
| 484 (error 'unimplemented "Charset support not available")) | |
| 3659 | 485 matchspec (cons charset nil)) |
| 486 (or (null (setcdr matchspec 'initial)) | |
| 487 (face-property-matching-instance | |
| 488 face 'font matchspec domain) | |
| 489 (null (setcdr matchspec 'final)) | |
| 490 (face-property-matching-instance | |
| 491 face 'font matchspec domain))))) | |
| 428 | 492 |
| 493 (defun set-face-font (face font &optional locale tag-set how-to-add) | |
| 494 "Change the font of FACE to FONT in LOCALE. | |
| 495 | |
| 496 FACE may be either a face object or a symbol representing a face. | |
| 497 | |
| 3659 | 498 FONT should be an instantiator (see `make-font-specifier'; a common |
| 499 instantiator is a platform-dependent string naming the font), a list | |
| 500 of instantiators, an alist of specifications (each mapping a locale | |
| 501 to an instantiator list), or a font specifier object. | |
| 428 | 502 |
| 3659 | 503 If FONT is an alist, LOCALE must be omitted. If FONT is a specifier |
| 504 object, LOCALE can be a locale, a locale type, `all', or nil; see | |
| 505 `copy-specifier' for its semantics. Common LOCALEs are buffer | |
| 506 objects, window objects, device objects and `global'. Otherwise | |
| 507 LOCALE specifies the locale under which the specified | |
| 508 instantiator(s) will be added, and defaults to `global'. | |
| 428 | 509 |
| 510 See `set-face-property' for more information." | |
| 511 (interactive (face-interactive "font")) | |
| 512 (set-face-property face 'font font locale tag-set how-to-add)) | |
| 513 | |
| 514 (defun face-foreground (face &optional locale tag-set exact-p) | |
| 3027 | 515 "Return the foreground spec of FACE in LOCALE, or nil if it is unspecified. |
| 516 | |
| 517 NOTE: This returns a locale-specific specification, not any sort of value | |
| 518 corresponding to the actual foreground being used. If you want to know the | |
| 519 actual foreground color used in a particular domain, use | |
| 520 `face-foreground-instance', or `face-foreground-name' for its name | |
| 521 \(i.e. the instantiator used to create it). | |
| 428 | 522 |
| 523 FACE may be either a face object or a symbol representing a face. | |
| 524 | |
| 525 LOCALE may be a locale (the instantiators for that particular locale | |
| 526 will be returned), a locale type (the specifications for all locales | |
| 3027 | 527 of that type will be returned), `all' (all specifications will be |
| 428 | 528 returned), or nil (the actual specifier object will be returned). |
| 529 | |
| 530 See `face-property' for more information." | |
| 531 (face-property face 'foreground locale tag-set exact-p)) | |
| 532 | |
| 533 (defun face-foreground-instance (face &optional domain default no-fallback) | |
| 534 "Return the instance of FACE's foreground in DOMAIN. | |
| 535 | |
| 3027 | 536 Return value will be a color instance object; query its properties using |
| 537 `color-instance-name' or `color-instance-rgb-properties'. | |
| 538 | |
| 428 | 539 FACE may be either a face object or a symbol representing a face. |
| 540 | |
| 541 Normally DOMAIN will be a window or nil (meaning the selected window), | |
| 542 and an instance object describing how the foreground appears in that | |
| 543 particular window and buffer will be returned. | |
| 544 | |
| 545 See `face-property-instance' for more information." | |
| 546 (face-property-instance face 'foreground domain default no-fallback)) | |
| 547 | |
| 548 (defun face-foreground-name (face &optional domain default no-fallback) | |
| 549 "Return the name of FACE's foreground color in DOMAIN. | |
| 550 | |
| 551 FACE may be either a face object or a symbol representing a face. | |
| 552 | |
| 553 Normally DOMAIN will be a window or nil (meaning the selected window), | |
| 554 and an instance object describing how the background appears in that | |
| 555 particular window and buffer will be returned. | |
| 556 | |
| 557 See `face-property-instance' for more information." | |
| 558 (color-instance-name (face-foreground-instance | |
| 559 face domain default no-fallback))) | |
| 560 | |
| 561 (defun set-face-foreground (face color &optional locale tag-set how-to-add) | |
| 562 "Change the foreground color of FACE to COLOR in LOCALE. | |
| 563 | |
| 564 FACE may be either a face object or a symbol representing a face. | |
| 565 | |
| 442 | 566 COLOR should be an instantiator (see `make-color-specifier'), a list of |
| 428 | 567 instantiators, an alist of specifications (each mapping a locale to |
| 568 an instantiator list), or a color specifier object. | |
| 569 | |
| 570 If COLOR is an alist, LOCALE must be omitted. If COLOR is a | |
| 3027 | 571 specifier object, LOCALE can be a locale, a locale type, `all', |
| 428 | 572 or nil; see `copy-specifier' for its semantics. Otherwise LOCALE |
| 573 specifies the locale under which the specified instantiator(s) | |
| 3027 | 574 will be added, and defaults to `global'. |
| 428 | 575 |
| 576 See `set-face-property' for more information." | |
| 577 (interactive (face-interactive "foreground")) | |
| 578 (set-face-property face 'foreground color locale tag-set how-to-add)) | |
| 579 | |
| 580 (defun face-background (face &optional locale tag-set exact-p) | |
| 581 "Return the background color of FACE in LOCALE, or nil if it is unspecified. | |
| 582 | |
| 3027 | 583 NOTE: This returns a locale-specific specification, not any sort of value |
| 584 corresponding to the actual background being used. If you want to know the | |
| 585 actual background color used in a particular domain, use | |
| 586 `face-background-instance', or `face-background-name' for its name | |
| 587 \(i.e. the instantiator used to create it). | |
| 588 | |
| 428 | 589 FACE may be either a face object or a symbol representing a face. |
| 590 | |
| 591 LOCALE may be a locale (the instantiators for that particular locale | |
| 592 will be returned), a locale type (the specifications for all locales | |
| 3027 | 593 of that type will be returned), `all' (all specifications will be |
| 428 | 594 returned), or nil (the actual specifier object will be returned). |
| 595 | |
| 596 See `face-property' for more information." | |
| 597 (face-property face 'background locale tag-set exact-p)) | |
| 598 | |
| 599 (defun face-background-instance (face &optional domain default no-fallback) | |
| 600 "Return the instance of FACE's background in DOMAIN. | |
| 601 | |
| 3027 | 602 Return value will be a color instance object; query its properties using |
| 603 `color-instance-name' or `color-instance-rgb-properties'. | |
| 604 | |
| 428 | 605 FACE may be either a face object or a symbol representing a face. |
| 606 | |
| 607 Normally DOMAIN will be a window or nil (meaning the selected window), | |
| 608 and an instance object describing how the background appears in that | |
| 609 particular window and buffer will be returned. | |
| 610 | |
| 611 See `face-property-instance' for more information." | |
| 612 (face-property-instance face 'background domain default no-fallback)) | |
| 613 | |
| 614 (defun face-background-name (face &optional domain default no-fallback) | |
| 615 "Return the name of FACE's background color in DOMAIN. | |
| 616 | |
| 617 FACE may be either a face object or a symbol representing a face. | |
| 618 | |
| 619 Normally DOMAIN will be a window or nil (meaning the selected window), | |
| 620 and an instance object describing how the background appears in that | |
| 621 particular window and buffer will be returned. | |
| 622 | |
| 623 See `face-property-instance' for more information." | |
| 624 (color-instance-name (face-background-instance | |
| 625 face domain default no-fallback))) | |
| 626 | |
| 627 (defun set-face-background (face color &optional locale tag-set how-to-add) | |
| 628 "Change the background color of FACE to COLOR in LOCALE. | |
| 629 | |
| 630 FACE may be either a face object or a symbol representing a face. | |
| 631 | |
| 442 | 632 COLOR should be an instantiator (see `make-color-specifier'), a list of |
| 428 | 633 instantiators, an alist of specifications (each mapping a locale to |
| 634 an instantiator list), or a color specifier object. | |
| 635 | |
| 636 If COLOR is an alist, LOCALE must be omitted. If COLOR is a | |
| 3027 | 637 specifier object, LOCALE can be a locale, a locale type, `all', |
| 428 | 638 or nil; see `copy-specifier' for its semantics. Otherwise LOCALE |
| 639 specifies the locale under which the specified instantiator(s) | |
| 3027 | 640 will be added, and defaults to `global'. |
| 428 | 641 |
| 642 See `set-face-property' for more information." | |
| 643 (interactive (face-interactive "background")) | |
| 644 (set-face-property face 'background color locale tag-set how-to-add)) | |
| 645 | |
| 646 (defun face-background-pixmap (face &optional locale tag-set exact-p) | |
| 3027 | 647 "Return the background pixmap spec of FACE in LOCALE, or nil if unspecified. |
| 428 | 648 This property is only used on window system devices. |
| 649 | |
| 3027 | 650 NOTE: This returns a locale-specific specification, not any sort of value |
| 651 corresponding to the actual background pixmap being used. If you want to | |
| 652 know the actual background pixmap used in a particular domain, use | |
| 653 `face-background-pixmap-instance'. | |
| 654 | |
| 428 | 655 FACE may be either a face object or a symbol representing a face. |
| 656 | |
| 657 LOCALE may be a locale (the instantiators for that particular locale | |
| 658 will be returned), a locale type (the specifications for all locales | |
| 3027 | 659 of that type will be returned), `all' (all specifications will be |
| 428 | 660 returned), or nil (the actual specifier object will be returned). |
| 661 | |
| 662 See `face-property' for more information." | |
| 663 (face-property face 'background-pixmap locale tag-set exact-p)) | |
| 664 | |
| 665 (defun face-background-pixmap-instance (face &optional domain default | |
| 666 no-fallback) | |
| 667 "Return the instance of FACE's background pixmap in DOMAIN. | |
| 668 | |
| 3027 | 669 Return value will be an image instance object; query its properties using |
| 670 `image-instance-instantiator' (the original instantiator used to create | |
| 671 the image, which may be a complex beast -- see `make-image-specifier'), | |
| 672 `image-instance-file-name' (the file, if any, from which the image was | |
| 673 created), `image-instance-height', etc. | |
| 674 | |
| 428 | 675 FACE may be either a face object or a symbol representing a face. |
| 676 | |
| 677 Normally DOMAIN will be a window or nil (meaning the selected window), | |
| 678 and an instance object describing how the background appears in that | |
| 679 particular window and buffer will be returned. | |
| 680 | |
| 681 See `face-property-instance' for more information." | |
| 682 (face-property-instance face 'background-pixmap domain default no-fallback)) | |
| 683 | |
| 684 (defun set-face-background-pixmap (face pixmap &optional locale tag-set | |
| 685 how-to-add) | |
| 686 "Change the background pixmap of FACE to PIXMAP in LOCALE. | |
| 687 This property is only used on window system devices. | |
| 688 | |
| 689 FACE may be either a face object or a symbol representing a face. | |
| 690 | |
| 442 | 691 PIXMAP should be an instantiator (see `make-image-specifier'), a list |
| 428 | 692 of instantiators, an alist of specifications (each mapping a locale |
| 693 to an instantiator list), or an image specifier object. | |
| 694 | |
| 695 If PIXMAP is an alist, LOCALE must be omitted. If PIXMAP is a | |
| 3027 | 696 specifier object, LOCALE can be a locale, a locale type, `all', |
| 428 | 697 or nil; see `copy-specifier' for its semantics. Otherwise LOCALE |
| 698 specifies the locale under which the specified instantiator(s) | |
| 3027 | 699 will be added, and defaults to `global'. |
| 428 | 700 |
| 701 See `set-face-property' for more information." | |
| 702 (interactive (face-interactive "background-pixmap")) | |
| 703 (set-face-property face 'background-pixmap pixmap locale tag-set how-to-add)) | |
| 704 | |
| 1137 | 705 (defvar background-pixmap-file-history nil |
| 706 ;; History for `set-face-background-pixmap-file' | |
| 707 ) | |
| 708 | |
| 709 (defun set-face-background-pixmap-file (face file) | |
| 710 "Read (and set) the background pixmap of FACE from FILE. | |
| 711 This function is a simplified version of `set-face-background-pixmap', | |
| 712 designed for interactive use." | |
| 713 (interactive | |
| 714 (let* ((face (read-face-name "Set background pixmap of face: ")) | |
| 1139 | 715 (default (and (face-background-pixmap-instance face) |
|
4670
5a54ce6dc945
Remove some extra parentheses, #'set-face-background-pixmap-file.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
716 (image-instance-file-name |
|
5a54ce6dc945
Remove some extra parentheses, #'set-face-background-pixmap-file.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
717 (face-background-pixmap-instance face)))) |
| 1137 | 718 (file (read-file-name |
| 719 (format "Set background pixmap of face %s to: " | |
| 720 (symbol-name face)) | |
| 1139 | 721 nil default t nil |
| 1137 | 722 'background-pixmap-file-history))) |
| 723 (list face (if (equal file "") nil file)))) | |
| 724 (set-face-property face 'background-pixmap file)) | |
| 725 | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
726 (defun face-background-placement (face &optional domain default no-fallback) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
727 "Return FACE's background placement in DOMAIN. |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
728 See `face-property-instance' for the semantics of the DOMAIN argument." |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
729 (face-property face 'background-placement domain default no-fallback)) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
730 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
731 (defun set-face-background-placement (face placement &optional locale tag-set |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
732 how-to-add) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
733 "Change the background-placement property of FACE to PLACEMENT. |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
734 PLACEMENT is normally a background-placement instantiator; see |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
735 `make-face-background-placement-specifier'. |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
736 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
737 HOW-TO-ADD arguments." |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
738 (interactive (face-interactive "background placement")) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
739 ;; When called non-interactively (for example via custom), PLACEMENT is |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
740 ;; expected to be a symbol. -- dvl |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
741 (unless (symbolp placement) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
742 (setq placement (intern placement))) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
743 (set-face-property face 'background-placement placement locale tag-set |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
744 how-to-add)) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
745 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
746 (defun face-background-placement-instance (face &optional domain default |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
747 no-fallback) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
748 "Return FACE's background-placement instance in DOMAIN. |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
749 Return value will be a background-placement instance object. |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
750 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
751 FACE may be either a face object or a symbol representing a face. |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
752 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
753 Normally DOMAIN will be a window or nil (meaning the selected window), |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
754 and an instance object describing the background placement in that particular |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
755 window and buffer will be returned. |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
756 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
757 See `face-property-instance' for more information." |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
758 (face-property-instance face 'background-placement domain default |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
759 no-fallback)) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
760 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
761 (defun face-background-placement-instance-p (object) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
762 "Return t if OBJECT is a face-background-placement instance." |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
763 (or (eq object 'absolute) (eq object 'relative))) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
764 |
| 428 | 765 (defun face-display-table (face &optional locale tag-set exact-p) |
| 3027 | 766 "Return the display table spec of FACE in LOCALE, or nil if unspecified.. |
| 428 | 767 |
| 3027 | 768 NOTE: This returns a locale-specific specification, not any sort of value |
| 769 corresponding to the actual display table being used. If you want to | |
| 770 know the actual display table used in a particular domain, use | |
| 771 `face-display-table-instance'. | |
| 772 | |
| 773 FACE may be either a face object or a symbol representing a face. | |
| 428 | 774 |
| 775 LOCALE may be a locale (the instantiators for that particular locale | |
| 776 will be returned), a locale type (the specifications for all locales | |
| 3027 | 777 of that type will be returned), `all' (all specifications will be |
| 428 | 778 returned), or nil (the actual specifier object will be returned). |
| 779 | |
| 780 See `face-property' for more information." | |
| 781 (face-property face 'display-table locale tag-set exact-p)) | |
| 782 | |
| 783 (defun face-display-table-instance (face &optional domain default no-fallback) | |
| 784 "Return the instance of FACE's display table in DOMAIN. | |
| 3027 | 785 |
| 786 Return value will be a vector, char table or range table; see | |
| 787 `current-display-table'. | |
| 788 | |
| 789 FACE may be either a face object or a symbol representing a face. | |
| 428 | 790 |
| 3027 | 791 Normally DOMAIN will be a window or nil (meaning the selected window), |
| 792 and the actual display table used in that particular window and buffer | |
| 793 will be returned. | |
| 794 | |
| 795 See `face-property-instance' for more information." | |
| 428 | 796 (face-property-instance face 'display-table domain default no-fallback)) |
| 797 | |
| 798 (defun set-face-display-table (face display-table &optional locale tag-set | |
| 872 | 799 how-to-add) |
| 428 | 800 "Change the display table of FACE to DISPLAY-TABLE in LOCALE. |
| 801 DISPLAY-TABLE should be a vector as returned by `make-display-table'. | |
| 802 | |
| 803 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and | |
| 804 HOW-TO-ADD arguments." | |
| 805 (interactive (face-interactive "display-table")) | |
| 806 (set-face-property face 'display-table display-table locale tag-set | |
| 807 how-to-add)) | |
| 808 | |
| 809 ;; The following accessors and mutators are, IMHO, good | |
| 810 ;; implementation. Cf. with `make-face-bold'. | |
| 811 | |
| 812 (defun face-underline-p (face &optional domain default no-fallback) | |
| 813 "Return t if FACE is underlined in DOMAIN. | |
| 814 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 815 (face-property-instance face 'underline domain default no-fallback)) | |
| 816 | |
| 817 (defun set-face-underline-p (face underline-p &optional locale tag-set | |
| 872 | 818 how-to-add) |
| 428 | 819 "Change the underline property of FACE to UNDERLINE-P. |
| 820 UNDERLINE-P is normally a face-boolean instantiator; see | |
| 442 | 821 `make-face-boolean-specifier'. |
| 428 | 822 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and |
| 823 HOW-TO-ADD arguments." | |
| 824 (interactive (face-interactive "underline-p" "underlined")) | |
| 825 (set-face-property face 'underline underline-p locale tag-set how-to-add)) | |
| 826 | |
| 827 (defun face-strikethru-p (face &optional domain default no-fallback) | |
| 828 "Return t if FACE is strikethru-d (i.e. struck through) in DOMAIN. | |
| 829 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 830 (face-property-instance face 'strikethru domain default no-fallback)) | |
| 831 | |
| 832 (defun set-face-strikethru-p (face strikethru-p &optional locale tag-set | |
| 872 | 833 how-to-add) |
| 428 | 834 "Change whether FACE is strikethru-d (i.e. struck through) in LOCALE. |
| 835 STRIKETHRU-P is normally a face-boolean instantiator; see | |
| 442 | 836 `make-face-boolean-specifier'. |
| 428 | 837 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and |
| 838 HOW-TO-ADD arguments." | |
| 839 (interactive (face-interactive "strikethru-p" "strikethru-d")) | |
| 840 (set-face-property face 'strikethru strikethru-p locale tag-set how-to-add)) | |
| 841 | |
| 842 (defun face-highlight-p (face &optional domain default no-fallback) | |
| 843 "Return t if FACE is highlighted in DOMAIN (TTY domains only). | |
| 844 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 845 (face-property-instance face 'highlight domain default no-fallback)) | |
| 846 | |
| 847 (defun set-face-highlight-p (face highlight-p &optional locale tag-set | |
| 872 | 848 how-to-add) |
| 428 | 849 "Change whether FACE is highlighted in LOCALE (TTY locales only). |
| 850 HIGHLIGHT-P is normally a face-boolean instantiator; see | |
| 442 | 851 `make-face-boolean-specifier'. |
| 428 | 852 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and |
| 853 HOW-TO-ADD arguments." | |
| 854 (interactive (face-interactive "highlight-p" "highlighted")) | |
| 855 (set-face-property face 'highlight highlight-p locale tag-set how-to-add)) | |
| 856 | |
| 857 (defun face-dim-p (face &optional domain default no-fallback) | |
| 858 "Return t if FACE is dimmed in DOMAIN. | |
| 859 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 860 (face-property-instance face 'dim domain default no-fallback)) | |
| 861 | |
| 862 (defun set-face-dim-p (face dim-p &optional locale tag-set how-to-add) | |
| 863 "Change whether FACE is dimmed in LOCALE. | |
| 864 DIM-P is normally a face-boolean instantiator; see | |
| 442 | 865 `make-face-boolean-specifier'. |
| 428 | 866 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and |
| 867 HOW-TO-ADD arguments." | |
| 868 (interactive (face-interactive "dim-p" "dimmed")) | |
| 869 (set-face-property face 'dim dim-p locale tag-set how-to-add)) | |
| 870 | |
| 871 (defun face-blinking-p (face &optional domain default no-fallback) | |
| 872 "Return t if FACE is blinking in DOMAIN (TTY domains only). | |
| 873 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 874 (face-property-instance face 'blinking domain default no-fallback)) | |
| 875 | |
| 876 (defun set-face-blinking-p (face blinking-p &optional locale tag-set | |
| 872 | 877 how-to-add) |
| 428 | 878 "Change whether FACE is blinking in LOCALE (TTY locales only). |
| 879 BLINKING-P is normally a face-boolean instantiator; see | |
| 442 | 880 `make-face-boolean-specifier'. |
| 428 | 881 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and |
| 882 HOW-TO-ADD arguments." | |
| 883 (interactive (face-interactive "blinking-p" "blinking")) | |
| 884 (set-face-property face 'blinking blinking-p locale tag-set how-to-add)) | |
| 885 | |
| 886 (defun face-reverse-p (face &optional domain default no-fallback) | |
| 887 "Return t if FACE is reversed in DOMAIN (TTY domains only). | |
| 888 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 889 (face-property-instance face 'reverse domain default no-fallback)) | |
| 890 | |
| 891 (defun set-face-reverse-p (face reverse-p &optional locale tag-set how-to-add) | |
| 892 "Change whether FACE is reversed in LOCALE (TTY locales only). | |
| 893 REVERSE-P is normally a face-boolean instantiator; see | |
| 442 | 894 `make-face-boolean-specifier'. |
| 428 | 895 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and |
| 896 HOW-TO-ADD arguments." | |
| 897 (interactive (face-interactive "reverse-p" "reversed")) | |
| 898 (set-face-property face 'reverse reverse-p locale tag-set how-to-add)) | |
| 899 | |
| 900 | |
| 901 (defun face-property-equal (face1 face2 prop domain) | |
| 902 (equal (face-property-instance face1 prop domain) | |
| 903 (face-property-instance face2 prop domain))) | |
| 904 | |
| 905 (defun face-equal-loop (props face1 face2 domain) | |
| 906 (while (and props | |
| 907 (face-property-equal face1 face2 (car props) domain)) | |
| 908 (setq props (cdr props))) | |
| 909 (null props)) | |
| 910 | |
| 911 (defun face-equal (face1 face2 &optional domain) | |
| 912 "Return t if FACE1 and FACE2 will display in the same way in DOMAIN. | |
| 913 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 914 (if (null domain) (setq domain (selected-window))) | |
| 915 (if (not (valid-specifier-domain-p domain)) | |
| 916 (error "Invalid specifier domain")) | |
| 917 (let ((device (dfw-device domain)) | |
| 918 (common-props '(foreground background font display-table underline | |
| 3027 | 919 dim inherit)) |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
920 (win-props '(background-pixmap background-placement strikethru)) |
| 428 | 921 (tty-props '(highlight blinking reverse))) |
| 922 | |
| 923 ;; First check the properties which are used in common between the | |
| 924 ;; x and tty devices. Then, check those properties specific to | |
| 925 ;; the particular device type. | |
| 926 (and (face-equal-loop common-props face1 face2 domain) | |
| 927 (cond ((eq 'tty (device-type device)) | |
| 928 (face-equal-loop tty-props face1 face2 domain)) | |
| 872 | 929 ((console-on-window-system-p (device-console device)) |
| 428 | 930 (face-equal-loop win-props face1 face2 domain)) |
| 931 (t t))))) | |
| 932 | |
| 933 (defun face-differs-from-default-p (face &optional domain) | |
| 934 "Return t if FACE will display differently from the default face in DOMAIN. | |
| 935 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 936 (not (face-equal face 'default domain))) | |
| 937 | |
| 938 (defun try-font-name (name &optional device) | |
| 872 | 939 "Return NAME if it's a valid font name on DEVICE, else nil." |
| 428 | 940 ;; yes, name really should be here twice. |
| 941 (and name (make-font-instance name device t) name)) | |
| 942 | |
| 943 | |
| 872 | 944 |
| 945 (defcustom face-frob-from-locale-first nil | |
| 946 "*If non nil, use kludgy way of frobbing fonts suitable for non-mule | |
| 947 multi-charset environments." | |
| 948 :group 'faces | |
| 949 :type 'boolean) | |
| 950 | |
| 428 | 951 ;; This function is a terrible, disgusting hack!!!! Need to |
| 952 ;; separate out the font elements as separate face properties! | |
| 953 | |
| 954 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 955 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 956 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 957 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 958 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 959 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 960 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 961 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 962 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 963 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 964 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 965 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 966 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 967 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 968 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 872 | 969 |
| 970 ;; When we are initializing a device, it won't be selected; we communicate | |
| 971 ;; the device to consider as selected using this variable. | |
| 972 (defvar Face-frob-property-device-considered-current nil) | |
| 428 | 973 |
| 872 | 974 (defun Face-frob-property (face locale tag-set exact-p |
| 975 unfrobbed-face frobbed-face | |
| 976 win-prop tty-props | |
| 977 frob-mapping standard-face-mapping) | |
| 978 ;; implement the semantics of `make-face-bold' et al. FACE, LOCALE, TAG-SET | |
| 979 ;; and EXACT-P are as in that call. UNFROBBED-FACE and FROBBED-FACE are | |
| 980 ;; what we expect the original face and the result to look like, | |
| 981 ;; respectively. TTY-PROPS is a list of face properties to frob in place | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
982 ;; of `font' for TTYs. FROB-MAPPING is either a plist mapping device |
| 872 | 983 ;; types to functions of two args (NAME DEVICE) that will frob the |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
984 ;; instantiator to NAME as appropriate for DEVICE's type (this includes |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
985 ;; TTYs #### TTYs are not passed the device, just the symbol 'tty), or a |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
986 ;; function to handle the mapping for all device types. |
| 872 | 987 ;; STANDARD-FACE-MAPPING is an alist of mappings of inheritance |
| 988 ;; instantiators to be replaced with other inheritance instantiators, meant | |
| 989 ;; for e.g. converting [bold] into [bold-italic]. | |
| 990 | |
| 991 ;; #### it would be nice if this function could be generalized to be | |
| 992 ;; a general specifier frobber. but so much of what it does is specific | |
| 993 ;; to faces -- e.g. handling of inheritance, standard faces, | |
| 994 ;; special-casing in various ways for tty's, etc. i've already extracted | |
| 995 ;; as much of the functionality as i can into subfunctions in the | |
| 996 ;; heuristic section of specifier.el. | |
| 442 | 997 |
| 872 | 998 ;; #### Note: The old code was totally different (and there was much less |
| 999 ;; of it). It didn't bother with trying to frob all the instantiators, | |
| 1000 ;; or handle inheritance vectors as instantiators, or do something | |
| 1001 ;; sensible with buffer locales, or many other things. (It always, or | |
| 1002 ;; usually, did a specifier-instance and frobbed the result.) But it did | |
| 1003 ;; do three things we don't: | |
| 1004 ;; | |
| 1005 ;; (1) Map over all devices when processing global or buffer locales. | |
| 1006 ;; Should we be doing this in stages 2 and/or 3? The fact that we | |
| 1007 ;; now process all fallback instantiators seems to make this less | |
| 1008 ;; necessary, at least for global locales. | |
| 1009 ;; | |
| 1010 ;; (2) Remove all instantiators tagged with `default' when putting the | |
| 1011 ;; instantiators back. I don't see why this is necessary, but maybe | |
| 1012 ;; it is. | |
| 1013 ;; | |
| 1014 ;; (3) Pay attention to the face-frob-from-locale-first variable. #### | |
| 1015 ;; I don't understand its purpose. Undocumented hacks like this, | |
| 1016 ;; clearly added after-the-fact, don't deserve to live. DOCUMENT | |
| 1017 ;; THIS SHIT! | |
| 428 | 1018 |
|
5567
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5484
diff
changeset
|
1019 (labels |
| 872 | 1020 ( |
| 1021 | |
| 1022 ;; non-nil if either instantiator non-nil, or nil instantiators allowed. | |
| 1023 (nil-instantiator-ok (inst devtype-spec) | |
| 1024 (or inst (eq devtype-spec 'tty))) | |
| 1025 | |
| 1026 ;; if LOCALE is a global locale (all, nil, global), return 'global, | |
| 1027 ;; else nil. | |
| 1028 (global-locale (locale) | |
| 1029 (and (memq locale '(all nil global)) 'global)) | |
| 444 | 1030 |
| 872 | 1031 ;; Given a locale and the inst-list from that locale, frob the |
| 1032 ;; instantiators according to FROB-MAPPING, a plist mapping device | |
| 1033 ;; types to functions that frob instantiators of that device type. | |
| 1034 ;; NOTE: TAG-SET and FROB-MAPPING from environment. | |
| 1035 (frob-face-inst-list (locale inst-list prop devtype-spec) | |
| 1036 (let* ((ffpdev Face-frob-property-device-considered-current) | |
| 1037 (results | |
| 1038 ;; for each inst-pair, frob it (the result will be 0 or | |
| 1039 ;; more inst-pairs; we may get more than one if, e.g. the | |
| 1040 ;; instantiator specifies inheritance and we expand the | |
| 1041 ;; inheritance); then nconc the results together | |
| 1042 (loop for (tag-set . x) in inst-list | |
| 1043 for devtype = (derive-device-type-from-locale-and-tag-set | |
| 1044 locale tag-set devtype-spec ffpdev) | |
| 1045 ;; devtype may be nil if it fails to match DEVTYPE-SPEC | |
| 1046 if devtype | |
| 3360 | 1047 if (let* ((mapper |
| 1048 (cond ((functionp frob-mapping) frob-mapping) | |
| 1049 ((plist-get frob-mapping devtype)) | |
| 1050 (t (error 'unimplemented "mapper" devtype)))) | |
| 872 | 1051 (result |
| 1052 (cond | |
| 1053 ;; if a vector ... | |
| 1054 ((vectorp x) | |
| 1055 (let ((change-to | |
| 1056 (cdr (assoc x standard-face-mapping)))) | |
| 1057 (cond | |
| 1058 ;; (1) handle standard mappings/null vectors | |
| 1059 ((or change-to (null (length x))) | |
| 1060 (list (cons tag-set | |
| 1061 (cond ((eq change-to t) x) | |
| 1062 (change-to) | |
| 1063 (t x))))) | |
| 1064 ;; (2) inheritance vectors. retrieve the | |
| 1065 ;; inherited value and recursively frob. | |
| 1066 ;; stick the tag-set into the result. | |
| 1067 (t (let* | |
| 1068 ((subprop | |
| 1069 (if (> (length x) 1) (elt x 1) | |
| 1070 prop)) | |
| 1071 (subinsts | |
| 1072 (frob-face-inst-list | |
| 1073 locale | |
| 1074 (cdar | |
| 1075 (specifier-spec-list | |
| 1076 (face-property (elt x 0) | |
| 1077 subprop))) | |
| 1078 subprop devtype-spec))) | |
| 1079 ;; #### we don't currently handle | |
| 1080 ;; the "reverse the sense" flag on | |
| 1081 ;; tty inheritance vectors. | |
| 1082 (add-tag-to-inst-list subinsts | |
| 1083 tag-set)))))) | |
| 1084 ;; (3) not a vector. just process it. | |
| 1085 (t | |
| 1086 (let ((value | |
| 1087 (if (eq devtype-spec 'tty) | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1088 ;; #### not quite right but need |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1089 ;; two args to match documentation |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1090 ;; mostly we just ignore TTYs so |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1091 ;; for now just pass the devtype |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1092 (funcall mapper x 'tty) |
| 872 | 1093 (funcall mapper x |
| 1094 (derive-domain-from-locale | |
| 1095 locale devtype-spec | |
| 1096 ffpdev))))) | |
| 1097 (and (nil-instantiator-ok value devtype-spec) | |
| 1098 (list (cons tag-set value)))))))) | |
| 1099 ;; if we're adding to a tty, we need to tag our | |
| 1100 ;; additions with `tty'; see [note 1] below. we leave | |
| 1101 ;; the old spec in place, however -- if e.g. we're | |
| 1102 ;; italicizing a font that was always set to be | |
| 1103 ;; underlined, even on window systems, then we still | |
| 1104 ;; want the underline there. unless we put the old | |
| 1105 ;; spec back, the underline will disappear, since | |
| 1106 ;; the new specs are all tagged with `tty'. this | |
| 1107 ;; doesn't apply to the [note 1] situations below | |
| 1108 ;; because there we're just adding, not substituting. | |
| 1109 (if (and (eq 'tty devtype-spec) | |
| 1110 (not (or (eq 'tty tag-set) | |
| 1111 (memq 'tty tag-set)))) | |
| 1112 (nconc (add-tag-to-inst-list result 'tty) | |
| 1113 (list (cons tag-set x))) | |
| 1114 result)) | |
| 1115 nconc it))) | |
| 1116 (delete-duplicates results :test #'equal))) | |
| 428 | 1117 |
| 872 | 1118 ;; Frob INST-LIST, which came from LOCALE, and put the new value back |
| 1119 ;; into SP at LOCALE. THUNK is a cons of (PROP . DEVTYPE-SPEC), the | |
| 1120 ;; property being processed and whether this is a TTY property or a | |
| 1121 ;; win property. | |
| 1122 (frob-locale (sp locale inst-list thunk) | |
| 1123 (let ((newinst (frob-face-inst-list locale inst-list | |
| 1124 (car thunk) (cdr thunk)))) | |
| 1125 (remove-specifier sp locale tag-set exact-p) | |
| 1126 (add-spec-list-to-specifier sp (list (cons locale newinst)))) | |
| 1127 ;; map-specifier should keep going | |
| 1128 nil) | |
| 428 | 1129 |
| 872 | 1130 ;; map over all specified locales in LOCALE; for each locale, |
| 1131 ;; frob the instantiators in that locale in the specifier in both | |
| 1132 ;; WIN-PROP and TTY-PROPS in FACE. Takes values from environment. | |
| 1133 (map-over-locales (locale) | |
| 1134 (map-specifier (get face win-prop) #'frob-locale locale | |
| 1135 (cons win-prop 'window-system) | |
| 1136 tag-set exact-p) | |
| 1137 (loop for prop in tty-props do | |
| 1138 (map-specifier (get face prop) #'frob-locale locale | |
| 1139 (cons prop 'tty) | |
| 1140 tag-set exact-p))) | |
| 1141 | |
|
5567
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5484
diff
changeset
|
1142 ;; end of labels |
| 872 | 1143 ) |
| 1144 | |
|
5576
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5567
diff
changeset
|
1145 (declare (inline global-locale nil-instantiator-ok)) |
| 872 | 1146 ;; the function itself |
| 452 | 1147 |
| 872 | 1148 (let* ((ffpdev Face-frob-property-device-considered-current) |
| 1149 (do-later-stages | |
| 1150 (or (global-locale locale) | |
| 1151 (valid-specifier-domain-p locale) | |
| 1152 (bufferp locale))) | |
| 1153 (domain (and do-later-stages | |
| 1154 (derive-domain-from-locale locale 'window-system | |
| 1155 ffpdev))) | |
| 1156 (check-differences | |
| 1157 (and unfrobbed-face frobbed-face domain | |
| 1158 (not (memq (face-name face) | |
| 1159 '(default bold italic bold-italic))))) | |
| 1160 (orig-instance | |
| 1161 (and check-differences | |
| 1162 (face-property-instance face win-prop domain)))) | |
| 1163 | |
| 1164 ;; first do the frobbing | |
| 1165 (setq face (get-face face)) | |
| 1166 (map-over-locales locale) | |
| 1167 | |
| 1168 (when do-later-stages | |
| 1169 | |
| 1170 (if (global-locale locale) (setq locale 'global)) | |
| 428 | 1171 |
| 872 | 1172 ;; now do the second stage -- if there's nothing there, try |
| 1173 ;; harder to find an instantiator, and frob it. | |
| 1174 (let (do-something) | |
| 1175 (loop for prop in (cons win-prop tty-props) | |
| 1176 for propspec = (get face prop) | |
| 1177 for devtype-spec = (if (eq prop win-prop) 'window-system 'tty) | |
| 1178 if propspec | |
| 1179 do | |
| 1180 (or (specifier-spec-list propspec locale) | |
| 1181 (let ((doit (derive-specifier-specs-from-locale | |
| 1182 propspec locale devtype-spec ffpdev | |
| 1183 ;; #### does this make sense? When no tags | |
| 1184 ;; given, frob the whole list of fallbacks when | |
| 1185 ;; global, else just retrieve a current-device | |
| 1186 ;; value. this tries to mirror normal practices, | |
| 1187 ;; where with no tags you want everything frobbed, | |
| 1188 ;; but with a tag you want only the tag frobbed | |
| 1189 ;; and hence you probably don't want lots and lots | |
| 1190 ;; of items there. (#### Perhaps the best way -- | |
| 1191 ;; or at least a way with some theoretical | |
| 1192 ;; justifiability -- is to fetch the fallbacks | |
| 1193 ;; that match the TAG-SET/EXACT-P, and if none, | |
| 1194 ;; fall back onto doing the selected-device | |
| 1195 ;; trick.) | |
| 1196 (and (not tag-set) (not exact-p))))) | |
| 1197 (if (and (not doit) (eq locale 'global)) | |
| 1198 (error | |
| 1199 "No fallback for specifier property %s in face %s???" | |
| 1200 prop face)) | |
| 1201 ;; [note 1] whenever we add to a tty property, | |
| 1202 ;; make sure we tag our additions with `tty' to | |
| 1203 ;; avoid accidentally messing things up on window | |
| 1204 ;; systems (e.g. when making things italic we | |
| 1205 ;; don't want to set the underline property on | |
| 1206 ;; window systems) | |
| 1207 (when doit | |
| 1208 (add-spec-list-to-specifier | |
| 1209 propspec | |
| 1210 (list (cons locale | |
| 1211 (add-tag-to-inst-list | |
| 1212 doit | |
| 1213 (append (if (listp tag-set) tag-set | |
| 1214 (list tag-set)) | |
| 1215 (if (eq devtype-spec 'tty) '(tty))) | |
| 1216 )))) | |
| 1217 (setq do-something t))))) | |
| 1218 (when do-something | |
| 1219 (map-over-locales (or (global-locale locale) locale)))) | |
| 1220 | |
| 1221 ;; then do the third stage -- check for whether we have to do | |
| 1222 ;; the inheritance trick. | |
| 1223 | |
| 1224 (when (and check-differences | |
| 1225 (let ((new-instance | |
| 1226 (face-property-instance face win-prop domain))) | |
| 1227 (and | |
| 1228 (equal orig-instance new-instance) | |
| 1229 (equal orig-instance | |
| 1230 (face-property-instance unfrobbed-face win-prop | |
| 1231 domain))))) | |
| 1232 (set-face-property face win-prop (vector frobbed-face) | |
| 1233 (or (global-locale locale) locale) tag-set)))))) | |
| 428 | 1234 |
| 707 | 1235 ;; WE DEMAND FOUNDRY FROBBING! |
| 1236 | |
| 1237 ;; Family frobbing | |
| 1238 ;; Thx Jan Vroonhof, Ref xemacs-beta <87oflypbum.fsf@petteflet.ntlworld.com> | |
| 1239 ;; Brainlessly derived from make-face-size by Stephen; don't blame Jan. | |
| 1240 ;; I'm long since flown to Rio, it does you little good to blame me, either. | |
| 872 | 1241 (defun make-face-family (face family &optional locale tags exact-p) |
| 1242 "Set FACE's family to FAMILY in LOCALE, if possible." | |
| 1243 (interactive (list (read-face-name "Set family of which face: ") | |
| 1244 (read-string "Family to set: "))) | |
| 707 | 1245 |
| 872 | 1246 (Face-frob-property face locale tags exact-p |
| 1247 nil nil 'font nil | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1248 ;; #### this code is duplicated in make-face-size |
| 872 | 1249 `(lambda (f d) |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1250 ;; keep the dependency on font.el for now |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1251 ;; #### The filter on null d is a band-aid. |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1252 ;; Frob-face-property should not be passing in |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1253 ;; null devices. |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1254 (unless (or (null d) (eq d 'tty)) |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1255 (let ((fo (font-create-object f d))) |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1256 (set-font-family fo ,family) |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1257 (font-create-name fo d)))) |
| 872 | 1258 nil)) |
| 707 | 1259 |
| 1260 ;; Style (ie, typographical face) frobbing | |
| 872 | 1261 (defun make-face-bold (face &optional locale tags exact-p) |
| 428 | 1262 "Make FACE bold in LOCALE, if possible. |
| 872 | 1263 This will attempt to make the font bold for window-system locales and will |
| 1264 set the highlight flag for TTY locales. | |
| 1265 | |
| 1266 The actual behavior of this function is somewhat messy, in an attempt to | |
| 1267 get more intuitive behavior in quite a lot of different circumstances. (You | |
| 1268 might view this as indicative of design failures with specifiers, but in | |
| 1269 fact almost all code that attempts to interface to humans and produce | |
| 1270 \"intuitive\" results gets messy, particularly with a system as complicated | |
| 1271 as specifiers, whose complexity results from an attempt to work well in | |
| 1272 many different circumstances.) | |
| 1273 | |
| 1274 The meaning of LOCALE is the same as for `specifier-spec-list', i.e.: | |
| 1275 | |
| 1276 -- If LOCALE is nil, omitted, or `all', this will attempt to \"frob\" all | |
| 1277 font specifications for FACE to make them appear bold (i.e. the | |
| 1278 specifications are replaced with equivalent specifications, where the | |
| 1279 font names have been changed to the closest bold font). | |
| 1280 | |
| 1281 -- If LOCALE is a locale type \(`buffer', `window', etc.), this frobs all | |
| 1282 font specifications for locales of that type. | |
| 1283 | |
| 1284 -- If LOCALE is a particular locale, this frobs all font specifications for | |
| 1285 that locale. | |
| 428 | 1286 |
| 872 | 1287 If TAGS is given, this only processes instantiators whose tag set includes |
| 1288 all tags mentioned in TAGS. In addition, if EXACT-P is non-nil, only | |
| 1289 instantiators whose tag set exactly matches TAGS are processed; otherwise, | |
| 1290 additional tags may be present in the instantiator's tag set. | |
| 1291 | |
| 1292 This function proceeeds in three stages. | |
| 1293 | |
| 1294 STAGE 1: Frob the settings that are already present. | |
| 1295 STAGE 2: (if called for) Ensure that *some* setting exists in the locale | |
| 1296 that was given, finding it in various ways and frobbing it as in | |
| 1297 stage 1. This ensures that there is an actual setting for | |
| 1298 the locale, so you will get the expected buffer-local/frame-local | |
| 1299 behavior -- changes to the global value, to other locales, won't | |
| 1300 affect this locale, (b) the face will actually look bold in | |
| 1301 the locale. | |
| 1137 | 1302 STAGE 3: (if called for) |
| 872 | 1303 |
| 1304 The way the frobbing works depends on the device type -- first on whether | |
| 1305 or not it's TTY, and second, if it's a window-system device type, on which | |
| 1306 particular window-system device type. For locales with a specific device | |
| 1307 type, we do the frobbing in the context of that device type -- this means | |
| 1308 that for TTY device types we set the highlight flag, and for window-system | |
| 1309 device types we modify the font spec according to the rules for font specs | |
| 1310 of that device type. For global locales, we may process both the highlight | |
| 1311 flag and the font specs (depending on the device types compiled into this | |
| 1312 XEmacs). When processing font specs, we check the tag set associated with | |
| 1313 each font spec to see if it's specific to a particular device type; if so, | |
| 1314 we frob it in the context of that type, else we use the type of the current | |
| 1315 device. (A hack, but works well in practice -- and if a new device is | |
| 1316 created, we will automatically frob all the standard fonts to make sure | |
| 1317 they display OK on that device.) | |
| 1318 | |
| 1319 If LOCALE is not a locale type, and both TAGS and EXACT-P are omitted, we | |
| 1320 do further frobbing in an attempt to give more intuitive behavior. | |
| 428 | 1321 |
| 872 | 1322 First, if there are no specifications in LOCALE (if LOCALE is `all', we act |
| 1323 as if it were `global' for this step), we do our utmost to put a | |
| 1324 specification there; otherwise, this function will have no effect. For | |
| 1325 device, frame, or window locales, the face's font is instantiated using the | |
| 1326 locale as a domain, and the resulting font is frobbed and added back as a | |
| 1327 specification for this locale. If LOCALE is `global', we retrieve the | |
| 1328 fallback specs and frob them. If LOCALE is a buffer, things get tricky | |
| 1329 since you can't instantiate a specifier in a buffer domain \(the buffer can | |
| 1330 appear in multiple places, or in different places over time, so this | |
| 1331 operation is not well-defined). We used to signal an error in this case, | |
| 1332 but now we instead try to do something logical so that we work somewhat | |
| 1333 similarly to buffer-local variables. Specifically, we use | |
| 1334 `get-buffer-window' to find a window viewing the buffer, and if there is | |
| 1335 one, use this as a domain to instantiate the font, and frob the resulting | |
| 1336 value. Otherwise, we use the selected window for the same purpose. | |
| 1337 | |
| 1338 Finally, if the frobbing didn't actually make the font look any different | |
| 1339 in whatever domain we instantiated the font in (this happens, for example, | |
| 1340 if your font specification is already bold or has no bold equivalent; note | |
| 1341 that in this step, we use the selected device in place of `global' or `all' | |
| 1342 -- another hack, but works well in practice since there's usually only one | |
| 1343 device), and the font currently looks like the font of the `default' face, | |
| 1344 it is set to inherit from the `bold' face. | |
| 1345 | |
| 1346 NOTE: For the other functions defined below, the identity of these two | |
| 1347 standard faces mentioned in the previous paragraph, and the TTY properties | |
| 1348 that are modified, may be different, and whether the TTY property or | |
| 1349 properties are set or unset may be different. For example, for | |
| 1350 `make-face-unitalic', the last sentence in the previous paragraph would | |
| 1351 read \"... and the font currently looks like the font of the `italic' face, | |
| 1352 it is set to inherit from the `default' face.\", and the second sentence in | |
| 1353 the first paragraph would read \"This will attempt to make the font | |
| 1354 non-italic for window-system locales and will unset the underline flag for | |
| 1355 TTY locales.\" | |
| 1356 | |
| 1357 Here's a table indicating the behavior differences with the different | |
| 1358 functions: | |
| 1359 | |
| 1360 function face1 face2 tty-props tty-val | |
| 1361 ---------------------------------------------------------------------------- | |
| 1362 make-face-bold default bold highlight t | |
| 1363 make-face-italic default italic underline t | |
| 1364 make-face-bold-italic default bold-italic highlight,underline t | |
| 1365 make-face-unbold bold default highlight nil | |
| 1366 make-face-unitalic italic default underline nil | |
| 1367 " | |
| 428 | 1368 (interactive (list (read-face-name "Make which face bold: "))) |
| 872 | 1369 (Face-frob-property face locale tags exact-p |
| 1370 'default 'bold 'font '(highlight) | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1371 '(tty (lambda (f d) t) |
| 872 | 1372 x x-make-font-bold |
| 1373 gtk gtk-make-font-bold | |
| 1374 mswindows mswindows-make-font-bold | |
| 1375 msprinter mswindows-make-font-bold) | |
| 1376 '(([default] . [bold]) | |
| 1377 ([bold] . t) | |
| 1378 ([italic] . [bold-italic]) | |
| 1379 ([bold-italic] . t)))) | |
| 428 | 1380 |
| 872 | 1381 (defun make-face-italic (face &optional locale tags exact-p) |
| 428 | 1382 "Make FACE italic in LOCALE, if possible. |
| 442 | 1383 This will attempt to make the font italic for X/MS Windows locales and |
| 1384 will set the underline flag for TTY locales. See `make-face-bold' for | |
| 1385 the semantics of the LOCALE argument and for more specifics on exactly | |
| 1386 how this function works." | |
| 428 | 1387 (interactive (list (read-face-name "Make which face italic: "))) |
| 872 | 1388 (Face-frob-property face locale tags exact-p |
| 1389 'default 'italic 'font '(underline) | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1390 '(tty (lambda (f d) t) |
| 872 | 1391 x x-make-font-italic |
| 1392 gtk gtk-make-font-italic | |
| 1393 mswindows mswindows-make-font-italic | |
| 1394 msprinter mswindows-make-font-italic) | |
| 1395 '(([default] . [italic]) | |
| 1396 ([bold] . [bold-italic]) | |
| 1397 ([italic] . t) | |
| 1398 ([bold-italic] . t)))) | |
| 428 | 1399 |
| 872 | 1400 (defun make-face-bold-italic (face &optional locale tags exact-p) |
| 428 | 1401 "Make FACE bold and italic in LOCALE, if possible. |
| 442 | 1402 This will attempt to make the font bold-italic for X/MS Windows |
| 1403 locales and will set the highlight and underline flags for TTY | |
| 1404 locales. See `make-face-bold' for the semantics of the LOCALE | |
| 1405 argument and for more specifics on exactly how this function works." | |
| 428 | 1406 (interactive (list (read-face-name "Make which face bold-italic: "))) |
| 872 | 1407 (Face-frob-property face locale tags exact-p |
| 1408 'default 'bold-italic 'font '(underline highlight) | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1409 '(tty (lambda (f d) t) |
| 872 | 1410 x x-make-font-bold-italic |
| 1411 gtk gtk-make-font-bold-italic | |
| 1412 mswindows mswindows-make-font-bold-italic | |
| 1413 msprinter mswindows-make-font-bold-italic) | |
| 1414 '(([default] . [italic]) | |
| 1415 ([bold] . [bold-italic]) | |
| 1416 ([italic] . [bold-italic]) | |
| 1417 ([bold-italic] . t)))) | |
| 428 | 1418 |
| 872 | 1419 |
| 1420 (defun make-face-unbold (face &optional locale tags exact-p) | |
| 428 | 1421 "Make FACE non-bold in LOCALE, if possible. |
| 442 | 1422 This will attempt to make the font non-bold for X/MS Windows locales |
| 1423 and will unset the highlight flag for TTY locales. See | |
| 1424 `make-face-bold' for the semantics of the LOCALE argument and for more | |
| 1425 specifics on exactly how this function works." | |
| 428 | 1426 (interactive (list (read-face-name "Make which face non-bold: "))) |
| 872 | 1427 (Face-frob-property face locale tags exact-p |
| 1428 'bold 'default 'font '(highlight) | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1429 '(tty (lambda (f d) nil) |
| 872 | 1430 x x-make-font-unbold |
| 1431 gtk gtk-make-font-unbold | |
| 1432 mswindows mswindows-make-font-unbold | |
| 1433 msprinter mswindows-make-font-unbold) | |
| 1434 '(([default] . t) | |
| 1435 ([bold] . [default]) | |
| 1436 ([italic] . t) | |
| 1437 ([bold-italic] . [italic])))) | |
| 428 | 1438 |
| 872 | 1439 (defun make-face-unitalic (face &optional locale tags exact-p) |
| 428 | 1440 "Make FACE non-italic in LOCALE, if possible. |
| 442 | 1441 This will attempt to make the font non-italic for X/MS Windows locales |
| 1442 and will unset the underline flag for TTY locales. See | |
| 1443 `make-face-bold' for the semantics of the LOCALE argument and for more | |
| 1444 specifics on exactly how this function works." | |
| 428 | 1445 (interactive (list (read-face-name "Make which face non-italic: "))) |
| 872 | 1446 (Face-frob-property face locale tags exact-p |
| 1447 'italic 'default 'font '(underline) | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1448 '(tty (lambda (f d) nil) |
| 872 | 1449 x x-make-font-unitalic |
| 1450 gtk gtk-make-font-unitalic | |
| 1451 mswindows mswindows-make-font-unitalic | |
| 1452 msprinter mswindows-make-font-unitalic) | |
| 1453 '(([default] . t) | |
| 1454 ([bold] . t) | |
| 1455 ([italic] . [default]) | |
| 1456 ([bold-italic] . [bold])))) | |
| 428 | 1457 |
| 1458 | |
| 707 | 1459 ;; Size frobbing |
| 1460 ;; Thx Jan Vroonhof, Ref xemacs-beta <87oflypbum.fsf@petteflet.ntlworld.com> | |
| 1137 | 1461 ;; Jan had a separate helper function |
| 872 | 1462 (defun make-face-size (face size &optional locale tags exact-p) |
| 1463 "Adjust FACE to SIZE in LOCALE, if possible." | |
| 1464 (interactive (list (read-face-name "Set size of which face: ") | |
| 1465 (read-number "Size to set: " t 10))) | |
| 1466 (Face-frob-property face locale tags exact-p | |
| 1467 nil nil 'font nil | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1468 ;; #### this code is duplicated in make-face-family |
| 872 | 1469 `(lambda (f d) |
| 1470 ;; keep the dependency on font.el for now | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1471 ;; #### The filter on null d is a band-aid. |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1472 ;; Frob-face-property should not be passing in |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1473 ;; null devices. |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1474 (unless (or (null d) (eq d 'tty)) |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1475 (let ((fo (font-create-object f d))) |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1476 (set-font-size fo ,size) |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1477 (font-create-name fo d)))) |
| 872 | 1478 nil)) |
| 707 | 1479 |
| 428 | 1480 ;; Why do the following two functions lose so badly in so many |
| 1481 ;; circumstances? | |
| 1482 | |
| 872 | 1483 (defun make-face-smaller (face &optional locale tags exact-p) |
| 428 | 1484 "Make the font of FACE be smaller, if possible. |
| 1485 LOCALE works as in `make-face-bold' et al., but the ``inheriting- | |
| 1486 from-the-bold-face'' operations described there are not done | |
| 1487 because they don't make sense in this context." | |
| 1488 (interactive (list (read-face-name "Shrink which face: "))) | |
| 872 | 1489 (Face-frob-property face locale tags exact-p |
| 1490 nil nil 'font nil | |
| 1491 '(x x-find-smaller-font | |
| 1492 gtk gtk-find-smaller-font | |
| 1493 mswindows mswindows-find-smaller-font | |
| 1494 msprinter mswindows-find-smaller-font) | |
| 1495 nil)) | |
| 428 | 1496 |
| 872 | 1497 (defun make-face-larger (face &optional locale tags exact-p) |
| 428 | 1498 "Make the font of FACE be larger, if possible. |
| 1499 See `make-face-smaller' for the semantics of the LOCALE argument." | |
| 1500 (interactive (list (read-face-name "Enlarge which face: "))) | |
| 872 | 1501 (Face-frob-property face locale tags exact-p |
| 1502 nil nil 'font nil | |
| 1503 '(x x-find-larger-font | |
| 1504 gtk gtk-find-larger-font | |
| 1505 mswindows mswindows-find-larger-font | |
| 1506 msprinter mswindows-find-larger-font) | |
| 1507 nil)) | |
| 428 | 1508 |
| 1509 (defun invert-face (face &optional locale) | |
| 1510 "Swap the foreground and background colors of the face." | |
| 1511 (interactive (list (read-face-name "Invert face: "))) | |
| 1512 (if (valid-specifier-domain-p locale) | |
| 1513 (let ((foreface (face-foreground-instance face locale))) | |
| 1514 (set-face-foreground face (face-background-instance face locale) | |
| 1515 locale) | |
| 1516 (set-face-background face foreface locale)) | |
| 1517 (let ((forespec (copy-specifier (face-foreground face) nil locale))) | |
| 1518 (copy-specifier (face-background face) (face-foreground face) locale) | |
| 1519 (copy-specifier forespec (face-background face) locale)))) | |
| 1520 | |
| 1521 | |
| 1522 ;;; Convenience functions | |
| 1523 | |
| 1524 (defun face-ascent (face &optional domain charset) | |
| 1525 "Return the ascent of FACE in DOMAIN. | |
| 1526 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 1527 (font-ascent (face-font face) domain charset)) | |
| 1528 | |
| 1529 (defun face-descent (face &optional domain charset) | |
| 1530 "Return the descent of FACE in DOMAIN. | |
| 1531 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 1532 (font-descent (face-font face) domain charset)) | |
| 1533 | |
| 1534 (defun face-width (face &optional domain charset) | |
| 1535 "Return the width of FACE in DOMAIN. | |
| 1536 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 1537 (font-width (face-font face) domain charset)) | |
| 1538 | |
| 1539 (defun face-height (face &optional domain charset) | |
| 1540 "Return the height of FACE in DOMAIN. | |
| 1541 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 1542 (+ (face-ascent face domain charset) (face-descent face domain charset))) | |
| 1543 | |
| 1544 (defun face-proportional-p (face &optional domain charset) | |
| 1545 "Return t if FACE is proportional in DOMAIN. | |
| 1546 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 1547 (font-proportional-p (face-font face) domain charset)) | |
| 1548 | |
| 1549 | |
| 1550 ;; Functions that used to be in cus-face.el, but logically go here. | |
| 1551 | |
| 1552 (defcustom frame-background-mode nil | |
| 1553 "*The brightness of the background. | |
| 1554 Set this to the symbol dark if your background color is dark, light if | |
| 1555 your background is light, or nil (default) if you want Emacs to | |
| 1556 examine the brightness for you." | |
| 1557 :group 'faces | |
| 1558 :type '(choice (choice-item dark) | |
| 1559 (choice-item light) | |
| 1560 (choice-item :tag "Auto" nil))) | |
| 1561 | |
| 1562 ;; The old variable that many people still have in .emacs files. | |
| 1563 (define-obsolete-variable-alias 'custom-background-mode | |
| 1564 'frame-background-mode) | |
| 1565 | |
| 1566 (defun get-frame-background-mode (frame) | |
| 1567 "Detect background mode for FRAME." | |
| 1568 (let* ((color-instance (face-background-instance 'default frame)) | |
| 1569 (mode (condition-case nil | |
| 1570 (if (< (apply '+ (color-instance-rgb-components | |
| 1571 color-instance)) 65536) | |
| 1572 'dark 'light) | |
| 872 | 1573 ;; Here, we get an error on a TTY (Return value from |
| 1574 ;; color-instance-rgb-components is nil), and on the | |
| 1575 ;; initial stream device (Return value from | |
| 1576 ;; face-background-instance is nil). As we don't have a | |
| 1577 ;; good way of detecting whether a TTY is light or dark, | |
| 1578 ;; we'll guess it's dark. | |
| 428 | 1579 (error 'dark)))) |
| 1580 (set-frame-property frame 'background-mode mode) | |
| 1581 mode)) | |
| 1582 | |
| 1583 (defun extract-custom-frame-properties (frame) | |
| 1584 "Return a plist with the frame properties of FRAME used by custom." | |
| 1585 (list 'type (or (frame-property frame 'display-type) | |
| 1586 (device-type (frame-device frame))) | |
| 1587 'class (device-class (frame-device frame)) | |
| 1588 'background (or frame-background-mode | |
| 1589 (frame-property frame 'background-mode) | |
| 1590 (get-frame-background-mode frame)))) | |
| 1591 | |
| 1592 (defcustom init-face-from-resources t | |
| 1593 "If non nil, attempt to initialize faces from the resource database." | |
| 1594 :group 'faces | |
| 1595 :type 'boolean) | |
| 1596 | |
| 1597 ;; Old name, used by custom. Also, FSFmacs name. | |
| 1598 (defvaralias 'initialize-face-resources 'init-face-from-resources) | |
| 1599 | |
| 1600 ;; Make sure all custom setting are added with this tag so we can | |
| 1601 ;; identify-them | |
| 1602 (define-specifier-tag 'custom) | |
| 1603 | |
| 1604 (defun face-spec-set (face spec &optional frame tags) | |
| 1605 "Set FACE's face attributes according to the first matching entry in SPEC. | |
| 1606 If optional FRAME is non-nil, set it for that frame only. | |
| 1607 If it is nil, then apply SPEC to each frame individually. | |
| 1608 See `defface' for information about SPEC." | |
| 1609 (if frame | |
| 1610 (progn | |
| 1611 (reset-face face frame tags) | |
| 1612 (face-display-set face spec frame tags) | |
| 1613 (init-face-from-resources face frame)) | |
| 1614 (let ((frames (relevant-custom-frames))) | |
| 1615 (reset-face face nil tags) | |
| 1616 ;; This should not be needed. We only remove our own specifiers | |
| 1617 ;; (if (and (eq 'default face) (featurep 'x)) | |
| 1618 ;; (x-init-global-faces)) | |
| 1619 (face-display-set face spec nil tags) | |
| 1620 (while frames | |
| 1621 (face-display-set face spec (car frames) tags) | |
| 1622 (pop frames)) | |
| 1623 (init-face-from-resources face)))) | |
| 1624 | |
| 1625 (defun face-display-set (face spec &optional frame tags) | |
| 1626 "Set FACE to the attributes to the first matching entry in SPEC. | |
| 1627 Iff optional FRAME is non-nil, set it for that frame only. | |
| 1628 See `defface' for information about SPEC." | |
| 1629 (while spec | |
| 1630 (let ((display (caar spec)) | |
| 1631 (atts (cadar spec))) | |
| 1632 (pop spec) | |
| 1633 (when (face-spec-set-match-display display frame) | |
| 1634 ;; Avoid creating frame local duplicates of the global face. | |
| 1635 (unless (and frame (eq display (get face 'custom-face-display))) | |
| 1636 (apply 'face-custom-attributes-set face frame tags atts)) | |
| 1637 (unless frame | |
| 1638 (put face 'custom-face-display display)) | |
| 1639 (setq spec nil))))) | |
| 1640 | |
| 1641 (defvar default-custom-frame-properties nil | |
| 1642 "The frame properties used for the global faces. | |
| 442 | 1643 Frames not matching these properties should have frame local faces. |
| 428 | 1644 The value should be nil, if uninitialized, or a plist otherwise. |
| 1645 See `defface' for a list of valid keys and values for the plist.") | |
| 1646 | |
| 1647 (defun get-custom-frame-properties (&optional frame) | |
| 1648 "Return a plist with the frame properties of FRAME used by custom. | |
| 1649 If FRAME is nil, return the default frame properties." | |
| 1650 (cond (frame | |
| 1651 ;; Try to get from cache. | |
| 1652 (let ((cache (frame-property frame 'custom-properties))) | |
| 1653 (unless cache | |
| 1654 ;; Oh well, get it then. | |
| 1655 (setq cache (extract-custom-frame-properties frame)) | |
| 1656 ;; and cache it... | |
| 1657 (set-frame-property frame 'custom-properties cache)) | |
| 1658 cache)) | |
| 1659 (default-custom-frame-properties) | |
| 1660 (t | |
| 1661 (setq default-custom-frame-properties | |
| 1662 (extract-custom-frame-properties (selected-frame)))))) | |
| 1663 | |
| 1664 (defun face-spec-update-all-matching (spec display plist) | |
| 1665 "Update all entries in the face spec that could match display to | |
| 444 | 1666 have the entries from the new plist and return the new spec." |
| 428 | 1667 (mapcar |
| 1668 (lambda (e) | |
| 1669 (let ((entries (car e)) | |
| 1670 (options (cadr e)) | |
| 1671 (match t) | |
| 1672 dplist | |
| 1673 (new-options plist) | |
| 1674 ) | |
| 1675 (unless (eq display t) | |
| 1676 (mapc (lambda (arg) | |
| 1677 (setq dplist (plist-put dplist (car arg) (cadr arg)))) | |
| 1678 display)) | |
| 1679 (unless (eq entries t) | |
| 1680 (mapc (lambda (arg) | |
| 1681 (setq match (and match (eq (cadr arg) | |
| 1682 (plist-get | |
| 1683 dplist (car arg) | |
| 1684 (cadr arg)))))) | |
| 1685 entries)) | |
| 1686 (if (not match) | |
| 1687 e | |
| 1688 (while new-options | |
| 1689 (setq options | |
| 1690 (plist-put options (car new-options) (cadr new-options))) | |
| 1691 (setq new-options (cddr new-options))) | |
| 1692 (list entries options)))) | |
| 1693 (copy-sequence spec))) | |
| 444 | 1694 |
| 1695 | |
| 428 | 1696 |
| 1697 (defun face-spec-set-match-display (display &optional frame) | |
| 1698 "Return non-nil if DISPLAY matches FRAME. | |
| 1699 DISPLAY is part of a spec such as can be used in `defface'. | |
| 1700 If FRAME is nil or omitted, the selected frame is used." | |
| 1701 (if (eq display t) | |
| 1702 t | |
| 1703 (let* ((props (get-custom-frame-properties frame)) | |
| 1704 (type (plist-get props 'type)) | |
| 1705 (class (plist-get props 'class)) | |
| 1706 (background (plist-get props 'background)) | |
| 1707 (match t) | |
| 1708 (entries display) | |
| 1709 entry req options) | |
| 1710 (while (and entries match) | |
| 1711 (setq entry (car entries) | |
| 1712 entries (cdr entries) | |
| 1713 req (car entry) | |
| 1714 options (cdr entry) | |
| 1715 match (case req | |
| 1716 (type (memq type options)) | |
| 1717 (class (memq class options)) | |
| 1718 (background (memq background options)) | |
|
5378
4f0a1f4cc111
Improve support for min-colors req in `defface'.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5373
diff
changeset
|
1719 ;; `display-color-cells' can return nil (eg, TTYs). |
|
4f0a1f4cc111
Improve support for min-colors req in `defface'.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5373
diff
changeset
|
1720 ;; If so, assume monochrome. |
|
4f0a1f4cc111
Improve support for min-colors req in `defface'.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5373
diff
changeset
|
1721 (min-colors (>= (or (display-color-cells frame) 2) |
|
5373
b6e59ea11533
Add min-colors specifier to defface, and document it.
Jeff Sparkes <jsparkes@gmail.com>
parents:
5368
diff
changeset
|
1722 (car options))) |
| 428 | 1723 (t (warn "Unknown req `%S' with options `%S'" |
| 1724 req options) | |
| 1725 nil)))) | |
| 1726 match))) | |
| 1727 | |
| 1728 (defun relevant-custom-frames () | |
| 1729 "List of frames whose custom properties differ from the default." | |
| 1730 (let ((relevant nil) | |
| 1731 (default (get-custom-frame-properties)) | |
| 1732 (frames (frame-list)) | |
| 1733 frame) | |
| 1734 (while frames | |
| 1735 (setq frame (car frames) | |
| 1736 frames (cdr frames)) | |
| 1737 (unless (equal default (get-custom-frame-properties frame)) | |
| 1738 (push frame relevant))) | |
| 1739 relevant)) | |
| 1740 | |
| 1741 (defun initialize-custom-faces (&optional frame) | |
| 1742 "Initialize all custom faces for FRAME. | |
| 1743 If FRAME is nil or omitted, initialize them for all frames." | |
| 1744 (mapc (lambda (symbol) | |
| 1745 (let ((spec (or (get symbol 'saved-face) | |
| 1746 (get symbol 'face-defface-spec)))) | |
| 1747 (when spec | |
| 1748 ;; No need to init-face-from-resources -- code in | |
| 1749 ;; `init-frame-faces' does it already. | |
| 1750 (face-display-set symbol spec frame)))) | |
| 1751 (face-list))) | |
| 1752 | |
| 1753 (defun custom-initialize-frame (frame) | |
| 1754 "Initialize frame-local custom faces for FRAME if necessary." | |
| 1755 (unless (equal (get-custom-frame-properties) | |
| 1756 (get-custom-frame-properties frame)) | |
| 1757 (initialize-custom-faces frame))) | |
| 1758 | |
| 440 | 1759 (defun startup-initialize-custom-faces () |
| 1760 "Reset faces created by defface. Only called at startup. | |
| 1761 Don't use this function in your program." | |
| 1762 (when default-custom-frame-properties | |
| 1763 ;; Reset default value to the actual frame, not stream. | |
| 1764 (setq default-custom-frame-properties | |
| 1765 (extract-custom-frame-properties (selected-frame))) | |
| 1766 ;; like initialize-custom-faces but removes property first. | |
| 1767 (mapc (lambda (symbol) | |
| 1768 (let ((spec (or (get symbol 'saved-face) | |
| 1769 (get symbol 'face-defface-spec)))) | |
| 1770 (when spec | |
| 1771 ;; Reset faces created during auto-autoloads loading. | |
| 1772 (reset-face symbol) | |
| 1773 ;; And set it according to the spec. | |
| 1774 (face-display-set symbol spec nil)))) | |
| 1775 (face-list)))) | |
| 1776 | |
| 428 | 1777 |
| 1778 (defun make-empty-face (name &optional doc-string temporary) | |
| 1779 "Like `make-face', but doesn't query the resource database." | |
| 1780 (let ((init-face-from-resources nil)) | |
| 1781 (make-face name doc-string temporary))) | |
| 1782 | |
| 1783 (defun init-face-from-resources (face &optional locale) | |
| 1784 "Initialize FACE from the resource database. | |
| 3027 | 1785 If LOCALE is specified, it should be a frame, device, or `global', and |
| 428 | 1786 the face will be resourced over that locale. Otherwise, the face will |
| 1787 be resourced over all possible locales (i.e. all frames, all devices, | |
| 3027 | 1788 and `global')." |
| 428 | 1789 (cond ((null init-face-from-resources) |
| 1790 ;; Do nothing. | |
| 1791 ) | |
| 1792 ((not locale) | |
| 1793 ;; Global, set for all frames. | |
| 1794 (progn | |
| 1795 (init-face-from-resources face 'global) | |
| 1796 (let ((devices (device-list))) | |
| 1797 (while devices | |
| 1798 (init-face-from-resources face (car devices)) | |
| 1799 (setq devices (cdr devices)))) | |
| 1800 (let ((frames (frame-list))) | |
| 1801 (while frames | |
| 1802 (init-face-from-resources face (car frames)) | |
| 1803 (setq frames (cdr frames)))))) | |
| 1804 (t | |
| 1805 ;; Specific. | |
| 1806 (let ((devtype (cond ((devicep locale) (device-type locale)) | |
| 1807 ((framep locale) (frame-type locale)) | |
| 1808 (t nil)))) | |
| 1809 (cond ((or (and (not devtype) (featurep 'x)) (eq 'x devtype)) | |
| 502 | 1810 (declare-fboundp (x-init-face-from-resources face locale))) |
| 428 | 1811 ((or (not devtype) (eq 'tty devtype)) |
| 1812 ;; Nothing to do for TTYs? | |
| 1813 )))))) | |
| 1814 | |
| 1815 (defun init-device-faces (device) | |
| 1816 ;; First, add any device-local face resources. | |
| 1817 (when init-face-from-resources | |
| 1818 (loop for face in (face-list) do | |
| 1819 (init-face-from-resources face device)) | |
| 1820 ;; Then do any device-specific initialization. | |
| 1821 (cond ((eq 'x (device-type device)) | |
| 502 | 1822 (declare-fboundp (x-init-device-faces device))) |
| 462 | 1823 ((eq 'gtk (device-type device)) |
| 502 | 1824 (declare-fboundp (gtk-init-device-faces device))) |
| 428 | 1825 ((eq 'mswindows (device-type device)) |
| 502 | 1826 (declare-fboundp (mswindows-init-device-faces device))) |
| 428 | 1827 ;; Nothing to do for TTYs? |
| 1828 ) | |
| 1829 (or (eq 'stream (device-type device)) | |
| 1830 (init-other-random-faces device)))) | |
| 1831 | |
| 1832 (defun init-frame-faces (frame) | |
| 1833 (when init-face-from-resources | |
| 1834 ;; First, add any frame-local face resources. | |
| 1835 (loop for face in (face-list) do | |
| 1836 (init-face-from-resources face frame)) | |
| 1837 ;; Then do any frame-specific initialization. | |
| 1838 (cond ((eq 'x (frame-type frame)) | |
| 502 | 1839 (declare-fboundp (x-init-frame-faces frame))) |
| 462 | 1840 ((eq 'gtk (frame-type frame)) |
| 502 | 1841 (declare-fboundp (gtk-init-frame-faces frame))) |
| 428 | 1842 ((eq 'mswindows (frame-type frame)) |
| 502 | 1843 (declare-fboundp (mswindows-init-frame-faces frame))) |
| 428 | 1844 ;; Is there anything which should be done for TTY's? |
| 1845 ))) | |
| 1846 | |
| 872 | 1847 ;; Called when the first device created. |
| 428 | 1848 |
| 872 | 1849 (defun init-global-faces (device) |
| 1850 (let ((Face-frob-property-device-considered-current device)) | |
| 1851 ;; Look for global face resources. | |
| 1852 (loop for face in (face-list) do | |
| 1853 (init-face-from-resources face 'global)) | |
| 1854 ;; Further frobbing. | |
| 1855 (and (featurep 'x) (declare-fboundp (x-init-global-faces))) | |
| 1856 (and (featurep 'gtk) (declare-fboundp (gtk-init-global-faces))) | |
| 1857 (and (featurep 'mswindows) (declare-fboundp (mswindows-init-global-faces))) | |
| 462 | 1858 |
| 872 | 1859 ;; for bold and the like, make the global specification be bold etc. |
| 1860 ;; if the user didn't already specify a value. These will also be | |
| 1861 ;; frobbed further in init-other-random-faces. | |
| 1862 (unless (face-font 'bold 'global) | |
| 1863 (make-face-bold 'bold 'global)) | |
| 1864 ;; | |
| 1865 (unless (face-font 'italic 'global) | |
| 1866 (make-face-italic 'italic 'global)) | |
| 1867 ;; | |
| 428 | 1868 (unless (face-font 'bold-italic 'global) |
| 872 | 1869 (make-face-bold-italic 'bold-italic 'global) |
| 1870 (unless (face-font 'bold-italic 'global) | |
| 1871 (copy-face 'bold 'bold-italic) | |
| 1872 (make-face-italic 'bold-italic))) | |
| 428 | 1873 |
| 872 | 1874 (when (face-equal 'bold 'bold-italic device) |
| 1875 (copy-face 'italic 'bold-italic) | |
| 1876 (make-face-bold 'bold-italic)))) | |
| 428 | 1877 |
| 1878 | |
| 1879 ;; These warnings are there for a reason. Just specify your fonts | |
| 1880 ;; correctly. Deal with it. Additionally, one can use | |
| 1881 ;; `log-warning-minimum-level' instead of this. | |
| 1882 ;(defvar inhibit-font-complaints nil | |
| 1883 ; "Whether to suppress complaints about incomplete sets of fonts.") | |
| 1884 | |
| 1885 (defun face-complain-about-font (face device) | |
| 1886 (if (symbolp face) (setq face (symbol-name face))) | |
| 1887 ;; (if (not inhibit-font-complaints) | |
| 707 | 1888 ;; complaining for printers is generally annoying. |
| 1889 (unless (device-printer-p device) | |
| 1890 (display-warning | |
| 1891 'font | |
| 1892 (let ((default-name (face-font-name 'default device))) | |
| 1893 (format "%s: couldn't deduce %s %s version of the font | |
| 428 | 1894 %S. |
| 1895 | |
| 1896 Please specify X resources to make the %s face | |
| 1897 visually distinguishable from the default face. | |
| 1898 For example, you could add one of the following to $HOME/Emacs: | |
| 1899 | |
| 2703 | 1900 XEmacs.%s.attributeFont: -dt-*-medium-i-* |
| 428 | 1901 or |
| 2703 | 1902 XEmacs.%s.attributeForeground: hotpink\n" |
| 707 | 1903 invocation-name |
| 1904 (if (string-match "\\`[aeiouAEIOU]" face) "an" "a") | |
| 1905 face | |
| 1906 default-name | |
| 1907 face | |
| 1908 face | |
| 1909 face | |
| 1910 ))))) | |
| 428 | 1911 |
| 1912 | |
| 1913 ;; #### This is quite a mess. We should use the custom mechanism for | |
| 1914 ;; most of this stuff. Currently we don't do it, because Custom | |
| 1915 ;; doesn't use specifiers (yet.) FSF does it the Right Way. | |
| 1916 | |
| 1917 ;; For instance, the definition of `bold' should be something like | |
| 1918 ;; (defface bold ((t (:bold t))) "Bold text.") -- and `:bold t' should | |
| 1919 ;; make sure that everything works properly. | |
| 1920 | |
| 1921 (defun init-other-random-faces (device) | |
| 1922 "Initialize the colors and fonts of the bold, italic, bold-italic, | |
| 1923 zmacs-region, list-mode-item-selected, highlight, primary-selection, | |
| 1924 secondary-selection, and isearch faces when each device is created. If | |
| 1925 you want to add code to do stuff like this, use the create-device-hook." | |
| 1926 | |
| 1927 ;; try to make 'bold look different from the default on this device. | |
| 1928 ;; If that doesn't work at all, then issue a warning. | |
| 1929 (unless (face-differs-from-default-p 'bold device) | |
| 1930 (make-face-bold 'bold device) | |
| 1931 (unless (face-differs-from-default-p 'bold device) | |
| 1932 (make-face-unbold 'bold device) | |
| 1933 (unless (face-differs-from-default-p 'bold device) | |
| 1934 ;; the luser specified one of the bogus font names | |
| 1935 (face-complain-about-font 'bold device)))) | |
| 1936 | |
| 1937 ;; Similar for italic. | |
| 1938 ;; It's unreasonable to expect to be able to make a font italic all | |
| 1939 ;; the time. For many languages, italic is an alien concept. | |
| 1940 ;; Basically, because italic is not a globally meaningful concept, | |
| 440 | 1941 ;; the use of the italic face should really be obsoleted. |
| 428 | 1942 |
| 1943 ;; I disagree with above. In many languages, the concept of capital | |
| 1944 ;; letters is just as alien, and yet we use them. Italic is here to | |
| 1945 ;; stay. -hniksic | |
| 1946 | |
| 1947 ;; In a Solaris Japanese environment, there just aren't any italic | |
| 1948 ;; fonts - period. CDE recognizes this reality, and fonts | |
| 1949 ;; -dt-interface user-medium-r-normal-*-*-*-*-*-*-*-*-* don't come | |
| 1950 ;; in italic versions. So we first try to make the font bold before | |
| 1951 ;; complaining. | |
| 1952 (unless (face-differs-from-default-p 'italic device) | |
| 1953 (make-face-italic 'italic device) | |
| 1954 (unless (face-differs-from-default-p 'italic device) | |
| 1955 (make-face-bold 'italic device) | |
| 1956 (unless (face-differs-from-default-p 'italic device) | |
| 1957 (face-complain-about-font 'italic device)))) | |
| 1958 | |
| 1959 ;; similar for bold-italic. | |
| 1960 (unless (face-differs-from-default-p 'bold-italic device) | |
| 1961 (make-face-bold-italic 'bold-italic device) | |
| 1962 ;; if we couldn't get a bold-italic version, try just bold. | |
| 1963 (unless (face-differs-from-default-p 'bold-italic device) | |
| 1964 (make-face-bold 'bold-italic device) | |
| 1965 ;; if we couldn't get bold or bold-italic, then that's probably because | |
| 1966 ;; the default font is bold, so make the `bold-italic' face be unbold. | |
| 1967 (unless (face-differs-from-default-p 'bold-italic device) | |
| 1968 (make-face-unbold 'bold-italic device) | |
| 1969 (make-face-italic 'bold-italic device) | |
| 1970 (unless (face-differs-from-default-p 'bold-italic device) | |
| 1971 ;; if that didn't work, try plain italic | |
| 1972 ;; (can this ever happen? what the hell.) | |
| 1973 (make-face-italic 'bold-italic device) | |
| 1974 (unless (face-differs-from-default-p 'bold-italic device) | |
| 1975 ;; then bitch and moan. | |
| 1976 (face-complain-about-font 'bold-italic device)))))) | |
| 1977 | |
| 1978 ;; Set the text-cursor colors unless already specified. | |
| 1979 (when (and (not (eq 'tty (device-type device))) | |
| 1980 (not (face-background 'text-cursor 'global)) | |
| 1981 (face-property-equal 'text-cursor 'default 'background device)) | |
| 1982 (set-face-background 'text-cursor [default foreground] 'global | |
| 1983 nil 'append)) | |
| 1984 (when (and (not (eq 'tty (device-type device))) | |
| 1985 (not (face-foreground 'text-cursor 'global)) | |
| 1986 (face-property-equal 'text-cursor 'default 'foreground device)) | |
| 1987 (set-face-foreground 'text-cursor [default background] 'global | |
| 1988 nil 'append)) | |
|
4741
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1989 |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1990 ;; The faces buffers-tab, modeline-mousable and modeline-buffer-id all |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1991 ;; inherit directly from modeline; they require that modeline's details be |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1992 ;; specified, that it not use fallbacks, otherwise *they* use the general |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1993 ;; fallback of the default face instead, which clashes with the gui |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1994 ;; element faces. So take the modeline face information from its |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1995 ;; fallbacks, themselves ultimately set up in faces.c: |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1996 (loop |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
1997 for face-property in '(foreground background |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
1998 background-pixmap background-placement) |
|
4741
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1999 do (when (and (setq face-property (face-property 'modeline face-property)) |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
2000 (null (specifier-instance face-property device nil t)) |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
2001 (specifier-instance face-property device)) |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
2002 (set-specifier face-property |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
2003 (or (specifier-specs (specifier-fallback |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
2004 face-property)) |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
2005 ;; This will error at startup if the |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
2006 ;; corresponding C fallback doesn't exist, |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
2007 ;; which is well and good. |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
2008 (specifier-fallback (specifier-fallback |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
2009 face-property)))))) |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
2010 nil) |
| 428 | 2011 |
| 442 | 2012 ;; New function with 20.1, suggested by Per Abrahamsen, coded by Kyle |
| 2013 ;; Jones and Hrvoje Niksic. | |
| 428 | 2014 (defun set-face-stipple (face pixmap &optional frame) |
| 2015 "Change the stipple pixmap of FACE to PIXMAP. | |
| 2016 This is an Emacs compatibility function; consider using | |
| 2017 set-face-background-pixmap instead. | |
| 2018 | |
| 2019 PIXMAP should be a string, the name of a file of pixmap data. | |
| 442 | 2020 The directories listed in the variables `x-bitmap-file-path' and |
| 2021 `mswindows-bitmap-file-path' under X and MS Windows respectively | |
| 2022 are searched. | |
| 428 | 2023 |
| 2024 Alternatively, PIXMAP may be a list of the form (WIDTH HEIGHT | |
| 2025 DATA) where WIDTH and HEIGHT are the size in pixels, and DATA is | |
| 2026 a string, containing the raw bits of the bitmap. XBM data is | |
| 2027 expected in this case, other types of image data will not work. | |
| 2028 | |
| 2029 If the optional FRAME argument is provided, change only | |
| 2030 in that frame; otherwise change each frame." | |
| 2031 (while (not (find-face face)) | |
| 446 | 2032 (setq face (wrong-type-argument 'facep face))) |
| 502 | 2033 (let ((bitmap-path |
| 2034 (ecase (console-type) | |
| 2035 (x (declare-boundp x-bitmap-file-path)) | |
| 2036 (mswindows (declare-boundp mswindows-bitmap-file-path)))) | |
| 442 | 2037 instantiator) |
| 2038 (while | |
| 2039 (null | |
| 2040 (setq instantiator | |
| 2041 (cond ((stringp pixmap) | |
| 2042 (let ((file (if (file-name-absolute-p pixmap) | |
| 2043 pixmap | |
| 2044 (locate-file pixmap bitmap-path | |
| 2045 '(".xbm" ""))))) | |
| 2046 (and file | |
| 2047 `[xbm :file ,file]))) | |
|
5366
f00192e1cd49
Examining the result of #'length: `eql', not `=', it's better style & cheaper
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
2048 ((and (listp pixmap) (eql (length pixmap) 3)) |
| 442 | 2049 `[xbm :data ,pixmap]) |
| 2050 (t nil)))) | |
| 2051 ;; We're signaling a continuable error; let's make sure the | |
| 2052 ;; function `stipple-pixmap-p' at least exists. | |
|
5567
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5484
diff
changeset
|
2053 (labels ((stipple-pixmap-p (pixmap) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5484
diff
changeset
|
2054 (or (stringp pixmap) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5484
diff
changeset
|
2055 (and (listp pixmap) (eql (length pixmap) 3))))) |
| 442 | 2056 (setq pixmap (signal 'wrong-type-argument |
|
5567
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5484
diff
changeset
|
2057 (list #'stipple-pixmap-p pixmap))))) |
| 446 | 2058 (check-type frame (or null frame)) |
| 442 | 2059 (set-face-background-pixmap face instantiator frame))) |
| 428 | 2060 |
| 2061 | |
| 2062 ;; Create the remaining standard faces now. This way, packages that we dump | |
| 2063 ;; can reference these faces as parents. | |
| 2064 ;; | |
| 2065 ;; The default, modeline, left-margin, right-margin, text-cursor, | |
| 2066 ;; and pointer faces are created in C. | |
| 2067 | |
| 2068 (make-face 'bold "Bold text.") | |
| 2069 (make-face 'italic "Italic text.") | |
| 2070 (make-face 'bold-italic "Bold-italic text.") | |
| 2071 (make-face 'underline "Underlined text.") | |
| 2072 (or (face-differs-from-default-p 'underline) | |
| 2073 (set-face-underline-p 'underline t 'global '(default))) | |
| 735 | 2074 (make-face 'zmacs-region "Used on highlighted region between point and mark.") |
| 428 | 2075 (make-face 'isearch "Used on region matched by isearch.") |
| 2076 (make-face 'isearch-secondary "Face to use for highlighting all matches.") | |
| 2077 (make-face 'list-mode-item-selected | |
| 2078 "Face for the selected list item in list-mode.") | |
| 2079 (make-face 'highlight "Highlight face.") | |
| 2080 (make-face 'primary-selection "Primary selection face.") | |
| 2081 (make-face 'secondary-selection "Secondary selection face.") | |
| 2082 | |
| 2083 ;; Several useful color faces. | |
| 2084 (dolist (color '(red green blue yellow)) | |
| 2085 (make-face color (concat (symbol-name color) " text.")) | |
| 2086 (set-face-foreground color (symbol-name color) nil 'color)) | |
| 2087 | |
| 2088 ;; Make some useful faces. This happens very early, before creating | |
| 2089 ;; the first non-stream device. | |
| 2090 | |
| 2091 (set-face-background 'text-cursor | |
| 711 | 2092 '(((win default) . "Red3")) |
| 428 | 2093 'global) |
| 2094 | |
| 2095 ;; some older X servers don't recognize "darkseagreen2" | |
| 2096 (set-face-background 'highlight | |
| 711 | 2097 '(((win default color) . "darkseagreen2") |
| 2098 ((win default color) . "green") | |
| 2099 ((win default grayscale) . "gray53")) | |
| 428 | 2100 'global) |
| 2101 (set-face-background-pixmap 'highlight | |
| 711 | 2102 '(((win default mono) . "gray1")) |
| 428 | 2103 'global) |
| 2104 | |
| 2105 (set-face-background 'zmacs-region | |
| 711 | 2106 '(((win default color) . "gray65") |
| 2107 ((win default grayscale) . "gray65")) | |
| 428 | 2108 'global) |
| 2109 (set-face-background-pixmap 'zmacs-region | |
| 711 | 2110 '(((win default mono) . "gray3")) |
| 428 | 2111 'global) |
| 2112 | |
| 2113 (set-face-background 'list-mode-item-selected | |
| 711 | 2114 '(((win default color) . "gray68") |
| 2115 ((win default grayscale) . "gray68") | |
| 2116 ((win default mono) . [default foreground])) | |
| 428 | 2117 'global) |
| 2118 (set-face-foreground 'list-mode-item-selected | |
| 711 | 2119 '(((win default mono) . [default background])) |
| 428 | 2120 'global) |
| 2121 | |
| 2122 (set-face-background 'primary-selection | |
| 711 | 2123 '(((win default color) . "gray65") |
| 2124 ((win default grayscale) . "gray65")) | |
| 428 | 2125 'global) |
| 2126 (set-face-background-pixmap 'primary-selection | |
| 711 | 2127 '(((win default mono) . "gray3")) |
| 428 | 2128 'global) |
| 2129 | |
| 2130 (set-face-background 'secondary-selection | |
| 711 | 2131 '(((win default color) . "paleturquoise") |
| 2132 ((win default color) . "green") | |
| 2133 ((win default grayscale) . "gray53")) | |
| 428 | 2134 'global) |
| 2135 (set-face-background-pixmap 'secondary-selection | |
| 711 | 2136 '(((win default mono) . "gray1")) |
| 428 | 2137 'global) |
| 2138 | |
| 2139 (set-face-background 'isearch | |
| 711 | 2140 '(((win default color) . "paleturquoise") |
| 2141 ((win default color) . "green")) | |
| 428 | 2142 'global) |
| 2143 | |
| 2144 ;; #### This should really, I mean *really*, be converted to some form | |
| 2145 ;; of `defface' one day. | |
| 2146 (set-face-foreground 'isearch-secondary | |
| 711 | 2147 '(((win default color) . "red3")) |
| 428 | 2148 'global) |
| 2149 | |
| 2150 ;; Define some logical color names to be used when reading the pixmap files. | |
| 4222 | 2151 (and-boundp |
| 2152 'xpm-color-symbols | |
| 2153 (featurep 'xpm) | |
| 2154 (setq xpm-color-symbols | |
| 2155 (list | |
| 2156 '("foreground" (face-foreground 'default)) | |
| 2157 '("background" (face-background 'default)) | |
|
4676
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2158 `("backgroundToolBarColor" |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2159 ,(if (featurep 'x) |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2160 '(or (x-get-resource "backgroundToolBarColor" |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2161 "BackgroundToolBarColor" 'string |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2162 nil nil 'warn) |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2163 (face-background 'toolbar)) |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2164 '(face-background 'toolbar))) |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2165 `("foregroundToolBarColor" |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2166 ,(if (featurep 'x) |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2167 '(or (x-get-resource "foregroundToolBarColor" |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2168 "ForegroundToolBarColor" 'string |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2169 nil nil 'warn) |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2170 (face-foreground 'toolbar)) |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2171 '(face-foreground 'toolbar)))))) |
| 428 | 2172 |
| 2173 (when (featurep 'tty) | |
| 2174 (set-face-highlight-p 'bold t 'global '(default tty)) | |
| 2175 (set-face-underline-p 'italic t 'global '(default tty)) | |
| 2176 (set-face-highlight-p 'bold-italic t 'global '(default tty)) | |
| 2177 (set-face-underline-p 'bold-italic t 'global '(default tty)) | |
| 2178 (set-face-highlight-p 'highlight t 'global '(default tty)) | |
| 2179 (set-face-reverse-p 'text-cursor t 'global '(default tty)) | |
| 2180 (set-face-reverse-p 'modeline t 'global '(default tty)) | |
| 2181 (set-face-reverse-p 'zmacs-region t 'global '(default tty)) | |
| 2182 (set-face-reverse-p 'primary-selection t 'global '(default tty)) | |
| 2183 (set-face-underline-p 'secondary-selection t 'global '(default tty)) | |
| 2184 (set-face-reverse-p 'list-mode-item-selected t 'global '(default tty)) | |
| 2185 (set-face-reverse-p 'isearch t 'global '(default tty)) | |
| 2186 ) | |
| 2187 | |
| 2188 ;;; faces.el ends here |