428
+ − 1 ;;; specifier.el --- Lisp interface to specifiers
+ − 2
+ − 3 ;; Copyright (C) 1997 Free Software Foundation, Inc.
442
+ − 4 ;; Copyright (C) 1995, 1996, 2000 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)
+ − 35 "Create and initialize a new specifier.
+ − 36
+ − 37 This is a front-end onto `make-specifier' that allows you to create a
+ − 38 specifier and add specs to it at the same time. TYPE specifies the
+ − 39 specifier type. SPEC-LIST supplies the specification(s) to be added
+ − 40 to the specifier. Normally, almost any reasonable abbreviation of the
+ − 41 full spec-list form is accepted, and is converted to the full form;
+ − 42 however, if optional argument DONT-CANONICALIZE is non-nil, this
+ − 43 conversion is not performed, and the SPEC-LIST must already be in full
+ − 44 form. See `canonicalize-spec-list'."
+ − 45 (let ((sp (make-specifier type)))
+ − 46 (if (not dont-canonicalize)
+ − 47 (setq spec-list (canonicalize-spec-list spec-list type)))
+ − 48 (add-spec-list-to-specifier sp spec-list)
+ − 49 sp))
+ − 50
+ − 51 ;; God damn, do I hate dynamic scoping.
+ − 52
+ − 53 (defun map-specifier (ms-specifier ms-func &optional ms-locale ms-maparg)
+ − 54 "Apply MS-FUNC to the specification(s) for MS-LOCALE in MS-SPECIFIER.
+ − 55
+ − 56 If 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
+ − 58 of that type. If MS-LOCALE is 'all or nil, MS-FUNC will be mapped
+ − 59 over all locales in MS-SPECIFIER.
+ − 60
+ − 61 MS-FUNC is called with four arguments: the MS-SPECIFIER, the locale
+ − 62 being mapped over, the inst-list for that locale, and the
+ − 63 optional MS-MAPARG. If any invocation of MS-FUNC returns non-nil,
+ − 64 the mapping will stop and the returned value becomes the
+ − 65 value returned from `map-specifier'. Otherwise, `map-specifier'
+ − 66 returns nil."
+ − 67 (let ((ms-specs (specifier-spec-list ms-specifier ms-locale))
+ − 68 ms-result)
+ − 69 (while (and ms-specs (not ms-result))
+ − 70 (let ((ms-this-spec (car ms-specs)))
+ − 71 (setq ms-result (funcall ms-func ms-specifier (car ms-this-spec)
+ − 72 (cdr ms-this-spec) ms-maparg))
+ − 73 (setq ms-specs (cdr ms-specs))))
+ − 74 ms-result))
+ − 75
+ − 76 (defun canonicalize-inst-pair (inst-pair specifier-type &optional noerror)
+ − 77 "Canonicalize the given INST-PAIR.
+ − 78
+ − 79 SPECIFIER-TYPE specifies the type of specifier that this SPEC-LIST
+ − 80 will be used for.
+ − 81
+ − 82 Canonicalizing means converting to the full form for an inst-pair, i.e.
+ − 83 `(TAG-SET . INSTANTIATOR)'. A single, untagged instantiator is given
+ − 84 a tag set of nil (the empty set), and a single tag is converted into
+ − 85 a tag set consisting only of that tag.
+ − 86
+ − 87 If NOERROR is non-nil, signal an error if the inst-pair is invalid;
+ − 88 otherwise return t."
+ − 89 ;; OK, the possibilities are:
+ − 90 ;;
+ − 91 ;; a) a single instantiator
+ − 92 ;; b) a cons of a tag and an instantiator
+ − 93 ;; c) a cons of a tag set and an instantiator
+ − 94 (cond ((valid-instantiator-p inst-pair specifier-type)
+ − 95 ;; case (a)
+ − 96 (cons nil inst-pair))
+ − 97
+ − 98 ((not (consp inst-pair))
+ − 99 ;; not an inst-pair
+ − 100 (if noerror t
+ − 101 ;; this will signal an appropriate error.
+ − 102 (check-valid-instantiator inst-pair specifier-type)))
+ − 103
+ − 104 ((and (valid-specifier-tag-p (car inst-pair))
+ − 105 (valid-instantiator-p (cdr inst-pair) specifier-type))
+ − 106 ;; case (b)
+ − 107 (cons (list (car inst-pair)) (cdr inst-pair)))
+ − 108
+ − 109 ((and (valid-specifier-tag-set-p (car inst-pair))
+ − 110 (valid-instantiator-p (cdr inst-pair) specifier-type))
+ − 111 ;; case (c)
+ − 112 inst-pair)
+ − 113
+ − 114 (t
+ − 115 (if noerror t
+ − 116 (signal 'error (list "Invalid specifier tag set"
+ − 117 (car inst-pair)))))))
+ − 118
+ − 119 (defun canonicalize-inst-list (inst-list specifier-type &optional noerror)
+ − 120 "Canonicalize the given INST-LIST (a list of inst-pairs).
+ − 121
+ − 122 SPECIFIER-TYPE specifies the type of specifier that this INST-LIST
+ − 123 will be used for.
+ − 124
+ − 125 Canonicalizing means converting to the full form for an inst-list, i.e.
+ − 126 `((TAG-SET . INSTANTIATOR) ...)'. This function accepts a single
+ − 127 inst-pair or any abbreviation thereof or a list of (possibly
+ − 128 abbreviated) inst-pairs. (See `canonicalize-inst-pair'.)
+ − 129
+ − 130 If NOERROR is non-nil, signal an error if the inst-list is invalid;
+ − 131 otherwise return t."
+ − 132
+ − 133 ;; OK, the possibilities are:
+ − 134 ;;
+ − 135 ;; a) an inst-pair or various abbreviations thereof
+ − 136 ;; b) a list of (a)
+ − 137 (let ((result (canonicalize-inst-pair inst-list specifier-type t)))
+ − 138 (if (not (eq result t))
+ − 139 ;; case (a)
+ − 140 (list result)
+ − 141
+ − 142 (if (not (consp inst-list))
+ − 143 ;; not an inst-list.
+ − 144 (if noerror t
+ − 145 ;; this will signal an appropriate error.
+ − 146 (check-valid-instantiator inst-list specifier-type))
+ − 147
+ − 148 ;; case (b)
+ − 149 (catch 'cann-inst-list
+ − 150 ;; don't use mapcar here; we need to catch the case of
+ − 151 ;; an invalid list.
+ − 152 (let ((rest inst-list)
+ − 153 (result nil))
+ − 154 (while rest
+ − 155 (if (not (consp rest))
+ − 156 (if noerror (throw 'cann-inst-list t)
+ − 157 (signal 'error (list "Invalid list format" inst-list)))
+ − 158 (let ((res2 (canonicalize-inst-pair (car rest) specifier-type
+ − 159 noerror)))
+ − 160 (if (eq res2 t)
+ − 161 ;; at this point, we know we're noerror because
+ − 162 ;; otherwise canonicalize-inst-pair would have
+ − 163 ;; signalled an error.
+ − 164 (throw 'cann-inst-list t)
+ − 165 (setq result (cons res2 result)))))
+ − 166 (setq rest (cdr rest)))
+ − 167 (nreverse result)))))))
+ − 168
+ − 169 (defun canonicalize-spec (spec specifier-type &optional noerror)
+ − 170 "Canonicalize the given SPEC (a specification).
+ − 171
+ − 172 SPECIFIER-TYPE specifies the type of specifier that this SPEC-LIST
+ − 173 will be used for.
+ − 174
+ − 175 Canonicalizing means converting to the full form for a spec, i.e.
+ − 176 `(LOCALE (TAG-SET . INSTANTIATOR) ...)'. This function accepts a
+ − 177 possibly abbreviated inst-list or a cons of a locale and a possibly
+ − 178 abbreviated inst-list. (See `canonicalize-inst-list'.)
+ − 179
+ − 180 If NOERROR is nil, signal an error if the specification is invalid;
+ − 181 otherwise return t."
+ − 182 ;; OK, the possibilities are:
+ − 183 ;;
+ − 184 ;; a) an inst-list or some abbreviation thereof
+ − 185 ;; b) a cons of a locale and an inst-list
+ − 186 (let ((result (canonicalize-inst-list spec specifier-type t)))
+ − 187 (if (not (eq result t))
+ − 188 ;; case (a)
+ − 189 (cons 'global result)
+ − 190
+ − 191 (if (not (consp spec))
+ − 192 ;; not a spec.
+ − 193 (if noerror t
+ − 194 ;; this will signal an appropriate error.
+ − 195 (check-valid-instantiator spec specifier-type))
+ − 196
+ − 197 (if (not (valid-specifier-locale-p (car spec)))
+ − 198 ;; invalid locale.
+ − 199 (if noerror t
+ − 200 (signal 'error (list "Invalid specifier locale" (car spec))))
+ − 201
+ − 202 ;; case (b)
+ − 203 (let ((result (canonicalize-inst-list (cdr spec) specifier-type
+ − 204 noerror)))
+ − 205 (if (eq result t)
+ − 206 ;; at this point, we know we're noerror because
+ − 207 ;; otherwise canonicalize-inst-list would have
+ − 208 ;; signalled an error.
+ − 209 t
+ − 210 (cons (car spec) result))))))))
+ − 211
+ − 212 (defun canonicalize-spec-list (spec-list specifier-type &optional noerror)
+ − 213 "Canonicalize the given SPEC-LIST (a list of specifications).
+ − 214
+ − 215 SPECIFIER-TYPE specifies the type of specifier that this SPEC-LIST
+ − 216 will be used for.
+ − 217
+ − 218 Canonicalizing means converting to the full form for a spec-list, i.e.
+ − 219 `((LOCALE (TAG-SET . INSTANTIATOR) ...) ...)'. This function accepts
+ − 220 a possibly abbreviated specification or a list of such things. (See
+ − 221 `canonicalize-spec'.) This is the function used to convert spec-lists
+ − 222 accepted by `set-specifier' and such into a form suitable for
+ − 223 `add-spec-list-to-specifier'.
+ − 224
+ − 225 This function tries extremely hard to resolve any ambiguities,
+ − 226 and the built-in specifier types (font, image, toolbar, etc.) are
+ − 227 designed so that there won't be any ambiguities.
+ − 228
+ − 229 If NOERROR is nil, signal an error if the spec-list is invalid;
+ − 230 otherwise return t."
+ − 231 ;; OK, the possibilities are:
+ − 232 ;;
+ − 233 ;; a) a spec or various abbreviations thereof
+ − 234 ;; b) a list of (a)
+ − 235 (let ((result (canonicalize-spec spec-list specifier-type t)))
+ − 236 (if (not (eq result t))
+ − 237 ;; case (a)
+ − 238 (list result)
+ − 239
+ − 240 (if (not (consp spec-list))
+ − 241 ;; not a spec-list.
+ − 242 (if noerror t
+ − 243 ;; this will signal an appropriate error.
+ − 244 (check-valid-instantiator spec-list specifier-type))
+ − 245
+ − 246 ;; case (b)
+ − 247 (catch 'cann-spec-list
+ − 248 ;; don't use mapcar here; we need to catch the case of
+ − 249 ;; an invalid list.
+ − 250 (let ((rest spec-list)
+ − 251 (result nil))
+ − 252 (while rest
+ − 253 (if (not (consp rest))
+ − 254 (if noerror (throw 'cann-spec-list t)
+ − 255 (signal 'error (list "Invalid list format" spec-list)))
+ − 256 (let ((res2 (canonicalize-spec (car rest) specifier-type
+ − 257 noerror)))
+ − 258 (if (eq res2 t)
+ − 259 ;; at this point, we know we're noerror because
+ − 260 ;; otherwise canonicalize-spec would have
+ − 261 ;; signalled an error.
+ − 262 (throw 'cann-spec-list t)
+ − 263 (setq result (cons res2 result)))))
+ − 264 (setq rest (cdr rest)))
+ − 265 (nreverse result)))))))
+ − 266
+ − 267 (defun set-specifier (specifier value &optional locale tag-set how-to-add)
+ − 268 "Add a specification or specifications to SPECIFIER.
+ − 269
+ − 270 This function adds a specification of VALUE in locale LOCALE.
+ − 271 LOCALE indicates where this specification is active, and should be
+ − 272 a buffer, a window, a frame, a device, or the symbol `global' to
+ − 273 indicate that it applies everywhere. LOCALE usually defaults to
+ − 274 `global' if omitted.
+ − 275
+ − 276 VALUE is usually what is called an \"instantiator\" (which, roughly
+ − 277 speaking, corresponds to the \"value\" of the property governed by
442
+ − 278 SPECIFIER). The valid instantiators for SPECIFIER depend on the type
+ − 279 of SPECIFIER (which you can determine using `specifier-type'). The
+ − 280 specifier `scrollbar-width', for example, is of type `integer',
+ − 281 meaning its valid instantiators are integers. The specifier governing
+ − 282 the background color of the `default' face (you can retrieve this
+ − 283 specifier using `(face-background 'default)') is of type `color',
+ − 284 meaning its valid instantiators are strings naming colors and
+ − 285 color-instance objects. For some types of specifiers, such as `image'
+ − 286 and `toolbar', the instantiators can be very complex. Generally this
+ − 287 is documented in the appropriate creation function --
+ − 288 e.g. `make-color-specifier', `make-font-specifier',
+ − 289 `make-image-specifier' -- or in the global variable holding the most
+ − 290 common specifier for that type (`default-toolbar', `default-gutter',
+ − 291 `current-display-table').
428
+ − 292
+ − 293 NOTE: It does *not* work to give a VALUE of nil as a way of
+ − 294 removing the specifications for a locale. Use `remove-specifier'
+ − 295 instead. (And keep in mind that, if you omit the LOCALE argument
+ − 296 to `remove-specifier', it removes *all* specifications! If you
+ − 297 want to remove just the `global' specification, make sure to
+ − 298 specify a LOCALE of `global'.)
+ − 299
+ − 300 VALUE can also be a list of instantiators. This means basically,
+ − 301 \"try each one in turn until you get one that works\". This allows
+ − 302 you to give funky instantiators that may only work in some cases,
+ − 303 and provide more normal backups for the other cases. (For example,
+ − 304 you might like the color \"darkseagreen2\", but some X servers
+ − 305 don't recognize this color, so you could provide a backup
+ − 306 \"forest green\". Color TTY devices probably won't recognize this
+ − 307 either, so you could provide a second backup \"green\". You'd
+ − 308 do this by specifying this list of instantiators:
+ − 309
+ − 310 '(\"darkseagreen2\" \"forest green\" \"green\")
+ − 311
+ − 312 VALUE can also be various more complicated forms; see below.
+ − 313
+ − 314 Optional argument TAG-SET is a tag or a list of tags, to be associated
+ − 315 with the VALUE. Tags are symbols (usually naming device types, such
+ − 316 as `x' and `tty', or device classes, such as `color', `mono', and
+ − 317 `grayscale'); specifying a TAG-SET restricts the scope of VALUE to
+ − 318 devices that match all specified tags. (You can also create your
+ − 319 own tags using `define-specifier-tag', and use them to identify
+ − 320 specifications added by you, so you can remove them later.)
+ − 321
+ − 322 Optional argument HOW-TO-ADD should be either nil or one of the
+ − 323 symbols `prepend', `append', `remove-tag-set-prepend',
+ − 324 `remove-tag-set-append', `remove-locale', `remove-locale-type',
+ − 325 or `remove-all'. This specifies what to do with existing
+ − 326 specifications in LOCALE (and possibly elsewhere in the specifier).
+ − 327 Most of the time, you do not need to worry about this argument;
+ − 328 the default behavior of `remove-tag-set-prepend' is usually fine.
+ − 329 See `copy-specifier' and `add-spec-to-specifier' for a full
+ − 330 description of what each of these means.
+ − 331
+ − 332 VALUE can actually be anything acceptable to `canonicalize-spec-list';
+ − 333 this includes, among other things:
+ − 334
+ − 335 -- a cons of a locale and an instantiator (or list of instantiators)
+ − 336 -- a cons of a tag or tag-set and an instantiator (or list of
+ − 337 instantiators)
+ − 338 -- a cons of a locale and the previous type of item
+ − 339 -- a list of one or more of any of the previous types of items
+ − 340
+ − 341 However, in these cases, you cannot give a LOCALE or TAG-SET,
+ − 342 because they do not make sense. (You will probably get an error if
+ − 343 you try this.)
+ − 344
+ − 345 Finally, VALUE can itself be a specifier (of the same type as
+ − 346 SPECIFIER), if you want to copy specifications from one specifier
+ − 347 to another; this is equivalent to calling `copy-specifier', and
+ − 348 LOCALE, TAG-SET, and HOW-TO-ADD have the same semantics as with
+ − 349 that function.
+ − 350
+ − 351 Note that `set-specifier' is exactly complementary to `specifier-specs'
+ − 352 except in the case where SPECIFIER has no specs at all in it but nil
+ − 353 is a valid instantiator (in that case, `specifier-specs' will return
+ − 354 nil (meaning no specs) and `set-specifier' will interpret the `nil'
+ − 355 as meaning \"I'm adding a global instantiator and its value is `nil'\"),
+ − 356 or in strange cases where there is an ambiguity between a spec-list
+ − 357 and an inst-list, etc. (The built-in specifier types are designed
+ − 358 in such a way as to avoid any such ambiguities.)
+ − 359
+ − 360 NOTE: If you want to work with spec-lists, you should probably not
+ − 361 use either `set-specifier' or `specifier-specs', but should use the
+ − 362 lower-level functions `add-spec-list-to-specifier' and `specifier-spec-list'.
+ − 363 These functions always work with fully-qualified spec-lists; thus, there
+ − 364 is no possibility for ambiguity and no need to go through the function
+ − 365 `canonicalize-spec-list', which is potentially time-consuming."
+ − 366
+ − 367 ;; backward compatibility: the old function had HOW-TO-ADD as the
+ − 368 ;; third argument and no arguments after that.
+ − 369 ;; #### this should disappear at some point.
+ − 370 (if (and (null how-to-add)
+ − 371 (memq locale '(prepend append remove-tag-set-prepend
+ − 372 remove-tag-set-append remove-locale
+ − 373 remove-locale-type remove-all)))
+ − 374 (progn
+ − 375 (setq how-to-add locale)
+ − 376 (setq locale nil)))
+ − 377
+ − 378 ;; proper beginning of the function.
+ − 379 (let ((is-valid (valid-instantiator-p value (specifier-type specifier)))
+ − 380 (nval value))
+ − 381 (cond ((and (not is-valid) (specifierp nval))
+ − 382 (copy-specifier nval specifier locale tag-set nil how-to-add))
+ − 383 (t
+ − 384 (if tag-set
+ − 385 (progn
+ − 386 (if (not (listp tag-set))
+ − 387 (setq tag-set (list tag-set)))
+ − 388 ;; You tend to get more accurate errors
+ − 389 ;; for a variety of cases if you call
+ − 390 ;; canonicalize-tag-set here.
+ − 391 (setq tag-set (canonicalize-tag-set tag-set))
+ − 392 (if (and (not is-valid) (consp nval))
+ − 393 (setq nval
+ − 394 (mapcar #'(lambda (x)
+ − 395 (check-valid-instantiator
+ − 396 x (specifier-type specifier))
+ − 397 (cons tag-set x))
+ − 398 nval))
+ − 399 (setq nval (cons tag-set nval)))))
+ − 400 (if locale
+ − 401 (setq nval (cons locale nval)))
+ − 402 (add-spec-list-to-specifier
+ − 403 specifier
+ − 404 (canonicalize-spec-list nval (specifier-type specifier))
+ − 405 how-to-add))))
+ − 406 value)
+ − 407
442
+ − 408 (defun modify-specifier-instances (specifier func &optional args force default
+ − 409 locale tag-set)
+ − 410 "Modify all specifications that match LOCALE and TAG-SET by FUNC.
+ − 411
+ − 412 For each specification that exists for SPECIFIER, in locale LOCALE
+ − 413 that matches TAG-SET, call the function FUNC with the instance as its
+ − 414 first argument and with optional arguments ARGS. The result is then
+ − 415 used as the new value of the instantiator.
+ − 416
+ − 417 If there is no specification in the domain LOCALE matching TAG-SET and
+ − 418 FORCE is non-nil, an explicit one is created from the matching
+ − 419 specifier instance if that exists or DEFAULT otherwise. If LOCALE is
+ − 420 not a domain (i.e. a buffer), DEFAULT is always used. FUNC is then
+ − 421 applied like above and the resulting specification is added."
+ − 422
+ − 423 (let ((spec-list (specifier-spec-list specifier locale tag-set)))
+ − 424 (cond
+ − 425 (spec-list
+ − 426 ;; Destructively edit the spec-list
+ − 427 (mapc #'(lambda (spec)
+ − 428 (mapc #'(lambda (inst-pair)
+ − 429 (setcdr inst-pair
+ − 430 (apply func (cdr inst-pair) args)))
+ − 431 (cdr spec)))
+ − 432 spec-list)
+ − 433 (add-spec-list-to-specifier specifier spec-list))
+ − 434 (force
+ − 435 (set-specifier specifier
+ − 436 (apply func
+ − 437 (or (and (valid-specifier-domain-p locale)
+ − 438 (specifier-instance specifier))
+ − 439 default) args)
+ − 440 locale tag-set)))))
+ − 441
428
+ − 442 (defmacro let-specifier (specifier-list &rest body)
+ − 443 "Add specifier specs, evaluate forms in BODY and restore the specifiers.
+ − 444 \(let-specifier SPECIFIER-LIST BODY...)
+ − 445
+ − 446 Each element of SPECIFIER-LIST should look like this:
+ − 447 \(SPECIFIER VALUE &optional LOCALE TAG-SET HOW-TO-ADD).
+ − 448
+ − 449 SPECIFIER is the specifier to be temporarily modified. VALUE is the
+ − 450 instantiator to be temporarily added to SPECIFIER in LOCALE. LOCALE,
+ − 451 TAG-SET and HOW-TO-ADD have the same meaning as in
+ − 452 `add-spec-to-specifier'.
+ − 453
+ − 454 The code resulting from macro expansion will add specifications to
+ − 455 specifiers using `add-spec-to-specifier'. After BODY is finished, the
+ − 456 temporary specifications are removed and old spec-lists are restored.
+ − 457
+ − 458 LOCALE, TAG-SET and HOW-TO-ADD may be omitted, and default to nil.
+ − 459 The value of the last form in BODY is returned.
+ − 460
+ − 461 NOTE: If you want the specifier's instance to change in all
+ − 462 circumstances, use (selected-window) as the LOCALE. If LOCALE is nil
+ − 463 or omitted, it defaults to `global'.
+ − 464
+ − 465 Example:
+ − 466 (let-specifier ((modeline-shadow-thickness 0 (selected-window)))
+ − 467 (sit-for 1))"
+ − 468 (check-argument-type 'listp specifier-list)
+ − 469 (flet ((gensym-frob (x name)
+ − 470 (if (or (atom x) (eq (car x) 'quote))
+ − 471 (list x)
+ − 472 (list (gensym name) x))))
+ − 473 ;; VARLIST is a list of
+ − 474 ;; ((SPECIFIERSYM SPECIFIER) (VALUE) (LOCALESYM LOCALE)
+ − 475 ;; (TAG-SET) (HOW-TO-ADD))
+ − 476 ;; If any of these is an atom, then a separate symbol is
+ − 477 ;; unnecessary, the CAR will contain the atom and CDR will be nil.
+ − 478 (let* ((varlist (mapcar #'(lambda (listel)
+ − 479 (or (and (consp listel)
+ − 480 (<= (length listel) 5)
+ − 481 (> (length listel) 1))
+ − 482 (signal 'error
+ − 483 (list
+ − 484 "should be a list of 2-5 elements"
+ − 485 listel)))
+ − 486 ;; VALUE, TAG-SET and HOW-TO-ADD are
+ − 487 ;; referenced only once, so we needn't
+ − 488 ;; frob them with gensym.
+ − 489 (list (gensym-frob (nth 0 listel) "specifier-")
+ − 490 (list (nth 1 listel))
+ − 491 (gensym-frob (nth 2 listel) "locale-")
+ − 492 (list (nth 3 listel))
+ − 493 (list (nth 4 listel))))
+ − 494 specifier-list))
+ − 495 ;; OLDVALLIST is a list of (OLDVALSYM OLDVALFORM)
+ − 496 (oldvallist (mapcar #'(lambda (varel)
+ − 497 (list (gensym "old-")
+ − 498 `(specifier-spec-list
+ − 499 ,(car (nth 0 varel))
+ − 500 ,(car (nth 2 varel)))))
+ − 501 varlist)))
+ − 502 ;; Bind the appropriate variables.
+ − 503 `(let* (,@(mapcan #'(lambda (varel)
+ − 504 (delq nil (mapcar
+ − 505 #'(lambda (varcons)
+ − 506 (and (cdr varcons) varcons))
+ − 507 varel)))
+ − 508 varlist)
+ − 509 ,@oldvallist)
+ − 510 (unwind-protect
+ − 511 (progn
+ − 512 ,@(mapcar #'(lambda (varel)
+ − 513 `(add-spec-to-specifier
+ − 514 ,(car (nth 0 varel)) ,(car (nth 1 varel))
+ − 515 ,(car (nth 2 varel)) ,(car (nth 3 varel))
+ − 516 ,(car (nth 4 varel))))
+ − 517 varlist)
+ − 518 ,@body)
+ − 519 ;; Reverse the unwinding order, so that using the same
+ − 520 ;; specifier multiple times works.
+ − 521 ,@(apply #'nconc (nreverse (mapcar*
+ − 522 #'(lambda (oldval varel)
+ − 523 `((remove-specifier
+ − 524 ,(car (nth 0 varel))
+ − 525 ,(car (nth 2 varel)))
+ − 526 (add-spec-list-to-specifier
+ − 527 ,(car (nth 0 varel))
+ − 528 ,(car oldval))))
+ − 529 oldvallist varlist))))))))
+ − 530
442
+ − 531 (defun make-integer-specifier (spec-list)
+ − 532 "Return a new `integer' specifier object with the given specification list.
+ − 533 SPEC-LIST can be a list of specifications (each of which is a cons of a
+ − 534 locale and a list of instantiators), a single instantiator, or a list
+ − 535 of instantiators. See `make-specifier' for more information about
+ − 536 specifiers.
+ − 537
+ − 538 Valid instantiators for integer specifiers are integers."
+ − 539 (make-specifier-and-init 'integer spec-list))
+ − 540
+ − 541 (defun make-boolean-specifier (spec-list)
+ − 542 "Return a new `boolean' specifier object with the given specification list.
+ − 543 SPEC-LIST can be a list of specifications (each of which is a cons of a
+ − 544 locale and a list of instantiators), a single instantiator, or a list
+ − 545 of instantiators. See `make-specifier' for more information about
+ − 546 specifiers.
+ − 547
+ − 548 Valid instantiators for boolean specifiers are t and nil."
+ − 549 (make-specifier-and-init 'boolean spec-list))
+ − 550
+ − 551 (defun make-natnum-specifier (spec-list)
+ − 552 "Return a new `natnum' specifier object with the given specification list.
+ − 553 SPEC-LIST can be a list of specifications (each of which is a cons of a
+ − 554 locale and a list of instantiators), a single instantiator, or a list
+ − 555 of instantiators. See `make-specifier' for more information about
+ − 556 specifiers.
+ − 557
+ − 558 Valid instantiators for natnum specifiers are non-negative integers."
+ − 559 (make-specifier-and-init 'natnum spec-list))
+ − 560
+ − 561 (defun make-generic-specifier (spec-list)
+ − 562 "Return a new `generic' specifier object with the given specification list.
+ − 563 SPEC-LIST can be a list of specifications (each of which is a cons of a
+ − 564 locale and a list of instantiators), a single instantiator, or a list
+ − 565 of instantiators. See `make-specifier' for more information about
+ − 566 specifiers.
+ − 567
+ − 568 Valid instantiators for generic specifiers are all Lisp values.
+ − 569 They are returned back unchanged when a specifier is instantiated."
+ − 570 (make-specifier-and-init 'generic spec-list))
+ − 571
+ − 572 (defun make-display-table-specifier (spec-list)
+ − 573 "Return a new `display-table' specifier object with the given spec list.
+ − 574 SPEC-LIST can be a list of specifications (each of which is a cons of a
+ − 575 locale and a list of instantiators), a single instantiator, or a list
+ − 576 of instantiators. See `make-specifier' for more information about
+ − 577 specifiers.
+ − 578
+ − 579 Valid instantiators for display-table specifiers are described in
+ − 580 detail in the doc string for `current-display-table'."
+ − 581 (make-specifier-and-init 'display-table spec-list))
+ − 582
428
+ − 583 ;; Evaluate this for testing:
+ − 584 ; (cl-prettyexpand '(let-specifier ((modeline-shadow-thickness 0 (selected-window) 'x) (fubar (value) baz)) (sit-for 1)))
+ − 585
+ − 586 (define-specifier-tag 'win 'device-on-window-system-p)
+ − 587
+ − 588 ;; Add tags for device types that don't have support compiled
+ − 589 ;; into the binary that we're about to dump. This will prevent
+ − 590 ;; code like
+ − 591 ;;
+ − 592 ;; (set-face-foreground 'default "black" nil '(x color))
+ − 593 ;;
+ − 594 ;; from producing an error if no X support was compiled in.
+ − 595
+ − 596 (or (valid-specifier-tag-p 'x)
+ − 597 (define-specifier-tag 'x (lambda (dev) (eq (device-type dev) 'x))))
+ − 598 (or (valid-specifier-tag-p 'tty)
+ − 599 (define-specifier-tag 'tty (lambda (dev) (eq (device-type dev) 'tty))))
+ − 600 (or (valid-specifier-tag-p 'mswindows)
+ − 601 (define-specifier-tag 'mswindows (lambda (dev)
+ − 602 (eq (device-type dev) 'mswindows))))
630
+ − 603 (or (valid-specifier-tag-p 'gtk)
+ − 604 (define-specifier-tag 'gtk (lambda (dev) (eq (device-type dev) 'gtk))))
428
+ − 605
+ − 606 ;; Add special tag for use by initialization code. Code that
+ − 607 ;; sets up default specs should use this tag. Code that needs to
+ − 608 ;; override default specs (e.g. the X resource initialization
+ − 609 ;; code) can safely clear specs with this tag without worrying
+ − 610 ;; about clobbering user settings.
+ − 611
+ − 612 (define-specifier-tag 'default)
+ − 613
+ − 614 ;;; specifier.el ends here
