Mercurial > hg > xemacs-beta

comparison src/specifier.c @ 412:697ef44129c6 r21-2-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-14
author cvs
date Mon, 13 Aug 2007 11:20:41 +0200
parents de805c49cfc1
children 41dbb7a9d5f2
comparison
equal deleted inserted replaced
411:12e008d41344 412:697ef44129c6
39 #include "window.h" 39 #include "window.h"
40 #include "chartab.h" 40 #include "chartab.h"
41 #include "rangetab.h" 41 #include "rangetab.h"
42 42
43 Lisp_Object Qspecifierp; 43 Lisp_Object Qspecifierp;
44 Lisp_Object Qprepend, Qremove_tag_set_prepend, Qremove_tag_set_append; 44 Lisp_Object Qprepend, Qappend, Qremove_tag_set_prepend, Qremove_tag_set_append;
45 Lisp_Object Qremove_locale, Qremove_locale_type, Qremove_all; 45 Lisp_Object Qremove_locale, Qremove_locale_type, Qremove_all;
46 Lisp_Object Qfallback; 46 Lisp_Object Qfallback;
47 47
48 /* Qinteger, Qboolean, Qgeneric defined in general.c. */ 48 /* Qinteger, Qboolean, Qgeneric defined in general.c. */
49 Lisp_Object Qnatnum; 49 Lisp_Object Qnatnum;
62 typedef struct 62 typedef struct
63 { 63 {
64 Dynarr_declare (specifier_type_entry); 64 Dynarr_declare (specifier_type_entry);
65 } specifier_type_entry_dynarr; 65 } specifier_type_entry_dynarr;
66 66
67 static specifier_type_entry_dynarr *the_specifier_type_entry_dynarr; 67 specifier_type_entry_dynarr *the_specifier_type_entry_dynarr;
68
69 static const struct lrecord_description ste_description_1[] = {
70 { XD_LISP_OBJECT, offsetof (specifier_type_entry, symbol) },
71 { XD_STRUCT_PTR, offsetof (specifier_type_entry, meths), 1, &specifier_methods_description },
72 { XD_END }
73 };
74
75 static const struct struct_description ste_description = {
76 sizeof (specifier_type_entry),
77 ste_description_1
78 };
79
80 static const struct lrecord_description sted_description_1[] = {
81 XD_DYNARR_DESC (specifier_type_entry_dynarr, &ste_description),
82 { XD_END }
83 };
84
85 static const struct struct_description sted_description = {
86 sizeof (specifier_type_entry_dynarr),
87 sted_description_1
88 };
89 68
90 static Lisp_Object Vspecifier_type_list; 69 static Lisp_Object Vspecifier_type_list;
91 70
92 static Lisp_Object Vcached_specifiers; 71 static Lisp_Object Vcached_specifiers;
93 /* Do NOT mark through this, or specifiers will never be GC'd. */ 72 /* Do NOT mark through this, or specifiers will never be GC'd. */
160 139
161 for (rest = Vall_specifiers; 140 for (rest = Vall_specifiers;
162 !NILP (rest); 141 !NILP (rest);
163 rest = XSPECIFIER (rest)->next_specifier) 142 rest = XSPECIFIER (rest)->next_specifier)
164 { 143 {
165 Lisp_Specifier *sp = XSPECIFIER (rest); 144 struct Lisp_Specifier *sp = XSPECIFIER (rest);
166 /* This effectively changes the specifier specs. 145 /* This effectively changes the specifier specs.
167 However, there's no need to call 146 However, there's no need to call
168 recompute_cached_specifier_everywhere() or the 147 recompute_cached_specifier_everywhere() or the
169 after-change methods because the only specs we 148 after-change methods because the only specs we
170 are removing are for dead objects, and they can 149 are removing are for dead objects, and they can
187 166
188 for (rest = Vall_specifiers; 167 for (rest = Vall_specifiers;
189 !NILP (rest); 168 !NILP (rest);
190 rest = XSPECIFIER (rest)->next_specifier) 169 rest = XSPECIFIER (rest)->next_specifier)
191 { 170 {
192 Lisp_Specifier *sp = XSPECIFIER (rest); 171 struct Lisp_Specifier *sp = XSPECIFIER (rest);
193 172
194 /* Make sure we're actually going to be changing something. 173 /* Make sure we're actually going to be changing something.
195 Fremove_specifier() always calls 174 Fremove_specifier() always calls
196 recompute_cached_specifier_everywhere() (#### but should 175 recompute_cached_specifier_everywhere() (#### but should
197 be smarter about this). */ 176 be smarter about this). */
199 Fremove_specifier (rest, buffer, Qnil, Qnil); 178 Fremove_specifier (rest, buffer, Qnil, Qnil);
200 } 179 }
201 } 180 }
202 181
203 static Lisp_Object 182 static Lisp_Object
204 mark_specifier (Lisp_Object obj) 183 mark_specifier (Lisp_Object obj, void (*markobj) (Lisp_Object))
205 { 184 {
206 Lisp_Specifier *specifier = XSPECIFIER (obj); 185 struct Lisp_Specifier *specifier = XSPECIFIER (obj);
207 186
208 mark_object (specifier->global_specs); 187 markobj (specifier->global_specs);
209 mark_object (specifier->device_specs); 188 markobj (specifier->device_specs);
210 mark_object (specifier->frame_specs); 189 markobj (specifier->frame_specs);
211 mark_object (specifier->window_specs); 190 markobj (specifier->window_specs);
212 mark_object (specifier->buffer_specs); 191 markobj (specifier->buffer_specs);
213 mark_object (specifier->magic_parent); 192 markobj (specifier->magic_parent);
214 mark_object (specifier->fallback); 193 markobj (specifier->fallback);
215 if (!GHOST_SPECIFIER_P (XSPECIFIER (obj))) 194 if (!GHOST_SPECIFIER_P (XSPECIFIER (obj)))
216 MAYBE_SPECMETH (specifier, mark, (obj)); 195 MAYBE_SPECMETH (specifier, mark, (obj, markobj));
217 return Qnil; 196 return Qnil;
218 } 197 }
219 198
220 /* The idea here is that the specifier specs point to locales 199 /* The idea here is that the specifier specs point to locales
221 (windows, buffers, frames, and devices), and we want to make sure 200 (windows, buffers, frames, and devices), and we want to make sure
235 We now use weak lists for this purpose. 214 We now use weak lists for this purpose.
236 215
237 */ 216 */
238 217
239 void 218 void
240 prune_specifiers (void) 219 prune_specifiers (int (*obj_marked_p) (Lisp_Object))
241 { 220 {
242 Lisp_Object rest, prev = Qnil; 221 Lisp_Object rest, prev = Qnil;
243 222
244 for (rest = Vall_specifiers; 223 for (rest = Vall_specifiers;
245 !NILP (rest); 224 !GC_NILP (rest);
246 rest = XSPECIFIER (rest)->next_specifier) 225 rest = XSPECIFIER (rest)->next_specifier)
247 { 226 {
248 if (! marked_p (rest)) 227 if (! obj_marked_p (rest))
249 { 228 {
250 Lisp_Specifier* sp = XSPECIFIER (rest); 229 struct Lisp_Specifier* sp = XSPECIFIER (rest);
251 /* A bit of assertion that we're removing both parts of the 230 /* A bit of assertion that we're removing both parts of the
252 magic one altogether */ 231 magic one altogether */
253 assert (!MAGIC_SPECIFIER_P(sp) 232 assert (!GC_MAGIC_SPECIFIER_P(sp)
254 || (BODILY_SPECIFIER_P(sp) && marked_p (sp->fallback)) 233 || (GC_BODILY_SPECIFIER_P(sp) && obj_marked_p (sp->fallback))
255 || (GHOST_SPECIFIER_P(sp) && marked_p (sp->magic_parent))); 234 || (GC_GHOST_SPECIFIER_P(sp) && obj_marked_p (sp->magic_parent)));
256 /* This specifier is garbage. Remove it from the list. */ 235 /* This specifier is garbage. Remove it from the list. */
257 if (NILP (prev)) 236 if (GC_NILP (prev))
258 Vall_specifiers = sp->next_specifier; 237 Vall_specifiers = sp->next_specifier;
259 else 238 else
260 XSPECIFIER (prev)->next_specifier = sp->next_specifier; 239 XSPECIFIER (prev)->next_specifier = sp->next_specifier;
261 } 240 }
262 else 241 else
265 } 244 }
266 245
267 static void 246 static void
268 print_specifier (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 247 print_specifier (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
269 { 248 {
270 Lisp_Specifier *sp = XSPECIFIER (obj); 249 struct Lisp_Specifier *sp = XSPECIFIER (obj);
271 char buf[100]; 250 char buf[100];
272 int count = specpdl_depth (); 251 int count = specpdl_depth ();
273 Lisp_Object the_specs; 252 Lisp_Object the_specs;
274 253
275 if (print_readably) 254 if (print_readably)
297 } 276 }
298 277
299 static void 278 static void
300 finalize_specifier (void *header, int for_disksave) 279 finalize_specifier (void *header, int for_disksave)
301 { 280 {
302 Lisp_Specifier *sp = (Lisp_Specifier *) header; 281 struct Lisp_Specifier *sp = (struct Lisp_Specifier *) header;
303 /* don't be snafued by the disksave finalization. */ 282 /* don't be snafued by the disksave finalization. */
304 if (!for_disksave && !GHOST_SPECIFIER_P(sp) && sp->caching) 283 if (!for_disksave && !GC_GHOST_SPECIFIER_P(sp) && sp->caching)
305 { 284 {
306 xfree (sp->caching); 285 xfree (sp->caching);
307 sp->caching = 0; 286 sp->caching = 0;
308 } 287 }
309 } 288 }
310 289
311 static int 290 static int
312 specifier_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) 291 specifier_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
313 { 292 {
314 Lisp_Specifier *s1 = XSPECIFIER (obj1); 293 struct Lisp_Specifier *s1 = XSPECIFIER (obj1);
315 Lisp_Specifier *s2 = XSPECIFIER (obj2); 294 struct Lisp_Specifier *s2 = XSPECIFIER (obj2);
316 int retval; 295 int retval;
317 Lisp_Object old_inhibit_quit = Vinhibit_quit; 296 Lisp_Object old_inhibit_quit = Vinhibit_quit;
318 297
319 /* This function can be called from within redisplay. 298 /* This function can be called from within redisplay.
320 internal_equal can trigger a quit. That leads to Bad Things. */ 299 internal_equal can trigger a quit. That leads to Bad Things. */
338 } 317 }
339 318
340 static unsigned long 319 static unsigned long
341 specifier_hash (Lisp_Object obj, int depth) 320 specifier_hash (Lisp_Object obj, int depth)
342 { 321 {
343 Lisp_Specifier *s = XSPECIFIER (obj); 322 struct Lisp_Specifier *s = XSPECIFIER (obj);
344 323
345 /* specifier hashing is a bit problematic because there are so 324 /* specifier hashing is a bit problematic because there are so
346 many places where data can be stored. We pick what are perhaps 325 many places where data can be stored. We pick what are perhaps
347 the most likely places where interesting stuff will be. */ 326 the most likely places where interesting stuff will be. */
348 return HASH5 ((HAS_SPECMETH_P (s, hash) ? 327 return HASH5 ((HAS_SPECMETH_P (s, hash) ?
352 internal_hash (s->frame_specs, depth + 1), 331 internal_hash (s->frame_specs, depth + 1),
353 internal_hash (s->buffer_specs, depth + 1)); 332 internal_hash (s->buffer_specs, depth + 1));
354 } 333 }
355 334
356 static size_t 335 static size_t
357 sizeof_specifier (const void *header) 336 sizeof_specifier (CONST void *header)
358 { 337 {
359 if (GHOST_SPECIFIER_P ((Lisp_Specifier *) header)) 338 if (GHOST_SPECIFIER_P ((struct Lisp_Specifier *) header))
360 return offsetof (Lisp_Specifier, data); 339 return sizeof (struct Lisp_Specifier);
361 else 340 else
362 { 341 {
363 const Lisp_Specifier *p = (const Lisp_Specifier *) header; 342 CONST struct Lisp_Specifier *p = (CONST struct Lisp_Specifier *) header;
364 return offsetof (Lisp_Specifier, data) + p->methods->extra_data_size; 343 return sizeof (*p) + p->methods->extra_data_size - 1;
365 } 344 }
366 } 345 }
367
368 static const struct lrecord_description specifier_methods_description_1[] = {
369 { XD_LISP_OBJECT, offsetof (struct specifier_methods, predicate_symbol) },
370 { XD_END }
371 };
372
373 const struct struct_description specifier_methods_description = {
374 sizeof (struct specifier_methods),
375 specifier_methods_description_1
376 };
377
378 static const struct lrecord_description specifier_caching_description_1[] = {
379 { XD_END }
380 };
381
382 static const struct struct_description specifier_caching_description = {
383 sizeof (struct specifier_caching),
384 specifier_caching_description_1
385 };
386
387 static const struct lrecord_description specifier_description[] = {
388 { XD_STRUCT_PTR, offsetof (Lisp_Specifier, methods), 1, &specifier_methods_description },
389 { XD_LO_LINK, offsetof (Lisp_Specifier, next_specifier) },
390 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, global_specs) },
391 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, device_specs) },
392 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, frame_specs) },
393 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, window_specs) },
394 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, buffer_specs) },
395 { XD_STRUCT_PTR, offsetof (Lisp_Specifier, caching), 1, &specifier_caching_description },
396 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, magic_parent) },
397 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, fallback) },
398 { XD_SPECIFIER_END }
399 };
400
401 const struct lrecord_description specifier_empty_extra_description[] = {
402 { XD_END }
403 };
404 346
405 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("specifier", specifier, 347 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("specifier", specifier,
406 mark_specifier, print_specifier, 348 mark_specifier, print_specifier,
407 finalize_specifier, 349 finalize_specifier,
408 specifier_equal, specifier_hash, 350 specifier_equal, specifier_hash,
409 specifier_description,
410 sizeof_specifier, 351 sizeof_specifier,
411 Lisp_Specifier); 352 struct Lisp_Specifier);
412 353
413 /************************************************************************/ 354 /************************************************************************/
414 /* Creating specifiers */ 355 /* Creating specifiers */
415 /************************************************************************/ 356 /************************************************************************/
416 357
470 static Lisp_Object 411 static Lisp_Object
471 make_specifier_internal (struct specifier_methods *spec_meths, 412 make_specifier_internal (struct specifier_methods *spec_meths,
472 size_t data_size, int call_create_meth) 413 size_t data_size, int call_create_meth)
473 { 414 {
474 Lisp_Object specifier; 415 Lisp_Object specifier;
475 Lisp_Specifier *sp = (Lisp_Specifier *) 416 struct Lisp_Specifier *sp = (struct Lisp_Specifier *)
476 alloc_lcrecord (offsetof (Lisp_Specifier, data) + data_size, 417 alloc_lcrecord (sizeof (struct Lisp_Specifier) +
477 &lrecord_specifier); 418 data_size - 1, &lrecord_specifier);
478 419
479 sp->methods = spec_meths; 420 sp->methods = spec_meths;
480 sp->global_specs = Qnil; 421 sp->global_specs = Qnil;
481 sp->device_specs = Qnil; 422 sp->device_specs = Qnil;
482 sp->frame_specs = Qnil; 423 sp->frame_specs = Qnil;
530 DEFUN ("make-specifier", Fmake_specifier, 1, 1, 0, /* 471 DEFUN ("make-specifier", Fmake_specifier, 1, 1, 0, /*
531 Return a new specifier object of type TYPE. 472 Return a new specifier object of type TYPE.
532 473
533 A specifier is an object that can be used to keep track of a property 474 A specifier is an object that can be used to keep track of a property
534 whose value can be per-buffer, per-window, per-frame, or per-device, 475 whose value can be per-buffer, per-window, per-frame, or per-device,
535 and can further be restricted to a particular console-type or 476 and can further be restricted to a particular console-type or device-class.
536 device-class. Specifiers are used, for example, for the various 477 Specifiers are used, for example, for the various built-in properties of a
537 built-in properties of a face; this allows a face to have different 478 face; this allows a face to have different values in different frames,
538 values in different frames, buffers, etc. 479 buffers, etc. For more information, see `specifier-instance',
539
540 When speaking of the value of a specifier, it is important to
541 distinguish between the *setting* of a specifier, called an
542 \"instantiator\", and the *actual value*, called an \"instance\". You
543 put various possible instantiators (i.e. settings) into a specifier
544 and associate them with particular locales (buffer, window, frame,
545 device, global), and then the instance (i.e. actual value) is
546 retrieved in a specific domain (window, frame, device) by looking
547 through the possible instantiators (i.e. settings). This process is
548 called \"instantiation\".
549
550 To put settings into a specifier, use `set-specifier', or the
551 lower-level functions `add-spec-to-specifier' and
552 `add-spec-list-to-specifier'. You can also temporarily bind a setting
553 to a specifier using `let-specifier'. To retrieve settings, use
554 `specifier-specs', or its lower-level counterpart
555 `specifier-spec-list'. To determine the actual value, use
556 `specifier-instance'.
557
558 For more information, see `set-specifier', `specifier-instance',
559 `specifier-specs', and `add-spec-to-specifier'; or, for a detailed 480 `specifier-specs', and `add-spec-to-specifier'; or, for a detailed
560 description of specifiers, including how exactly the instantiation 481 description of specifiers, including how they are instantiated over a
561 process works, see the chapter on specifiers in the XEmacs Lisp 482 particular domain (i.e. how their value in that domain is determined),
562 Reference Manual. 483 see the chapter on specifiers in the XEmacs Lisp Reference Manual.
563 484
564 TYPE specifies the particular type of specifier, and should be one of 485 TYPE specifies the particular type of specifier, and should be one of
565 the symbols 'generic, 'integer, 'natnum, 'boolean, 'color, 'font, 486 the symbols 'generic, 'integer, 'boolean, 'color, 'font, 'image,
566 'image, 'face-boolean, 'display-table, 'gutter, 'gutter-size, 487 'face-boolean, or 'toolbar.
567 'gutter-visible or 'toolbar. 488
568 489 For more information on particular types of specifiers, see the functions
569 For more information on particular types of specifiers, see the 490 `generic-specifier-p', `integer-specifier-p', `boolean-specifier-p',
570 functions `make-generic-specifier', `make-integer-specifier', 491 `color-specifier-p', `font-specifier-p', `image-specifier-p',
571 `make-natnum-specifier', `make-boolean-specifier', 492 `face-boolean-specifier-p', and `toolbar-specifier-p'.
572 `make-color-specifier', `make-font-specifier', `make-image-specifier',
573 `make-face-boolean-specifier', `make-gutter-size-specifier',
574 `make-gutter-visible-specifier', `default-toolbar', `default-gutter',
575 and `current-display-table'.
576 */ 493 */
577 (type)) 494 (type))
578 { 495 {
579 /* This function can GC */ 496 /* This function can GC */
580 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME); 497 struct specifier_methods *meths = decode_specifier_type (type,
498 ERROR_ME);
581 499
582 return make_specifier (meths); 500 return make_specifier (meths);
583 } 501 }
584 502
585 DEFUN ("specifierp", Fspecifierp, 1, 1, 0, /* 503 DEFUN ("specifierp", Fspecifierp, 1, 1, 0, /*
628 } 546 }
629 547
630 DEFUN ("valid-specifier-domain-p", Fvalid_specifier_domain_p, 1, 1, 0, /* 548 DEFUN ("valid-specifier-domain-p", Fvalid_specifier_domain_p, 1, 1, 0, /*
631 Return t if DOMAIN is a valid specifier domain. 549 Return t if DOMAIN is a valid specifier domain.
632 A domain is used to instance a specifier (i.e. determine the specifier's 550 A domain is used to instance a specifier (i.e. determine the specifier's
633 value in that domain). Valid domains are image instances, windows, frames, 551 value in that domain). Valid domains are windows, frames, and devices.
634 and devices. \(nil is not valid.) image instances are pseudo-domains since 552 \(nil is not valid.)
635 instantiation will actually occur in the window the image instance itself is
636 instantiated in.
637 */ 553 */
638 (domain)) 554 (domain))
639 { 555 {
640 /* This cannot GC. */ 556 /* This cannot GC. */
641 return ((DEVICEP (domain) && DEVICE_LIVE_P (XDEVICE (domain))) || 557 return ((DEVICEP (domain) && DEVICE_LIVE_P (XDEVICE (domain))) ||
642 (FRAMEP (domain) && FRAME_LIVE_P (XFRAME (domain))) || 558 (FRAMEP (domain) && FRAME_LIVE_P (XFRAME (domain))) ||
643 (WINDOWP (domain) && WINDOW_LIVE_P (XWINDOW (domain))) || 559 (WINDOWP (domain) && WINDOW_LIVE_P (XWINDOW (domain))))
644 /* #### get image instances out of domains! */
645 IMAGE_INSTANCEP (domain))
646 ? Qt : Qnil; 560 ? Qt : Qnil;
647 } 561 }
648 562
649 DEFUN ("valid-specifier-locale-type-p", Fvalid_specifier_locale_type_p, 1, 1, 0, /* 563 DEFUN ("valid-specifier-locale-type-p", Fvalid_specifier_locale_type_p, 1, 1, 0, /*
650 Given a specifier LOCALE-TYPE, return non-nil if it is valid. 564 Given a specifier LOCALE-TYPE, return non-nil if it is valid.
752 { 666 {
753 if (NILP (Fvalid_specifier_domain_p (domain))) 667 if (NILP (Fvalid_specifier_domain_p (domain)))
754 signal_simple_error ("Invalid specifier domain", domain); 668 signal_simple_error ("Invalid specifier domain", domain);
755 } 669 }
756 670
757 Lisp_Object 671 static Lisp_Object
758 decode_domain (Lisp_Object domain) 672 decode_domain (Lisp_Object domain)
759 { 673 {
760 if (NILP (domain)) 674 if (NILP (domain))
761 return Fselected_window (Qnil); 675 return Fselected_window (Qnil);
762 check_valid_domain (domain); 676 check_valid_domain (domain);
1671 build_up_processed_list (Lisp_Object specifier, Lisp_Object locale, 1585 build_up_processed_list (Lisp_Object specifier, Lisp_Object locale,
1672 Lisp_Object inst_list) 1586 Lisp_Object inst_list)
1673 { 1587 {
1674 /* The return value of this function must be GCPRO'd. */ 1588 /* The return value of this function must be GCPRO'd. */
1675 Lisp_Object rest, list_to_build_up = Qnil; 1589 Lisp_Object rest, list_to_build_up = Qnil;
1676 Lisp_Specifier *sp = XSPECIFIER (specifier); 1590 struct Lisp_Specifier *sp = XSPECIFIER (specifier);
1677 struct gcpro gcpro1; 1591 struct gcpro gcpro1;
1678 1592
1679 GCPRO1 (list_to_build_up); 1593 GCPRO1 (list_to_build_up);
1680 LIST_LOOP (rest, inst_list) 1594 LIST_LOOP (rest, inst_list)
1681 { 1595 {
1682 Lisp_Object tag_set = XCAR (XCAR (rest)); 1596 Lisp_Object tag_set = XCAR (XCAR (rest));
1597 Lisp_Object instantiator = Fcopy_tree (XCDR (XCAR (rest)), Qt);
1683 Lisp_Object sub_inst_list = Qnil; 1598 Lisp_Object sub_inst_list = Qnil;
1684 Lisp_Object instantiator;
1685 struct gcpro ngcpro1, ngcpro2; 1599 struct gcpro ngcpro1, ngcpro2;
1686
1687 if (HAS_SPECMETH_P (sp, copy_instantiator))
1688 instantiator = SPECMETH (sp, copy_instantiator,
1689 (XCDR (XCAR (rest))));
1690 else
1691 instantiator = Fcopy_tree (XCDR (XCAR (rest)), Qt);
1692 1600
1693 NGCPRO2 (instantiator, sub_inst_list); 1601 NGCPRO2 (instantiator, sub_inst_list);
1694 /* call the will-add method; it may GC */ 1602 /* call the will-add method; it may GC */
1695 sub_inst_list = HAS_SPECMETH_P (sp, going_to_add) ? 1603 sub_inst_list = HAS_SPECMETH_P (sp, going_to_add) ?
1696 SPECMETH (sp, going_to_add, 1604 SPECMETH (sp, going_to_add,
1728 1636
1729 static void 1637 static void
1730 specifier_add_spec (Lisp_Object specifier, Lisp_Object locale, 1638 specifier_add_spec (Lisp_Object specifier, Lisp_Object locale,
1731 Lisp_Object inst_list, enum spec_add_meth add_meth) 1639 Lisp_Object inst_list, enum spec_add_meth add_meth)
1732 { 1640 {
1733 Lisp_Specifier *sp = XSPECIFIER (specifier); 1641 struct Lisp_Specifier *sp = XSPECIFIER (specifier);
1734 enum spec_locale_type type = locale_type_from_locale (locale); 1642 enum spec_locale_type type = locale_type_from_locale (locale);
1735 Lisp_Object *orig_inst_list, tem; 1643 Lisp_Object *orig_inst_list, tem;
1736 Lisp_Object list_to_build_up = Qnil; 1644 Lisp_Object list_to_build_up = Qnil;
1737 struct gcpro gcpro1; 1645 struct gcpro gcpro1;
1738 1646
2399 global value. */ 2307 global value. */
2400 2308
2401 void 2309 void
2402 set_specifier_fallback (Lisp_Object specifier, Lisp_Object fallback) 2310 set_specifier_fallback (Lisp_Object specifier, Lisp_Object fallback)
2403 { 2311 {
2404 Lisp_Specifier *sp = XSPECIFIER (specifier); 2312 struct Lisp_Specifier *sp = XSPECIFIER (specifier);
2405 assert (SPECIFIERP (fallback) || 2313 assert (SPECIFIERP (fallback) ||
2406 !NILP (Fvalid_inst_list_p (fallback, Fspecifier_type (specifier)))); 2314 !NILP (Fvalid_inst_list_p (fallback, Fspecifier_type (specifier))));
2407 if (SPECIFIERP (fallback)) 2315 if (SPECIFIERP (fallback))
2408 assert (EQ (Fspecifier_type (specifier), Fspecifier_type (fallback))); 2316 assert (EQ (Fspecifier_type (specifier), Fspecifier_type (fallback)));
2409 if (BODILY_SPECIFIER_P (sp)) 2317 if (BODILY_SPECIFIER_P (sp))
2449 Lisp_Object inst_list, 2357 Lisp_Object inst_list,
2450 Error_behavior errb, int no_quit, 2358 Error_behavior errb, int no_quit,
2451 Lisp_Object depth) 2359 Lisp_Object depth)
2452 { 2360 {
2453 /* This function can GC */ 2361 /* This function can GC */
2454 Lisp_Specifier *sp; 2362 struct Lisp_Specifier *sp;
2455 Lisp_Object device; 2363 Lisp_Object device;
2456 Lisp_Object rest; 2364 Lisp_Object rest;
2457 int count = specpdl_depth (); 2365 int count = specpdl_depth ();
2458 struct gcpro gcpro1, gcpro2; 2366 struct gcpro gcpro1, gcpro2;
2459 2367
2460 GCPRO2 (specifier, inst_list); 2368 GCPRO2 (specifier, inst_list);
2461 2369
2462 sp = XSPECIFIER (specifier); 2370 sp = XSPECIFIER (specifier);
2463 device = DOMAIN_DEVICE (domain); 2371 device = DFW_DEVICE (domain);
2464 2372
2465 if (no_quit) 2373 if (no_quit)
2466 /* The instantiate method is allowed to call eval. Since it 2374 /* The instantiate method is allowed to call eval. Since it
2467 is quite common for this function to get called from somewhere in 2375 is quite common for this function to get called from somewhere in
2468 redisplay we need to make sure that quits are ignored. Otherwise 2376 redisplay we need to make sure that quits are ignored. Otherwise
2532 Lisp_Object window = Qnil; 2440 Lisp_Object window = Qnil;
2533 Lisp_Object frame = Qnil; 2441 Lisp_Object frame = Qnil;
2534 Lisp_Object device = Qnil; 2442 Lisp_Object device = Qnil;
2535 Lisp_Object tag = Qnil; 2443 Lisp_Object tag = Qnil;
2536 struct device *d; 2444 struct device *d;
2537 Lisp_Specifier *sp; 2445 struct Lisp_Specifier *sp;
2538 2446
2539 sp = XSPECIFIER (specifier); 2447 sp = XSPECIFIER (specifier);
2540 2448
2541 /* Attempt to determine buffer, window, frame, and device from the 2449 /* Attempt to determine buffer, window, frame, and device from the
2542 domain. */ 2450 domain. */
2543 /* #### get image instances out of domains! */ 2451 if (WINDOWP (domain))
2544 if (IMAGE_INSTANCEP (domain))
2545 window = DOMAIN_WINDOW (domain);
2546 else if (WINDOWP (domain))
2547 window = domain; 2452 window = domain;
2548 else if (FRAMEP (domain)) 2453 else if (FRAMEP (domain))
2549 frame = domain; 2454 frame = domain;
2550 else if (DEVICEP (domain)) 2455 else if (DEVICEP (domain))
2551 device = domain; 2456 device = domain;
2552 else 2457 else
2553 /* dmoore writes: [dammit, this should just signal an error or something 2458 /* #### dmoore - dammit, this should just signal an error or something
2554 shouldn't it?] 2459 shouldn't it?
2555 2460 #### No. Errors are handled in Lisp primitives implementation.
2556 No. Errors are handled in Lisp primitives implementation.
2557 Invalid domain is a design error here - kkm. */ 2461 Invalid domain is a design error here - kkm. */
2558 abort (); 2462 abort ();
2559 2463
2560 if (NILP (buffer) && !NILP (window)) 2464 if (NILP (buffer) && !NILP (window))
2561 buffer = XWINDOW (window)->buffer; 2465 buffer = XWINDOW (window)->buffer;
2579 from Lisp). */ 2483 from Lisp). */
2580 depth = Qzero; 2484 depth = Qzero;
2581 goto do_fallback; 2485 goto do_fallback;
2582 } 2486 }
2583 2487
2584 retry: 2488 retry:
2585 /* First see if we can generate one from the window specifiers. */ 2489 /* First see if we can generate one from the window specifiers. */
2586 if (!NILP (window)) 2490 if (!NILP (window))
2587 CHECK_INSTANCE_ENTRY (window, matchspec, LOCALE_WINDOW); 2491 CHECK_INSTANCE_ENTRY (window, matchspec, LOCALE_WINDOW);
2588 2492
2589 /* Next see if we can generate one from the buffer specifiers. */ 2493 /* Next see if we can generate one from the buffer specifiers. */
2598 CHECK_INSTANCE_ENTRY (device, matchspec, LOCALE_DEVICE); 2502 CHECK_INSTANCE_ENTRY (device, matchspec, LOCALE_DEVICE);
2599 2503
2600 /* Last and least try the global specifiers. */ 2504 /* Last and least try the global specifiers. */
2601 CHECK_INSTANCE_ENTRY (Qglobal, matchspec, LOCALE_GLOBAL); 2505 CHECK_INSTANCE_ENTRY (Qglobal, matchspec, LOCALE_GLOBAL);
2602 2506
2603 do_fallback: 2507 do_fallback:
2604 /* We're out of specifiers and we still haven't generated an 2508 /* We're out of specifiers and we still haven't generated an
2605 instance. At least try the fallback ... If this fails, 2509 instance. At least try the fallback ... If this fails,
2606 then we just return Qunbound. */ 2510 then we just return Qunbound. */
2607 2511
2608 if (no_fallback || NILP (sp->fallback)) 2512 if (no_fallback || NILP (sp->fallback))
2739 you should not use this function; use `specifier-instance' instead. 2643 you should not use this function; use `specifier-instance' instead.
2740 */ 2644 */
2741 (specifier, domain, inst_list, default_)) 2645 (specifier, domain, inst_list, default_))
2742 { 2646 {
2743 Lisp_Object val = Qunbound; 2647 Lisp_Object val = Qunbound;
2744 Lisp_Specifier *sp = XSPECIFIER (specifier); 2648 struct Lisp_Specifier *sp = XSPECIFIER (specifier);
2745 struct gcpro gcpro1; 2649 struct gcpro gcpro1;
2746 Lisp_Object built_up_list = Qnil; 2650 Lisp_Object built_up_list = Qnil;
2747 2651
2748 CHECK_SPECIFIER (specifier); 2652 CHECK_SPECIFIER (specifier);
2749 check_valid_domain (domain); 2653 check_valid_domain (domain);
2771 works. 2675 works.
2772 */ 2676 */
2773 (specifier, matchspec, domain, inst_list, default_)) 2677 (specifier, matchspec, domain, inst_list, default_))
2774 { 2678 {
2775 Lisp_Object val = Qunbound; 2679 Lisp_Object val = Qunbound;
2776 Lisp_Specifier *sp = XSPECIFIER (specifier); 2680 struct Lisp_Specifier *sp = XSPECIFIER (specifier);
2777 struct gcpro gcpro1; 2681 struct gcpro gcpro1;
2778 Lisp_Object built_up_list = Qnil; 2682 Lisp_Object built_up_list = Qnil;
2779 2683
2780 CHECK_SPECIFIER (specifier); 2684 CHECK_SPECIFIER (specifier);
2781 check_valid_specifier_matchspec (matchspec, XSPECIFIER (specifier)->methods, 2685 check_valid_specifier_matchspec (matchspec, XSPECIFIER (specifier)->methods,
2811 int struct_frame_offset, 2715 int struct_frame_offset,
2812 void (*value_changed_in_frame) 2716 void (*value_changed_in_frame)
2813 (Lisp_Object specifier, struct frame *f, 2717 (Lisp_Object specifier, struct frame *f,
2814 Lisp_Object oldval)) 2718 Lisp_Object oldval))
2815 { 2719 {
2816 Lisp_Specifier *sp = XSPECIFIER (specifier); 2720 struct Lisp_Specifier *sp = XSPECIFIER (specifier);
2817 assert (!GHOST_SPECIFIER_P (sp)); 2721 assert (!GHOST_SPECIFIER_P (sp));
2818 2722
2819 if (!sp->caching) 2723 if (!sp->caching)
2820 sp->caching = xnew_and_zero (struct specifier_caching); 2724 sp->caching = xnew_and_zero (struct specifier_caching);
2821 sp->caching->offset_into_struct_window = struct_window_offset; 2725 sp->caching->offset_into_struct_window = struct_window_offset;
2845 better be able to deal. If not, set a default so this 2749 better be able to deal. If not, set a default so this
2846 never happens or correct it in the value_changed_in_window 2750 never happens or correct it in the value_changed_in_window
2847 method. */ 2751 method. */
2848 location = (Lisp_Object *) 2752 location = (Lisp_Object *)
2849 ((char *) w + XSPECIFIER (specifier)->caching->offset_into_struct_window); 2753 ((char *) w + XSPECIFIER (specifier)->caching->offset_into_struct_window);
2850 /* #### What's the point of this check, other than to optimize image
2851 instance instantiation? Unless you specify a caching instantiate
2852 method the instantiation that specifier_instance will do will
2853 always create a new copy. Thus EQ will always fail. Unfortunately
2854 calling equal is no good either as this doesn't take into account
2855 things attached to the specifier - for instance strings on
2856 extents. --andyp */
2857 if (!EQ (newval, *location)) 2754 if (!EQ (newval, *location))
2858 { 2755 {
2859 Lisp_Object oldval = *location; 2756 Lisp_Object oldval = *location;
2860 *location = newval; 2757 *location = newval;
2861 (XSPECIFIER (specifier)->caching->value_changed_in_window) 2758 (XSPECIFIER (specifier)->caching->value_changed_in_window)
2986 is supposed to require only that the specifier type is passed, 2883 is supposed to require only that the specifier type is passed,
2987 while with this approach the actual specifier is needed.) 2884 while with this approach the actual specifier is needed.)
2988 2885
2989 What really needs to be done is to write a function 2886 What really needs to be done is to write a function
2990 `make-specifier-type' that creates new specifier types. 2887 `make-specifier-type' that creates new specifier types.
2991 2888 #### I'll look into this for 19.14.
2992 #### [I'll look into this for 19.14.] Well, sometime. (Currently 2889 */
2993 May 2000, 21.2 is in development. 19.14 was released in June 1996.) */
2994 2890
2995 "A generic specifier is a generalized kind of specifier with user-defined\n" 2891 "A generic specifier is a generalized kind of specifier with user-defined\n"
2996 "semantics. The instantiator can be any kind of Lisp object, and the\n" 2892 "semantics. The instantiator can be any kind of Lisp object, and the\n"
2997 "instance computed from it is likewise any kind of Lisp object. The\n" 2893 "instance computed from it is likewise any kind of Lisp object. The\n"
2998 "SPECIFIER-DATA should be an alist of methods governing how the specifier\n" 2894 "SPECIFIER-DATA should be an alist of methods governing how the specifier\n"
3025 #endif /* 0 */ 2921 #endif /* 0 */
3026 2922
3027 DEFUN ("generic-specifier-p", Fgeneric_specifier_p, 1, 1, 0, /* 2923 DEFUN ("generic-specifier-p", Fgeneric_specifier_p, 1, 1, 0, /*
3028 Return non-nil if OBJECT is a generic specifier. 2924 Return non-nil if OBJECT is a generic specifier.
3029 2925
3030 See `make-generic-specifier' for a description of possible generic 2926 A generic specifier allows any kind of Lisp object as an instantiator,
3031 instantiators. 2927 and returns back the Lisp object unchanged when it is instantiated.
3032 */ 2928 */
3033 (object)) 2929 (object))
3034 { 2930 {
3035 return GENERIC_SPECIFIERP (object) ? Qt : Qnil; 2931 return GENERIC_SPECIFIERP (object) ? Qt : Qnil;
3036 } 2932 }
3048 CHECK_INT (instantiator); 2944 CHECK_INT (instantiator);
3049 } 2945 }
3050 2946
3051 DEFUN ("integer-specifier-p", Finteger_specifier_p, 1, 1, 0, /* 2947 DEFUN ("integer-specifier-p", Finteger_specifier_p, 1, 1, 0, /*
3052 Return non-nil if OBJECT is an integer specifier. 2948 Return non-nil if OBJECT is an integer specifier.
3053
3054 See `make-integer-specifier' for a description of possible integer
3055 instantiators.
3056 */ 2949 */
3057 (object)) 2950 (object))
3058 { 2951 {
3059 return INTEGER_SPECIFIERP (object) ? Qt : Qnil; 2952 return INTEGER_SPECIFIERP (object) ? Qt : Qnil;
3060 } 2953 }
3071 CHECK_NATNUM (instantiator); 2964 CHECK_NATNUM (instantiator);
3072 } 2965 }
3073 2966
3074 DEFUN ("natnum-specifier-p", Fnatnum_specifier_p, 1, 1, 0, /* 2967 DEFUN ("natnum-specifier-p", Fnatnum_specifier_p, 1, 1, 0, /*
3075 Return non-nil if OBJECT is a natnum (non-negative-integer) specifier. 2968 Return non-nil if OBJECT is a natnum (non-negative-integer) specifier.
3076
3077 See `make-natnum-specifier' for a description of possible natnum
3078 instantiators.
3079 */ 2969 */
3080 (object)) 2970 (object))
3081 { 2971 {
3082 return NATNUM_SPECIFIERP (object) ? Qt : Qnil; 2972 return NATNUM_SPECIFIERP (object) ? Qt : Qnil;
3083 } 2973 }
3095 signal_simple_error ("Must be t or nil", instantiator); 2985 signal_simple_error ("Must be t or nil", instantiator);
3096 } 2986 }
3097 2987
3098 DEFUN ("boolean-specifier-p", Fboolean_specifier_p, 1, 1, 0, /* 2988 DEFUN ("boolean-specifier-p", Fboolean_specifier_p, 1, 1, 0, /*
3099 Return non-nil if OBJECT is a boolean specifier. 2989 Return non-nil if OBJECT is a boolean specifier.
3100
3101 See `make-boolean-specifier' for a description of possible boolean
3102 instantiators.
3103 */ 2990 */
3104 (object)) 2991 (object))
3105 { 2992 {
3106 return BOOLEAN_SPECIFIERP (object) ? Qt : Qnil; 2993 return BOOLEAN_SPECIFIERP (object) ? Qt : Qnil;
3107 } 2994 }
3110 /* Display table specifier type */ 2997 /* Display table specifier type */
3111 /************************************************************************/ 2998 /************************************************************************/
3112 2999
3113 DEFINE_SPECIFIER_TYPE (display_table); 3000 DEFINE_SPECIFIER_TYPE (display_table);
3114 3001
3115 #define VALID_SINGLE_DISPTABLE_INSTANTIATOR_P(instantiator) \ 3002 #define VALID_SINGLE_DISPTABLE_INSTANTIATOR_P(instantiator) \
3116 (VECTORP (instantiator) \ 3003 (VECTORP (instantiator) \
3117 || (CHAR_TABLEP (instantiator) \ 3004 || (CHAR_TABLEP (instantiator) \
3118 && (XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_CHAR \ 3005 && (XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_CHAR \
3119 || XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_GENERIC)) \ 3006 || XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_GENERIC)) \
3120 || RANGE_TABLEP (instantiator)) 3007 || RANGE_TABLEP (instantiator))
3121 3008
3122 static void 3009 static void
3123 display_table_validate (Lisp_Object instantiator) 3010 display_table_validate (Lisp_Object instantiator)
3124 { 3011 {
3146 } 3033 }
3147 } 3034 }
3148 3035
3149 DEFUN ("display-table-specifier-p", Fdisplay_table_specifier_p, 1, 1, 0, /* 3036 DEFUN ("display-table-specifier-p", Fdisplay_table_specifier_p, 1, 1, 0, /*
3150 Return non-nil if OBJECT is a display-table specifier. 3037 Return non-nil if OBJECT is a display-table specifier.
3151
3152 See `current-display-table' for a description of possible display-table
3153 instantiators.
3154 */ 3038 */
3155 (object)) 3039 (object))
3156 { 3040 {
3157 return DISPLAYTABLE_SPECIFIERP (object) ? Qt : Qnil; 3041 return DISPLAYTABLE_SPECIFIERP (object) ? Qt : Qnil;
3158 } 3042 }
3163 /************************************************************************/ 3047 /************************************************************************/
3164 3048
3165 void 3049 void
3166 syms_of_specifier (void) 3050 syms_of_specifier (void)
3167 { 3051 {
3168 INIT_LRECORD_IMPLEMENTATION (specifier);
3169
3170 defsymbol (&Qspecifierp, "specifierp"); 3052 defsymbol (&Qspecifierp, "specifierp");
3171 3053
3172 defsymbol (&Qconsole_type, "console-type"); 3054 defsymbol (&Qconsole_type, "console-type");
3173 defsymbol (&Qdevice_class, "device-class"); 3055 defsymbol (&Qdevice_class, "device-class");
3174 3056
3227 in the syms_of() functions. */ 3109 in the syms_of() functions. */
3228 3110
3229 /* locales are defined in general.c. */ 3111 /* locales are defined in general.c. */
3230 3112
3231 defsymbol (&Qprepend, "prepend"); 3113 defsymbol (&Qprepend, "prepend");
3114 defsymbol (&Qappend, "append");
3232 defsymbol (&Qremove_tag_set_prepend, "remove-tag-set-prepend"); 3115 defsymbol (&Qremove_tag_set_prepend, "remove-tag-set-prepend");
3233 defsymbol (&Qremove_tag_set_append, "remove-tag-set-append"); 3116 defsymbol (&Qremove_tag_set_append, "remove-tag-set-append");
3234 defsymbol (&Qremove_locale, "remove-locale"); 3117 defsymbol (&Qremove_locale, "remove-locale");
3235 defsymbol (&Qremove_locale_type, "remove-locale-type"); 3118 defsymbol (&Qremove_locale_type, "remove-locale-type");
3236 defsymbol (&Qremove_all, "remove-all"); 3119 defsymbol (&Qremove_all, "remove-all");
3240 3123
3241 void 3124 void
3242 specifier_type_create (void) 3125 specifier_type_create (void)
3243 { 3126 {
3244 the_specifier_type_entry_dynarr = Dynarr_new (specifier_type_entry); 3127 the_specifier_type_entry_dynarr = Dynarr_new (specifier_type_entry);
3245 dumpstruct (&the_specifier_type_entry_dynarr, &sted_description);
3246 3128
3247 Vspecifier_type_list = Qnil; 3129 Vspecifier_type_list = Qnil;
3248 staticpro (&Vspecifier_type_list); 3130 staticpro (&Vspecifier_type_list);
3249 3131
3250 INITIALIZE_SPECIFIER_TYPE (generic, "generic", "generic-specifier-p"); 3132 INITIALIZE_SPECIFIER_TYPE (generic, "generic", "generic-specifier-p");
3262 SPECIFIER_HAS_METHOD (boolean, validate); 3144 SPECIFIER_HAS_METHOD (boolean, validate);
3263 3145
3264 INITIALIZE_SPECIFIER_TYPE (display_table, "display-table", "display-table-p"); 3146 INITIALIZE_SPECIFIER_TYPE (display_table, "display-table", "display-table-p");
3265 3147
3266 SPECIFIER_HAS_METHOD (display_table, validate); 3148 SPECIFIER_HAS_METHOD (display_table, validate);
3267 }
3268
3269 void
3270 reinit_specifier_type_create (void)
3271 {
3272 REINITIALIZE_SPECIFIER_TYPE (generic);
3273 REINITIALIZE_SPECIFIER_TYPE (integer);
3274 REINITIALIZE_SPECIFIER_TYPE (natnum);
3275 REINITIALIZE_SPECIFIER_TYPE (boolean);
3276 REINITIALIZE_SPECIFIER_TYPE (display_table);
3277 } 3149 }
3278 3150
3279 void 3151 void
3280 vars_of_specifier (void) 3152 vars_of_specifier (void)
3281 { 3153 {
3283 staticpro (&Vcached_specifiers); 3155 staticpro (&Vcached_specifiers);
3284 3156
3285 /* Do NOT mark through this, or specifiers will never be GC'd. 3157 /* Do NOT mark through this, or specifiers will never be GC'd.
3286 This is the same deal as for weak hash tables. */ 3158 This is the same deal as for weak hash tables. */
3287 Vall_specifiers = Qnil; 3159 Vall_specifiers = Qnil;
3288 pdump_wire_list (&Vall_specifiers);
3289 3160
3290 Vuser_defined_tags = Qnil; 3161 Vuser_defined_tags = Qnil;
3291 staticpro (&Vuser_defined_tags); 3162 staticpro (&Vuser_defined_tags);
3292 3163
3293 Vunlock_ghost_specifiers = Qnil; 3164 Vunlock_ghost_specifiers = Qnil;