428
+ − 1 ;;; specifier.el --- Lisp interface to specifiers
+ − 2
+ − 3 ;; Copyright (C) 1997 Free Software Foundation, Inc.
872
+ − 4 ;; Copyright (C) 1995, 1996, 2000, 2002 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
+ − 58 type. If MS-LOCALE is 'all or nil, MS-FUNC will be mapped over all locales in
+ − 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
+ − 309 specifier is instanced, or a Lisp object that can be instantiated to
+ − 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
+ − 333 just the 'global one!
+ − 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
+ − 350 devices that match all specified tags. (You can also create your
+ − 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
+ − 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
442
+ − 414 (defun modify-specifier-instances (specifier func &optional args force default
872
+ − 415 locale tag-set)
442
+ − 416 "Modify all specifications that match LOCALE and TAG-SET by FUNC.
+ − 417
+ − 418 For each specification that exists for SPECIFIER, in locale LOCALE
+ − 419 that matches TAG-SET, call the function FUNC with the instance as its
+ − 420 first argument and with optional arguments ARGS. The result is then
+ − 421 used as the new value of the instantiator.
+ − 422
+ − 423 If there is no specification in the domain LOCALE matching TAG-SET and
+ − 424 FORCE is non-nil, an explicit one is created from the matching
+ − 425 specifier instance if that exists or DEFAULT otherwise. If LOCALE is
+ − 426 not a domain (i.e. a buffer), DEFAULT is always used. FUNC is then
+ − 427 applied like above and the resulting specification is added."
+ − 428
+ − 429 (let ((spec-list (specifier-spec-list specifier locale tag-set)))
+ − 430 (cond
+ − 431 (spec-list
+ − 432 ;; Destructively edit the spec-list
+ − 433 (mapc #'(lambda (spec)
+ − 434 (mapc #'(lambda (inst-pair)
+ − 435 (setcdr inst-pair
+ − 436 (apply func (cdr inst-pair) args)))
+ − 437 (cdr spec)))
+ − 438 spec-list)
+ − 439 (add-spec-list-to-specifier specifier spec-list))
+ − 440 (force
+ − 441 (set-specifier specifier
+ − 442 (apply func
+ − 443 (or (and (valid-specifier-domain-p locale)
+ − 444 (specifier-instance specifier))
+ − 445 default) args)
+ − 446 locale tag-set)))))
+ − 447
428
+ − 448 (defmacro let-specifier (specifier-list &rest body)
+ − 449 "Add specifier specs, evaluate forms in BODY and restore the specifiers.
+ − 450 \(let-specifier SPECIFIER-LIST BODY...)
+ − 451
+ − 452 Each element of SPECIFIER-LIST should look like this:
+ − 453 \(SPECIFIER VALUE &optional LOCALE TAG-SET HOW-TO-ADD).
+ − 454
+ − 455 SPECIFIER is the specifier to be temporarily modified. VALUE is the
+ − 456 instantiator to be temporarily added to SPECIFIER in LOCALE. LOCALE,
+ − 457 TAG-SET and HOW-TO-ADD have the same meaning as in
+ − 458 `add-spec-to-specifier'.
+ − 459
+ − 460 The code resulting from macro expansion will add specifications to
+ − 461 specifiers using `add-spec-to-specifier'. After BODY is finished, the
+ − 462 temporary specifications are removed and old spec-lists are restored.
+ − 463
+ − 464 LOCALE, TAG-SET and HOW-TO-ADD may be omitted, and default to nil.
+ − 465 The value of the last form in BODY is returned.
+ − 466
+ − 467 NOTE: If you want the specifier's instance to change in all
+ − 468 circumstances, use (selected-window) as the LOCALE. If LOCALE is nil
+ − 469 or omitted, it defaults to `global'.
+ − 470
+ − 471 Example:
+ − 472 (let-specifier ((modeline-shadow-thickness 0 (selected-window)))
+ − 473 (sit-for 1))"
+ − 474 (check-argument-type 'listp specifier-list)
+ − 475 (flet ((gensym-frob (x name)
+ − 476 (if (or (atom x) (eq (car x) 'quote))
+ − 477 (list x)
+ − 478 (list (gensym name) x))))
+ − 479 ;; VARLIST is a list of
+ − 480 ;; ((SPECIFIERSYM SPECIFIER) (VALUE) (LOCALESYM LOCALE)
+ − 481 ;; (TAG-SET) (HOW-TO-ADD))
+ − 482 ;; If any of these is an atom, then a separate symbol is
+ − 483 ;; unnecessary, the CAR will contain the atom and CDR will be nil.
+ − 484 (let* ((varlist (mapcar #'(lambda (listel)
+ − 485 (or (and (consp listel)
+ − 486 (<= (length listel) 5)
+ − 487 (> (length listel) 1))
+ − 488 (signal 'error
+ − 489 (list
+ − 490 "should be a list of 2-5 elements"
+ − 491 listel)))
+ − 492 ;; VALUE, TAG-SET and HOW-TO-ADD are
+ − 493 ;; referenced only once, so we needn't
+ − 494 ;; frob them with gensym.
+ − 495 (list (gensym-frob (nth 0 listel) "specifier-")
+ − 496 (list (nth 1 listel))
+ − 497 (gensym-frob (nth 2 listel) "locale-")
+ − 498 (list (nth 3 listel))
+ − 499 (list (nth 4 listel))))
+ − 500 specifier-list))
+ − 501 ;; OLDVALLIST is a list of (OLDVALSYM OLDVALFORM)
+ − 502 (oldvallist (mapcar #'(lambda (varel)
+ − 503 (list (gensym "old-")
+ − 504 `(specifier-spec-list
+ − 505 ,(car (nth 0 varel))
+ − 506 ,(car (nth 2 varel)))))
+ − 507 varlist)))
+ − 508 ;; Bind the appropriate variables.
+ − 509 `(let* (,@(mapcan #'(lambda (varel)
+ − 510 (delq nil (mapcar
+ − 511 #'(lambda (varcons)
+ − 512 (and (cdr varcons) varcons))
+ − 513 varel)))
+ − 514 varlist)
+ − 515 ,@oldvallist)
+ − 516 (unwind-protect
+ − 517 (progn
+ − 518 ,@(mapcar #'(lambda (varel)
+ − 519 `(add-spec-to-specifier
+ − 520 ,(car (nth 0 varel)) ,(car (nth 1 varel))
+ − 521 ,(car (nth 2 varel)) ,(car (nth 3 varel))
+ − 522 ,(car (nth 4 varel))))
+ − 523 varlist)
+ − 524 ,@body)
+ − 525 ;; Reverse the unwinding order, so that using the same
+ − 526 ;; specifier multiple times works.
+ − 527 ,@(apply #'nconc (nreverse (mapcar*
+ − 528 #'(lambda (oldval varel)
+ − 529 `((remove-specifier
+ − 530 ,(car (nth 0 varel))
+ − 531 ,(car (nth 2 varel)))
+ − 532 (add-spec-list-to-specifier
+ − 533 ,(car (nth 0 varel))
+ − 534 ,(car oldval))))
+ − 535 oldvallist varlist))))))))
+ − 536
442
+ − 537 (defun make-integer-specifier (spec-list)
+ − 538 "Return a new `integer' specifier object with the given specification list.
+ − 539 SPEC-LIST can be a list of specifications (each of which is a cons of a
+ − 540 locale and a list of instantiators), a single instantiator, or a list
+ − 541 of instantiators. See `make-specifier' for more information about
+ − 542 specifiers.
+ − 543
+ − 544 Valid instantiators for integer specifiers are integers."
+ − 545 (make-specifier-and-init 'integer spec-list))
+ − 546
+ − 547 (defun make-boolean-specifier (spec-list)
+ − 548 "Return a new `boolean' specifier object with the given specification list.
+ − 549 SPEC-LIST can be a list of specifications (each of which is a cons of a
+ − 550 locale and a list of instantiators), a single instantiator, or a list
+ − 551 of instantiators. See `make-specifier' for more information about
+ − 552 specifiers.
+ − 553
+ − 554 Valid instantiators for boolean specifiers are t and nil."
+ − 555 (make-specifier-and-init 'boolean spec-list))
+ − 556
+ − 557 (defun make-natnum-specifier (spec-list)
+ − 558 "Return a new `natnum' specifier object with the given specification list.
+ − 559 SPEC-LIST can be a list of specifications (each of which is a cons of a
+ − 560 locale and a list of instantiators), a single instantiator, or a list
+ − 561 of instantiators. See `make-specifier' for more information about
+ − 562 specifiers.
+ − 563
+ − 564 Valid instantiators for natnum specifiers are non-negative integers."
+ − 565 (make-specifier-and-init 'natnum spec-list))
+ − 566
+ − 567 (defun make-generic-specifier (spec-list)
+ − 568 "Return a new `generic' specifier object with the given specification list.
+ − 569 SPEC-LIST can be a list of specifications (each of which is a cons of a
+ − 570 locale and a list of instantiators), a single instantiator, or a list
+ − 571 of instantiators. See `make-specifier' for more information about
+ − 572 specifiers.
+ − 573
+ − 574 Valid instantiators for generic specifiers are all Lisp values.
+ − 575 They are returned back unchanged when a specifier is instantiated."
+ − 576 (make-specifier-and-init 'generic spec-list))
+ − 577
+ − 578 (defun make-display-table-specifier (spec-list)
+ − 579 "Return a new `display-table' specifier object with the given spec list.
+ − 580 SPEC-LIST can be a list of specifications (each of which is a cons of a
+ − 581 locale and a list of instantiators), a single instantiator, or a list
+ − 582 of instantiators. See `make-specifier' for more information about
+ − 583 specifiers.
+ − 584
+ − 585 Valid instantiators for display-table specifiers are described in
+ − 586 detail in the doc string for `current-display-table'."
+ − 587 (make-specifier-and-init 'display-table spec-list))
+ − 588
428
+ − 589 ;; Evaluate this for testing:
+ − 590 ; (cl-prettyexpand '(let-specifier ((modeline-shadow-thickness 0 (selected-window) 'x) (fubar (value) baz)) (sit-for 1)))
+ − 591
+ − 592 (define-specifier-tag 'win 'device-on-window-system-p)
+ − 593
+ − 594 ;; Add tags for device types that don't have support compiled
+ − 595 ;; into the binary that we're about to dump. This will prevent
+ − 596 ;; code like
+ − 597 ;;
+ − 598 ;; (set-face-foreground 'default "black" nil '(x color))
+ − 599 ;;
+ − 600 ;; from producing an error if no X support was compiled in.
+ − 601
+ − 602 (or (valid-specifier-tag-p 'x)
+ − 603 (define-specifier-tag 'x (lambda (dev) (eq (device-type dev) 'x))))
+ − 604 (or (valid-specifier-tag-p 'tty)
+ − 605 (define-specifier-tag 'tty (lambda (dev) (eq (device-type dev) 'tty))))
+ − 606 (or (valid-specifier-tag-p 'mswindows)
+ − 607 (define-specifier-tag 'mswindows (lambda (dev)
+ − 608 (eq (device-type dev) 'mswindows))))
630
+ − 609 (or (valid-specifier-tag-p 'gtk)
+ − 610 (define-specifier-tag 'gtk (lambda (dev) (eq (device-type dev) 'gtk))))
428
+ − 611
+ − 612 ;; Add special tag for use by initialization code. Code that
+ − 613 ;; sets up default specs should use this tag. Code that needs to
+ − 614 ;; override default specs (e.g. the X resource initialization
+ − 615 ;; code) can safely clear specs with this tag without worrying
+ − 616 ;; about clobbering user settings.
+ − 617
+ − 618 (define-specifier-tag 'default)
+ − 619
872
+ − 620 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 621 ;;; "Heuristic" specifier functions ;;;
+ − 622 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 623
+ − 624 ;;; "Heuristic" is a euphemism for kludge. This stuff works well in
+ − 625 ;;; practice, though.
+ − 626
+ − 627 ;;; You might view all the contortions we do here and in Face-frob-property
+ − 628 ;;; as indicative of design failures with specifiers, and perhaps you're
+ − 629 ;;; right. But in fact almost all code that attempts to interface to
+ − 630 ;;; humans and produce "intuitive" results gets messy, particularly with a
+ − 631 ;;; system as complicated as specifiers, whose complexity results from an
+ − 632 ;;; attempt to work well in many different circumstances. We could create
+ − 633 ;;; a much simpler system, but the tradeoff would be that you'd have to
+ − 634 ;;; programmatically control all the stuff that gets handled automatically
+ − 635 ;;; by setting the right specifiers -- and then things wouldn't "just work"
+ − 636 ;;; if the user simultaneously creates a TTY and X device, or X devices on
+ − 637 ;;; different types of machines, or wants some buffers to display
+ − 638 ;;; differently from others, etc. without a lot of hook functions and other
+ − 639 ;;; glue machinery to set everything up. The result would be just as much
+ − 640 ;;; complexity, but worse, and much harder to control, since there wouldn't
+ − 641 ;;; be any standard framework for managing all these hook functions and the
+ − 642 ;;; user would have to be able to write lots of Lisp code to get things
+ − 643 ;;; working.
+ − 644
+ − 645 ;;; The problem is that we have no high-level code, e.g. custom, to make it
+ − 646 ;;; easy for the user to control specifiers nicely. The following
+ − 647 ;;; lower-level code, though, should make it easier to implement the
+ − 648 ;;; high-level code.
+ − 649
+ − 650 ;;; #### Something like Face-frob-property, but more general, should be
+ − 651 ;;; created for general specifier frobbing.
+ − 652
+ − 653 ;;; #### Other possible extensions to specifiers would be
+ − 654 ;;;
+ − 655 ;;; (a) the ability to create specifications for particular types of
+ − 656 ;;; buffers, e.g. all C-mode buffers one way, all text-mode buffers
+ − 657 ;;; another way, etc. Perhaps this should be implemented through hook
+ − 658 ;;; functions; but that wouldn't easily allow you to `make-face-bold'
+ − 659 ;;; and have it work on these other kinds of specifications. Probably
+ − 660 ;;; a better way is to extend the tag mechanism so that it can specify
+ − 661 ;;; things other than device types. One way would be to simply allow
+ − 662 ;;; tags to have arbitrary elisp attached to them -- a function that
+ − 663 ;;; takes a domain and returns whether the attached instantiator
+ − 664 ;;; applies. This should be doable given (a) that we now have code to
+ − 665 ;;; allow elisp to be run inside a "sandbox", sufficiently protected
+ − 666 ;;; that it can even be called from redisplay, and (b) the large amount
+ − 667 ;;; of caching we already have, which would minimize the speed hit.
+ − 668 ;;; However, this still runs into problems -- (a) it requires
+ − 669 ;;; programming to get anything at all done, and (b) you'll get
+ − 670 ;;; horrible namespace clashes very quickly. Another possibility to be
+ − 671 ;;; used in conjunction with this would be vector tags, with an
+ − 672 ;;; extendable mechanism to control their syntax. For example,
+ − 673 ;;;
+ − 674 ;;; [tag :mode 'c] (buffer in c-mode)
+ − 675 ;;; [tag :buffer-name "\\*Help: function"] (help-on-function buffers)
+ − 676 ;;; [tag :buffer-coding-system 'japanese-euc] (buffer's coding system is
+ − 677 ;;; EUC-JP)
+ − 678 ;;; [tag :buffer-file-name "^#.*#$"] (autosave files)
+ − 679 ;;; [tag :language-environment "French"] (whenever the global language
+ − 680 ;;; environment is French)
+ − 681 ;;; [tag :font-height-minimum '(default 12)] (if the height of the default
+ − 682 ;;; font is at least 12 pixels
+ − 683 ;;; in this domain)
+ − 684 ;;;
+ − 685 ;;; The general idea is that the properties allowable in a tag vector
+ − 686 ;;; are extendable, just by specifying the property name and a function
+ − 687 ;;; of two arguments, the property value and the domain, which should
+ − 688 ;;; return whether the tag applies. You could imagine very complex
+ − 689 ;;; behavior (e.g. combining two tags in a single tag set makes an
+ − 690 ;;; `and', and putting the two tags separately with separate (perhaps
+ − 691 ;;; identical) instantiators makes an `or'. You could effectively do a
+ − 692 ;;; lot of what you might want to do with hooks, but in a much more
+ − 693 ;;; controllable fashion. Obviously, much of this complexity wouldn't
+ − 694 ;;; necessarily be directly set by the user -- they wouldn't probably
+ − 695 ;;; do more than simple tags based on mode, buffer or file name, etc.
+ − 696 ;;; But a higher-level interface could easily have various possible
+ − 697 ;;; "behaviors" to choose from, implemented using this mechanism.
+ − 698 ;;;
+ − 699 ;;; #### WE NEED CUSTOM SUPPORT!
+ − 700 ;;;
+ − 701 ;;; (b) Another possibility is "partial" inheritance. For example --
+ − 702 ;;; toolbars and menubars are complex specifications. Currently the
+ − 703 ;;; only way to make a change is to copy the entire value and make the
+ − 704 ;;; necessary modifications. What we would like instead is to be able
+ − 705 ;;; to construct a mini-menubar that says something like "add this menu
+ − 706 ;;; here" and combine with everything else. That would require a
+ − 707 ;;; slightly different approach to instantiation. Currently it just
+ − 708 ;;; searches up the tree from specific to general, looking for a match;
+ − 709 ;;; from this match, it generates the instance. Instead, it would
+ − 710 ;;; potentially have to record all the matches it found and pass a list
+ − 711 ;;; of them to the instantiation function. To implement this, we would
+ − 712 ;;; create another specifier method "instantiator_inherits_up", which
+ − 713 ;;; looks at the instantiator to determine if it calls for combining
+ − 714 ;;; itself with the value higher up. this tells the specifier code
+ − 715 ;;; whether to stop now or keep going. It would then pass a Dynarr of
+ − 716 ;;; the instantiators to the instantiate method, which might be a
+ − 717 ;;; special version, e.g. "instantiate_multi".
+ − 718
+ − 719 (defun instance-to-instantiator (inst)
+ − 720 "Convert an instance to an instantiator.
+ − 721 If we have an instance object, we fetch the instantiator that generated the object. Otherwise, we just return the instance."
+ − 722 (cond ((font-instance-p inst)
+ − 723 (setq inst (font-instance-name inst)))
+ − 724 ((color-instance-p inst)
+ − 725 (setq inst (color-instance-name inst)))
+ − 726 ((image-instance-p inst)
+ − 727 (setq inst (image-instance-instantiator inst)))
+ − 728 (t inst)))
+ − 729
+ − 730 (defun device-type-matches-spec (devtype devtype-spec)
+ − 731 ;; Return DEVTYPE (a devtype) if it matches DEVTYPE-SPEC, else nil.
+ − 732 ;; DEVTYPE-SPEC can be nil (all types OK), a device type (only that type
+ − 733 ;; OK), or `window-system' -- window system device types OK.
+ − 734 (cond ((not devtype-spec) devtype)
+ − 735 ((eq devtype-spec 'window-system)
+ − 736 (and (not (memq devtype '(tty stream))) devtype))
+ − 737 (t (and (eq devtype devtype-spec) devtype))))
+ − 738
+ − 739 (defun add-tag-to-inst-list (inst-list tag-set)
+ − 740 "Add TAG-SET (tag or tag-set) to all tags in INST-LIST."
+ − 741 ;; Ah, all is sweetness and light with `loop'
+ − 742 (if (null tag-set) inst-list
+ − 743 (loop for (t2 . x2) in inst-list
+ − 744 for newt2 = (delete-duplicates
+ − 745 (append (if (listp tag-set) tag-set (list tag-set))
+ − 746 (if (listp t2) t2 (list t2))))
+ − 747 collect (cons newt2 x2))))
+ − 748
+ − 749 (defun derive-domain-from-locale (locale &optional devtype-spec current-device)
+ − 750 "Given a locale, try to derive the \"most reasonable\" domain.
+ − 751
+ − 752 This is a heuristic \(\"works most of the time\") algorithm.
+ − 753
+ − 754 \[Remember that, in specifiers, locales are what you attach specifications or
+ − 755 \"instantiators\" to, and domains are the contexts in which you can
+ − 756 retrieve the value or \"instance\" of the specifier. Not all locales are
+ − 757 domains. In particular, buffers are locales but not domains because
+ − 758 buffers may be displayed in different windows on different frames, and thus
+ − 759 end up with different values if the frames each have a frame-local
+ − 760 instantiator and the instantiators are different. However, we may well
+ − 761 find ourselves in a situation where we want to figure out the most likely
+ − 762 value of a specifier in a buffer -- for example we might conceptually want
+ − 763 to make a buffer's modeline face be bold, so we need to figure out what the
+ − 764 current face is. If the buffer already has an instantiator, it's easy; but
+ − 765 if it doesn't, we want to do something reasonable rather than just issue an
+ − 766 error, even though technically the value is not well-defined. We want
+ − 767 something that gives the right answer most of the time.]
+ − 768
+ − 769 LOCALE is a specifier locale -- i.e. a buffer, window, frame, device, the
+ − 770 symbol `global', or nil, meaning the same as `global'.
+ − 771
+ − 772 DEVTYPE-SPEC, if given, can restrict the possible return values to domains
+ − 773 on devices of that device type; or if it's `window-system', to domains on
+ − 774 window-system devices.
+ − 775
+ − 776 CURRENT-DEVICE is what should be considered as the \"selected device\" when
+ − 777 this value is needed. It defaults to the currently selected device.
+ − 778
+ − 779 -- If LOCALE is a domain, it's simply returned.
+ − 780 -- If LOCALE is `all', `global', or nil, we return CURRENT-DEVICE.
+ − 781 -- If LOCALE is a buffer, we use `get-buffer-window' to find a window viewing
+ − 782 the buffer, and return it if there is one; otherwise we return the selected
+ − 783 window on CURRENT-DEVICE.
+ − 784
+ − 785 The return value may be nil if the only possible values don't agree with
+ − 786 DEVTYPE-SPEC."
+ − 787 ;; DEVICE aims to be the selected device, but picks some other
+ − 788 ;; device if that won't work. may be nil.
+ − 789 (let* ((device (or current-device (selected-device)))
+ − 790 (device (if (device-type-matches-spec (device-type device)
+ − 791 devtype-spec)
+ − 792 device
+ − 793 (first
+ − 794 (delete-if-not
+ − 795 #'(lambda (x)
+ − 796 (device-type-matches-spec (device-type x)
+ − 797 devtype-spec))
+ − 798 (device-list))))))
+ − 799 (cond ((memq locale '(all nil global)) device)
+ − 800 ((valid-specifier-domain-p locale)
+ − 801 (and (device-type-matches-spec (device-type (dfw-device locale))
+ − 802 devtype-spec)
+ − 803 locale))
+ − 804 ((bufferp locale)
+ − 805 (let ((win (get-buffer-window locale t devtype-spec)))
+ − 806 (or win (and device (selected-window device))))))))
+ − 807
+ − 808 (defun derive-device-type-from-tag-set (tag-set &optional try-stages
+ − 809 devtype-spec current-device)
+ − 810 "Given a tag set, try (heuristically) to get a device type from it.
+ − 811
+ − 812 There are three stages that this function proceeds through, each one trying
+ − 813 harder than the previous to get a value. TRY-STAGES controls how many
+ − 814 stages to try. If nil or 1, only stage 1 is done; if 2; stages 1 and 2 are
+ − 815 done; if 3, stages 1-3 are done; if t, all stages are done (currently 1-3).
+ − 816
+ − 817 Stage 1 looks at the tags themselves to see if any of them are device-type
+ − 818 tags. If so, it returns the device type. If there is more than one device
+ − 819 type, this tag can never match anything, but we go ahead and return one of
+ − 820 them. If no device types in the tags, we fail.
+ − 821
+ − 822 Stage 2 runs all devices through the tag set to see if any match, and
+ − 823 accumulate a list of device types of all matching devices. If there is
+ − 824 exactly one device type in the list, we return it, else fail.
+ − 825
+ − 826 Stage 3 picks up from where stage 2 left off, and tries hard to return
+ − 827 *SOME* device type in all possible situations, modulo the DEVTYPE-SPEC
+ − 828 flag. \(DEVTYPE-SPEC and CURRENT-DEVICE are the same as in
+ − 829 `derive-domain-from-locale'.)
+ − 830
+ − 831 Specifically:
+ − 832
+ − 833 \(a) if no matching devices, return the selected device's type.
+ − 834 \(b) if more than device type and the selected device's type is
+ − 835 listed, use it.
+ − 836 \(c) else, pick one of the device types (currently the first).
+ − 837
+ − 838 This will never return a device type that's incompatible with the
+ − 839 DEVTYPE-SPEC flag; thus, it may return nil."
+ − 840 (or try-stages (setq try-stages 1))
+ − 841 (if (eq try-stages t) (setq try-stages 3))
+ − 842 (check-argument-range try-stages 1 3)
+ − 843 (flet ((delete-wrong-type (x)
+ − 844 (delete-if-not
+ − 845 #'(lambda (y)
+ − 846 (device-type-matches-spec y devtype-spec))
+ − 847 x)))
+ − 848 (let ((both (intersection (device-type-list)
+ − 849 (canonicalize-tag-set tag-set))))
+ − 850 ;; shouldn't be more than one (will fail), but whatever
+ − 851 (if both (first (delete-wrong-type both))
+ − 852 (and (>= try-stages 2)
+ − 853 ;; no device types mentioned. try the hard way,
+ − 854 ;; i.e. check each existing device to see if it will
+ − 855 ;; pass muster.
+ − 856 (let ((okdevs
+ − 857 (delete-wrong-type
+ − 858 (delete-duplicates
+ − 859 (mapcan
+ − 860 #'(lambda (dev)
+ − 861 (and (device-matches-specifier-tag-set-p
+ − 862 dev tag-set)
+ − 863 (list (device-type dev))))
+ − 864 (device-list)))))
+ − 865 (devtype (cond ((or (null devtype-spec)
+ − 866 (eq devtype-spec 'window-system))
+ − 867 (let ((dev (derive-domain-from-locale
+ − 868 'global devtype-spec
+ − 869 current-device)))
+ − 870 (and dev (device-type dev))))
+ − 871 (t devtype-spec))))
+ − 872 (cond ((= 1 (length okdevs)) (car okdevs))
+ − 873 ((< try-stages 3) nil)
+ − 874 ((null okdevs) devtype)
+ − 875 ((memq devtype okdevs) devtype)
+ − 876 (t (car okdevs)))))))))
+ − 877
+ − 878 ;; Sheesh, the things you do to get "intuitive" behavior.
+ − 879 (defun derive-device-type-from-locale-and-tag-set (locale tag-set
+ − 880 &optional devtype-spec
+ − 881 current-device)
+ − 882 "Try to derive a device type from a locale and tag set.
+ − 883
+ − 884 If the locale is a domain, use the domain's device type. Else, if the tag
+ − 885 set uniquely specifies a device type, use it. Else, if a buffer is given,
+ − 886 find a window visiting the buffer, and if any, use its device type.
+ − 887 Finally, go back to the tag set and \"try harder\" -- if the selected
+ − 888 device matches the tag set, use its device type, else use some valid device
+ − 889 type from the tag set.
+ − 890
+ − 891 DEVTYPE-SPEC and CURRENT-DEVICE as in `derive-domain-from-locale'."
+ − 892
+ − 893 (cond ((valid-specifier-domain-p locale)
+ − 894 ;; if locale is a domain, then it must match DEVTYPE-SPEC,
+ − 895 ;; or we exit immediately with nil.
+ − 896 (device-type-matches-spec (device-type (dfw-device locale))
+ − 897 devtype-spec))
+ − 898 ((derive-device-type-from-tag-set tag-set 2 devtype-spec
+ − 899 current-device))
+ − 900 ((and (bufferp locale)
+ − 901 (let ((win (get-buffer-window locale t devtype-spec)))
+ − 902 (and win (device-type (dfw-device win))))))
+ − 903 ((derive-device-type-from-tag-set tag-set t devtype-spec
+ − 904 current-device))))
+ − 905
+ − 906 (defun derive-specifier-specs-from-locale (specifier locale
+ − 907 &optional devtype-spec
+ − 908 current-device
+ − 909 global-use-fallback)
+ − 910 "Heuristically find the specs of a specifier in a locale.
+ − 911
+ − 912 This tries to find some reasonable instantiators that are most likely to
+ − 913 correspond to the specifier's \"value\" (i.e. instance) in a particular
+ − 914 locale, even when the user has not specifically set any such instantiators.
+ − 915 This is useful for functions that want to modify the instance of a
+ − 916 specifier in a particular locale, and only in that locale.
+ − 917
+ − 918 Keep in mind that this is a heuristic (i.e. kludge) function, and that it
+ − 919 may not always give the right results, since the operation is not
+ − 920 technically well-defined in many cases! (See `derive-domain-from-locale'.)
+ − 921
+ − 922 DEVTYPE-SPEC and CURRENT-DEVICE are as in `derive-domain-from-locale'.
+ − 923
+ − 924 The return value is an inst-list, i.e.
+ − 925
+ − 926 ((TAG-SET . INSTANTIATOR) ...)
+ − 927
+ − 928 More specifically, if there is already a spec in the locale, it's just
+ − 929 returned. Otherwise, if LOCALE is `global', `all', or nil: If
+ − 930 GLOBAL-USE-FALLBACK is non-nil, the fallback is fetched, and returned, with
+ − 931 `default' added to the tag set; else, we use CURRENT-DEVICE (defaulting to
+ − 932 the selected device) as a domain and proceed as in the following. If
+ − 933 LOCALE is a domain (window, frame, device), the specifier's instance in
+ − 934 that domain is computed, and converted back to an instantiator
+ − 935 \(`instance-to-instantiator'). Else, if LOCALE is a buffer, we use
+ − 936 `derive-domain-from-locale' to heuristically get a likely domain, and
+ − 937 proceed as if LOCALE were a domain."
+ − 938 (if (memq locale '(all nil)) (setq locale 'global))
+ − 939 (let ((current (specifier-spec-list specifier locale)))
+ − 940 (if current (cdar current)
+ − 941 ;; case 1: a global locale, fallbacks
+ − 942 (cond ((and (eq locale 'global) global-use-fallback)
+ − 943 ;; if nothing there globally, retrieve the fallback.
+ − 944 ;; this is either an inst-list or a specifier. in the
+ − 945 ;; latter case, we need to recursively retrieve its
+ − 946 ;; fallback.
+ − 947 (let (sofar
+ − 948 (fallback (specifier-fallback specifier)))
+ − 949 (while (specifierp fallback)
+ − 950 (setq sofar (nconc sofar
+ − 951 (cdar (specifier-spec-list fallback
+ − 952 'global))))
+ − 953 (setq fallback (specifier-fallback fallback)))
+ − 954 (add-tag-to-inst-list (nconc sofar fallback) 'default)))
+ − 955 (t
+ − 956 (let (domain)
+ − 957 ;; case 2: window, frame, device locale
+ − 958 (cond ((eq locale 'global)
+ − 959 (setq domain (or current-device (selected-device))))
+ − 960 ((valid-specifier-domain-p locale)
+ − 961 (setq domain locale))
+ − 962 ;; case 3: buffer locale
+ − 963 ((bufferp locale)
+ − 964 (setq domain (derive-domain-from-locale
+ − 965 locale devtype-spec current-device)))
+ − 966 (t nil))
+ − 967 ;; retrieve an instance, convert back to instantiator
+ − 968 (when domain
+ − 969 (let ((inst
+ − 970 (instance-to-instantiator
+ − 971 (specifier-instance specifier domain))))
+ − 972 (list (cons nil inst))))))))))
+ − 973
428
+ − 974 ;;; specifier.el ends here
