1 ;;; specifier.el --- Lisp interface to specifiers
3 ;; Copyright (C) 1997, 2004 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995, 1996, 2000, 2002 Ben Wing.
6 ;; Author: Ben Wing <ben@xemacs.org>
7 ;; Keywords: internal, dumped
9 ;;; Synched up with: Not in FSF.
11 ;; This file is part of XEmacs.
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)
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.
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.
30 ;; This file is dumped with XEmacs.
34 (defun make-specifier-and-init (type spec-list &optional dont-canonicalize)
35 "Create and initialize a specifier of type TYPE with spec(s) SPEC-LIST.
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."
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)
50 ;; God damn, do I hate dynamic scoping.
52 (defun map-specifier (ms-specifier ms-func &optional ms-locale ms-maparg)
53 "Apply MS-FUNC to the specification(s) for MS-LOCALE in MS-SPECIFIER.
55 If optional MS-LOCALE is a locale, MS-FUNC will be called for that locale.
56 If MS-LOCALE is a locale type, MS-FUNC will be mapped over all locales of that
57 type. If MS-LOCALE is 'all or nil, MS-FUNC will be mapped over all locales in
60 Optional MS-MAPARG will be passed to MS-FUNC.
62 MS-FUNC is called with four arguments: the MS-SPECIFIER, the locale
63 being mapped over, the inst-list for that locale, and the
64 optional MS-MAPARG. If any invocation of MS-FUNC returns non-nil,
65 the mapping will stop and the returned value becomes the
66 value returned from `map-specifier'. Otherwise, `map-specifier'
68 (let ((ms-specs (specifier-spec-list ms-specifier ms-locale))
70 (while (and ms-specs (not ms-result))
71 (let ((ms-this-spec (car ms-specs)))
72 (setq ms-result (funcall ms-func ms-specifier (car ms-this-spec)
73 (cdr ms-this-spec) ms-maparg))
74 (setq ms-specs (cdr ms-specs))))
77 (defun canonicalize-inst-pair (inst-pair specifier-type &optional noerror)
78 "Canonicalize the given INST-PAIR.
80 SPECIFIER-TYPE specifies the type of specifier that this INST-PAIR
83 Canonicalizing means converting to the full form for an inst-pair, i.e.
84 `(TAG-SET . INSTANTIATOR)'. A single, untagged instantiator is given
85 a tag set of nil (the empty set), and a single tag is converted into
86 a tag set consisting only of that tag.
88 If NOERROR is non-nil, signal an error if the inst-pair is invalid;
90 ;; OK, the possibilities are:
92 ;; a) a single instantiator
93 ;; b) a cons of a tag and an instantiator
94 ;; c) a cons of a tag set and an instantiator
95 (cond ((valid-instantiator-p inst-pair specifier-type)
99 ((not (consp inst-pair))
102 ;; this will signal an appropriate error.
103 (check-valid-instantiator inst-pair specifier-type)))
105 ((and (valid-specifier-tag-p (car inst-pair))
106 (valid-instantiator-p (cdr inst-pair) specifier-type))
108 (cons (list (car inst-pair)) (cdr inst-pair)))
110 ((and (valid-specifier-tag-set-p (car inst-pair))
111 (valid-instantiator-p (cdr inst-pair) specifier-type))
117 (signal 'error (list "Invalid specifier tag set"
118 (car inst-pair)))))))
120 (defun canonicalize-inst-list (inst-list specifier-type &optional noerror)
121 "Canonicalize the given INST-LIST (a list of inst-pairs).
123 SPECIFIER-TYPE specifies the type of specifier that this INST-LIST
126 Canonicalizing means converting to the full form for an inst-list, i.e.
127 `((TAG-SET . INSTANTIATOR) ...)'. This function accepts a single
128 inst-pair or any abbreviation thereof or a list of (possibly
129 abbreviated) inst-pairs. (See `canonicalize-inst-pair'.)
131 If NOERROR is non-nil, signal an error if the inst-list is invalid;
134 ;; OK, the possibilities are:
136 ;; a) an inst-pair or various abbreviations thereof
138 (let ((result (canonicalize-inst-pair inst-list specifier-type t)))
139 (if (not (eq result t))
143 (if (not (consp inst-list))
146 ;; this will signal an appropriate error.
147 (check-valid-instantiator inst-list specifier-type))
150 (catch 'cann-inst-list
151 ;; don't use mapcar here; we need to catch the case of
153 (let ((rest inst-list)
156 (if (not (consp rest))
157 (if noerror (throw 'cann-inst-list t)
158 (signal 'error (list "Invalid list format" inst-list)))
159 (let ((res2 (canonicalize-inst-pair (car rest) specifier-type
162 ;; at this point, we know we're noerror because
163 ;; otherwise canonicalize-inst-pair would have
164 ;; signalled an error.
165 (throw 'cann-inst-list t)
166 (setq result (cons res2 result)))))
167 (setq rest (cdr rest)))
168 (nreverse result)))))))
170 (defun canonicalize-spec (spec specifier-type &optional noerror)
171 "Canonicalize the given SPEC (a specification).
173 SPECIFIER-TYPE is the type of specifier that this SPEC will be used for.
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'.)
180 If NOERROR is nil, signal an error if the specification is invalid;
182 ;; OK, the possibilities are:
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))
189 (cons 'global result)
191 (if (not (consp spec))
194 ;; this will signal an appropriate error.
195 (check-valid-instantiator spec specifier-type))
197 (if (not (valid-specifier-locale-p (car spec)))
200 (signal 'error (list "Invalid specifier locale" (car spec))))
203 (let ((result (canonicalize-inst-list (cdr spec) specifier-type
206 ;; at this point, we know we're noerror because
207 ;; otherwise canonicalize-inst-list would have
208 ;; signalled an error.
210 (cons (car spec) result))))))))
212 (defun canonicalize-spec-list (spec-list specifier-type &optional noerror)
213 "Canonicalize the given SPEC-LIST (a list of specifications).
215 SPECIFIER-TYPE specifies the type of specifier that this SPEC-LIST
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'.
225 The canonicalization algorithm is as follows:
227 1. Attempt to parse SPEC-LIST as a single, possibly abbreviated, specification.
228 2. If (1) fails, attempt to parse SPEC-LIST as a list of (abbreviated)
230 3. If (2) fails, SPEC-LIST is invalid.
232 A possibly abbreviated specification SPEC is parsed by
234 1. Attempt to parse SPEC as a possibly abbreviated inst-list.
235 2. If (1) fails, attempt to parse SPEC as a cons of a locale and an
236 (abbreviated) inst-list.
237 3. If (2) fails, SPEC is invalid.
239 A possibly abbreviated inst-list INST-LIST is parsed by
241 1. Attempt to parse INST-LIST as a possibly abbreviated inst-pair.
242 2. If (1) fails, attempt to parse INST-LIST as a list of (abbreviated)
244 3. If (2) fails, INST-LIST is invalid.
246 A possibly abbreviated inst-pair INST-PAIR is parsed by
248 1. Check if INST-PAIR is `valid-instantiator-p'.
249 2. If not, check if INST-PAIR is a cons of something that is a tag, ie,
250 `valid-specifier-tag-p', and something that is `valid-instantiator-p'.
251 3. If not, check if INST-PAIR is a cons of a list of tags and something that
252 is `valid-instantiator-p'.
254 In summary, this function generally prefers more abbreviated forms.
256 This function tries extremely hard to resolve any ambiguities, and the
257 built-in specifier types (font, image, toolbar, etc.) are designed so that
258 there won't be any ambiguities. (#### Unfortunately there are bugs in the
259 treatment of toolbar spec-lists and generic spec-lists; avoid depending on
260 canonicalization for these types.)
262 If NOERROR is nil, signal an error if the spec-list is invalid;
264 ;; OK, the possibilities are:
266 ;; a) a spec or various abbreviations thereof
268 (let ((result (canonicalize-spec spec-list specifier-type t)))
269 (if (not (eq result t))
273 (if (not (consp spec-list))
276 ;; this will signal an appropriate error.
277 (check-valid-instantiator spec-list specifier-type))
280 (catch 'cann-spec-list
281 ;; don't use mapcar here; we need to catch the case of
283 (let ((rest spec-list)
286 (if (not (consp rest))
287 (if noerror (throw 'cann-spec-list t)
288 (signal 'error (list "Invalid list format" spec-list)))
289 (let ((res2 (canonicalize-spec (car rest) specifier-type
292 ;; at this point, we know we're noerror because
293 ;; otherwise canonicalize-spec would have
294 ;; signalled an error.
295 (throw 'cann-spec-list t)
296 (setq result (cons res2 result)))))
297 (setq rest (cdr rest)))
298 (nreverse result)))))))
300 (defun set-specifier (specifier value &optional locale tag-set how-to-add)
301 "Add the specification(s) given by VALUE to SPECIFIER in LOCALE.
303 VALUE may be any of the values accepted by `canonicalize-spec-list', including
305 -- an instantiator (either a Lisp object which will be returned when the
306 specifier is instanced, or a Lisp object that can be instantiated to
307 produce an opaque value: eg, a font name (string) can be used for a font
308 specifier, but an instance will be a font object)
309 -- a list of instantiators
310 -- a cons of a locale and an instantiator, or of a locale and a list of
312 -- a cons of a tag or tag-set and an instantiator (or list of instantiators)
313 -- a cons of a locale and the previous type of item
314 -- a list of one or more of any of the previous types of items
315 -- a canonical spec-list.
317 See `canonicalize-spec-list' for details. If you need to know the details,
318 though, strongly consider using the unambiguous APIs `add-spec-to-specifier'
319 and `add-spec-list-to-specifier' instead.
321 Finally, VALUE can itself be a specifier (of the same type as
322 SPECIFIER), if you want to copy specifications from one specifier
323 to another; this is equivalent to calling `copy-specifier', and
324 LOCALE, TAG-SET, and HOW-TO-ADD have the same semantics as with
327 Note that a VALUE of `nil' is either illegal or will be treated as a value of
328 `nil'; it does not remove existing specifications. Use `remove-specifier' for
329 that. N.B. `remove-specifier' defaults to removing all specifications, not
330 just the 'global one!
332 Warning: this function is inherently heuristic, and should not be relied on to
333 properly resolve ambiguities, when specifier instantiators can be lists
334 \(currently, for toolbar specifiers and generic specifiers). In those cases
335 use either `add-spec-to-specifier' or `add-spec-list-to-specifier'.
337 LOCALE indicates where this specification is active, and should be
338 a buffer, a window, a frame, a device, or the symbol `global' to
339 indicate that it applies everywhere. LOCALE defaults to
340 `global' if omitted, and is overridden by locales provided by VALUE (in the
341 cases where value is a full specification or a spec-list).
343 Optional argument TAG-SET is a tag or a list of tags, to be associated
344 with the VALUE. Tags are symbols (usually naming device types, such
345 as `x' and `tty', or device classes, such as `color', `mono', and
346 `grayscale'); specifying a TAG-SET restricts the scope of VALUE to
347 devices that match all specified tags. (You can also create your
348 own tags using `define-specifier-tag', and use them to identify
349 specifications added by you, so you can remove them later.)
351 Optional argument HOW-TO-ADD should be either nil or one of the
352 symbols `prepend', `append', `remove-tag-set-prepend',
353 `remove-tag-set-append', `remove-locale', `remove-locale-type',
354 or `remove-all'. This specifies what to do with existing
355 specifications in LOCALE (and possibly elsewhere in the specifier).
356 Most of the time, you do not need to worry about this argument;
357 the default behavior of `remove-tag-set-prepend' is usually fine.
358 See `copy-specifier' and `add-spec-to-specifier' for a full
359 description of what each of these means.
361 Note that `set-specifier' is exactly complementary to `specifier-specs'
362 except in the case where SPECIFIER has no specs at all in it but nil
363 is a valid instantiator (in that case, `specifier-specs' will return
364 nil (meaning no specs) and `set-specifier' will interpret the `nil'
365 as meaning \"I'm adding a global instantiator and its value is `nil'\"),
366 or in strange cases where there is an ambiguity between a spec-list
367 and an inst-list, etc. (The built-in specifier types are designed
368 in such a way as to avoid any such ambiguities.)"
370 ;; backward compatibility: the old function had HOW-TO-ADD as the
371 ;; third argument and no arguments after that.
372 ;; #### this should disappear at some point.
373 (if (and (null how-to-add)
374 (memq locale '(prepend append remove-tag-set-prepend
375 remove-tag-set-append remove-locale
376 remove-locale-type remove-all)))
378 (setq how-to-add locale)
381 ;; proper beginning of the function.
382 (let ((is-valid (valid-instantiator-p value (specifier-type specifier)))
384 (cond ((and (not is-valid) (specifierp nval))
385 (copy-specifier nval specifier locale tag-set nil how-to-add))
389 (if (not (listp tag-set))
390 (setq tag-set (list tag-set)))
391 ;; You tend to get more accurate errors
392 ;; for a variety of cases if you call
393 ;; canonicalize-tag-set here.
394 (setq tag-set (canonicalize-tag-set tag-set))
395 (if (and (not is-valid) (consp nval))
397 (mapcar #'(lambda (x)
398 (check-valid-instantiator
399 x (specifier-type specifier))
402 (setq nval (cons tag-set nval)))))
404 (setq nval (cons locale nval)))
405 (add-spec-list-to-specifier
407 (canonicalize-spec-list nval (specifier-type specifier))
411 (defun modify-specifier-instances (specifier func &optional args force default
413 "Modify all specifications that match LOCALE and TAG-SET by FUNC.
415 For each specification that exists for SPECIFIER, in locale LOCALE
416 that matches TAG-SET, call the function FUNC with the instance as its
417 first argument and with optional arguments ARGS. The result is then
418 used as the new value of the instantiator.
420 If there is no specification in the domain LOCALE matching TAG-SET and
421 FORCE is non-nil, an explicit one is created from the matching
422 specifier instance if that exists or DEFAULT otherwise. If LOCALE is
423 not a domain (i.e. a buffer), DEFAULT is always used. FUNC is then
424 applied like above and the resulting specification is added."
426 (let ((spec-list (specifier-spec-list specifier locale tag-set)))
429 ;; Destructively edit the spec-list
430 (mapc #'(lambda (spec)
431 (mapc #'(lambda (inst-pair)
433 (apply func (cdr inst-pair) args)))
436 (add-spec-list-to-specifier specifier spec-list))
438 (set-specifier specifier
440 (or (and (valid-specifier-domain-p locale)
441 (specifier-instance specifier))
445 (defmacro let-specifier (specifier-list &rest body)
446 "Add specifier specs, evaluate forms in BODY and restore the specifiers.
447 \(let-specifier SPECIFIER-LIST BODY...)
449 Each element of SPECIFIER-LIST should look like this:
450 \(SPECIFIER VALUE &optional LOCALE TAG-SET HOW-TO-ADD).
452 SPECIFIER is the specifier to be temporarily modified. VALUE is the
453 instantiator to be temporarily added to SPECIFIER in LOCALE. LOCALE,
454 TAG-SET and HOW-TO-ADD have the same meaning as in
455 `add-spec-to-specifier'.
457 The code resulting from macro expansion will add specifications to
458 specifiers using `add-spec-to-specifier'. After BODY is finished, the
459 temporary specifications are removed and old spec-lists are restored.
461 LOCALE, TAG-SET and HOW-TO-ADD may be omitted, and default to nil.
462 The value of the last form in BODY is returned.
464 NOTE: If you want the specifier's instance to change in all
465 circumstances, use (selected-window) as the LOCALE. If LOCALE is nil
466 or omitted, it defaults to `global'.
469 (let-specifier ((modeline-shadow-thickness 0 (selected-window)))
471 (check-argument-type 'listp specifier-list)
472 (flet ((gensym-frob (x name)
473 (if (or (atom x) (eq (car x) 'quote))
475 (list (gensym name) x))))
476 ;; VARLIST is a list of
477 ;; ((SPECIFIERSYM SPECIFIER) (VALUE) (LOCALESYM LOCALE)
478 ;; (TAG-SET) (HOW-TO-ADD))
479 ;; If any of these is an atom, then a separate symbol is
480 ;; unnecessary, the CAR will contain the atom and CDR will be nil.
481 (let* ((varlist (mapcar #'(lambda (listel)
482 (or (and (consp listel)
483 (<= (length listel) 5)
484 (> (length listel) 1))
487 "should be a list of 2-5 elements"
489 ;; VALUE, TAG-SET and HOW-TO-ADD are
490 ;; referenced only once, so we needn't
491 ;; frob them with gensym.
492 (list (gensym-frob (nth 0 listel) "specifier-")
493 (list (nth 1 listel))
494 (gensym-frob (nth 2 listel) "locale-")
495 (list (nth 3 listel))
496 (list (nth 4 listel))))
498 ;; OLDVALLIST is a list of (OLDVALSYM OLDVALFORM)
499 (oldvallist (mapcar #'(lambda (varel)
500 (list (gensym "old-")
501 `(specifier-spec-list
503 ,(car (nth 2 varel)))))
505 ;; Bind the appropriate variables.
506 `(let* (,@(mapcan #'(lambda (varel)
509 (and (cdr varcons) varcons))
515 ,@(mapcar #'(lambda (varel)
516 `(add-spec-to-specifier
517 ,(car (nth 0 varel)) ,(car (nth 1 varel))
518 ,(car (nth 2 varel)) ,(car (nth 3 varel))
519 ,(car (nth 4 varel))))
522 ;; Reverse the unwinding order, so that using the same
523 ;; specifier multiple times works.
524 ,@(apply #'nconc (nreverse (mapcar*
525 #'(lambda (oldval varel)
528 ,(car (nth 2 varel)))
529 (add-spec-list-to-specifier
532 oldvallist varlist))))))))
534 (defun make-integer-specifier (spec-list)
535 "Return a new `integer' specifier object with the given specification list.
536 SPEC-LIST can be a list of specifications (each of which is a cons of a
537 locale and a list of instantiators), a single instantiator, or a list
538 of instantiators. See `make-specifier' for more information about
541 Valid instantiators for integer specifiers are integers."
542 (make-specifier-and-init 'integer spec-list))
544 (defun make-boolean-specifier (spec-list)
545 "Return a new `boolean' specifier object with the given specification list.
546 SPEC-LIST can be a list of specifications (each of which is a cons of a
547 locale and a list of instantiators), a single instantiator, or a list
548 of instantiators. See `make-specifier' for more information about
551 Valid instantiators for boolean specifiers are t and nil."
552 (make-specifier-and-init 'boolean spec-list))
554 (defun make-natnum-specifier (spec-list)
555 "Return a new `natnum' specifier object with the given specification list.
556 SPEC-LIST can be a list of specifications (each of which is a cons of a
557 locale and a list of instantiators), a single instantiator, or a list
558 of instantiators. See `make-specifier' for more information about
561 Valid instantiators for natnum specifiers are non-negative integers."
562 (make-specifier-and-init 'natnum spec-list))
564 (defun make-generic-specifier (spec-list)
565 "Return a new `generic' specifier object with the given specification list.
566 SPEC-LIST can be a list of specifications (each of which is a cons of a
567 locale and a list of instantiators), a single instantiator, or a list
568 of instantiators. See `make-specifier' for more information about
571 Valid instantiators for generic specifiers are all Lisp values.
572 They are returned back unchanged when a specifier is instantiated."
573 (make-specifier-and-init 'generic spec-list))
575 (defun make-display-table-specifier (spec-list)
576 "Return a new `display-table' specifier object with the given spec list.
577 SPEC-LIST can be a list of specifications (each of which is a cons of a
578 locale and a list of instantiators), a single instantiator, or a list
579 of instantiators. See `make-specifier' for more information about
582 Valid instantiators for display-table specifiers are described in
583 detail in the doc string for `current-display-table'."
584 (make-specifier-and-init 'display-table spec-list))
586 ;; Evaluate this for testing:
587 ; (cl-prettyexpand '(let-specifier ((modeline-shadow-thickness 0 (selected-window) 'x) (fubar (value) baz)) (sit-for 1)))
589 (define-specifier-tag 'win 'device-on-window-system-p)
591 ;; Add tags for device types that don't have support compiled
592 ;; into the binary that we're about to dump. This will prevent
595 ;; (set-face-foreground 'default "black" nil '(x color))
597 ;; from producing an error if no X support was compiled in.
599 (or (valid-specifier-tag-p 'x)
600 (define-specifier-tag 'x (lambda (dev) (eq (device-type dev) 'x))))
601 (or (valid-specifier-tag-p 'tty)
602 (define-specifier-tag 'tty (lambda (dev) (eq (device-type dev) 'tty))))
603 (or (valid-specifier-tag-p 'mswindows)
604 (define-specifier-tag 'mswindows (lambda (dev)
605 (eq (device-type dev) 'mswindows))))
606 (or (valid-specifier-tag-p 'gtk)
607 (define-specifier-tag 'gtk (lambda (dev) (eq (device-type dev) 'gtk))))
609 ;; Add special tag for use by initialization code. Code that
610 ;; sets up default specs should use this tag. Code that needs to
611 ;; override default specs (e.g. the X resource initialization
612 ;; code) can safely clear specs with this tag without worrying
613 ;; about clobbering user settings.
615 (define-specifier-tag 'default)
617 ;;; specifier.el ends here