Mercurial > hg > xemacs-beta
annotate lisp/specifier.el @ 5940:c608d4b0b75e cygwin64 tip
rescue lost branch from 64bit.backup
| author | Henry Thompson <ht@markup.co.uk> |
|---|---|
| date | Thu, 16 Dec 2021 18:48:58 +0000 |
| parents | 071b810ceb18 |
| children |
| rev | line source |
|---|---|
| 428 | 1 ;;; specifier.el --- Lisp interface to specifiers |
| 2 | |
| 3 ;; Copyright (C) 1997 Free Software Foundation, Inc. | |
| 3061 | 4 ;; Copyright (C) 1995, 1996, 2000, 2002, 2005 Ben Wing. |
| 428 | 5 |
| 6 ;; Author: Ben Wing <ben@xemacs.org> | |
| 7 ;; Keywords: internal, dumped | |
| 8 | |
| 9 ;;; Synched up with: Not in FSF. | |
| 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:
5267
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:
5267
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:
5267
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:
5267
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:
5267
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:
5267
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:
5267
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:
5267
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:
5267
diff
changeset
|
24 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 428 | 25 |
| 26 ;;; Commentary: | |
| 27 | |
| 28 ;; This file is dumped with XEmacs. | |
| 29 | |
| 30 ;;; Code: | |
| 31 | |
| 32 (defun make-specifier-and-init (type spec-list &optional dont-canonicalize) | |
| 1875 | 33 "Create and initialize a specifier of type TYPE with spec(s) SPEC-LIST. |
| 428 | 34 |
| 1875 | 35 A convenience API combining `make-specifier' and `set-specifier', allowing you |
| 36 to create a specifier and add specs to it at the same time. | |
| 37 TYPE specifies the specifier type. See `make-specifier' for known types. | |
| 38 SPEC-LIST supplies the specification(s) to be added to the specifier, in any | |
| 39 form acceptable to `canonicalize-spec-list'. | |
| 40 Optional DONT-CANONICALIZE, if non-nil, inhibits the conversion, and the | |
| 41 SPEC-LIST must already be in full form." | |
| 428 | 42 (let ((sp (make-specifier type))) |
| 43 (if (not dont-canonicalize) | |
| 44 (setq spec-list (canonicalize-spec-list spec-list type))) | |
| 45 (add-spec-list-to-specifier sp spec-list) | |
| 46 sp)) | |
| 47 | |
| 48 ;; God damn, do I hate dynamic scoping. | |
| 49 | |
| 872 | 50 (defun map-specifier (ms-specifier ms-func &optional ms-locale ms-maparg |
| 51 ms-tag-set ms-exact-p) | |
| 428 | 52 "Apply MS-FUNC to the specification(s) for MS-LOCALE in MS-SPECIFIER. |
| 53 | |
| 1875 | 54 If optional MS-LOCALE is a locale, MS-FUNC will be called for that locale. |
| 55 If MS-LOCALE is a locale type, MS-FUNC will be mapped over all locales of that | |
| 3061 | 56 type. If MS-LOCALE is `all' or nil, MS-FUNC will be mapped over all locales in |
| 1875 | 57 MS-SPECIFIER. |
| 428 | 58 |
| 1875 | 59 Optional MS-TAG-SET and MS-EXACT-P are as in `specifier-spec-list'. |
| 60 Optional MS-MAPARG will be passed to MS-FUNC. | |
| 872 | 61 |
| 428 | 62 MS-FUNC is called with four arguments: the MS-SPECIFIER, the locale |
| 63 being mapped over, the inst-list for that locale, and the | |
| 64 optional MS-MAPARG. If any invocation of MS-FUNC returns non-nil, | |
| 65 the mapping will stop and the returned value becomes the | |
| 66 value returned from `map-specifier'. Otherwise, `map-specifier' | |
| 67 returns nil." | |
| 872 | 68 (let ((ms-specs (specifier-spec-list ms-specifier ms-locale ms-tag-set |
| 69 ms-exact-p)) | |
| 428 | 70 ms-result) |
| 71 (while (and ms-specs (not ms-result)) | |
| 72 (let ((ms-this-spec (car ms-specs))) | |
| 73 (setq ms-result (funcall ms-func ms-specifier (car ms-this-spec) | |
| 74 (cdr ms-this-spec) ms-maparg)) | |
| 75 (setq ms-specs (cdr ms-specs)))) | |
| 76 ms-result)) | |
| 77 | |
| 78 (defun canonicalize-inst-pair (inst-pair specifier-type &optional noerror) | |
| 79 "Canonicalize the given INST-PAIR. | |
| 80 | |
| 81 SPECIFIER-TYPE specifies the type of specifier that this SPEC-LIST | |
| 82 will be used for. | |
| 83 | |
| 84 Canonicalizing means converting to the full form for an inst-pair, i.e. | |
| 85 `(TAG-SET . INSTANTIATOR)'. A single, untagged instantiator is given | |
| 86 a tag set of nil (the empty set), and a single tag is converted into | |
| 87 a tag set consisting only of that tag. | |
| 88 | |
| 89 If NOERROR is non-nil, signal an error if the inst-pair is invalid; | |
| 90 otherwise return t." | |
| 91 ;; OK, the possibilities are: | |
| 92 ;; | |
| 93 ;; a) a single instantiator | |
| 94 ;; b) a cons of a tag and an instantiator | |
| 95 ;; c) a cons of a tag set and an instantiator | |
| 96 (cond ((valid-instantiator-p inst-pair specifier-type) | |
| 97 ;; case (a) | |
| 98 (cons nil inst-pair)) | |
| 99 | |
| 100 ((not (consp inst-pair)) | |
| 101 ;; not an inst-pair | |
| 102 (if noerror t | |
| 103 ;; this will signal an appropriate error. | |
| 104 (check-valid-instantiator inst-pair specifier-type))) | |
| 105 | |
|
5244
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5222
diff
changeset
|
106 ((not (valid-instantiator-p (cdr inst-pair) specifier-type)) |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5222
diff
changeset
|
107 (if noerror |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5222
diff
changeset
|
108 t |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5222
diff
changeset
|
109 (check-valid-instantiator (cdr inst-pair) specifier-type))) |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5222
diff
changeset
|
110 |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5222
diff
changeset
|
111 ((valid-specifier-tag-p (car inst-pair)) |
| 428 | 112 ;; case (b) |
| 113 (cons (list (car inst-pair)) (cdr inst-pair))) | |
| 114 | |
|
5244
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5222
diff
changeset
|
115 ((valid-specifier-tag-set-p (car inst-pair)) |
| 428 | 116 ;; case (c) |
| 117 inst-pair) | |
| 118 | |
| 119 (t | |
| 120 (if noerror t | |
|
5244
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5222
diff
changeset
|
121 (error 'invalid-argument "Invalid specifier tag set" |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5222
diff
changeset
|
122 (car inst-pair)))))) |
| 428 | 123 |
| 124 (defun canonicalize-inst-list (inst-list specifier-type &optional noerror) | |
| 125 "Canonicalize the given INST-LIST (a list of inst-pairs). | |
| 126 | |
| 127 SPECIFIER-TYPE specifies the type of specifier that this INST-LIST | |
| 128 will be used for. | |
| 129 | |
| 130 Canonicalizing means converting to the full form for an inst-list, i.e. | |
| 131 `((TAG-SET . INSTANTIATOR) ...)'. This function accepts a single | |
| 132 inst-pair or any abbreviation thereof or a list of (possibly | |
| 133 abbreviated) inst-pairs. (See `canonicalize-inst-pair'.) | |
| 134 | |
| 135 If NOERROR is non-nil, signal an error if the inst-list is invalid; | |
| 136 otherwise return t." | |
| 137 | |
| 138 ;; OK, the possibilities are: | |
| 139 ;; | |
| 140 ;; a) an inst-pair or various abbreviations thereof | |
| 141 ;; b) a list of (a) | |
| 142 (let ((result (canonicalize-inst-pair inst-list specifier-type t))) | |
| 143 (if (not (eq result t)) | |
| 144 ;; case (a) | |
| 145 (list result) | |
| 146 | |
| 147 (if (not (consp inst-list)) | |
| 148 ;; not an inst-list. | |
| 149 (if noerror t | |
| 150 ;; this will signal an appropriate error. | |
| 151 (check-valid-instantiator inst-list specifier-type)) | |
| 152 | |
| 153 ;; case (b) | |
| 154 (catch 'cann-inst-list | |
| 155 ;; don't use mapcar here; we need to catch the case of | |
| 156 ;; an invalid list. | |
| 157 (let ((rest inst-list) | |
| 158 (result nil)) | |
| 159 (while rest | |
| 160 (if (not (consp rest)) | |
| 161 (if noerror (throw 'cann-inst-list t) | |
| 162 (signal 'error (list "Invalid list format" inst-list))) | |
| 163 (let ((res2 (canonicalize-inst-pair (car rest) specifier-type | |
| 164 noerror))) | |
| 165 (if (eq res2 t) | |
| 166 ;; at this point, we know we're noerror because | |
| 167 ;; otherwise canonicalize-inst-pair would have | |
| 168 ;; signalled an error. | |
| 169 (throw 'cann-inst-list t) | |
| 170 (setq result (cons res2 result))))) | |
| 171 (setq rest (cdr rest))) | |
| 172 (nreverse result))))))) | |
| 173 | |
| 174 (defun canonicalize-spec (spec specifier-type &optional noerror) | |
| 175 "Canonicalize the given SPEC (a specification). | |
| 176 | |
| 1875 | 177 SPECIFIER-TYPE is the type of specifier that this SPEC will be used for. |
| 428 | 178 |
| 179 Canonicalizing means converting to the full form for a spec, i.e. | |
| 180 `(LOCALE (TAG-SET . INSTANTIATOR) ...)'. This function accepts a | |
| 181 possibly abbreviated inst-list or a cons of a locale and a possibly | |
| 182 abbreviated inst-list. (See `canonicalize-inst-list'.) | |
| 183 | |
| 184 If NOERROR is nil, signal an error if the specification is invalid; | |
| 185 otherwise return t." | |
| 186 ;; OK, the possibilities are: | |
| 187 ;; | |
| 188 ;; a) an inst-list or some abbreviation thereof | |
| 189 ;; b) a cons of a locale and an inst-list | |
| 190 (let ((result (canonicalize-inst-list spec specifier-type t))) | |
| 191 (if (not (eq result t)) | |
| 192 ;; case (a) | |
| 193 (cons 'global result) | |
| 194 | |
| 195 (if (not (consp spec)) | |
| 196 ;; not a spec. | |
| 197 (if noerror t | |
| 198 ;; this will signal an appropriate error. | |
| 199 (check-valid-instantiator spec specifier-type)) | |
| 200 | |
| 201 (if (not (valid-specifier-locale-p (car spec))) | |
| 202 ;; invalid locale. | |
|
5244
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5222
diff
changeset
|
203 (if noerror |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5222
diff
changeset
|
204 t |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5222
diff
changeset
|
205 (if (consp (car spec)) |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5222
diff
changeset
|
206 ;; If it's a cons, they're probably not passing a locale |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5222
diff
changeset
|
207 (error 'invalid-argument |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5222
diff
changeset
|
208 "Not a valid instantiator list" spec) |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5222
diff
changeset
|
209 (error 'invalid-argument |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5222
diff
changeset
|
210 "Invalid specifier locale" (car spec)))) |
| 428 | 211 ;; case (b) |
| 212 (let ((result (canonicalize-inst-list (cdr spec) specifier-type | |
| 213 noerror))) | |
| 214 (if (eq result t) | |
| 215 ;; at this point, we know we're noerror because | |
| 216 ;; otherwise canonicalize-inst-list would have | |
| 217 ;; signalled an error. | |
| 218 t | |
| 219 (cons (car spec) result)))))))) | |
| 220 | |
| 221 (defun canonicalize-spec-list (spec-list specifier-type &optional noerror) | |
| 222 "Canonicalize the given SPEC-LIST (a list of specifications). | |
| 223 | |
| 224 SPECIFIER-TYPE specifies the type of specifier that this SPEC-LIST | |
| 225 will be used for. | |
| 226 | |
| 227 Canonicalizing means converting to the full form for a spec-list, i.e. | |
| 228 `((LOCALE (TAG-SET . INSTANTIATOR) ...) ...)'. This function accepts | |
| 229 a possibly abbreviated specification or a list of such things. (See | |
| 230 `canonicalize-spec'.) This is the function used to convert spec-lists | |
| 231 accepted by `set-specifier' and such into a form suitable for | |
| 232 `add-spec-list-to-specifier'. | |
| 233 | |
| 1875 | 234 The canonicalization algorithm is as follows: |
| 235 | |
| 236 1. Attempt to parse SPEC-LIST as a single, possibly abbreviated, specification. | |
| 237 2. If (1) fails, attempt to parse SPEC-LIST as a list of (abbreviated) | |
| 238 specifications. | |
| 239 3. If (2) fails, SPEC-LIST is invalid. | |
| 240 | |
| 241 A possibly abbreviated specification SPEC is parsed by | |
| 242 | |
| 243 1. Attempt to parse SPEC as a possibly abbreviated inst-list. | |
| 244 2. If (1) fails, attempt to parse SPEC as a cons of a locale and an | |
| 245 (abbreviated) inst-list. | |
| 246 3. If (2) fails, SPEC is invalid. | |
| 247 | |
| 248 A possibly abbreviated inst-list INST-LIST is parsed by | |
| 249 | |
| 250 1. Attempt to parse INST-LIST as a possibly abbreviated inst-pair. | |
| 251 2. If (1) fails, attempt to parse INST-LIST as a list of (abbreviated) | |
| 252 inst-pairs. | |
| 253 3. If (2) fails, INST-LIST is invalid. | |
| 254 | |
| 255 A possibly abbreviated inst-pair INST-PAIR is parsed by | |
| 256 | |
| 257 1. Check if INST-PAIR is `valid-instantiator-p'. | |
| 258 2. If not, check if INST-PAIR is a cons of something that is a tag, ie, | |
| 259 `valid-specifier-tag-p', and something that is `valid-instantiator-p'. | |
| 260 3. If not, check if INST-PAIR is a cons of a list of tags and something that | |
| 261 is `valid-instantiator-p'. | |
| 262 | |
| 263 In summary, this function generally prefers more abbreviated forms. | |
| 264 | |
| 265 This function tries extremely hard to resolve any ambiguities, and the | |
| 266 built-in specifier types (font, image, toolbar, etc.) are designed so that | |
| 267 there won't be any ambiguities. (#### Unfortunately there are bugs in the | |
| 268 treatment of toolbar spec-lists and generic spec-lists; avoid depending on | |
| 269 canonicalization for these types.) | |
| 428 | 270 |
| 271 If NOERROR is nil, signal an error if the spec-list is invalid; | |
| 272 otherwise return t." | |
| 273 ;; OK, the possibilities are: | |
| 274 ;; | |
| 275 ;; a) a spec or various abbreviations thereof | |
| 276 ;; b) a list of (a) | |
| 277 (let ((result (canonicalize-spec spec-list specifier-type t))) | |
| 278 (if (not (eq result t)) | |
| 279 ;; case (a) | |
| 280 (list result) | |
| 281 | |
| 282 (if (not (consp spec-list)) | |
| 283 ;; not a spec-list. | |
| 284 (if noerror t | |
| 285 ;; this will signal an appropriate error. | |
| 286 (check-valid-instantiator spec-list specifier-type)) | |
| 287 | |
| 288 ;; case (b) | |
| 289 (catch 'cann-spec-list | |
| 290 ;; don't use mapcar here; we need to catch the case of | |
| 291 ;; an invalid list. | |
| 292 (let ((rest spec-list) | |
| 293 (result nil)) | |
| 294 (while rest | |
| 295 (if (not (consp rest)) | |
| 296 (if noerror (throw 'cann-spec-list t) | |
| 297 (signal 'error (list "Invalid list format" spec-list))) | |
| 298 (let ((res2 (canonicalize-spec (car rest) specifier-type | |
| 299 noerror))) | |
| 300 (if (eq res2 t) | |
| 301 ;; at this point, we know we're noerror because | |
| 302 ;; otherwise canonicalize-spec would have | |
| 303 ;; signalled an error. | |
| 304 (throw 'cann-spec-list t) | |
| 305 (setq result (cons res2 result))))) | |
| 306 (setq rest (cdr rest))) | |
| 307 (nreverse result))))))) | |
| 308 | |
| 309 (defun set-specifier (specifier value &optional locale tag-set how-to-add) | |
| 1875 | 310 "Add the specification(s) given by VALUE to SPECIFIER in LOCALE. |
| 311 | |
| 312 VALUE may be any of the values accepted by `canonicalize-spec-list', including | |
| 313 | |
| 314 -- an instantiator (either a Lisp object which will be returned when the | |
| 3061 | 315 specifier is instantiated, or a Lisp object that can be instantiated to |
| 1875 | 316 produce an opaque value: eg, a font name (string) can be used for a font |
| 317 specifier, but an instance will be a font object) | |
| 318 -- a list of instantiators | |
| 319 -- a cons of a locale and an instantiator, or of a locale and a list of | |
| 320 instantiators | |
| 321 -- a cons of a tag or tag-set and an instantiator (or list of instantiators) | |
| 322 -- a cons of a locale and the previous type of item | |
| 323 -- a list of one or more of any of the previous types of items | |
| 324 -- a canonical spec-list. | |
| 428 | 325 |
| 1875 | 326 See `canonicalize-spec-list' for details. If you need to know the details, |
| 327 though, strongly consider using the unambiguous APIs `add-spec-to-specifier' | |
| 328 and `add-spec-list-to-specifier' instead. | |
| 329 | |
| 330 Finally, VALUE can itself be a specifier (of the same type as | |
| 331 SPECIFIER), if you want to copy specifications from one specifier | |
| 332 to another; this is equivalent to calling `copy-specifier', and | |
| 333 LOCALE, TAG-SET, and HOW-TO-ADD have the same semantics as with | |
| 334 that function. | |
| 335 | |
| 336 Note that a VALUE of `nil' is either illegal or will be treated as a value of | |
| 337 `nil'; it does not remove existing specifications. Use `remove-specifier' for | |
| 338 that. N.B. `remove-specifier' defaults to removing all specifications, not | |
| 3061 | 339 just the `global' one! |
| 1875 | 340 |
| 341 Warning: this function is inherently heuristic, and should not be relied on to | |
| 342 properly resolve ambiguities, when specifier instantiators can be lists | |
| 343 \(currently, for toolbar specifiers and generic specifiers). In those cases | |
| 344 use either `add-spec-to-specifier' or `add-spec-list-to-specifier'. | |
| 345 | |
| 428 | 346 LOCALE indicates where this specification is active, and should be |
| 347 a buffer, a window, a frame, a device, or the symbol `global' to | |
| 1875 | 348 indicate that it applies everywhere. LOCALE defaults to |
| 349 `global' if omitted, and is overridden by locales provided by VALUE (in the | |
| 350 cases where value is a full specification or a spec-list). | |
| 428 | 351 |
| 352 Optional argument TAG-SET is a tag or a list of tags, to be associated | |
| 353 with the VALUE. Tags are symbols (usually naming device types, such | |
| 354 as `x' and `tty', or device classes, such as `color', `mono', and | |
| 355 `grayscale'); specifying a TAG-SET restricts the scope of VALUE to | |
| 2297 | 356 devices that match all specified tags. (You can also create your |
| 428 | 357 own tags using `define-specifier-tag', and use them to identify |
| 358 specifications added by you, so you can remove them later.) | |
| 359 | |
| 360 Optional argument HOW-TO-ADD should be either nil or one of the | |
| 361 symbols `prepend', `append', `remove-tag-set-prepend', | |
| 362 `remove-tag-set-append', `remove-locale', `remove-locale-type', | |
| 363 or `remove-all'. This specifies what to do with existing | |
| 364 specifications in LOCALE (and possibly elsewhere in the specifier). | |
| 365 Most of the time, you do not need to worry about this argument; | |
| 366 the default behavior of `remove-tag-set-prepend' is usually fine. | |
| 367 See `copy-specifier' and `add-spec-to-specifier' for a full | |
| 368 description of what each of these means. | |
| 369 | |
| 370 Note that `set-specifier' is exactly complementary to `specifier-specs' | |
| 371 except in the case where SPECIFIER has no specs at all in it but nil | |
| 372 is a valid instantiator (in that case, `specifier-specs' will return | |
| 373 nil (meaning no specs) and `set-specifier' will interpret the `nil' | |
| 374 as meaning \"I'm adding a global instantiator and its value is `nil'\"), | |
| 375 or in strange cases where there is an ambiguity between a spec-list | |
| 2297 | 376 and an inst-list, etc. (The built-in specifier types are designed |
| 1875 | 377 in such a way as to avoid any such ambiguities.)" |
| 428 | 378 |
| 379 ;; backward compatibility: the old function had HOW-TO-ADD as the | |
| 380 ;; third argument and no arguments after that. | |
| 381 ;; #### this should disappear at some point. | |
| 382 (if (and (null how-to-add) | |
| 383 (memq locale '(prepend append remove-tag-set-prepend | |
| 384 remove-tag-set-append remove-locale | |
| 385 remove-locale-type remove-all))) | |
| 386 (progn | |
| 387 (setq how-to-add locale) | |
| 388 (setq locale nil))) | |
| 389 | |
| 390 ;; proper beginning of the function. | |
| 391 (let ((is-valid (valid-instantiator-p value (specifier-type specifier))) | |
| 392 (nval value)) | |
| 393 (cond ((and (not is-valid) (specifierp nval)) | |
| 394 (copy-specifier nval specifier locale tag-set nil how-to-add)) | |
| 395 (t | |
| 396 (if tag-set | |
| 397 (progn | |
| 398 (if (not (listp tag-set)) | |
| 399 (setq tag-set (list tag-set))) | |
| 400 ;; You tend to get more accurate errors | |
| 401 ;; for a variety of cases if you call | |
| 402 ;; canonicalize-tag-set here. | |
| 403 (setq tag-set (canonicalize-tag-set tag-set)) | |
| 404 (if (and (not is-valid) (consp nval)) | |
| 405 (setq nval | |
| 406 (mapcar #'(lambda (x) | |
| 407 (check-valid-instantiator | |
| 408 x (specifier-type specifier)) | |
| 409 (cons tag-set x)) | |
| 410 nval)) | |
| 411 (setq nval (cons tag-set nval))))) | |
| 412 (if locale | |
| 413 (setq nval (cons locale nval))) | |
| 414 (add-spec-list-to-specifier | |
| 415 specifier | |
| 416 (canonicalize-spec-list nval (specifier-type specifier)) | |
| 417 how-to-add)))) | |
| 418 value) | |
| 419 | |
| 3061 | 420 ;; #### Misnamed and wrong behavior. Should operate on INSTANTIATORS, not |
| 421 ;; instances. Need to come up with clean and general functions for | |
| 422 ;; modifying a specifier. New `specifier-instantiator' may help. | |
| 423 ;; #### Also need `instantiator-to-instance', a convenient version of | |
| 424 ;; `specifier-instance-from-inst-list'. | |
| 425 | |
| 442 | 426 (defun modify-specifier-instances (specifier func &optional args force default |
| 872 | 427 locale tag-set) |
| 442 | 428 "Modify all specifications that match LOCALE and TAG-SET by FUNC. |
| 429 | |
| 430 For each specification that exists for SPECIFIER, in locale LOCALE | |
| 431 that matches TAG-SET, call the function FUNC with the instance as its | |
| 432 first argument and with optional arguments ARGS. The result is then | |
| 433 used as the new value of the instantiator. | |
| 434 | |
| 435 If there is no specification in the domain LOCALE matching TAG-SET and | |
| 436 FORCE is non-nil, an explicit one is created from the matching | |
| 437 specifier instance if that exists or DEFAULT otherwise. If LOCALE is | |
| 438 not a domain (i.e. a buffer), DEFAULT is always used. FUNC is then | |
| 439 applied like above and the resulting specification is added." | |
| 440 | |
| 441 (let ((spec-list (specifier-spec-list specifier locale tag-set))) | |
| 442 (cond | |
| 443 (spec-list | |
| 444 ;; Destructively edit the spec-list | |
| 445 (mapc #'(lambda (spec) | |
| 446 (mapc #'(lambda (inst-pair) | |
| 447 (setcdr inst-pair | |
| 448 (apply func (cdr inst-pair) args))) | |
| 449 (cdr spec))) | |
| 450 spec-list) | |
| 451 (add-spec-list-to-specifier specifier spec-list)) | |
| 452 (force | |
| 453 (set-specifier specifier | |
| 454 (apply func | |
| 455 (or (and (valid-specifier-domain-p locale) | |
| 456 (specifier-instance specifier)) | |
| 457 default) args) | |
| 458 locale tag-set))))) | |
| 459 | |
| 428 | 460 (defmacro let-specifier (specifier-list &rest body) |
| 461 "Add specifier specs, evaluate forms in BODY and restore the specifiers. | |
| 462 \(let-specifier SPECIFIER-LIST BODY...) | |
| 463 | |
| 464 Each element of SPECIFIER-LIST should look like this: | |
| 465 \(SPECIFIER VALUE &optional LOCALE TAG-SET HOW-TO-ADD). | |
| 466 | |
| 467 SPECIFIER is the specifier to be temporarily modified. VALUE is the | |
| 468 instantiator to be temporarily added to SPECIFIER in LOCALE. LOCALE, | |
| 469 TAG-SET and HOW-TO-ADD have the same meaning as in | |
| 470 `add-spec-to-specifier'. | |
| 471 | |
| 472 The code resulting from macro expansion will add specifications to | |
| 473 specifiers using `add-spec-to-specifier'. After BODY is finished, the | |
| 474 temporary specifications are removed and old spec-lists are restored. | |
| 475 | |
| 476 LOCALE, TAG-SET and HOW-TO-ADD may be omitted, and default to nil. | |
| 477 The value of the last form in BODY is returned. | |
| 478 | |
| 479 NOTE: If you want the specifier's instance to change in all | |
| 480 circumstances, use (selected-window) as the LOCALE. If LOCALE is nil | |
| 481 or omitted, it defaults to `global'. | |
| 482 | |
| 483 Example: | |
| 484 (let-specifier ((modeline-shadow-thickness 0 (selected-window))) | |
| 485 (sit-for 1))" | |
| 486 (check-argument-type 'listp specifier-list) | |
|
5567
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
487 (labels ((gensym-frob (x name) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
488 (if (or (atom x) (eq (car x) 'quote)) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
489 (list x) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
490 (list (gensym name) x)))) |
|
5576
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5567
diff
changeset
|
491 (declare (inline gensym-frob)) |
| 428 | 492 ;; VARLIST is a list of |
| 493 ;; ((SPECIFIERSYM SPECIFIER) (VALUE) (LOCALESYM LOCALE) | |
| 494 ;; (TAG-SET) (HOW-TO-ADD)) | |
| 495 ;; If any of these is an atom, then a separate symbol is | |
| 496 ;; unnecessary, the CAR will contain the atom and CDR will be nil. | |
| 497 (let* ((varlist (mapcar #'(lambda (listel) | |
| 498 (or (and (consp listel) | |
| 499 (<= (length listel) 5) | |
| 500 (> (length listel) 1)) | |
| 501 (signal 'error | |
| 502 (list | |
| 503 "should be a list of 2-5 elements" | |
| 504 listel))) | |
| 505 ;; VALUE, TAG-SET and HOW-TO-ADD are | |
| 506 ;; referenced only once, so we needn't | |
| 507 ;; frob them with gensym. | |
| 508 (list (gensym-frob (nth 0 listel) "specifier-") | |
| 509 (list (nth 1 listel)) | |
| 510 (gensym-frob (nth 2 listel) "locale-") | |
| 511 (list (nth 3 listel)) | |
| 512 (list (nth 4 listel)))) | |
| 513 specifier-list)) | |
| 514 ;; OLDVALLIST is a list of (OLDVALSYM OLDVALFORM) | |
| 515 (oldvallist (mapcar #'(lambda (varel) | |
| 516 (list (gensym "old-") | |
| 517 `(specifier-spec-list | |
| 518 ,(car (nth 0 varel)) | |
| 519 ,(car (nth 2 varel))))) | |
| 520 varlist))) | |
| 521 ;; Bind the appropriate variables. | |
| 522 `(let* (,@(mapcan #'(lambda (varel) | |
|
5267
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5244
diff
changeset
|
523 (mapcan #'(lambda (varcons) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5244
diff
changeset
|
524 (and (cdr varcons) (list varcons))) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5244
diff
changeset
|
525 varel)) |
| 428 | 526 varlist) |
| 527 ,@oldvallist) | |
| 528 (unwind-protect | |
| 529 (progn | |
| 530 ,@(mapcar #'(lambda (varel) | |
| 531 `(add-spec-to-specifier | |
| 532 ,(car (nth 0 varel)) ,(car (nth 1 varel)) | |
| 533 ,(car (nth 2 varel)) ,(car (nth 3 varel)) | |
| 534 ,(car (nth 4 varel)))) | |
| 535 varlist) | |
| 536 ,@body) | |
| 537 ;; Reverse the unwinding order, so that using the same | |
| 538 ;; specifier multiple times works. | |
| 539 ,@(apply #'nconc (nreverse (mapcar* | |
| 540 #'(lambda (oldval varel) | |
| 541 `((remove-specifier | |
| 542 ,(car (nth 0 varel)) | |
| 543 ,(car (nth 2 varel))) | |
| 544 (add-spec-list-to-specifier | |
| 545 ,(car (nth 0 varel)) | |
| 546 ,(car oldval)))) | |
| 547 oldvallist varlist)))))))) | |
| 548 | |
| 442 | 549 (defun make-integer-specifier (spec-list) |
| 550 "Return a new `integer' specifier object with the given specification list. | |
| 551 SPEC-LIST can be a list of specifications (each of which is a cons of a | |
| 552 locale and a list of instantiators), a single instantiator, or a list | |
| 553 of instantiators. See `make-specifier' for more information about | |
| 554 specifiers. | |
| 555 | |
| 556 Valid instantiators for integer specifiers are integers." | |
| 557 (make-specifier-and-init 'integer spec-list)) | |
| 558 | |
| 559 (defun make-boolean-specifier (spec-list) | |
| 560 "Return a new `boolean' specifier object with the given specification list. | |
| 561 SPEC-LIST can be a list of specifications (each of which is a cons of a | |
| 562 locale and a list of instantiators), a single instantiator, or a list | |
| 563 of instantiators. See `make-specifier' for more information about | |
| 564 specifiers. | |
| 565 | |
| 566 Valid instantiators for boolean specifiers are t and nil." | |
| 567 (make-specifier-and-init 'boolean spec-list)) | |
| 568 | |
| 569 (defun make-natnum-specifier (spec-list) | |
| 570 "Return a new `natnum' specifier object with the given specification list. | |
| 571 SPEC-LIST can be a list of specifications (each of which is a cons of a | |
| 572 locale and a list of instantiators), a single instantiator, or a list | |
| 573 of instantiators. See `make-specifier' for more information about | |
| 574 specifiers. | |
| 575 | |
| 576 Valid instantiators for natnum specifiers are non-negative integers." | |
| 577 (make-specifier-and-init 'natnum spec-list)) | |
| 578 | |
| 579 (defun make-generic-specifier (spec-list) | |
| 580 "Return a new `generic' specifier object with the given specification list. | |
| 581 SPEC-LIST can be a list of specifications (each of which is a cons of a | |
| 582 locale and a list of instantiators), a single instantiator, or a list | |
| 583 of instantiators. See `make-specifier' for more information about | |
| 584 specifiers. | |
| 585 | |
| 586 Valid instantiators for generic specifiers are all Lisp values. | |
| 587 They are returned back unchanged when a specifier is instantiated." | |
| 588 (make-specifier-and-init 'generic spec-list)) | |
| 589 | |
| 590 (defun make-display-table-specifier (spec-list) | |
| 591 "Return a new `display-table' specifier object with the given spec list. | |
| 592 SPEC-LIST can be a list of specifications (each of which is a cons of a | |
| 593 locale and a list of instantiators), a single instantiator, or a list | |
| 594 of instantiators. See `make-specifier' for more information about | |
| 595 specifiers. | |
| 596 | |
| 597 Valid instantiators for display-table specifiers are described in | |
| 598 detail in the doc string for `current-display-table'." | |
| 599 (make-specifier-and-init 'display-table spec-list)) | |
| 600 | |
| 428 | 601 ;; Evaluate this for testing: |
| 602 ; (cl-prettyexpand '(let-specifier ((modeline-shadow-thickness 0 (selected-window) 'x) (fubar (value) baz)) (sit-for 1))) | |
| 603 | |
| 604 (define-specifier-tag 'win 'device-on-window-system-p) | |
| 605 | |
| 606 ;; Add tags for device types that don't have support compiled | |
| 607 ;; into the binary that we're about to dump. This will prevent | |
| 608 ;; code like | |
| 609 ;; | |
| 610 ;; (set-face-foreground 'default "black" nil '(x color)) | |
| 611 ;; | |
| 612 ;; from producing an error if no X support was compiled in. | |
| 613 | |
| 4194 | 614 (loop |
| 615 for tag in '(x tty mswindows msprinter gtk carbon) | |
| 616 do (unless (valid-specifier-tag-p tag) | |
| 617 (define-specifier-tag tag #'ignore))) | |
| 428 | 618 |
| 619 ;; Add special tag for use by initialization code. Code that | |
| 620 ;; sets up default specs should use this tag. Code that needs to | |
| 621 ;; override default specs (e.g. the X resource initialization | |
| 622 ;; code) can safely clear specs with this tag without worrying | |
| 623 ;; about clobbering user settings. | |
| 624 | |
| 625 (define-specifier-tag 'default) | |
| 626 | |
| 4194 | 627 ;; The x-resource specifier tag is provide so the X resource initialization |
| 628 ;; code can be overridden by custom without trouble. | |
| 629 | |
| 630 (define-specifier-tag 'x-resource) | |
| 631 | |
| 872 | 632 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 633 ;;; "Heuristic" specifier functions ;;; | |
| 634 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 635 | |
| 636 ;;; "Heuristic" is a euphemism for kludge. This stuff works well in | |
| 637 ;;; practice, though. | |
| 638 | |
| 639 ;;; You might view all the contortions we do here and in Face-frob-property | |
| 640 ;;; as indicative of design failures with specifiers, and perhaps you're | |
| 641 ;;; right. But in fact almost all code that attempts to interface to | |
| 642 ;;; humans and produce "intuitive" results gets messy, particularly with a | |
| 643 ;;; system as complicated as specifiers, whose complexity results from an | |
| 644 ;;; attempt to work well in many different circumstances. We could create | |
| 645 ;;; a much simpler system, but the tradeoff would be that you'd have to | |
| 646 ;;; programmatically control all the stuff that gets handled automatically | |
| 647 ;;; by setting the right specifiers -- and then things wouldn't "just work" | |
| 648 ;;; if the user simultaneously creates a TTY and X device, or X devices on | |
| 649 ;;; different types of machines, or wants some buffers to display | |
| 650 ;;; differently from others, etc. without a lot of hook functions and other | |
| 651 ;;; glue machinery to set everything up. The result would be just as much | |
| 652 ;;; complexity, but worse, and much harder to control, since there wouldn't | |
| 653 ;;; be any standard framework for managing all these hook functions and the | |
| 654 ;;; user would have to be able to write lots of Lisp code to get things | |
| 655 ;;; working. | |
| 656 | |
| 657 ;;; The problem is that we have no high-level code, e.g. custom, to make it | |
| 658 ;;; easy for the user to control specifiers nicely. The following | |
| 659 ;;; lower-level code, though, should make it easier to implement the | |
| 660 ;;; high-level code. | |
| 661 | |
| 662 ;;; #### Something like Face-frob-property, but more general, should be | |
| 663 ;;; created for general specifier frobbing. | |
| 664 | |
| 665 ;;; #### Other possible extensions to specifiers would be | |
| 666 ;;; | |
| 667 ;;; (a) the ability to create specifications for particular types of | |
| 668 ;;; buffers, e.g. all C-mode buffers one way, all text-mode buffers | |
| 669 ;;; another way, etc. Perhaps this should be implemented through hook | |
| 670 ;;; functions; but that wouldn't easily allow you to `make-face-bold' | |
| 671 ;;; and have it work on these other kinds of specifications. Probably | |
| 672 ;;; a better way is to extend the tag mechanism so that it can specify | |
| 673 ;;; things other than device types. One way would be to simply allow | |
| 674 ;;; tags to have arbitrary elisp attached to them -- a function that | |
| 675 ;;; takes a domain and returns whether the attached instantiator | |
| 676 ;;; applies. This should be doable given (a) that we now have code to | |
| 677 ;;; allow elisp to be run inside a "sandbox", sufficiently protected | |
| 678 ;;; that it can even be called from redisplay, and (b) the large amount | |
| 679 ;;; of caching we already have, which would minimize the speed hit. | |
| 680 ;;; However, this still runs into problems -- (a) it requires | |
| 681 ;;; programming to get anything at all done, and (b) you'll get | |
| 682 ;;; horrible namespace clashes very quickly. Another possibility to be | |
| 683 ;;; used in conjunction with this would be vector tags, with an | |
| 684 ;;; extendable mechanism to control their syntax. For example, | |
| 685 ;;; | |
| 686 ;;; [tag :mode 'c] (buffer in c-mode) | |
| 687 ;;; [tag :buffer-name "\\*Help: function"] (help-on-function buffers) | |
| 688 ;;; [tag :buffer-coding-system 'japanese-euc] (buffer's coding system is | |
| 689 ;;; EUC-JP) | |
| 690 ;;; [tag :buffer-file-name "^#.*#$"] (autosave files) | |
| 691 ;;; [tag :language-environment "French"] (whenever the global language | |
| 692 ;;; environment is French) | |
| 693 ;;; [tag :font-height-minimum '(default 12)] (if the height of the default | |
| 694 ;;; font is at least 12 pixels | |
| 695 ;;; in this domain) | |
| 696 ;;; | |
| 697 ;;; The general idea is that the properties allowable in a tag vector | |
| 698 ;;; are extendable, just by specifying the property name and a function | |
| 699 ;;; of two arguments, the property value and the domain, which should | |
| 700 ;;; return whether the tag applies. You could imagine very complex | |
| 701 ;;; behavior (e.g. combining two tags in a single tag set makes an | |
| 702 ;;; `and', and putting the two tags separately with separate (perhaps | |
| 703 ;;; identical) instantiators makes an `or'. You could effectively do a | |
| 704 ;;; lot of what you might want to do with hooks, but in a much more | |
| 705 ;;; controllable fashion. Obviously, much of this complexity wouldn't | |
| 706 ;;; necessarily be directly set by the user -- they wouldn't probably | |
| 707 ;;; do more than simple tags based on mode, buffer or file name, etc. | |
| 708 ;;; But a higher-level interface could easily have various possible | |
| 709 ;;; "behaviors" to choose from, implemented using this mechanism. | |
| 710 ;;; | |
| 711 ;;; #### WE NEED CUSTOM SUPPORT! | |
| 712 ;;; | |
| 713 ;;; (b) Another possibility is "partial" inheritance. For example -- | |
| 714 ;;; toolbars and menubars are complex specifications. Currently the | |
| 715 ;;; only way to make a change is to copy the entire value and make the | |
| 716 ;;; necessary modifications. What we would like instead is to be able | |
| 717 ;;; to construct a mini-menubar that says something like "add this menu | |
| 718 ;;; here" and combine with everything else. That would require a | |
| 719 ;;; slightly different approach to instantiation. Currently it just | |
| 720 ;;; searches up the tree from specific to general, looking for a match; | |
| 721 ;;; from this match, it generates the instance. Instead, it would | |
| 722 ;;; potentially have to record all the matches it found and pass a list | |
| 723 ;;; of them to the instantiation function. To implement this, we would | |
| 724 ;;; create another specifier method "instantiator_inherits_up", which | |
| 725 ;;; looks at the instantiator to determine if it calls for combining | |
| 726 ;;; itself with the value higher up. this tells the specifier code | |
| 727 ;;; whether to stop now or keep going. It would then pass a Dynarr of | |
| 728 ;;; the instantiators to the instantiate method, which might be a | |
| 729 ;;; special version, e.g. "instantiate_multi". | |
| 730 | |
| 731 (defun instance-to-instantiator (inst) | |
| 732 "Convert an instance to an instantiator. | |
| 733 If we have an instance object, we fetch the instantiator that generated the object. Otherwise, we just return the instance." | |
| 734 (cond ((font-instance-p inst) | |
| 735 (setq inst (font-instance-name inst))) | |
| 736 ((color-instance-p inst) | |
| 737 (setq inst (color-instance-name inst))) | |
| 738 ((image-instance-p inst) | |
| 739 (setq inst (image-instance-instantiator inst))) | |
| 740 (t inst))) | |
| 741 | |
| 742 (defun device-type-matches-spec (devtype devtype-spec) | |
| 743 ;; Return DEVTYPE (a devtype) if it matches DEVTYPE-SPEC, else nil. | |
| 744 ;; DEVTYPE-SPEC can be nil (all types OK), a device type (only that type | |
| 745 ;; OK), or `window-system' -- window system device types OK. | |
| 746 (cond ((not devtype-spec) devtype) | |
| 747 ((eq devtype-spec 'window-system) | |
| 3926 | 748 (and (not (memq devtype '(msprinter tty stream))) devtype)) |
| 872 | 749 (t (and (eq devtype devtype-spec) devtype)))) |
| 750 | |
| 751 (defun add-tag-to-inst-list (inst-list tag-set) | |
| 752 "Add TAG-SET (tag or tag-set) to all tags in INST-LIST." | |
| 753 ;; Ah, all is sweetness and light with `loop' | |
| 754 (if (null tag-set) inst-list | |
| 755 (loop for (t2 . x2) in inst-list | |
| 756 for newt2 = (delete-duplicates | |
| 757 (append (if (listp tag-set) tag-set (list tag-set)) | |
| 758 (if (listp t2) t2 (list t2)))) | |
| 759 collect (cons newt2 x2)))) | |
| 760 | |
| 761 (defun derive-domain-from-locale (locale &optional devtype-spec current-device) | |
| 762 "Given a locale, try to derive the \"most reasonable\" domain. | |
| 763 | |
| 764 This is a heuristic \(\"works most of the time\") algorithm. | |
| 765 | |
| 766 \[Remember that, in specifiers, locales are what you attach specifications or | |
| 767 \"instantiators\" to, and domains are the contexts in which you can | |
| 768 retrieve the value or \"instance\" of the specifier. Not all locales are | |
| 769 domains. In particular, buffers are locales but not domains because | |
| 770 buffers may be displayed in different windows on different frames, and thus | |
| 771 end up with different values if the frames each have a frame-local | |
| 772 instantiator and the instantiators are different. However, we may well | |
| 773 find ourselves in a situation where we want to figure out the most likely | |
| 774 value of a specifier in a buffer -- for example we might conceptually want | |
| 775 to make a buffer's modeline face be bold, so we need to figure out what the | |
| 776 current face is. If the buffer already has an instantiator, it's easy; but | |
| 777 if it doesn't, we want to do something reasonable rather than just issue an | |
| 778 error, even though technically the value is not well-defined. We want | |
| 779 something that gives the right answer most of the time.] | |
| 780 | |
| 781 LOCALE is a specifier locale -- i.e. a buffer, window, frame, device, the | |
| 782 symbol `global', or nil, meaning the same as `global'. | |
| 783 | |
| 784 DEVTYPE-SPEC, if given, can restrict the possible return values to domains | |
| 785 on devices of that device type; or if it's `window-system', to domains on | |
| 786 window-system devices. | |
| 787 | |
| 788 CURRENT-DEVICE is what should be considered as the \"selected device\" when | |
| 789 this value is needed. It defaults to the currently selected device. | |
| 790 | |
| 791 -- If LOCALE is a domain, it's simply returned. | |
| 792 -- If LOCALE is `all', `global', or nil, we return CURRENT-DEVICE. | |
| 793 -- If LOCALE is a buffer, we use `get-buffer-window' to find a window viewing | |
| 794 the buffer, and return it if there is one; otherwise we return the selected | |
| 795 window on CURRENT-DEVICE. | |
| 796 | |
| 797 The return value may be nil if the only possible values don't agree with | |
| 798 DEVTYPE-SPEC." | |
| 799 ;; DEVICE aims to be the selected device, but picks some other | |
| 800 ;; device if that won't work. may be nil. | |
| 801 (let* ((device (or current-device (selected-device))) | |
| 802 (device (if (device-type-matches-spec (device-type device) | |
| 803 devtype-spec) | |
| 804 device | |
| 805 (first | |
| 806 (delete-if-not | |
| 807 #'(lambda (x) | |
| 808 (device-type-matches-spec (device-type x) | |
| 809 devtype-spec)) | |
| 810 (device-list)))))) | |
| 811 (cond ((memq locale '(all nil global)) device) | |
| 812 ((valid-specifier-domain-p locale) | |
| 813 (and (device-type-matches-spec (device-type (dfw-device locale)) | |
| 814 devtype-spec) | |
| 815 locale)) | |
| 816 ((bufferp locale) | |
| 817 (let ((win (get-buffer-window locale t devtype-spec))) | |
| 818 (or win (and device (selected-window device)))))))) | |
| 819 | |
| 820 (defun derive-device-type-from-tag-set (tag-set &optional try-stages | |
| 821 devtype-spec current-device) | |
| 822 "Given a tag set, try (heuristically) to get a device type from it. | |
| 823 | |
| 3926 | 824 If CURRENT-DEVICE is supplied, then this function either returns its type, |
| 825 in the event that it matches TAG-SET, or nil. | |
| 826 | |
| 827 Otherwise, there are three stages that it proceeds through, each one trying | |
| 872 | 828 harder than the previous to get a value. TRY-STAGES controls how many |
| 829 stages to try. If nil or 1, only stage 1 is done; if 2; stages 1 and 2 are | |
| 830 done; if 3, stages 1-3 are done; if t, all stages are done (currently 1-3). | |
| 831 | |
| 832 Stage 1 looks at the tags themselves to see if any of them are device-type | |
| 833 tags. If so, it returns the device type. If there is more than one device | |
| 834 type, this tag can never match anything, but we go ahead and return one of | |
| 835 them. If no device types in the tags, we fail. | |
| 836 | |
| 837 Stage 2 runs all devices through the tag set to see if any match, and | |
| 838 accumulate a list of device types of all matching devices. If there is | |
| 839 exactly one device type in the list, we return it, else fail. | |
| 840 | |
| 841 Stage 3 picks up from where stage 2 left off, and tries hard to return | |
| 842 *SOME* device type in all possible situations, modulo the DEVTYPE-SPEC | |
| 843 flag. \(DEVTYPE-SPEC and CURRENT-DEVICE are the same as in | |
| 844 `derive-domain-from-locale'.) | |
| 845 | |
| 846 Specifically: | |
| 847 | |
| 848 \(a) if no matching devices, return the selected device's type. | |
| 849 \(b) if more than device type and the selected device's type is | |
| 850 listed, use it. | |
| 851 \(c) else, pick one of the device types (currently the first). | |
| 852 | |
| 853 This will never return a device type that's incompatible with the | |
| 854 DEVTYPE-SPEC flag; thus, it may return nil." | |
| 855 (or try-stages (setq try-stages 1)) | |
| 856 (if (eq try-stages t) (setq try-stages 3)) | |
| 857 (check-argument-range try-stages 1 3) | |
|
5567
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
858 (labels ((delete-wrong-type (x) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
859 (delete-if-not |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
860 #'(lambda (y) (device-type-matches-spec y devtype-spec)) x))) |
| 3926 | 861 (let ((both (intersection |
| 862 (if current-device | |
| 863 (list (device-type current-device)) | |
| 864 (device-type-list)) | |
| 865 (canonicalize-tag-set tag-set)))) | |
| 872 | 866 ;; shouldn't be more than one (will fail), but whatever |
| 867 (if both (first (delete-wrong-type both)) | |
| 3926 | 868 (and (>= try-stages 2) |
| 869 ;; no device types mentioned. try the hard way, | |
| 870 ;; i.e. check each existing device (or the | |
| 871 ;; supplied device) to see if it will pass muster. | |
| 872 ;; | |
| 873 ;; Further checking is not relevant if current-device was | |
| 874 ;; supplied. | |
| 875 (not current-device) | |
| 876 (let ((okdevs | |
| 877 (delete-wrong-type | |
| 878 (delete-duplicates | |
| 879 (mapcan | |
| 880 #'(lambda (dev) | |
| 881 (and (device-matches-specifier-tag-set-p | |
| 882 dev tag-set) | |
| 883 (list (device-type dev)))) | |
| 884 (if current-device | |
| 885 (list current-device) | |
| 886 (device-list)))))) | |
| 887 (devtype (cond ((or (null devtype-spec) | |
| 888 (eq devtype-spec 'window-system)) | |
| 889 (let ((dev (derive-domain-from-locale | |
| 890 'global devtype-spec | |
| 891 current-device))) | |
| 892 (and dev (device-type dev)))) | |
| 893 (t devtype-spec)))) | |
|
5366
f00192e1cd49
Examining the result of #'length: `eql', not `=', it's better style & cheaper
Aidan Kehoe <kehoea@parhasard.net>
parents:
5267
diff
changeset
|
894 (cond ((eql 1 (length okdevs)) (car okdevs)) |
| 3926 | 895 ((< try-stages 3) nil) |
| 896 ((null okdevs) devtype) | |
| 897 ((memq devtype okdevs) devtype) | |
| 898 (t (car okdevs))))))))) | |
| 872 | 899 |
| 900 ;; Sheesh, the things you do to get "intuitive" behavior. | |
| 901 (defun derive-device-type-from-locale-and-tag-set (locale tag-set | |
| 902 &optional devtype-spec | |
| 903 current-device) | |
| 904 "Try to derive a device type from a locale and tag set. | |
| 905 | |
| 906 If the locale is a domain, use the domain's device type. Else, if the tag | |
| 907 set uniquely specifies a device type, use it. Else, if a buffer is given, | |
| 908 find a window visiting the buffer, and if any, use its device type. | |
| 909 Finally, go back to the tag set and \"try harder\" -- if the selected | |
| 910 device matches the tag set, use its device type, else use some valid device | |
| 911 type from the tag set. | |
| 912 | |
| 913 DEVTYPE-SPEC and CURRENT-DEVICE as in `derive-domain-from-locale'." | |
| 914 (cond ((valid-specifier-domain-p locale) | |
| 915 ;; if locale is a domain, then it must match DEVTYPE-SPEC, | |
| 916 ;; or we exit immediately with nil. | |
| 917 (device-type-matches-spec (device-type (dfw-device locale)) | |
| 918 devtype-spec)) | |
| 919 ((derive-device-type-from-tag-set tag-set 2 devtype-spec | |
| 920 current-device)) | |
| 921 ((and (bufferp locale) | |
| 922 (let ((win (get-buffer-window locale t devtype-spec))) | |
| 923 (and win (device-type (dfw-device win)))))) | |
| 924 ((derive-device-type-from-tag-set tag-set t devtype-spec | |
| 925 current-device)))) | |
| 926 | |
| 927 (defun derive-specifier-specs-from-locale (specifier locale | |
| 928 &optional devtype-spec | |
| 929 current-device | |
| 930 global-use-fallback) | |
| 931 "Heuristically find the specs of a specifier in a locale. | |
| 932 | |
| 933 This tries to find some reasonable instantiators that are most likely to | |
| 934 correspond to the specifier's \"value\" (i.e. instance) in a particular | |
| 935 locale, even when the user has not specifically set any such instantiators. | |
| 936 This is useful for functions that want to modify the instance of a | |
| 937 specifier in a particular locale, and only in that locale. | |
| 938 | |
| 939 Keep in mind that this is a heuristic (i.e. kludge) function, and that it | |
| 940 may not always give the right results, since the operation is not | |
| 941 technically well-defined in many cases! (See `derive-domain-from-locale'.) | |
| 942 | |
| 943 DEVTYPE-SPEC and CURRENT-DEVICE are as in `derive-domain-from-locale'. | |
| 944 | |
| 945 The return value is an inst-list, i.e. | |
| 946 | |
| 947 ((TAG-SET . INSTANTIATOR) ...) | |
| 948 | |
| 949 More specifically, if there is already a spec in the locale, it's just | |
| 950 returned. Otherwise, if LOCALE is `global', `all', or nil: If | |
| 951 GLOBAL-USE-FALLBACK is non-nil, the fallback is fetched, and returned, with | |
| 952 `default' added to the tag set; else, we use CURRENT-DEVICE (defaulting to | |
| 953 the selected device) as a domain and proceed as in the following. If | |
| 954 LOCALE is a domain (window, frame, device), the specifier's instance in | |
| 955 that domain is computed, and converted back to an instantiator | |
| 956 \(`instance-to-instantiator'). Else, if LOCALE is a buffer, we use | |
| 957 `derive-domain-from-locale' to heuristically get a likely domain, and | |
| 958 proceed as if LOCALE were a domain." | |
| 959 (if (memq locale '(all nil)) (setq locale 'global)) | |
| 960 (let ((current (specifier-spec-list specifier locale))) | |
| 961 (if current (cdar current) | |
| 962 ;; case 1: a global locale, fallbacks | |
| 963 (cond ((and (eq locale 'global) global-use-fallback) | |
| 964 ;; if nothing there globally, retrieve the fallback. | |
| 965 ;; this is either an inst-list or a specifier. in the | |
| 966 ;; latter case, we need to recursively retrieve its | |
| 967 ;; fallback. | |
| 968 (let (sofar | |
| 969 (fallback (specifier-fallback specifier))) | |
| 970 (while (specifierp fallback) | |
| 971 (setq sofar (nconc sofar | |
| 972 (cdar (specifier-spec-list fallback | |
| 973 'global)))) | |
| 974 (setq fallback (specifier-fallback fallback))) | |
| 975 (add-tag-to-inst-list (nconc sofar fallback) 'default))) | |
| 976 (t | |
| 977 (let (domain) | |
| 978 ;; case 2: window, frame, device locale | |
| 979 (cond ((eq locale 'global) | |
| 980 (setq domain (or current-device (selected-device)))) | |
| 981 ((valid-specifier-domain-p locale) | |
| 982 (setq domain locale)) | |
| 983 ;; case 3: buffer locale | |
| 984 ((bufferp locale) | |
| 985 (setq domain (derive-domain-from-locale | |
| 986 locale devtype-spec current-device))) | |
| 987 (t nil)) | |
| 988 ;; retrieve an instance, convert back to instantiator | |
| 989 (when domain | |
| 990 (let ((inst | |
| 991 (instance-to-instantiator | |
| 992 (specifier-instance specifier domain)))) | |
| 993 (list (cons nil inst)))))))))) | |
| 994 | |
|
4489
b75b075a9041
Support displaying invalid UTF-8 in language-environment-specific ways.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4194
diff
changeset
|
995 ;; Character 160 (octal 0240) displays incorrectly under some X |
|
b75b075a9041
Support displaying invalid UTF-8 in language-environment-specific ways.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4194
diff
changeset
|
996 ;; installations apparently due to a universally crocked font width |
|
b75b075a9041
Support displaying invalid UTF-8 in language-environment-specific ways.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4194
diff
changeset
|
997 ;; specification. Display it as a space since that's what's expected. |
|
b75b075a9041
Support displaying invalid UTF-8 in language-environment-specific ways.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4194
diff
changeset
|
998 ;; |
|
b75b075a9041
Support displaying invalid UTF-8 in language-environment-specific ways.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4194
diff
changeset
|
999 ;; (make-char-table 'generic) instead of (make-display-table) because |
|
b75b075a9041
Support displaying invalid UTF-8 in language-environment-specific ways.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4194
diff
changeset
|
1000 ;; make-display-table isn't dumped, and this file is. |
|
b75b075a9041
Support displaying invalid UTF-8 in language-environment-specific ways.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4194
diff
changeset
|
1001 ;; |
|
b75b075a9041
Support displaying invalid UTF-8 in language-environment-specific ways.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4194
diff
changeset
|
1002 ;; We also want the global display table to be actually globally |
|
b75b075a9041
Support displaying invalid UTF-8 in language-environment-specific ways.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4194
diff
changeset
|
1003 ;; initialised; that's why this is here, and not in x-init.el, these days. |
|
b75b075a9041
Support displaying invalid UTF-8 in language-environment-specific ways.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4194
diff
changeset
|
1004 |
|
b75b075a9041
Support displaying invalid UTF-8 in language-environment-specific ways.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4194
diff
changeset
|
1005 (set-specifier current-display-table |
|
5222
18c0b5909d16
Use keywords in structure syntax; new #define, NEED_TO_HANDLE_21_4_CODE 1
Aidan Kehoe <kehoea@parhasard.net>
parents:
4489
diff
changeset
|
1006 #s(char-table :type generic :data (?\xA0 ?\x20)) |
|
4489
b75b075a9041
Support displaying invalid UTF-8 in language-environment-specific ways.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4194
diff
changeset
|
1007 'global) |
|
b75b075a9041
Support displaying invalid UTF-8 in language-environment-specific ways.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4194
diff
changeset
|
1008 |
| 428 | 1009 ;;; specifier.el ends here |