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