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