|
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
|
|
2297
|
350 devices that match all specified tags. (You can also create your
|
|
428
|
351 own tags using `define-specifier-tag', and use them to identify
|
|
|
352 specifications added by you, so you can remove them later.)
|
|
|
353
|
|
|
354 Optional argument HOW-TO-ADD should be either nil or one of the
|
|
|
355 symbols `prepend', `append', `remove-tag-set-prepend',
|
|
|
356 `remove-tag-set-append', `remove-locale', `remove-locale-type',
|
|
|
357 or `remove-all'. This specifies what to do with existing
|
|
|
358 specifications in LOCALE (and possibly elsewhere in the specifier).
|
|
|
359 Most of the time, you do not need to worry about this argument;
|
|
|
360 the default behavior of `remove-tag-set-prepend' is usually fine.
|
|
|
361 See `copy-specifier' and `add-spec-to-specifier' for a full
|
|
|
362 description of what each of these means.
|
|
|
363
|
|
|
364 Note that `set-specifier' is exactly complementary to `specifier-specs'
|
|
|
365 except in the case where SPECIFIER has no specs at all in it but nil
|
|
|
366 is a valid instantiator (in that case, `specifier-specs' will return
|
|
|
367 nil (meaning no specs) and `set-specifier' will interpret the `nil'
|
|
|
368 as meaning \"I'm adding a global instantiator and its value is `nil'\"),
|
|
|
369 or in strange cases where there is an ambiguity between a spec-list
|
|
2297
|
370 and an inst-list, etc. (The built-in specifier types are designed
|
|
1875
|
371 in such a way as to avoid any such ambiguities.)"
|
|
428
|
372
|
|
|
373 ;; backward compatibility: the old function had HOW-TO-ADD as the
|
|
|
374 ;; third argument and no arguments after that.
|
|
|
375 ;; #### this should disappear at some point.
|
|
|
376 (if (and (null how-to-add)
|
|
|
377 (memq locale '(prepend append remove-tag-set-prepend
|
|
|
378 remove-tag-set-append remove-locale
|
|
|
379 remove-locale-type remove-all)))
|
|
|
380 (progn
|
|
|
381 (setq how-to-add locale)
|
|
|
382 (setq locale nil)))
|
|
|
383
|
|
|
384 ;; proper beginning of the function.
|
|
|
385 (let ((is-valid (valid-instantiator-p value (specifier-type specifier)))
|
|
|
386 (nval value))
|
|
|
387 (cond ((and (not is-valid) (specifierp nval))
|
|
|
388 (copy-specifier nval specifier locale tag-set nil how-to-add))
|
|
|
389 (t
|
|
|
390 (if tag-set
|
|
|
391 (progn
|
|
|
392 (if (not (listp tag-set))
|
|
|
393 (setq tag-set (list tag-set)))
|
|
|
394 ;; You tend to get more accurate errors
|
|
|
395 ;; for a variety of cases if you call
|
|
|
396 ;; canonicalize-tag-set here.
|
|
|
397 (setq tag-set (canonicalize-tag-set tag-set))
|
|
|
398 (if (and (not is-valid) (consp nval))
|
|
|
399 (setq nval
|
|
|
400 (mapcar #'(lambda (x)
|
|
|
401 (check-valid-instantiator
|
|
|
402 x (specifier-type specifier))
|
|
|
403 (cons tag-set x))
|
|
|
404 nval))
|
|
|
405 (setq nval (cons tag-set nval)))))
|
|
|
406 (if locale
|
|
|
407 (setq nval (cons locale nval)))
|
|
|
408 (add-spec-list-to-specifier
|
|
|
409 specifier
|
|
|
410 (canonicalize-spec-list nval (specifier-type specifier))
|
|
|
411 how-to-add))))
|
|
|
412 value)
|
|
|
413
|
|
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
|
