Mercurial > hg > xemacs-beta
annotate src/specifier.c @ 5124:623d57b7fbe8 ben-lisp-object
separate regular and disksave finalization, print method fixes.
Create separate disksave method and make the finalize method only be for
actual object finalization, not disksave finalization.
Fix places where 0 was given in place of a printer -- print methods are
mandatory, and internal objects formerly without a print method now must
explicitly specify internal_object_printer().
Change the defn of CONSOLE_LIVE_P to avoid problems in some weird situations.
-------------------- ChangeLog entries follow: --------------------
src/ChangeLog addition:
2010-01-20 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (very_old_free_lcrecord):
* alloc.c (disksave_object_finalization_1):
* alloc.c (make_lcrecord_list):
* alloc.c (alloc_managed_lcrecord):
* alloc.c (free_managed_lcrecord):
* alloc.c (sweep_lcrecords_1):
* buffer.c:
* bytecode.c:
* bytecode.c (Fcompiled_function_p):
* chartab.c:
* console-impl.h:
* console-impl.h (CONSOLE_TYPE_P):
* console.c:
* console.c (set_quit_events):
* data.c:
* data.c (Fmake_ephemeron):
* database.c:
* database.c (finalize_database):
* database.c (Fclose_database):
* device-msw.c:
* device-msw.c (finalize_devmode):
* device-msw.c (allocate_devmode):
* device.c:
* elhash.c:
* elhash.c (finalize_hash_table):
* eval.c:
* eval.c (bind_multiple_value_limits):
* event-stream.c:
* event-stream.c (finalize_command_builder):
* events.c:
* events.c (mark_event):
* extents.c:
* extents.c (finalize_extent_info):
* extents.c (uninit_buffer_extents):
* faces.c:
* file-coding.c:
* file-coding.c (finalize_coding_system):
* file-coding.h:
* file-coding.h (struct coding_system_methods):
* file-coding.h (struct detector):
* floatfns.c:
* floatfns.c (extract_float):
* fns.c:
* fns.c (Fidentity):
* font-mgr.c (finalize_fc_pattern):
* font-mgr.c (finalize_fc_config):
* frame.c:
* glyphs.c:
* glyphs.c (finalize_image_instance):
* glyphs.c (unmap_subwindow_instance_cache_mapper):
* gui.c:
* gui.c (gui_error):
* keymap.c:
* lisp.h (struct Lisp_Symbol):
* lrecord.h:
* lrecord.h (struct lrecord_implementation):
* lrecord.h (MC_ALLOC_CALL_FINALIZER):
* lrecord.h (MC_ALLOC_CALL_FINALIZER_FOR_DISKSAVE):
* lrecord.h (DEFINE_DUMPABLE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_SIZABLE_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_FROB_BLOCK_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_FROB_BLOCK_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_SIZABLE_INTERNAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_SIZABLE_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_FROB_BLOCK_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_FROB_BLOCK_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_FROB_BLOCK_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_INTERNAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_SIZABLE_INTERNAL_LISP_OBJECT):
* lrecord.h (MAKE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_MODULE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_MODULE_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_MODULE_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_MODULE_SIZABLE_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_MODULE_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_MODULE_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_MODULE_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_MODULE_SIZABLE_GENERAL_LISP_OBJECT):
* lrecord.h (MAKE_MODULE_LISP_OBJECT):
* lstream.c:
* lstream.c (finalize_lstream):
* lstream.c (disksave_lstream):
* marker.c:
* marker.c (finalize_marker):
* mule-charset.c (make_charset):
* number.c:
* objects.c:
* objects.c (finalize_color_instance):
* objects.c (finalize_font_instance):
* opaque.c:
* opaque.c (make_opaque_ptr):
* process-nt.c:
* process-nt.c (nt_finalize_process_data):
* process-nt.c (nt_deactivate_process):
* process.c:
* process.c (finalize_process):
* procimpl.h (struct process_methods):
* scrollbar.c:
* scrollbar.c (free_scrollbar_instance):
* specifier.c (finalize_specifier):
* symbols.c:
* toolbar.c:
* toolbar.c (Ftoolbar_button_p):
* tooltalk.c:
* ui-gtk.c:
* ui-gtk.c (emacs_gtk_object_finalizer):
* ui-gtk.c (allocate_emacs_gtk_boxed_data):
* window.c:
* window.c (finalize_window):
* window.c (mark_window_as_deleted):
Separate out regular and disksave finalization. Instead of a
FOR_DISKSAVE argument to the finalizer, create a separate object
method `disksaver'. Make `finalizer' have only one argument.
Go through and separate out all finalize methods into finalize
and disksave. Delete lots of thereby redundant disksave checking.
Delete places that signal an error if we attempt to disksave --
all of these objects are non-dumpable and we will get an error
from pdump anyway if we attempt to dump them. After this is done,
only one object remains that has a disksave method -- lstream.
Change DEFINE_*_LISP_OBJECT_WITH_PROPS to DEFINE_*_GENERAL_LISP_OBJECT,
which is used for specifying either property methods or disksave
methods (or in the future, any other less-used methods).
Remove the for_disksave argument to finalize_process_data. Don't
provide a disksaver for processes because no one currently needs
it.
Clean up various places where objects didn't provide a print method.
It was made mandatory in previous changes, and all methods now
either provide their own print method or use internal_object_printer
or external_object_printer.
Change the definition of CONSOLE_LIVE_P to use the contype enum
rather than looking into the conmeths structure -- in some weird
situations with dead objects, the conmeths structure is NULL,
and printing such objects from debug_print() will crash if we try
to look into the conmeths structure.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Wed, 20 Jan 2010 07:05:57 -0600 |
| parents | d1247f3cc363 |
| children | b5df3737028a |
| rev | line source |
|---|---|
| 428 | 1 /* Specifier implementation |
| 2 Copyright (C) 1994, 1995 Board of Trustees, University of Illinois. | |
| 2953 | 3 Copyright (C) 1995, 1996, 2002, 2005 Ben Wing. |
| 428 | 4 Copyright (C) 1995 Sun Microsystems, Inc. |
| 5 | |
| 6 This file is part of XEmacs. | |
| 7 | |
| 8 XEmacs is free software; you can redistribute it and/or modify it | |
| 9 under the terms of the GNU General Public License as published by the | |
| 10 Free Software Foundation; either version 2, or (at your option) any | |
| 11 later version. | |
| 12 | |
| 13 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 16 for more details. | |
| 17 | |
| 18 You should have received a copy of the GNU General Public License | |
| 19 along with XEmacs; see the file COPYING. If not, write to | |
| 20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 21 Boston, MA 02111-1307, USA. */ | |
| 22 | |
| 23 /* Synched up with: Not in FSF. */ | |
| 24 | |
| 25 /* Design by Ben Wing; | |
| 2953 | 26 Written by Ben Wing based on prototype for 19.12 by Chuck Thompson. |
| 27 Magic specifiers by Kirill Katsnelson. | |
| 428 | 28 */ |
| 29 | |
| 30 #include <config.h> | |
| 31 #include "lisp.h" | |
| 32 | |
| 33 #include "buffer.h" | |
| 800 | 34 #include "chartab.h" |
| 872 | 35 #include "device-impl.h" |
| 428 | 36 #include "frame.h" |
| 800 | 37 #include "glyphs.h" |
| 428 | 38 #include "opaque.h" |
| 800 | 39 #include "rangetab.h" |
| 428 | 40 #include "specifier.h" |
| 41 #include "window.h" | |
| 42 | |
| 43 Lisp_Object Qspecifierp; | |
| 442 | 44 Lisp_Object Qremove_tag_set_prepend, Qremove_tag_set_append; |
| 45 Lisp_Object Qremove_locale, Qremove_locale_type; | |
| 428 | 46 |
| 47 Lisp_Object Qconsole_type, Qdevice_class; | |
| 48 | |
| 49 static Lisp_Object Vuser_defined_tags; | |
| 3659 | 50 static Lisp_Object Vcharset_tag_lists; |
| 428 | 51 |
| 52 typedef struct specifier_type_entry specifier_type_entry; | |
| 53 struct specifier_type_entry | |
| 54 { | |
| 55 Lisp_Object symbol; | |
| 56 struct specifier_methods *meths; | |
| 57 }; | |
| 58 | |
| 59 typedef struct | |
| 60 { | |
| 61 Dynarr_declare (specifier_type_entry); | |
| 62 } specifier_type_entry_dynarr; | |
| 63 | |
| 64 static specifier_type_entry_dynarr *the_specifier_type_entry_dynarr; | |
| 65 | |
| 1204 | 66 static const struct memory_description ste_description_1[] = { |
| 440 | 67 { XD_LISP_OBJECT, offsetof (specifier_type_entry, symbol) }, |
| 2367 | 68 { XD_BLOCK_PTR, offsetof (specifier_type_entry, meths), 1, |
| 2551 | 69 { &specifier_methods_description } }, |
| 428 | 70 { XD_END } |
| 71 }; | |
| 72 | |
| 1204 | 73 static const struct sized_memory_description ste_description = { |
| 440 | 74 sizeof (specifier_type_entry), |
| 428 | 75 ste_description_1 |
| 76 }; | |
| 77 | |
| 1204 | 78 static const struct memory_description sted_description_1[] = { |
| 440 | 79 XD_DYNARR_DESC (specifier_type_entry_dynarr, &ste_description), |
| 428 | 80 { XD_END } |
| 81 }; | |
| 82 | |
| 1204 | 83 static const struct sized_memory_description sted_description = { |
| 440 | 84 sizeof (specifier_type_entry_dynarr), |
| 428 | 85 sted_description_1 |
| 86 }; | |
| 87 | |
| 88 static Lisp_Object Vspecifier_type_list; | |
| 89 | |
| 90 static Lisp_Object Vcached_specifiers; | |
| 91 /* Do NOT mark through this, or specifiers will never be GC'd. */ | |
| 92 static Lisp_Object Vall_specifiers; | |
| 93 | |
| 94 static Lisp_Object Vunlock_ghost_specifiers; | |
| 95 | |
| 96 /* #### The purpose of this is to check for inheritance loops | |
| 97 in specifiers that can inherit from other specifiers, but it's | |
| 98 not yet implemented. | |
| 99 | |
| 100 #### Look into this for 19.14. */ | |
| 101 /* static Lisp_Object_dynarr current_specifiers; */ | |
| 102 | |
| 103 static void recompute_cached_specifier_everywhere (Lisp_Object specifier); | |
| 104 | |
| 105 EXFUN (Fspecifier_specs, 4); | |
| 106 EXFUN (Fremove_specifier, 4); | |
| 107 | |
| 108 | |
| 109 /************************************************************************/ | |
| 110 /* Specifier object methods */ | |
| 111 /************************************************************************/ | |
| 112 | |
| 113 /* Remove dead objects from the specified assoc list. */ | |
| 114 | |
| 115 static Lisp_Object | |
| 116 cleanup_assoc_list (Lisp_Object list) | |
| 117 { | |
| 118 Lisp_Object loop, prev, retval; | |
| 119 | |
| 120 loop = retval = list; | |
| 121 prev = Qnil; | |
| 122 | |
| 123 while (!NILP (loop)) | |
| 124 { | |
| 125 Lisp_Object entry = XCAR (loop); | |
| 126 Lisp_Object key = XCAR (entry); | |
| 127 | |
| 128 /* remember, dead windows can become alive again. */ | |
| 129 if (!WINDOWP (key) && object_dead_p (key)) | |
| 130 { | |
| 131 if (NILP (prev)) | |
| 132 { | |
| 133 /* Removing the head. */ | |
| 134 retval = XCDR (retval); | |
| 135 } | |
| 136 else | |
| 137 { | |
| 138 Fsetcdr (prev, XCDR (loop)); | |
| 139 } | |
| 140 } | |
| 141 else | |
| 142 prev = loop; | |
| 143 | |
| 144 loop = XCDR (loop); | |
| 145 } | |
| 146 | |
| 147 return retval; | |
| 148 } | |
| 149 | |
| 150 /* Remove dead objects from the various lists so that they | |
| 151 don't keep getting marked as long as this specifier exists and | |
| 152 therefore wasting memory. */ | |
| 153 | |
| 154 void | |
| 155 cleanup_specifiers (void) | |
| 156 { | |
| 157 Lisp_Object rest; | |
| 158 | |
| 159 for (rest = Vall_specifiers; | |
| 160 !NILP (rest); | |
| 161 rest = XSPECIFIER (rest)->next_specifier) | |
| 162 { | |
| 440 | 163 Lisp_Specifier *sp = XSPECIFIER (rest); |
| 428 | 164 /* This effectively changes the specifier specs. |
| 165 However, there's no need to call | |
| 166 recompute_cached_specifier_everywhere() or the | |
| 167 after-change methods because the only specs we | |
| 168 are removing are for dead objects, and they can | |
| 169 never have any effect on the specifier values: | |
| 170 specifiers can only be instantiated over live | |
| 171 objects, and you can't derive a dead object | |
| 172 from a live one. */ | |
| 173 sp->device_specs = cleanup_assoc_list (sp->device_specs); | |
| 174 sp->frame_specs = cleanup_assoc_list (sp->frame_specs); | |
| 175 sp->buffer_specs = cleanup_assoc_list (sp->buffer_specs); | |
| 176 /* windows are handled specially because dead windows | |
| 177 can be resurrected */ | |
| 178 } | |
| 179 } | |
| 180 | |
| 181 void | |
| 182 kill_specifier_buffer_locals (Lisp_Object buffer) | |
| 183 { | |
| 184 Lisp_Object rest; | |
| 185 | |
| 186 for (rest = Vall_specifiers; | |
| 187 !NILP (rest); | |
| 188 rest = XSPECIFIER (rest)->next_specifier) | |
| 189 { | |
| 440 | 190 Lisp_Specifier *sp = XSPECIFIER (rest); |
| 428 | 191 |
| 192 /* Make sure we're actually going to be changing something. | |
| 193 Fremove_specifier() always calls | |
| 194 recompute_cached_specifier_everywhere() (#### but should | |
| 195 be smarter about this). */ | |
| 196 if (!NILP (assq_no_quit (buffer, sp->buffer_specs))) | |
| 197 Fremove_specifier (rest, buffer, Qnil, Qnil); | |
| 198 } | |
| 199 } | |
| 200 | |
| 201 static Lisp_Object | |
| 202 mark_specifier (Lisp_Object obj) | |
| 203 { | |
| 440 | 204 Lisp_Specifier *specifier = XSPECIFIER (obj); |
| 428 | 205 |
| 206 mark_object (specifier->global_specs); | |
| 207 mark_object (specifier->device_specs); | |
| 208 mark_object (specifier->frame_specs); | |
| 209 mark_object (specifier->window_specs); | |
| 210 mark_object (specifier->buffer_specs); | |
| 211 mark_object (specifier->magic_parent); | |
| 212 mark_object (specifier->fallback); | |
| 213 if (!GHOST_SPECIFIER_P (XSPECIFIER (obj))) | |
| 214 MAYBE_SPECMETH (specifier, mark, (obj)); | |
| 215 return Qnil; | |
| 216 } | |
| 217 | |
| 218 /* The idea here is that the specifier specs point to locales | |
| 219 (windows, buffers, frames, and devices), and we want to make sure | |
| 220 that the specs disappear automatically when the associated locale | |
| 221 is no longer in use. For all but windows, "no longer in use" | |
| 222 corresponds exactly to when the object is deleted (non-deleted | |
| 223 objects are always held permanently in special lists, and deleted | |
| 224 objects are never on these lists and never reusable). To handle | |
| 225 this, we just have cleanup_specifiers() called periodically | |
| 226 (at the beginning of garbage collection); it removes all dead | |
| 227 objects. | |
| 228 | |
| 229 For windows, however, it's trickier because dead objects can be | |
| 230 converted to live ones again if the dead object is in a window | |
| 231 configuration. Therefore, for windows, "no longer in use" | |
| 232 corresponds to when the window object is garbage-collected. | |
| 233 We now use weak lists for this purpose. | |
| 234 | |
| 235 */ | |
| 236 | |
| 237 void | |
| 238 prune_specifiers (void) | |
| 239 { | |
| 240 Lisp_Object rest, prev = Qnil; | |
| 241 | |
| 242 for (rest = Vall_specifiers; | |
| 243 !NILP (rest); | |
| 244 rest = XSPECIFIER (rest)->next_specifier) | |
| 245 { | |
| 246 if (! marked_p (rest)) | |
| 247 { | |
| 440 | 248 Lisp_Specifier* sp = XSPECIFIER (rest); |
| 428 | 249 /* A bit of assertion that we're removing both parts of the |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
250 magic one altogether */ |
| 428 | 251 assert (!MAGIC_SPECIFIER_P(sp) |
| 252 || (BODILY_SPECIFIER_P(sp) && marked_p (sp->fallback)) | |
| 253 || (GHOST_SPECIFIER_P(sp) && marked_p (sp->magic_parent))); | |
| 254 /* This specifier is garbage. Remove it from the list. */ | |
| 255 if (NILP (prev)) | |
| 256 Vall_specifiers = sp->next_specifier; | |
| 257 else | |
| 258 XSPECIFIER (prev)->next_specifier = sp->next_specifier; | |
| 259 } | |
| 260 else | |
| 261 prev = rest; | |
| 262 } | |
| 263 } | |
| 264 | |
| 265 static void | |
| 2286 | 266 print_specifier (Lisp_Object obj, Lisp_Object printcharfun, |
| 267 int UNUSED (escapeflag)) | |
| 428 | 268 { |
| 440 | 269 Lisp_Specifier *sp = XSPECIFIER (obj); |
| 428 | 270 int count = specpdl_depth (); |
| 271 Lisp_Object the_specs; | |
| 272 | |
| 273 if (print_readably) | |
| 563 | 274 printing_unreadable_object ("#<%s-specifier 0x%x>", |
| 275 sp->methods->name, sp->header.uid); | |
| 428 | 276 |
| 800 | 277 write_fmt_string (printcharfun, "#<%s-specifier global=", sp->methods->name); |
| 872 | 278 #if 0 |
| 279 /* #### Not obvious this is useful, and overrides user settings; if we | |
| 280 resurrect this, create variables like `print-specifier-length' so it | |
| 281 can be controlled. */ | |
| 428 | 282 specbind (Qprint_string_length, make_int (100)); |
| 283 specbind (Qprint_length, make_int (5)); | |
| 872 | 284 #endif |
| 428 | 285 the_specs = Fspecifier_specs (obj, Qglobal, Qnil, Qnil); |
| 286 if (NILP (the_specs)) | |
| 287 /* there are no global specs */ | |
| 826 | 288 write_c_string (printcharfun, "<unspecified>"); |
| 428 | 289 else |
| 290 print_internal (the_specs, printcharfun, 1); | |
| 291 if (!NILP (sp->fallback)) | |
| 292 { | |
| 800 | 293 write_fmt_string_lisp (printcharfun, " fallback=%S", 1, sp->fallback); |
| 428 | 294 } |
| 771 | 295 unbind_to (count); |
| 800 | 296 write_fmt_string (printcharfun, " 0x%x>", sp->header.uid); |
| 428 | 297 } |
| 298 | |
| 3263 | 299 #ifndef NEW_GC |
| 428 | 300 static void |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
301 finalize_specifier (void *header) |
| 428 | 302 { |
| 440 | 303 Lisp_Specifier *sp = (Lisp_Specifier *) header; |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
304 if (!GHOST_SPECIFIER_P(sp) && sp->caching) |
| 428 | 305 { |
| 1726 | 306 xfree (sp->caching, struct specifier_caching *); |
| 428 | 307 sp->caching = 0; |
| 308 } | |
| 309 } | |
| 3263 | 310 #endif /* not NEW_GC */ |
| 428 | 311 |
| 312 static int | |
| 313 specifier_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
| 314 { | |
| 440 | 315 Lisp_Specifier *s1 = XSPECIFIER (obj1); |
| 316 Lisp_Specifier *s2 = XSPECIFIER (obj2); | |
| 428 | 317 int retval; |
| 318 Lisp_Object old_inhibit_quit = Vinhibit_quit; | |
| 319 | |
| 320 /* This function can be called from within redisplay. | |
| 321 internal_equal can trigger a quit. That leads to Bad Things. */ | |
| 322 Vinhibit_quit = Qt; | |
| 323 | |
| 324 depth++; | |
| 325 retval = | |
| 326 (s1->methods == s2->methods && | |
| 327 internal_equal (s1->global_specs, s2->global_specs, depth) && | |
| 328 internal_equal (s1->device_specs, s2->device_specs, depth) && | |
| 329 internal_equal (s1->frame_specs, s2->frame_specs, depth) && | |
| 330 internal_equal (s1->window_specs, s2->window_specs, depth) && | |
| 331 internal_equal (s1->buffer_specs, s2->buffer_specs, depth) && | |
| 332 internal_equal (s1->fallback, s2->fallback, depth)); | |
| 333 | |
| 334 if (retval && HAS_SPECMETH_P (s1, equal)) | |
| 335 retval = SPECMETH (s1, equal, (obj1, obj2, depth - 1)); | |
| 336 | |
| 337 Vinhibit_quit = old_inhibit_quit; | |
| 338 return retval; | |
| 339 } | |
| 340 | |
| 2515 | 341 static Hashcode |
| 428 | 342 specifier_hash (Lisp_Object obj, int depth) |
| 343 { | |
| 440 | 344 Lisp_Specifier *s = XSPECIFIER (obj); |
| 428 | 345 |
| 346 /* specifier hashing is a bit problematic because there are so | |
| 347 many places where data can be stored. We pick what are perhaps | |
| 348 the most likely places where interesting stuff will be. */ | |
| 349 return HASH5 ((HAS_SPECMETH_P (s, hash) ? | |
| 350 SPECMETH (s, hash, (obj, depth)) : 0), | |
| 2515 | 351 (Hashcode) s->methods, |
| 428 | 352 internal_hash (s->global_specs, depth + 1), |
| 353 internal_hash (s->frame_specs, depth + 1), | |
| 354 internal_hash (s->buffer_specs, depth + 1)); | |
| 355 } | |
| 356 | |
| 665 | 357 inline static Bytecount |
| 358 aligned_sizeof_specifier (Bytecount specifier_type_specific_size) | |
| 456 | 359 { |
| 826 | 360 return MAX_ALIGN_SIZE (offsetof (Lisp_Specifier, data) |
| 361 + specifier_type_specific_size); | |
| 456 | 362 } |
| 363 | |
| 665 | 364 static Bytecount |
| 442 | 365 sizeof_specifier (const void *header) |
| 428 | 366 { |
| 456 | 367 const Lisp_Specifier *p = (const Lisp_Specifier *) header; |
| 368 return aligned_sizeof_specifier (GHOST_SPECIFIER_P (p) | |
| 369 ? 0 | |
| 370 : p->methods->extra_data_size); | |
| 428 | 371 } |
| 372 | |
| 1204 | 373 static const struct memory_description specifier_methods_description_1[] = { |
| 440 | 374 { XD_LISP_OBJECT, offsetof (struct specifier_methods, predicate_symbol) }, |
| 428 | 375 { XD_END } |
| 376 }; | |
| 377 | |
| 1204 | 378 const struct sized_memory_description specifier_methods_description = { |
| 440 | 379 sizeof (struct specifier_methods), |
| 428 | 380 specifier_methods_description_1 |
| 381 }; | |
| 382 | |
| 1204 | 383 static const struct memory_description specifier_caching_description_1[] = { |
| 428 | 384 { XD_END } |
| 385 }; | |
| 386 | |
| 3092 | 387 #ifdef NEW_GC |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
388 DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("specifier-caching", specifier_caching, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
389 0, specifier_caching_description_1, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
390 struct specifier_caching); |
| 3092 | 391 #else /* not NEW_GC */ |
| 1204 | 392 static const struct sized_memory_description specifier_caching_description = { |
| 440 | 393 sizeof (struct specifier_caching), |
| 428 | 394 specifier_caching_description_1 |
| 395 }; | |
| 3092 | 396 #endif /* not NEW_GC */ |
| 428 | 397 |
| 1204 | 398 static const struct sized_memory_description specifier_extra_description_map[] |
| 399 = { | |
| 400 { offsetof (Lisp_Specifier, methods) }, | |
| 401 { offsetof (struct specifier_methods, extra_description) }, | |
| 402 { -1 }, | |
| 403 }; | |
| 404 | |
| 405 const struct memory_description specifier_description[] = { | |
| 2367 | 406 { XD_BLOCK_PTR, offsetof (Lisp_Specifier, methods), 1, |
| 2551 | 407 { &specifier_methods_description } }, |
| 440 | 408 { XD_LO_LINK, offsetof (Lisp_Specifier, next_specifier) }, |
| 409 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, global_specs) }, | |
| 410 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, device_specs) }, | |
| 411 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, frame_specs) }, | |
| 412 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, window_specs) }, | |
| 413 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, buffer_specs) }, | |
| 3092 | 414 #ifdef NEW_GC |
| 415 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, caching) }, | |
| 416 #else /* not NEW_GC */ | |
| 2367 | 417 { XD_BLOCK_PTR, offsetof (Lisp_Specifier, caching), 1, |
| 2551 | 418 { &specifier_caching_description } }, |
| 3092 | 419 #endif /* not NEW_GC */ |
| 440 | 420 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, magic_parent) }, |
| 421 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, fallback) }, | |
| 2367 | 422 { XD_BLOCK_ARRAY, offsetof (Lisp_Specifier, data), 1, |
| 2551 | 423 { specifier_extra_description_map } }, |
| 428 | 424 { XD_END } |
| 425 }; | |
| 426 | |
| 1204 | 427 static const struct memory_description specifier_empty_extra_description_1[] = |
| 3659 | 428 { |
| 429 { XD_END } | |
| 430 }; | |
| 1204 | 431 |
| 432 const struct sized_memory_description specifier_empty_extra_description = { | |
| 433 0, specifier_empty_extra_description_1 | |
| 434 }; | |
| 435 | |
| 3263 | 436 #ifdef NEW_GC |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
437 DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("specifier", specifier, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
438 mark_specifier, print_specifier, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
439 0, specifier_equal, specifier_hash, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
440 specifier_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
441 sizeof_specifier, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
442 Lisp_Specifier); |
| 3263 | 443 #else /* not NEW_GC */ |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
444 DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("specifier", specifier, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
445 mark_specifier, print_specifier, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
446 finalize_specifier, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
447 specifier_equal, specifier_hash, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
448 specifier_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
449 sizeof_specifier, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
450 Lisp_Specifier); |
| 3263 | 451 #endif /* not NEW_GC */ |
| 428 | 452 |
| 453 /************************************************************************/ | |
| 454 /* Creating specifiers */ | |
| 455 /************************************************************************/ | |
| 456 | |
| 457 static struct specifier_methods * | |
| 578 | 458 decode_specifier_type (Lisp_Object type, Error_Behavior errb) |
| 428 | 459 { |
| 460 int i; | |
| 461 | |
| 462 for (i = 0; i < Dynarr_length (the_specifier_type_entry_dynarr); i++) | |
| 463 { | |
| 464 if (EQ (type, Dynarr_at (the_specifier_type_entry_dynarr, i).symbol)) | |
| 465 return Dynarr_at (the_specifier_type_entry_dynarr, i).meths; | |
| 466 } | |
| 467 | |
| 563 | 468 maybe_invalid_argument ("Invalid specifier type", |
| 3659 | 469 type, Qspecifier, errb); |
| 428 | 470 |
| 471 return 0; | |
| 472 } | |
| 473 | |
| 474 static int | |
| 475 valid_specifier_type_p (Lisp_Object type) | |
| 476 { | |
| 477 return decode_specifier_type (type, ERROR_ME_NOT) != 0; | |
| 478 } | |
| 479 | |
| 480 DEFUN ("valid-specifier-type-p", Fvalid_specifier_type_p, 1, 1, 0, /* | |
| 481 Given a SPECIFIER-TYPE, return non-nil if it is valid. | |
| 2953 | 482 Valid types are `generic', `integer', `boolean', `color', `font', `image', |
| 483 `face-boolean', and `toolbar'. | |
| 428 | 484 */ |
| 485 (specifier_type)) | |
| 486 { | |
| 487 return valid_specifier_type_p (specifier_type) ? Qt : Qnil; | |
| 488 } | |
| 489 | |
| 490 DEFUN ("specifier-type-list", Fspecifier_type_list, 0, 0, 0, /* | |
| 491 Return a list of valid specifier types. | |
| 492 */ | |
| 493 ()) | |
| 494 { | |
| 495 return Fcopy_sequence (Vspecifier_type_list); | |
| 496 } | |
| 497 | |
| 498 void | |
| 499 add_entry_to_specifier_type_list (Lisp_Object symbol, | |
| 500 struct specifier_methods *meths) | |
| 501 { | |
| 502 struct specifier_type_entry entry; | |
| 503 | |
| 504 entry.symbol = symbol; | |
| 505 entry.meths = meths; | |
| 506 Dynarr_add (the_specifier_type_entry_dynarr, entry); | |
| 507 Vspecifier_type_list = Fcons (symbol, Vspecifier_type_list); | |
| 508 } | |
| 509 | |
| 510 static Lisp_Object | |
| 511 make_specifier_internal (struct specifier_methods *spec_meths, | |
| 665 | 512 Bytecount data_size, int call_create_meth) |
| 428 | 513 { |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
514 Lisp_Object specifier = |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
515 ALLOC_SIZED_LISP_OBJECT (aligned_sizeof_specifier (data_size), specifier); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
516 Lisp_Specifier *sp = XSPECIFIER (specifier); |
| 428 | 517 |
| 518 sp->methods = spec_meths; | |
| 519 sp->global_specs = Qnil; | |
| 520 sp->device_specs = Qnil; | |
| 521 sp->frame_specs = Qnil; | |
| 522 sp->window_specs = make_weak_list (WEAK_LIST_KEY_ASSOC); | |
| 523 sp->buffer_specs = Qnil; | |
| 524 sp->fallback = Qnil; | |
| 525 sp->magic_parent = Qnil; | |
| 526 sp->caching = 0; | |
| 527 sp->next_specifier = Vall_specifiers; | |
| 528 | |
| 529 Vall_specifiers = specifier; | |
| 530 | |
| 531 if (call_create_meth) | |
| 532 { | |
| 533 struct gcpro gcpro1; | |
| 534 GCPRO1 (specifier); | |
| 535 MAYBE_SPECMETH (XSPECIFIER (specifier), create, (specifier)); | |
| 536 UNGCPRO; | |
| 537 } | |
| 538 return specifier; | |
| 539 } | |
| 540 | |
| 541 static Lisp_Object | |
| 542 make_specifier (struct specifier_methods *meths) | |
| 543 { | |
| 544 return make_specifier_internal (meths, meths->extra_data_size, 1); | |
| 545 } | |
| 546 | |
| 547 Lisp_Object | |
| 548 make_magic_specifier (Lisp_Object type) | |
| 549 { | |
| 550 /* This function can GC */ | |
| 551 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME); | |
| 552 Lisp_Object bodily, ghost; | |
| 553 struct gcpro gcpro1; | |
| 554 | |
| 555 bodily = make_specifier (meths); | |
| 556 GCPRO1 (bodily); | |
| 557 ghost = make_specifier_internal (meths, 0, 0); | |
| 558 UNGCPRO; | |
| 559 | |
| 560 /* Connect guys together */ | |
| 561 XSPECIFIER(bodily)->magic_parent = Qt; | |
| 562 XSPECIFIER(bodily)->fallback = ghost; | |
| 563 XSPECIFIER(ghost)->magic_parent = bodily; | |
| 564 | |
| 565 return bodily; | |
| 566 } | |
| 567 | |
| 568 DEFUN ("make-specifier", Fmake_specifier, 1, 1, 0, /* | |
| 569 Return a new specifier object of type TYPE. | |
| 570 | |
| 571 A specifier is an object that can be used to keep track of a property | |
| 572 whose value can be per-buffer, per-window, per-frame, or per-device, | |
| 442 | 573 and can further be restricted to a particular console-type or |
| 574 device-class. Specifiers are used, for example, for the various | |
| 575 built-in properties of a face; this allows a face to have different | |
| 576 values in different frames, buffers, etc. | |
| 577 | |
| 578 When speaking of the value of a specifier, it is important to | |
| 579 distinguish between the *setting* of a specifier, called an | |
| 580 \"instantiator\", and the *actual value*, called an \"instance\". You | |
| 581 put various possible instantiators (i.e. settings) into a specifier | |
| 582 and associate them with particular locales (buffer, window, frame, | |
| 583 device, global), and then the instance (i.e. actual value) is | |
| 584 retrieved in a specific domain (window, frame, device) by looking | |
| 585 through the possible instantiators (i.e. settings). This process is | |
| 586 called \"instantiation\". | |
| 444 | 587 |
| 442 | 588 To put settings into a specifier, use `set-specifier', or the |
| 589 lower-level functions `add-spec-to-specifier' and | |
| 590 `add-spec-list-to-specifier'. You can also temporarily bind a setting | |
| 591 to a specifier using `let-specifier'. To retrieve settings, use | |
| 592 `specifier-specs', or its lower-level counterpart | |
| 2953 | 593 `specifier-spec-list'. |
| 594 | |
| 595 To determine the actual value (i.e. the instance) in a particular domain, use | |
| 596 `specifier-instance'. To determine the corresponding setting that yielded | |
| 597 the value (i.e. the instantiator), use `specifier-instantiator'. | |
| 442 | 598 |
| 599 For more information, see `set-specifier', `specifier-instance', | |
| 428 | 600 `specifier-specs', and `add-spec-to-specifier'; or, for a detailed |
| 442 | 601 description of specifiers, including how exactly the instantiation |
| 602 process works, see the chapter on specifiers in the XEmacs Lisp | |
| 603 Reference Manual. | |
| 428 | 604 |
| 605 TYPE specifies the particular type of specifier, and should be one of | |
| 2953 | 606 the symbols `generic', `integer', `natnum', `boolean', `color', `font', |
| 607 `image', `face-boolean', `display-table', `gutter', `gutter-size', | |
| 608 `gutter-visible' or `toolbar'. | |
| 442 | 609 |
| 610 For more information on particular types of specifiers, see the | |
| 611 functions `make-generic-specifier', `make-integer-specifier', | |
| 612 `make-natnum-specifier', `make-boolean-specifier', | |
| 613 `make-color-specifier', `make-font-specifier', `make-image-specifier', | |
| 614 `make-face-boolean-specifier', `make-gutter-size-specifier', | |
| 615 `make-gutter-visible-specifier', `default-toolbar', `default-gutter', | |
| 616 and `current-display-table'. | |
| 428 | 617 */ |
| 618 (type)) | |
| 619 { | |
| 620 /* This function can GC */ | |
| 442 | 621 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME); |
| 428 | 622 |
| 623 return make_specifier (meths); | |
| 624 } | |
| 625 | |
| 626 DEFUN ("specifierp", Fspecifierp, 1, 1, 0, /* | |
| 627 Return t if OBJECT is a specifier. | |
| 628 | |
| 629 A specifier is an object that can be used to keep track of a property | |
| 630 whose value can be per-buffer, per-window, per-frame, or per-device, | |
| 631 and can further be restricted to a particular console-type or device-class. | |
| 632 See `make-specifier'. | |
| 633 */ | |
| 634 (object)) | |
| 635 { | |
| 636 return SPECIFIERP (object) ? Qt : Qnil; | |
| 637 } | |
| 638 | |
| 639 DEFUN ("specifier-type", Fspecifier_type, 1, 1, 0, /* | |
| 640 Return the type of SPECIFIER. | |
| 641 */ | |
| 642 (specifier)) | |
| 643 { | |
| 644 CHECK_SPECIFIER (specifier); | |
| 645 return intern (XSPECIFIER (specifier)->methods->name); | |
| 646 } | |
| 647 | |
| 648 | |
| 649 /************************************************************************/ | |
| 650 /* Locales and domains */ | |
| 651 /************************************************************************/ | |
| 652 | |
| 653 DEFUN ("valid-specifier-locale-p", Fvalid_specifier_locale_p, 1, 1, 0, /* | |
| 654 Return t if LOCALE is a valid specifier locale. | |
| 2953 | 655 Valid locales are devices, frames, windows, buffers, and `global'. |
| 428 | 656 \(nil is not valid.) |
| 657 */ | |
| 658 (locale)) | |
| 659 { | |
| 660 /* This cannot GC. */ | |
| 661 return ((DEVICEP (locale) && DEVICE_LIVE_P (XDEVICE (locale))) || | |
| 662 (FRAMEP (locale) && FRAME_LIVE_P (XFRAME (locale))) || | |
| 663 (BUFFERP (locale) && BUFFER_LIVE_P (XBUFFER (locale))) || | |
| 664 /* dead windows are allowed because they may become live | |
| 665 windows again when a window configuration is restored */ | |
| 666 WINDOWP (locale) || | |
| 667 EQ (locale, Qglobal)) | |
| 668 ? Qt : Qnil; | |
| 669 } | |
| 670 | |
| 671 DEFUN ("valid-specifier-domain-p", Fvalid_specifier_domain_p, 1, 1, 0, /* | |
| 672 Return t if DOMAIN is a valid specifier domain. | |
| 2953 | 673 A domain is used to instantiate a specifier (i.e. determine the specifier's |
| 442 | 674 value in that domain). Valid domains are image instances, windows, frames, |
| 675 and devices. \(nil is not valid.) image instances are pseudo-domains since | |
| 676 instantiation will actually occur in the window the image instance itself is | |
| 677 instantiated in. | |
| 428 | 678 */ |
| 3659 | 679 (domain)) |
| 428 | 680 { |
| 681 /* This cannot GC. */ | |
| 682 return ((DEVICEP (domain) && DEVICE_LIVE_P (XDEVICE (domain))) || | |
| 683 (FRAMEP (domain) && FRAME_LIVE_P (XFRAME (domain))) || | |
| 442 | 684 (WINDOWP (domain) && WINDOW_LIVE_P (XWINDOW (domain))) || |
| 685 /* #### get image instances out of domains! */ | |
| 686 IMAGE_INSTANCEP (domain)) | |
| 428 | 687 ? Qt : Qnil; |
| 688 } | |
| 689 | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
690 DEFUN ("valid-specifier-locale-type-p", Fvalid_specifier_locale_type_p, 1, |
| 3659 | 691 1, 0, /* |
| 428 | 692 Given a specifier LOCALE-TYPE, return non-nil if it is valid. |
| 2953 | 693 Valid locale types are `global', `device', `frame', `window', and `buffer'. |
| 428 | 694 \(Note, however, that in functions that accept either a locale or a locale |
| 2953 | 695 type, `global' is considered an individual locale.) |
| 428 | 696 */ |
| 3659 | 697 (locale_type)) |
| 428 | 698 { |
| 699 /* This cannot GC. */ | |
| 700 return (EQ (locale_type, Qglobal) || | |
| 701 EQ (locale_type, Qdevice) || | |
| 702 EQ (locale_type, Qframe) || | |
| 703 EQ (locale_type, Qwindow) || | |
| 704 EQ (locale_type, Qbuffer)) ? Qt : Qnil; | |
| 705 } | |
| 706 | |
| 707 static void | |
| 708 check_valid_locale_or_locale_type (Lisp_Object locale) | |
| 709 { | |
| 710 /* This cannot GC. */ | |
| 711 if (EQ (locale, Qall) || | |
| 712 !NILP (Fvalid_specifier_locale_p (locale)) || | |
| 713 !NILP (Fvalid_specifier_locale_type_p (locale))) | |
| 714 return; | |
| 563 | 715 invalid_argument ("Invalid specifier locale or locale type", locale); |
| 428 | 716 } |
| 717 | |
| 718 DEFUN ("specifier-locale-type-from-locale", Fspecifier_locale_type_from_locale, | |
| 719 1, 1, 0, /* | |
| 720 Given a specifier LOCALE, return its type. | |
| 721 */ | |
| 722 (locale)) | |
| 723 { | |
| 724 /* This cannot GC. */ | |
| 725 if (NILP (Fvalid_specifier_locale_p (locale))) | |
| 563 | 726 invalid_argument ("Invalid specifier locale", |
| 3659 | 727 locale); |
| 428 | 728 if (DEVICEP (locale)) return Qdevice; |
| 729 if (FRAMEP (locale)) return Qframe; | |
| 730 if (WINDOWP (locale)) return Qwindow; | |
| 731 if (BUFFERP (locale)) return Qbuffer; | |
| 732 assert (EQ (locale, Qglobal)); | |
| 733 return Qglobal; | |
| 734 } | |
| 735 | |
| 736 static Lisp_Object | |
| 737 decode_locale (Lisp_Object locale) | |
| 738 { | |
| 739 /* This cannot GC. */ | |
| 740 if (NILP (locale)) | |
| 741 return Qglobal; | |
| 742 else if (!NILP (Fvalid_specifier_locale_p (locale))) | |
| 743 return locale; | |
| 744 else | |
| 563 | 745 invalid_argument ("Invalid specifier locale", |
| 3659 | 746 locale); |
| 428 | 747 |
| 748 return Qnil; | |
| 749 } | |
| 750 | |
| 751 static enum spec_locale_type | |
| 752 decode_locale_type (Lisp_Object locale_type) | |
| 753 { | |
| 754 /* This cannot GC. */ | |
| 755 if (EQ (locale_type, Qglobal)) return LOCALE_GLOBAL; | |
| 756 if (EQ (locale_type, Qdevice)) return LOCALE_DEVICE; | |
| 757 if (EQ (locale_type, Qframe)) return LOCALE_FRAME; | |
| 758 if (EQ (locale_type, Qwindow)) return LOCALE_WINDOW; | |
| 759 if (EQ (locale_type, Qbuffer)) return LOCALE_BUFFER; | |
| 760 | |
| 563 | 761 invalid_argument ("Invalid specifier locale type", |
| 3659 | 762 locale_type); |
| 1204 | 763 RETURN_NOT_REACHED (LOCALE_GLOBAL); |
| 428 | 764 } |
| 765 | |
| 766 Lisp_Object | |
| 767 decode_locale_list (Lisp_Object locale) | |
| 768 { | |
| 769 /* This cannot GC. */ | |
| 770 /* The return value of this function must be GCPRO'd. */ | |
| 771 if (NILP (locale)) | |
| 772 { | |
| 773 return list1 (Qall); | |
| 774 } | |
| 775 else if (CONSP (locale)) | |
| 776 { | |
| 777 EXTERNAL_LIST_LOOP_2 (elt, locale) | |
| 778 check_valid_locale_or_locale_type (elt); | |
| 779 return locale; | |
| 780 } | |
| 781 else | |
| 782 { | |
| 783 check_valid_locale_or_locale_type (locale); | |
| 784 return list1 (locale); | |
| 785 } | |
| 786 } | |
| 787 | |
| 788 static enum spec_locale_type | |
| 789 locale_type_from_locale (Lisp_Object locale) | |
| 790 { | |
| 791 return decode_locale_type (Fspecifier_locale_type_from_locale (locale)); | |
| 792 } | |
| 793 | |
| 794 static void | |
| 795 check_valid_domain (Lisp_Object domain) | |
| 796 { | |
| 797 if (NILP (Fvalid_specifier_domain_p (domain))) | |
| 563 | 798 invalid_argument ("Invalid specifier domain", |
| 3659 | 799 domain); |
| 428 | 800 } |
| 801 | |
| 442 | 802 Lisp_Object |
| 428 | 803 decode_domain (Lisp_Object domain) |
| 804 { | |
| 805 if (NILP (domain)) | |
| 806 return Fselected_window (Qnil); | |
| 807 check_valid_domain (domain); | |
| 808 return domain; | |
| 809 } | |
| 810 | |
| 811 | |
| 812 /************************************************************************/ | |
| 813 /* Tags */ | |
| 814 /************************************************************************/ | |
| 815 | |
| 816 DEFUN ("valid-specifier-tag-p", Fvalid_specifier_tag_p, 1, 1, 0, /* | |
| 817 Return non-nil if TAG is a valid specifier tag. | |
| 818 See also `valid-specifier-tag-set-p'. | |
| 819 */ | |
| 820 (tag)) | |
| 821 { | |
| 822 return (valid_console_type_p (tag) || | |
| 823 valid_device_class_p (tag) || | |
| 824 !NILP (assq_no_quit (tag, Vuser_defined_tags))) ? Qt : Qnil; | |
| 825 } | |
| 826 | |
| 827 DEFUN ("valid-specifier-tag-set-p", Fvalid_specifier_tag_set_p, 1, 1, 0, /* | |
| 828 Return non-nil if TAG-SET is a valid specifier tag set. | |
| 829 | |
| 3659 | 830 A specifier tag set is an entity that is attached to an instantiator and can |
| 831 be used to restrict the scope of that instantiator to a particular device | |
| 832 class, device type, or charset. It can also be used to mark instantiators | |
| 833 added by a particular package so that they can be later removed as a group. | |
| 428 | 834 |
| 835 A specifier tag set consists of a list of zero of more specifier tags, | |
| 836 each of which is a symbol that is recognized by XEmacs as a tag. | |
| 837 \(The valid device types and device classes are always tags, as are | |
| 838 any tags defined by `define-specifier-tag'.) It is called a "tag set" | |
| 839 \(as opposed to a list) because the order of the tags or the number of | |
| 840 times a particular tag occurs does not matter. | |
| 841 | |
| 3659 | 842 Each tag has two predicates associated with it, which specify, respectively, |
| 843 whether that tag applies to a particular device and whether it applies to a | |
| 844 particular character set. The predefined tags which are device types and | |
| 845 classes match devices of that type or class. User-defined tags can have any | |
| 846 device predicate, or none (meaning that all devices match). When attempting | |
| 847 to instantiate a specifier, a particular instantiator is only considered if | |
| 848 the device of the domain being instantiated over matches all tags in the tag | |
| 849 set attached to that instantiator. | |
| 850 | |
| 851 If a charset is to be considered--which is only the case for face | |
| 852 instantiators--this consideration may be done twice. The first iteration | |
| 853 pays attention to the character set predicates; if no instantiator can be | |
| 854 found in that case, the search is repeated ignoring the character set | |
| 855 predicates. | |
| 428 | 856 |
| 857 Most of the time, a tag set is not specified, and the instantiator | |
| 858 gets a null tag set, which matches all devices. | |
| 859 */ | |
| 3659 | 860 (tag_set)) |
| 428 | 861 { |
| 862 Lisp_Object rest; | |
| 863 | |
| 864 for (rest = tag_set; !NILP (rest); rest = XCDR (rest)) | |
| 865 { | |
| 866 if (!CONSP (rest)) | |
| 867 return Qnil; | |
| 868 if (NILP (Fvalid_specifier_tag_p (XCAR (rest)))) | |
| 869 return Qnil; | |
| 870 QUIT; | |
| 871 } | |
| 872 return Qt; | |
| 873 } | |
| 874 | |
| 875 Lisp_Object | |
| 876 decode_specifier_tag_set (Lisp_Object tag_set) | |
| 877 { | |
| 878 /* The return value of this function must be GCPRO'd. */ | |
| 879 if (!NILP (Fvalid_specifier_tag_p (tag_set))) | |
| 880 return list1 (tag_set); | |
| 881 if (NILP (Fvalid_specifier_tag_set_p (tag_set))) | |
| 563 | 882 invalid_argument ("Invalid specifier tag-set", |
| 3659 | 883 tag_set); |
| 428 | 884 return tag_set; |
| 885 } | |
| 886 | |
| 887 static Lisp_Object | |
| 888 canonicalize_tag_set (Lisp_Object tag_set) | |
| 889 { | |
| 890 int len = XINT (Flength (tag_set)); | |
| 891 Lisp_Object *tags, rest; | |
| 892 int i, j; | |
| 893 | |
| 894 /* We assume in this function that the tag_set has already been | |
| 895 validated, so there are no surprises. */ | |
| 896 | |
| 897 if (len == 0 || len == 1) | |
| 898 /* most common case */ | |
| 899 return tag_set; | |
| 900 | |
| 901 tags = alloca_array (Lisp_Object, len); | |
| 902 | |
| 903 i = 0; | |
| 904 LIST_LOOP (rest, tag_set) | |
| 905 tags[i++] = XCAR (rest); | |
| 906 | |
| 907 /* Sort the list of tags. We use a bubble sort here (copied from | |
| 908 extent_fragment_update()) -- reduces the function call overhead, | |
| 909 and is the fastest sort for small numbers of items. */ | |
| 910 | |
| 911 for (i = 1; i < len; i++) | |
| 912 { | |
| 913 j = i - 1; | |
| 914 while (j >= 0 && | |
| 793 | 915 qxestrcmp (XSTRING_DATA (XSYMBOL (tags[j])->name), |
| 916 XSTRING_DATA (XSYMBOL (tags[j+1])->name)) > 0) | |
| 428 | 917 { |
| 918 Lisp_Object tmp = tags[j]; | |
| 919 tags[j] = tags[j+1]; | |
| 920 tags[j+1] = tmp; | |
| 921 j--; | |
| 922 } | |
| 923 } | |
| 924 | |
| 925 /* Now eliminate duplicates. */ | |
| 926 | |
| 927 for (i = 1, j = 1; i < len; i++) | |
| 928 { | |
| 929 /* j holds the destination, i the source. */ | |
| 930 if (!EQ (tags[i], tags[i-1])) | |
| 931 tags[j++] = tags[i]; | |
| 932 } | |
| 933 | |
| 934 return Flist (j, tags); | |
| 935 } | |
| 936 | |
| 937 DEFUN ("canonicalize-tag-set", Fcanonicalize_tag_set, 1, 1, 0, /* | |
| 938 Canonicalize the given tag set. | |
| 939 Two canonicalized tag sets can be compared with `equal' to see if they | |
| 940 represent the same tag set. (Specifically, canonicalizing involves | |
| 941 sorting by symbol name and removing duplicates.) | |
| 942 */ | |
| 943 (tag_set)) | |
| 944 { | |
| 945 if (NILP (Fvalid_specifier_tag_set_p (tag_set))) | |
| 563 | 946 invalid_argument ("Invalid tag set", tag_set); |
| 428 | 947 return canonicalize_tag_set (tag_set); |
| 948 } | |
| 949 | |
| 950 static int | |
| 951 device_matches_specifier_tag_set_p (Lisp_Object device, Lisp_Object tag_set) | |
| 952 { | |
| 953 Lisp_Object devtype, devclass, rest; | |
| 954 struct device *d = XDEVICE (device); | |
| 955 | |
| 956 devtype = DEVICE_TYPE (d); | |
| 957 devclass = DEVICE_CLASS (d); | |
| 958 | |
| 959 LIST_LOOP (rest, tag_set) | |
| 960 { | |
| 961 Lisp_Object tag = XCAR (rest); | |
| 962 Lisp_Object assoc; | |
| 963 | |
| 964 if (EQ (tag, devtype) || EQ (tag, devclass)) | |
| 965 continue; | |
| 966 assoc = assq_no_quit (tag, DEVICE_USER_DEFINED_TAGS (d)); | |
| 967 /* other built-in tags (device types/classes) are not in | |
| 968 the user-defined-tags list. */ | |
| 969 if (NILP (assoc) || NILP (XCDR (assoc))) | |
| 970 return 0; | |
| 971 } | |
| 972 | |
| 973 return 1; | |
| 974 } | |
| 975 | |
| 3659 | 976 static int |
| 977 charset_matches_specifier_tag_set_p (Lisp_Object charset, | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
978 Lisp_Object tag_set, |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
979 enum font_specifier_matchspec_stages |
| 3659 | 980 stage) |
| 981 { | |
| 982 Lisp_Object rest; | |
| 983 int res = 0; | |
| 984 | |
| 985 assert(stage != impossible); | |
| 986 | |
| 987 LIST_LOOP (rest, tag_set) | |
| 988 { | |
| 989 Lisp_Object tag = XCAR (rest); | |
| 990 Lisp_Object assoc; | |
| 991 | |
| 3736 | 992 /* In the event that, during the creation of a charset, no specifier |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
993 tags exist for which CHARSET-PREDICATE has been specified, then |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
994 that charset's entry in Vcharset_tag_lists will be nil, and this |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
995 charset shouldn't match. */ |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
996 |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
997 if (NILP (XVECTOR_DATA(Vcharset_tag_lists)[XCHARSET_LEADING_BYTE(charset) |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
998 - MIN_LEADING_BYTE])) |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
999 { |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1000 return 0; |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1001 } |
| 3659 | 1002 |
| 1003 /* Now, find out what the pre-calculated value is. */ | |
| 1004 assoc = assq_no_quit(tag, | |
| 1005 XVECTOR_DATA(Vcharset_tag_lists) | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1006 [XCHARSET_LEADING_BYTE(charset) |
| 3659 | 1007 - MIN_LEADING_BYTE]); |
| 1008 | |
| 1009 if (!(NILP(assoc)) && !(NILP(XCDR(assoc)))) | |
| 1010 { | |
| 1011 assert(VECTORP(XCDR(assoc))); | |
| 1012 | |
| 1013 /* In the event that a tag specifies a charset, then the specifier | |
| 1014 must match for (this stage and this charset) for all | |
| 1015 charset-specifying tags. */ | |
| 1016 if (NILP(XVECTOR_DATA(XCDR(assoc))[stage])) | |
| 1017 { | |
| 1018 /* It doesn't match for this tag, even though the tag | |
| 1019 specifies a charset. Return 0. */ | |
| 1020 return 0; | |
| 1021 } | |
| 1022 | |
| 1023 /* This tag specifies charset limitations, and this charset and | |
| 1024 stage match those charset limitations. | |
| 1025 | |
| 1026 In the event that a later tag specifies charset limitations | |
| 1027 that don't match, the return 0 above prevents us giving a | |
| 1028 positive match. */ | |
| 1029 res = 1; | |
| 1030 } | |
| 1031 } | |
| 1032 | |
| 1033 return res; | |
| 1034 } | |
| 1035 | |
| 1036 | |
| 442 | 1037 DEFUN ("device-matches-specifier-tag-set-p", |
| 1038 Fdevice_matches_specifier_tag_set_p, 2, 2, 0, /* | |
| 428 | 1039 Return non-nil if DEVICE matches specifier tag set TAG-SET. |
| 1040 This means that DEVICE matches each tag in the tag set. (Every | |
| 1041 tag recognized by XEmacs has a predicate associated with it that | |
| 1042 specifies which devices match it.) | |
| 1043 */ | |
| 1044 (device, tag_set)) | |
| 1045 { | |
| 1046 CHECK_LIVE_DEVICE (device); | |
| 1047 | |
| 1048 if (NILP (Fvalid_specifier_tag_set_p (tag_set))) | |
| 563 | 1049 invalid_argument ("Invalid tag set", tag_set); |
| 428 | 1050 |
| 1051 return device_matches_specifier_tag_set_p (device, tag_set) ? Qt : Qnil; | |
| 1052 } | |
| 1053 | |
| 3659 | 1054 Lisp_Object |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1055 define_specifier_tag(Lisp_Object tag, Lisp_Object device_predicate, |
| 3659 | 1056 Lisp_Object charset_predicate) |
| 428 | 1057 { |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1058 Lisp_Object assoc = assq_no_quit (tag, Vuser_defined_tags), |
| 3659 | 1059 concons, devcons, charpres = Qnil; |
| 1060 int recompute_devices = 0, recompute_charsets = 0, i, max_args = -1; | |
| 1061 | |
| 428 | 1062 if (NILP (assoc)) |
| 1063 { | |
| 3659 | 1064 recompute_devices = recompute_charsets = 1; |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1065 Vuser_defined_tags = Fcons (list3 (tag, device_predicate, |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1066 charset_predicate), |
| 3659 | 1067 Vuser_defined_tags); |
| 428 | 1068 DEVICE_LOOP_NO_BREAK (devcons, concons) |
| 1069 { | |
| 1070 struct device *d = XDEVICE (XCAR (devcons)); | |
| 1071 /* Initially set the value to t in case of error | |
| 3659 | 1072 in device_predicate */ |
| 428 | 1073 DEVICE_USER_DEFINED_TAGS (d) = |
| 1074 Fcons (Fcons (tag, Qt), DEVICE_USER_DEFINED_TAGS (d)); | |
| 1075 } | |
| 3659 | 1076 |
| 1077 if (!NILP (charset_predicate)) | |
| 1078 { | |
| 1079 max_args = XINT(Ffunction_max_args(charset_predicate)); | |
| 1080 if (max_args < 1) | |
| 1081 { | |
| 1082 invalid_argument | |
| 1083 ("Charset predicate must be able to take an argument", tag); | |
| 1084 } | |
| 1085 } | |
| 428 | 1086 } |
| 3659 | 1087 else if (!NILP (device_predicate) && !NILP (XCADR (assoc))) |
| 428 | 1088 { |
| 3659 | 1089 recompute_devices = 1; |
| 1090 XCDR (assoc) = list2(device_predicate, charset_predicate); | |
| 428 | 1091 } |
| 3659 | 1092 else if (!NILP (charset_predicate) || !NILP(XCADDR (assoc))) |
| 1093 { | |
| 1094 max_args = XINT(Ffunction_max_args(charset_predicate)); | |
| 1095 if (max_args < 1) | |
| 1096 { | |
| 1097 invalid_argument | |
| 1098 ("Charset predicate must be able to take an argument", tag); | |
| 1099 } | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1100 |
| 3659 | 1101 /* If there exists a charset_predicate for the tag currently (even if |
| 1102 the new charset_predicate is nil), or if we're adding one, we need | |
| 1103 to recompute. This contrasts with the device predicates, where we | |
| 1104 don't need to recompute if the old and new device predicates are | |
| 1105 both nil. */ | |
| 1106 | |
| 1107 recompute_charsets = 1; | |
| 1108 XCDR (assoc) = list2(device_predicate, charset_predicate); | |
| 1109 } | |
| 1110 | |
| 1111 /* Recompute the tag values for all devices and charsets, if necessary. In | |
| 1112 the special case where both the old and new device_predicates are nil, | |
| 1113 we know that we don't have to do it for the device. (It's probably | |
| 1114 common for people to call (define-specifier-tag) more than once on the | |
| 1115 same tag, and the most common case is where DEVICE_PREDICATE is not | |
| 1116 specified.) */ | |
| 1117 | |
| 1118 if (recompute_devices) | |
| 428 | 1119 { |
| 1120 DEVICE_LOOP_NO_BREAK (devcons, concons) | |
| 1121 { | |
| 1122 Lisp_Object device = XCAR (devcons); | |
| 1123 assoc = assq_no_quit (tag, | |
| 1124 DEVICE_USER_DEFINED_TAGS (XDEVICE (device))); | |
| 1125 assert (CONSP (assoc)); | |
| 3659 | 1126 if (NILP (device_predicate)) |
| 428 | 1127 XCDR (assoc) = Qt; |
| 1128 else | |
| 3659 | 1129 XCDR (assoc) = !NILP (call1 (device_predicate, device)) ? Qt |
| 1130 : Qnil; | |
| 428 | 1131 } |
| 1132 } | |
| 1133 | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1134 if (recompute_charsets) |
| 3659 | 1135 { |
| 1136 if (NILP(charset_predicate)) | |
| 1137 { | |
| 1138 charpres = Qnil; | |
| 1139 } | |
| 1140 | |
| 1141 for (i = 0; i < NUM_LEADING_BYTES; ++i) | |
| 1142 { | |
| 1143 if (NILP(charset_by_leading_byte(MIN_LEADING_BYTE + i))) | |
| 1144 { | |
| 1145 continue; | |
| 1146 } | |
| 1147 | |
| 1148 assoc = assq_no_quit (tag, | |
| 1149 XVECTOR_DATA(Vcharset_tag_lists)[i]); | |
| 1150 | |
| 1151 if (!NILP(charset_predicate)) | |
| 1152 { | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1153 struct gcpro gcpro1; |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1154 charpres = make_vector(impossible, Qnil); |
| 3680 | 1155 GCPRO1 (charpres); |
| 3659 | 1156 |
| 1157 /* If you want to extend the number of stages available, here | |
| 1158 in setup_charset_initial_specifier_tags, and in specifier.h | |
| 1159 is where you want to go. */ | |
| 1160 | |
| 1161 #define DEFINE_SPECIFIER_TAG_FROB(stage) do { \ | |
| 1162 if (max_args > 1) \ | |
| 1163 { \ | |
| 1164 XVECTOR_DATA(charpres)[stage] = \ | |
| 1165 call2_trapping_problems \ | |
| 1166 ("Error during specifier tag charset predicate," \ | |
| 1167 " stage " #stage, charset_predicate, \ | |
| 1168 charset_by_leading_byte(MIN_LEADING_BYTE + i), \ | |
| 1169 Q##stage, 0); \ | |
| 1170 } \ | |
| 1171 else \ | |
| 1172 { \ | |
| 1173 XVECTOR_DATA(charpres)[stage] = \ | |
| 1174 call1_trapping_problems \ | |
| 1175 ("Error during specifier tag charset predicate," \ | |
| 1176 " stage " #stage, charset_predicate, \ | |
| 1177 charset_by_leading_byte(MIN_LEADING_BYTE + i), \ | |
| 1178 0); \ | |
| 1179 } \ | |
| 1180 \ | |
| 1181 if (UNBOUNDP(XVECTOR_DATA(charpres)[stage])) \ | |
| 1182 { \ | |
| 1183 XVECTOR_DATA(charpres)[stage] = Qnil; \ | |
| 1184 } \ | |
| 1185 else if (!NILP(XVECTOR_DATA(charpres)[stage])) \ | |
| 1186 { \ | |
| 1187 /* Don't want refs to random other objects. */ \ | |
| 1188 XVECTOR_DATA(charpres)[stage] = Qt; \ | |
| 1189 } \ | |
| 1190 } while (0) | |
| 1191 | |
| 1192 DEFINE_SPECIFIER_TAG_FROB (initial); | |
| 1193 DEFINE_SPECIFIER_TAG_FROB (final); | |
| 1194 | |
| 1195 #undef DEFINE_SPECIFIER_TAG_FROB | |
| 1196 | |
| 3680 | 1197 UNGCPRO; |
| 3659 | 1198 } |
| 1199 | |
| 1200 if (!NILP(assoc)) | |
| 1201 { | |
| 1202 assert(CONSP(assoc)); | |
| 1203 XCDR (assoc) = charpres; | |
| 1204 } | |
| 1205 else | |
| 1206 { | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1207 XVECTOR_DATA(Vcharset_tag_lists)[i] |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1208 = Fcons(Fcons(tag, charpres), |
| 3659 | 1209 XVECTOR_DATA (Vcharset_tag_lists)[i]); |
| 1210 } | |
| 1211 } | |
| 1212 } | |
| 1213 return Qt; | |
| 1214 } | |
| 1215 | |
| 1216 DEFUN ("define-specifier-tag", Fdefine_specifier_tag, 1, 3, 0, /* | |
| 1217 Define a new specifier tag. | |
| 1218 | |
| 1219 If DEVICE-PREDICATE is specified, it should be a function of one argument | |
| 1220 \(a device) that specifies whether the tag matches that particular device. | |
| 1221 If DEVICE-PREDICATE is omitted, the tag matches all devices. | |
| 1222 | |
| 1223 If CHARSET-PREDICATE is supplied, it should be a function taking a single | |
| 1224 Lisp character set argument. A tag's charset predicate is primarily used to | |
| 1225 determine what font to use for a given \(set of) charset\(s) when that tag | |
| 1226 is used in a set-face-font call; a non-nil return value indicates that the | |
| 1227 tag matches the charset. | |
| 1228 | |
| 1229 The font matching process also has a concept of stages; the defined stages | |
| 1230 are currently `initial' and `final', and there exist specifier tags with | |
| 1231 those names that correspond to those stages. On X11, 'initial is used when | |
| 1232 the font matching process is looking for fonts that match the desired | |
| 1233 registries of the charset--see the `charset-registries' function. If that | |
| 1234 match process fails, then the 'final tag becomes relevant; this means that a | |
| 1235 more general lookup is desired, and that a font doesn't necessarily have to | |
| 1236 match the desired XLFD for the face, just the charset repertoire for this | |
| 1237 charset. It also means that the charset registry and encoding used will be | |
| 1238 `iso10646-1', and the characters will be converted to display using that | |
| 1239 registry. | |
| 1240 | |
| 1241 If a tag set matches no character set; the two-stage match process will | |
| 1242 ignore the tag on its first pass, but if no match is found, it will respect | |
| 1243 it on the second pass, where character set information is ignored. | |
| 1244 | |
| 1245 You can redefine an existing user-defined specifier tag. However, you | |
| 1246 cannot redefine most of the built-in specifier tags \(the device types and | |
| 1247 classes, `initial', and `final') or the symbols nil, t, `all', or `global'. | |
| 1248 Note that if a device type is not supported in this XEmacs, it will not be | |
| 1249 available as a built-in specifier tag; this is probably something we should | |
| 1250 change. | |
| 1251 */ | |
| 1252 (tag, device_predicate, charset_predicate)) | |
| 1253 { | |
| 1254 int max_args; | |
| 1255 | |
| 1256 CHECK_SYMBOL (tag); | |
| 1257 if (valid_device_class_p (tag) || | |
| 1258 valid_console_type_p (tag) || | |
| 1259 EQ (tag, Qinitial) || EQ (tag, Qfinal)) | |
| 1260 invalid_change ("Cannot redefine built-in specifier tags", tag); | |
| 1261 /* Try to prevent common instantiators and locales from being | |
| 1262 redefined, to reduce ambiguity */ | |
| 1263 if (NILP (tag) || EQ (tag, Qt) || EQ (tag, Qall) || EQ (tag, Qglobal)) | |
| 1264 invalid_change ("Cannot define nil, t, `all', or `global'", tag); | |
| 1265 | |
| 1266 if (!NILP (charset_predicate)) | |
| 1267 { | |
| 1268 max_args = XINT(Ffunction_max_args(charset_predicate)); | |
| 1269 if (max_args != 1) | |
| 1270 { | |
| 1271 /* We only allow the stage argument to be specifed from C. */ | |
| 1272 invalid_change ("Charset predicate must take one argument", | |
| 1273 tag); | |
| 1274 } | |
| 1275 } | |
| 1276 | |
| 1277 return define_specifier_tag(tag, device_predicate, charset_predicate); | |
| 428 | 1278 } |
| 1279 | |
| 1280 /* Called at device-creation time to initialize the user-defined | |
| 1281 tag values for the newly-created device. */ | |
| 1282 | |
| 1283 void | |
| 1284 setup_device_initial_specifier_tags (struct device *d) | |
| 1285 { | |
| 1286 Lisp_Object rest, rest2; | |
| 793 | 1287 Lisp_Object device = wrap_device (d); |
| 3836 | 1288 Lisp_Object device_predicate; |
| 3659 | 1289 int list_len; |
| 793 | 1290 |
| 428 | 1291 DEVICE_USER_DEFINED_TAGS (d) = Fcopy_alist (Vuser_defined_tags); |
| 1292 | |
| 1293 /* Now set up the initial values */ | |
| 1294 LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d)) | |
| 1295 XCDR (XCAR (rest)) = Qt; | |
| 1296 | |
| 1297 for (rest = Vuser_defined_tags, rest2 = DEVICE_USER_DEFINED_TAGS (d); | |
| 1298 !NILP (rest); rest = XCDR (rest), rest2 = XCDR (rest2)) | |
| 1299 { | |
| 3659 | 1300 GET_LIST_LENGTH(XCAR(rest), list_len); |
| 1301 | |
| 1302 assert(3 == list_len); | |
| 1303 | |
| 1304 device_predicate = XCADR(XCAR (rest)); | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1305 |
| 3659 | 1306 if (NILP (device_predicate)) |
| 1307 { | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1308 XCDR (XCAR (rest2)) = Qt; |
| 3659 | 1309 } |
| 428 | 1310 else |
| 3659 | 1311 { |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1312 device_predicate = !NILP (call_critical_lisp_code |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1313 (d, device_predicate, device)) |
| 3659 | 1314 ? Qt : Qnil; |
| 3817 | 1315 XCDR (XCAR (rest2)) = device_predicate; |
| 3659 | 1316 } |
| 428 | 1317 } |
| 1318 } | |
| 1319 | |
| 3659 | 1320 void |
| 1321 setup_charset_initial_specifier_tags (Lisp_Object charset) | |
| 1322 { | |
| 1323 Lisp_Object rest, charset_predicate, tag, new_value; | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1324 Lisp_Object charset_tag_list = Qnil; |
| 3659 | 1325 |
| 1326 LIST_LOOP (rest, Vuser_defined_tags) | |
| 1327 { | |
| 1328 tag = XCAR(XCAR(rest)); | |
| 1329 charset_predicate = XCADDR(XCAR (rest)); | |
| 1330 | |
| 1331 if (NILP(charset_predicate)) | |
| 1332 { | |
| 1333 continue; | |
| 1334 } | |
| 1335 | |
| 1336 new_value = make_vector(impossible, Qnil); | |
| 1337 | |
| 1338 #define SETUP_CHARSET_TAGS_FROB(stage) do { \ | |
| 1339 \ | |
| 1340 XVECTOR_DATA(new_value)[stage] = call2_trapping_problems \ | |
| 1341 ("Error during specifier tag charset predicate," \ | |
| 1342 " stage " #stage, \ | |
| 1343 charset_predicate, charset, Q##stage, 0); \ | |
| 1344 \ | |
| 1345 if (UNBOUNDP(XVECTOR_DATA(new_value)[stage])) \ | |
| 1346 { \ | |
| 1347 XVECTOR_DATA(new_value)[stage] = Qnil; \ | |
| 1348 } \ | |
| 1349 else if (!NILP(XVECTOR_DATA(new_value)[stage])) \ | |
| 1350 { \ | |
| 1351 /* Don't want random other objects hanging around. */ \ | |
| 1352 XVECTOR_DATA(new_value)[stage] = Qt; \ | |
| 1353 } \ | |
| 1354 \ | |
| 1355 } while (0) | |
| 1356 | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1357 SETUP_CHARSET_TAGS_FROB (initial); |
| 3659 | 1358 SETUP_CHARSET_TAGS_FROB (final); |
| 1359 /* More later? */ | |
| 1360 | |
| 1361 #undef SETUP_CHARSET_TAGS_FROB | |
| 1362 | |
| 1363 charset_tag_list = Fcons(Fcons(tag, new_value), charset_tag_list); | |
| 1364 } | |
| 1365 | |
| 1366 XVECTOR_DATA | |
| 1367 (Vcharset_tag_lists)[XCHARSET_LEADING_BYTE(charset) - MIN_LEADING_BYTE] | |
| 1368 = charset_tag_list; | |
| 1369 } | |
| 1370 | |
| 3673 | 1371 /* VM calls this, in vm-multiple-frames-possible-p, in the event that you're |
| 1372 considering taking it out. */ | |
| 3659 | 1373 |
| 442 | 1374 DEFUN ("device-matching-specifier-tag-list", |
| 1375 Fdevice_matching_specifier_tag_list, | |
| 428 | 1376 0, 1, 0, /* |
| 3673 | 1377 Return a list of all specifier tags matching DEVICE. |
| 1378 DEVICE defaults to the selected device if omitted. | |
| 1379 */ | |
| 428 | 1380 (device)) |
| 1381 { | |
| 1382 struct device *d = decode_device (device); | |
| 1383 Lisp_Object rest, list = Qnil; | |
| 1384 struct gcpro gcpro1; | |
| 1385 | |
| 1386 GCPRO1 (list); | |
| 1387 | |
| 1388 LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d)) | |
| 1389 { | |
| 3836 | 1390 if (!NILP (XCDR (XCAR (rest)))) |
| 428 | 1391 list = Fcons (XCAR (XCAR (rest)), list); |
| 1392 } | |
| 1393 | |
| 1394 list = Fnreverse (list); | |
| 1395 list = Fcons (DEVICE_CLASS (d), list); | |
| 1396 list = Fcons (DEVICE_TYPE (d), list); | |
| 1397 | |
| 1398 RETURN_UNGCPRO (list); | |
| 1399 } | |
| 1400 | |
| 1401 DEFUN ("specifier-tag-list", Fspecifier_tag_list, 0, 0, 0, /* | |
| 1402 Return a list of all currently-defined specifier tags. | |
| 1403 This includes the built-in ones (the device types and classes). | |
| 1404 */ | |
| 1405 ()) | |
| 1406 { | |
| 1407 Lisp_Object list = Qnil, rest; | |
| 1408 struct gcpro gcpro1; | |
| 1409 | |
| 1410 GCPRO1 (list); | |
| 1411 | |
| 1412 LIST_LOOP (rest, Vuser_defined_tags) | |
| 1413 list = Fcons (XCAR (XCAR (rest)), list); | |
| 1414 | |
| 1415 list = Fnreverse (list); | |
| 1416 list = nconc2 (Fcopy_sequence (Vdevice_class_list), list); | |
| 1417 list = nconc2 (Fcopy_sequence (Vconsole_type_list), list); | |
| 1418 | |
| 1419 RETURN_UNGCPRO (list); | |
| 1420 } | |
| 1421 | |
| 3659 | 1422 DEFUN ("specifier-tag-device-predicate", Fspecifier_tag_device_predicate, |
| 1423 1, 1, 0, /* | |
| 1424 Return the device predicate for the given specifier tag. | |
| 428 | 1425 */ |
| 1426 (tag)) | |
| 1427 { | |
| 1428 /* The return value of this function must be GCPRO'd. */ | |
| 1429 CHECK_SYMBOL (tag); | |
| 1430 | |
| 1431 if (NILP (Fvalid_specifier_tag_p (tag))) | |
| 563 | 1432 invalid_argument ("Invalid specifier tag", |
| 3659 | 1433 tag); |
| 428 | 1434 |
| 1435 /* Make up some predicates for the built-in types */ | |
| 1436 | |
| 1437 if (valid_console_type_p (tag)) | |
| 1438 return list3 (Qlambda, list1 (Qdevice), | |
| 1439 list3 (Qeq, list2 (Qquote, tag), | |
| 1440 list2 (Qconsole_type, Qdevice))); | |
| 1441 | |
| 1442 if (valid_device_class_p (tag)) | |
| 1443 return list3 (Qlambda, list1 (Qdevice), | |
| 1444 list3 (Qeq, list2 (Qquote, tag), | |
| 1445 list2 (Qdevice_class, Qdevice))); | |
| 1446 | |
| 3659 | 1447 return XCADR (assq_no_quit (tag, Vuser_defined_tags)); |
| 1448 } | |
| 1449 | |
| 1450 DEFUN ("specifier-tag-charset-predicate", Fspecifier_tag_charset_predicate, | |
| 1451 1, 1, 0, /* | |
| 3673 | 1452 Return the charset predicate for the given specifier tag. |
| 1453 */ | |
| 3659 | 1454 (tag)) |
| 1455 { | |
| 1456 /* The return value of this function must be GCPRO'd. */ | |
| 1457 CHECK_SYMBOL (tag); | |
| 1458 | |
| 1459 if (NILP (Fvalid_specifier_tag_p (tag))) | |
| 1460 invalid_argument ("Invalid specifier tag", | |
| 1461 tag); | |
| 1462 | |
| 1463 return XCADDR (assq_no_quit (tag, Vuser_defined_tags)); | |
| 428 | 1464 } |
| 1465 | |
| 1466 /* Return true if A "matches" B. If EXACT_P is 0, A must be a subset of B. | |
| 3659 | 1467 Otherwise, A must be `equal' to B. The sets must be canonicalized. */ |
| 428 | 1468 static int |
| 1469 tag_sets_match_p (Lisp_Object a, Lisp_Object b, int exact_p) | |
| 1470 { | |
| 1471 if (!exact_p) | |
| 1472 { | |
| 1473 while (!NILP (a) && !NILP (b)) | |
| 1474 { | |
| 1475 if (EQ (XCAR (a), XCAR (b))) | |
| 1476 a = XCDR (a); | |
| 1477 b = XCDR (b); | |
| 1478 } | |
| 1479 | |
| 1480 return NILP (a); | |
| 1481 } | |
| 1482 else | |
| 1483 { | |
| 1484 while (!NILP (a) && !NILP (b)) | |
| 1485 { | |
| 1486 if (!EQ (XCAR (a), XCAR (b))) | |
| 1487 return 0; | |
| 1488 a = XCDR (a); | |
| 1489 b = XCDR (b); | |
| 1490 } | |
| 1491 | |
| 1492 return NILP (a) && NILP (b); | |
| 1493 } | |
| 1494 } | |
| 1495 | |
| 1496 | |
| 1497 /************************************************************************/ | |
| 1498 /* Spec-lists and inst-lists */ | |
| 1499 /************************************************************************/ | |
| 1500 | |
| 1501 static Lisp_Object | |
| 1502 call_validate_method (Lisp_Object boxed_method, Lisp_Object instantiator) | |
| 1503 { | |
| 1504 ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (instantiator); | |
| 1505 return Qt; | |
| 1506 } | |
| 1507 | |
| 1508 static Lisp_Object | |
| 1509 check_valid_instantiator (Lisp_Object instantiator, | |
| 1510 struct specifier_methods *meths, | |
| 578 | 1511 Error_Behavior errb) |
| 428 | 1512 { |
| 1513 if (meths->validate_method) | |
| 1514 { | |
| 1515 Lisp_Object retval; | |
| 1516 | |
| 1517 if (ERRB_EQ (errb, ERROR_ME)) | |
| 1518 { | |
| 1519 (meths->validate_method) (instantiator); | |
| 1520 retval = Qt; | |
| 1521 } | |
| 1522 else | |
| 1523 { | |
| 1524 Lisp_Object opaque = make_opaque_ptr ((void *) | |
| 1525 meths->validate_method); | |
| 1526 struct gcpro gcpro1; | |
| 1527 | |
| 1528 GCPRO1 (opaque); | |
| 1529 retval = call_with_suspended_errors | |
| 1530 ((lisp_fn_t) call_validate_method, | |
| 1531 Qnil, Qspecifier, errb, 2, opaque, instantiator); | |
| 1532 | |
| 1533 free_opaque_ptr (opaque); | |
| 1534 UNGCPRO; | |
| 1535 } | |
| 1536 | |
| 1537 return retval; | |
| 1538 } | |
| 1539 return Qt; | |
| 1540 } | |
| 1541 | |
| 1542 DEFUN ("check-valid-instantiator", Fcheck_valid_instantiator, 2, 2, 0, /* | |
| 1543 Signal an error if INSTANTIATOR is invalid for SPECIFIER-TYPE. | |
| 1544 */ | |
| 1545 (instantiator, specifier_type)) | |
| 1546 { | |
| 1547 struct specifier_methods *meths = decode_specifier_type (specifier_type, | |
| 1548 ERROR_ME); | |
| 1549 | |
| 1550 return check_valid_instantiator (instantiator, meths, ERROR_ME); | |
| 1551 } | |
| 1552 | |
| 1553 DEFUN ("valid-instantiator-p", Fvalid_instantiator_p, 2, 2, 0, /* | |
| 1554 Return non-nil if INSTANTIATOR is valid for SPECIFIER-TYPE. | |
| 1555 */ | |
| 1556 (instantiator, specifier_type)) | |
| 1557 { | |
| 1558 struct specifier_methods *meths = decode_specifier_type (specifier_type, | |
| 1559 ERROR_ME); | |
| 1560 | |
| 1561 return check_valid_instantiator (instantiator, meths, ERROR_ME_NOT); | |
| 1562 } | |
| 1563 | |
| 1564 static Lisp_Object | |
| 1565 check_valid_inst_list (Lisp_Object inst_list, struct specifier_methods *meths, | |
| 578 | 1566 Error_Behavior errb) |
| 428 | 1567 { |
| 2159 | 1568 EXTERNAL_LIST_LOOP_2 (inst_pair, inst_list) |
| 428 | 1569 { |
| 2159 | 1570 Lisp_Object tag_set; |
| 1571 | |
| 1572 if (!CONSP (inst_pair)) | |
| 428 | 1573 { |
| 563 | 1574 maybe_sferror ( |
| 3659 | 1575 "Invalid instantiator pair", inst_pair, |
| 1576 Qspecifier, errb); | |
| 428 | 1577 return Qnil; |
| 1578 } | |
| 1579 if (NILP (Fvalid_specifier_tag_set_p (tag_set = XCAR (inst_pair)))) | |
| 1580 { | |
| 563 | 1581 maybe_invalid_argument ( |
| 3659 | 1582 "Invalid specifier tag", tag_set, |
| 1583 Qspecifier, errb); | |
| 428 | 1584 return Qnil; |
| 1585 } | |
| 1586 | |
| 1587 if (NILP (check_valid_instantiator (XCDR (inst_pair), meths, errb))) | |
| 1588 return Qnil; | |
| 1589 } | |
| 1590 | |
| 1591 return Qt; | |
| 1592 } | |
| 1593 | |
| 1594 DEFUN ("check-valid-inst-list", Fcheck_valid_inst_list, 2, 2, 0, /* | |
| 1595 Signal an error if INST-LIST is invalid for specifier type TYPE. | |
| 1596 */ | |
| 1597 (inst_list, type)) | |
| 1598 { | |
| 1599 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME); | |
| 1600 | |
| 1601 return check_valid_inst_list (inst_list, meths, ERROR_ME); | |
| 1602 } | |
| 1603 | |
| 1604 DEFUN ("valid-inst-list-p", Fvalid_inst_list_p, 2, 2, 0, /* | |
| 1605 Return non-nil if INST-LIST is valid for specifier type TYPE. | |
| 1606 */ | |
| 1607 (inst_list, type)) | |
| 1608 { | |
| 1609 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME); | |
| 1610 | |
| 1611 return check_valid_inst_list (inst_list, meths, ERROR_ME_NOT); | |
| 1612 } | |
| 1613 | |
| 1614 static Lisp_Object | |
| 1615 check_valid_spec_list (Lisp_Object spec_list, struct specifier_methods *meths, | |
| 578 | 1616 Error_Behavior errb) |
| 428 | 1617 { |
| 2159 | 1618 EXTERNAL_LIST_LOOP_2 (spec, spec_list) |
| 428 | 1619 { |
| 2159 | 1620 Lisp_Object locale; |
| 1621 if (!CONSP (spec)) | |
| 428 | 1622 { |
| 563 | 1623 maybe_sferror ( |
| 3659 | 1624 "Invalid specification list", spec_list, |
| 1625 Qspecifier, errb); | |
| 428 | 1626 return Qnil; |
| 1627 } | |
| 1628 if (NILP (Fvalid_specifier_locale_p (locale = XCAR (spec)))) | |
| 1629 { | |
| 563 | 1630 maybe_invalid_argument ( |
| 3659 | 1631 "Invalid specifier locale", locale, |
| 1632 Qspecifier, errb); | |
| 428 | 1633 return Qnil; |
| 1634 } | |
| 1635 | |
| 1636 if (NILP (check_valid_inst_list (XCDR (spec), meths, errb))) | |
| 1637 return Qnil; | |
| 1638 } | |
| 1639 | |
| 1640 return Qt; | |
| 1641 } | |
| 1642 | |
| 1643 DEFUN ("check-valid-spec-list", Fcheck_valid_spec_list, 2, 2, 0, /* | |
| 1644 Signal an error if SPEC-LIST is invalid for specifier type TYPE. | |
| 1645 */ | |
| 1646 (spec_list, type)) | |
| 1647 { | |
| 1648 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME); | |
| 1649 | |
| 1650 return check_valid_spec_list (spec_list, meths, ERROR_ME); | |
| 1651 } | |
| 1652 | |
| 1653 DEFUN ("valid-spec-list-p", Fvalid_spec_list_p, 2, 2, 0, /* | |
| 1654 Return non-nil if SPEC-LIST is valid for specifier type TYPE. | |
| 1655 */ | |
| 1656 (spec_list, type)) | |
| 1657 { | |
| 1658 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME); | |
| 1659 | |
| 1660 return check_valid_spec_list (spec_list, meths, ERROR_ME_NOT); | |
| 1661 } | |
| 1662 | |
| 1663 enum spec_add_meth | |
| 1664 decode_how_to_add_specification (Lisp_Object how_to_add) | |
| 1665 { | |
| 1666 if (NILP (how_to_add) || EQ (Qremove_tag_set_prepend, how_to_add)) | |
| 1667 return SPEC_REMOVE_TAG_SET_PREPEND; | |
| 1668 if (EQ (Qremove_tag_set_append, how_to_add)) | |
| 1669 return SPEC_REMOVE_TAG_SET_APPEND; | |
| 1670 if (EQ (Qappend, how_to_add)) | |
| 1671 return SPEC_APPEND; | |
| 1672 if (EQ (Qprepend, how_to_add)) | |
| 1673 return SPEC_PREPEND; | |
| 1674 if (EQ (Qremove_locale, how_to_add)) | |
| 1675 return SPEC_REMOVE_LOCALE; | |
| 1676 if (EQ (Qremove_locale_type, how_to_add)) | |
| 1677 return SPEC_REMOVE_LOCALE_TYPE; | |
| 1678 if (EQ (Qremove_all, how_to_add)) | |
| 1679 return SPEC_REMOVE_ALL; | |
| 1680 | |
| 563 | 1681 invalid_constant ("Invalid `how-to-add' flag", how_to_add); |
| 428 | 1682 |
| 1204 | 1683 RETURN_NOT_REACHED (SPEC_PREPEND); |
| 428 | 1684 } |
| 1685 | |
| 1686 /* Given a specifier object SPEC, return bodily specifier if SPEC is a | |
| 1687 ghost specifier, otherwise return the object itself | |
| 1688 */ | |
| 1689 static Lisp_Object | |
| 1690 bodily_specifier (Lisp_Object spec) | |
| 1691 { | |
| 1692 return (GHOST_SPECIFIER_P (XSPECIFIER (spec)) | |
| 1693 ? XSPECIFIER(spec)->magic_parent : spec); | |
| 1694 } | |
| 1695 | |
| 1696 /* Signal error if (specifier SPEC is read-only. | |
| 1697 Read only are ghost specifiers unless Vunlock_ghost_specifiers is | |
| 1698 non-nil. All other specifiers are read-write. | |
| 1699 */ | |
| 1700 static void | |
| 1701 check_modifiable_specifier (Lisp_Object spec) | |
| 1702 { | |
| 1703 if (NILP (Vunlock_ghost_specifiers) | |
| 1704 && GHOST_SPECIFIER_P (XSPECIFIER (spec))) | |
| 563 | 1705 signal_error (Qsetting_constant, |
| 1706 "Attempt to modify read-only specifier", | |
| 1707 spec); | |
| 428 | 1708 } |
| 1709 | |
| 1710 int | |
| 1711 unlock_ghost_specifiers_protected (void) | |
| 1712 { | |
| 853 | 1713 return internal_bind_lisp_object (&Vunlock_ghost_specifiers, Qt); |
| 428 | 1714 } |
| 1715 | |
| 1716 /* This gets hit so much that the function call overhead had a | |
| 1717 measurable impact (according to Quantify). #### We should figure | |
| 1718 out the frequency with which this is called with the various types | |
| 1719 and reorder the check accordingly. */ | |
| 1720 #define SPECIFIER_GET_SPEC_LIST(specifier, type) \ | |
| 3659 | 1721 (type == LOCALE_GLOBAL ? &(XSPECIFIER (specifier)->global_specs) : \ |
| 1722 type == LOCALE_DEVICE ? &(XSPECIFIER (specifier)->device_specs) : \ | |
| 1723 type == LOCALE_FRAME ? &(XSPECIFIER (specifier)->frame_specs) : \ | |
| 1724 type == LOCALE_WINDOW ? &(XWEAK_LIST_LIST \ | |
| 1725 (XSPECIFIER (specifier)->window_specs)) : \ | |
| 1726 type == LOCALE_BUFFER ? &(XSPECIFIER (specifier)->buffer_specs) : \ | |
| 1727 0) | |
| 428 | 1728 |
| 1729 static Lisp_Object * | |
| 1730 specifier_get_inst_list (Lisp_Object specifier, Lisp_Object locale, | |
| 1731 enum spec_locale_type type) | |
| 1732 { | |
| 1733 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type); | |
| 1734 Lisp_Object specification; | |
| 1735 | |
| 1736 if (type == LOCALE_GLOBAL) | |
| 1737 return spec_list; | |
| 1738 /* Calling assq_no_quit when it is just going to return nil anyhow | |
| 1739 is extremely expensive. So sayeth Quantify. */ | |
| 1740 if (!CONSP (*spec_list)) | |
| 1741 return 0; | |
| 1742 specification = assq_no_quit (locale, *spec_list); | |
| 1743 if (NILP (specification)) | |
| 1744 return 0; | |
| 1745 return &XCDR (specification); | |
| 1746 } | |
| 1747 | |
| 1748 /* For the given INST_LIST, return a new INST_LIST containing all elements | |
| 1749 where TAG-SET matches the element's tag set. EXACT_P indicates whether | |
| 1750 the match must be exact (as opposed to a subset). SHORT_P indicates | |
| 1751 that the short form (for `specifier-specs') should be returned if | |
| 1752 possible. If COPY_TREE_P, `copy-tree' is used to ensure that no | |
| 1753 elements of the new list are shared with the initial list. | |
| 1754 */ | |
| 1755 | |
| 1756 static Lisp_Object | |
| 1757 specifier_process_inst_list (Lisp_Object inst_list, | |
| 1758 Lisp_Object tag_set, int exact_p, | |
| 1759 int short_p, int copy_tree_p) | |
| 1760 { | |
| 1761 Lisp_Object retval = Qnil; | |
| 1762 Lisp_Object rest; | |
| 1763 struct gcpro gcpro1; | |
| 1764 | |
| 1765 GCPRO1 (retval); | |
| 1766 LIST_LOOP (rest, inst_list) | |
| 1767 { | |
| 1768 Lisp_Object tagged_inst = XCAR (rest); | |
| 1769 Lisp_Object tagged_inst_tag = XCAR (tagged_inst); | |
| 1770 if (tag_sets_match_p (tag_set, tagged_inst_tag, exact_p)) | |
| 1771 { | |
| 1772 if (short_p && NILP (tagged_inst_tag)) | |
| 1773 retval = Fcons (copy_tree_p ? | |
| 1774 Fcopy_tree (XCDR (tagged_inst), Qt) : | |
| 1775 XCDR (tagged_inst), | |
| 1776 retval); | |
| 1777 else | |
| 1778 retval = Fcons (copy_tree_p ? Fcopy_tree (tagged_inst, Qt) : | |
| 1779 tagged_inst, retval); | |
| 1780 } | |
| 1781 } | |
| 1782 retval = Fnreverse (retval); | |
| 1783 UNGCPRO; | |
| 1784 /* If there is a single instantiator and the short form is | |
| 1785 requested, return just the instantiator (rather than a one-element | |
| 1786 list of it) unless it is nil (so that it can be distinguished from | |
| 1787 no instantiators at all). */ | |
| 1788 if (short_p && CONSP (retval) && !NILP (XCAR (retval)) && | |
| 1789 NILP (XCDR (retval))) | |
| 1790 return XCAR (retval); | |
| 1791 else | |
| 1792 return retval; | |
| 1793 } | |
| 1794 | |
| 1795 static Lisp_Object | |
| 1796 specifier_get_external_inst_list (Lisp_Object specifier, Lisp_Object locale, | |
| 1797 enum spec_locale_type type, | |
| 1798 Lisp_Object tag_set, int exact_p, | |
| 1799 int short_p, int copy_tree_p) | |
| 1800 { | |
| 1801 Lisp_Object *inst_list = specifier_get_inst_list (specifier, locale, | |
| 1802 type); | |
| 1803 if (!inst_list || NILP (*inst_list)) | |
| 1804 { | |
| 2953 | 1805 /* nil for *inst_list should only occur in `global' */ |
| 428 | 1806 assert (!inst_list || EQ (locale, Qglobal)); |
| 1807 return Qnil; | |
| 1808 } | |
| 1809 | |
| 1810 return specifier_process_inst_list (*inst_list, tag_set, exact_p, | |
| 1811 short_p, copy_tree_p); | |
| 1812 } | |
| 1813 | |
| 1814 static Lisp_Object | |
| 1815 specifier_get_external_spec_list (Lisp_Object specifier, | |
| 1816 enum spec_locale_type type, | |
| 1817 Lisp_Object tag_set, int exact_p) | |
| 1818 { | |
| 1819 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type); | |
| 1820 Lisp_Object retval = Qnil; | |
| 1821 Lisp_Object rest; | |
| 1822 struct gcpro gcpro1; | |
| 1823 | |
| 1824 assert (type != LOCALE_GLOBAL); | |
| 1825 /* We're about to let stuff go external; make sure there aren't | |
| 1826 any dead objects */ | |
| 1827 *spec_list = cleanup_assoc_list (*spec_list); | |
| 1828 | |
| 1829 GCPRO1 (retval); | |
| 1830 LIST_LOOP (rest, *spec_list) | |
| 1831 { | |
| 1832 Lisp_Object spec = XCAR (rest); | |
| 1833 Lisp_Object inst_list = | |
| 1834 specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 1); | |
| 1835 if (!NILP (inst_list)) | |
| 1836 retval = Fcons (Fcons (XCAR (spec), inst_list), retval); | |
| 1837 } | |
| 1838 RETURN_UNGCPRO (Fnreverse (retval)); | |
| 1839 } | |
| 1840 | |
| 1841 static Lisp_Object * | |
| 1842 specifier_new_spec (Lisp_Object specifier, Lisp_Object locale, | |
| 1843 enum spec_locale_type type) | |
| 1844 { | |
| 1845 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type); | |
| 1846 Lisp_Object new_spec = Fcons (locale, Qnil); | |
| 1847 assert (type != LOCALE_GLOBAL); | |
| 1848 *spec_list = Fcons (new_spec, *spec_list); | |
| 1849 return &XCDR (new_spec); | |
| 1850 } | |
| 1851 | |
| 1852 /* For the given INST_LIST, return a new list comprised of elements | |
| 1853 where TAG_SET does not match the element's tag set. This operation | |
| 1854 is destructive. */ | |
| 1855 | |
| 1856 static Lisp_Object | |
| 1857 specifier_process_remove_inst_list (Lisp_Object inst_list, | |
| 1858 Lisp_Object tag_set, int exact_p, | |
| 1859 int *was_removed) | |
| 1860 { | |
| 1861 Lisp_Object prev = Qnil, rest; | |
| 1862 | |
| 1863 *was_removed = 0; | |
| 1864 | |
| 1865 LIST_LOOP (rest, inst_list) | |
| 1866 { | |
| 1867 if (tag_sets_match_p (tag_set, XCAR (XCAR (rest)), exact_p)) | |
| 1868 { | |
| 1869 /* time to remove. */ | |
| 1870 *was_removed = 1; | |
| 1871 if (NILP (prev)) | |
| 1872 inst_list = XCDR (rest); | |
| 1873 else | |
| 1874 XCDR (prev) = XCDR (rest); | |
| 1875 } | |
| 1876 else | |
| 1877 prev = rest; | |
| 1878 } | |
| 1879 | |
| 1880 return inst_list; | |
| 1881 } | |
| 1882 | |
| 1883 static void | |
| 1884 specifier_remove_spec (Lisp_Object specifier, Lisp_Object locale, | |
| 1885 enum spec_locale_type type, | |
| 1886 Lisp_Object tag_set, int exact_p) | |
| 1887 { | |
| 1888 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type); | |
| 1889 Lisp_Object assoc; | |
| 1890 int was_removed; | |
| 1891 | |
| 1892 if (type == LOCALE_GLOBAL) | |
| 1893 *spec_list = specifier_process_remove_inst_list (*spec_list, tag_set, | |
| 1894 exact_p, &was_removed); | |
| 1895 else | |
| 1896 { | |
| 1897 assoc = assq_no_quit (locale, *spec_list); | |
| 1898 if (NILP (assoc)) | |
| 1899 /* this locale is not found. */ | |
| 1900 return; | |
| 1901 XCDR (assoc) = specifier_process_remove_inst_list (XCDR (assoc), | |
| 1902 tag_set, exact_p, | |
| 1903 &was_removed); | |
| 1904 if (NILP (XCDR (assoc))) | |
| 1905 /* no inst-pairs left; remove this locale entirely. */ | |
| 1906 *spec_list = remassq_no_quit (locale, *spec_list); | |
| 1907 } | |
| 1908 | |
| 1909 if (was_removed) | |
| 1910 MAYBE_SPECMETH (XSPECIFIER (specifier), after_change, | |
| 1911 (bodily_specifier (specifier), locale)); | |
| 1912 } | |
| 1913 | |
| 1914 static void | |
| 1915 specifier_remove_locale_type (Lisp_Object specifier, | |
| 1916 enum spec_locale_type type, | |
| 1917 Lisp_Object tag_set, int exact_p) | |
| 1918 { | |
| 1919 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type); | |
| 1920 Lisp_Object prev = Qnil, rest; | |
| 1921 | |
| 1922 assert (type != LOCALE_GLOBAL); | |
| 1923 LIST_LOOP (rest, *spec_list) | |
| 1924 { | |
| 1925 int was_removed; | |
| 1926 int remove_spec = 0; | |
| 1927 Lisp_Object spec = XCAR (rest); | |
| 1928 | |
| 1929 /* There may be dead objects floating around */ | |
| 1930 /* remember, dead windows can become alive again. */ | |
| 1931 if (!WINDOWP (XCAR (spec)) && object_dead_p (XCAR (spec))) | |
| 1932 { | |
| 1933 remove_spec = 1; | |
| 1934 was_removed = 0; | |
| 1935 } | |
| 1936 else | |
| 1937 { | |
| 1938 XCDR (spec) = specifier_process_remove_inst_list (XCDR (spec), | |
| 1939 tag_set, exact_p, | |
| 1940 &was_removed); | |
| 1941 if (NILP (XCDR (spec))) | |
| 1942 remove_spec = 1; | |
| 1943 } | |
| 1944 | |
| 1945 if (remove_spec) | |
| 1946 { | |
| 1947 if (NILP (prev)) | |
| 1948 *spec_list = XCDR (rest); | |
| 1949 else | |
| 1950 XCDR (prev) = XCDR (rest); | |
| 1951 } | |
| 1952 else | |
| 1953 prev = rest; | |
| 1954 | |
| 1955 if (was_removed) | |
| 1956 MAYBE_SPECMETH (XSPECIFIER (specifier), after_change, | |
| 1957 (bodily_specifier (specifier), XCAR (spec))); | |
| 1958 } | |
| 1959 } | |
| 1960 | |
| 1961 /* NEW_LIST is going to be added to INST_LIST, with add method ADD_METH. | |
| 1962 Frob INST_LIST according to ADD_METH. No need to call an after-change | |
| 1963 function; the calling function will do this. Return either SPEC_PREPEND | |
| 1964 or SPEC_APPEND, indicating whether to prepend or append the NEW_LIST. */ | |
| 1965 | |
| 1966 static enum spec_add_meth | |
| 1967 handle_multiple_add_insts (Lisp_Object *inst_list, | |
| 1968 Lisp_Object new_list, | |
| 1969 enum spec_add_meth add_meth) | |
| 1970 { | |
| 1971 switch (add_meth) | |
| 1972 { | |
| 1973 case SPEC_REMOVE_TAG_SET_APPEND: | |
| 1974 add_meth = SPEC_APPEND; | |
| 1975 goto remove_tag_set; | |
| 1976 case SPEC_REMOVE_TAG_SET_PREPEND: | |
| 1977 add_meth = SPEC_PREPEND; | |
| 1978 remove_tag_set: | |
| 1979 { | |
| 1980 Lisp_Object rest; | |
| 1981 | |
| 1982 LIST_LOOP (rest, new_list) | |
| 1983 { | |
| 1984 Lisp_Object canontag = canonicalize_tag_set (XCAR (XCAR (rest))); | |
| 1985 struct gcpro gcpro1; | |
| 1986 | |
| 1987 GCPRO1 (canontag); | |
| 1988 /* pull out all elements from the existing list with the | |
| 1989 same tag as any tags in NEW_LIST. */ | |
| 1990 *inst_list = remassoc_no_quit (canontag, *inst_list); | |
| 1991 UNGCPRO; | |
| 1992 } | |
| 1993 } | |
| 1994 return add_meth; | |
| 1995 case SPEC_REMOVE_LOCALE: | |
| 1996 *inst_list = Qnil; | |
| 1997 return SPEC_PREPEND; | |
| 1998 case SPEC_APPEND: | |
| 1999 return add_meth; | |
| 2000 default: | |
| 2001 return SPEC_PREPEND; | |
| 2002 } | |
| 2003 } | |
| 2004 | |
| 2005 /* Given a LOCALE and INST_LIST that is going to be added to SPECIFIER, | |
| 2006 copy, canonicalize, and call the going_to_add methods as necessary | |
| 2007 to produce a new list that is the one that really will be added | |
| 2008 to the specifier. */ | |
| 2009 | |
| 2010 static Lisp_Object | |
| 2011 build_up_processed_list (Lisp_Object specifier, Lisp_Object locale, | |
| 2012 Lisp_Object inst_list) | |
| 2013 { | |
| 2014 /* The return value of this function must be GCPRO'd. */ | |
| 2015 Lisp_Object rest, list_to_build_up = Qnil; | |
| 440 | 2016 Lisp_Specifier *sp = XSPECIFIER (specifier); |
| 428 | 2017 struct gcpro gcpro1; |
| 2018 | |
| 2019 GCPRO1 (list_to_build_up); | |
| 2020 LIST_LOOP (rest, inst_list) | |
| 2021 { | |
| 2022 Lisp_Object tag_set = XCAR (XCAR (rest)); | |
| 2023 Lisp_Object sub_inst_list = Qnil; | |
| 434 | 2024 Lisp_Object instantiator; |
| 428 | 2025 struct gcpro ngcpro1, ngcpro2; |
| 2026 | |
| 434 | 2027 if (HAS_SPECMETH_P (sp, copy_instantiator)) |
| 2028 instantiator = SPECMETH (sp, copy_instantiator, | |
| 2029 (XCDR (XCAR (rest)))); | |
| 2030 else | |
| 2031 instantiator = Fcopy_tree (XCDR (XCAR (rest)), Qt); | |
| 2032 | |
| 428 | 2033 NGCPRO2 (instantiator, sub_inst_list); |
| 2034 /* call the will-add method; it may GC */ | |
| 2035 sub_inst_list = HAS_SPECMETH_P (sp, going_to_add) ? | |
| 2036 SPECMETH (sp, going_to_add, | |
| 2037 (bodily_specifier (specifier), locale, | |
| 2038 tag_set, instantiator)) : | |
| 2039 Qt; | |
| 2040 if (EQ (sub_inst_list, Qt)) | |
| 2041 /* no change here. */ | |
| 2042 sub_inst_list = list1 (Fcons (canonicalize_tag_set (tag_set), | |
| 2043 instantiator)); | |
| 2044 else | |
| 2045 { | |
| 2046 /* now canonicalize all the tag sets in the new objects */ | |
| 2047 Lisp_Object rest2; | |
| 2048 LIST_LOOP (rest2, sub_inst_list) | |
| 2049 XCAR (XCAR (rest2)) = canonicalize_tag_set (XCAR (XCAR (rest2))); | |
| 2050 } | |
| 2051 | |
| 2052 list_to_build_up = nconc2 (sub_inst_list, list_to_build_up); | |
| 2053 NUNGCPRO; | |
| 2054 } | |
| 2055 | |
| 2056 RETURN_UNGCPRO (Fnreverse (list_to_build_up)); | |
| 2057 } | |
| 2058 | |
| 2059 /* Add a specification (locale and instantiator list) to a specifier. | |
| 2060 ADD_METH specifies what to do with existing specifications in the | |
| 2061 specifier, and is an enum that corresponds to the values in | |
| 2062 `add-spec-to-specifier'. The calling routine is responsible for | |
| 2063 validating LOCALE and INST-LIST, but the tag-sets in INST-LIST | |
| 2064 do not need to be canonicalized. */ | |
| 2065 | |
| 3659 | 2066 /* #### I really need to rethink the after-change |
| 2067 functions to make them easier to use and more efficient. */ | |
| 428 | 2068 |
| 2069 static void | |
| 2070 specifier_add_spec (Lisp_Object specifier, Lisp_Object locale, | |
| 2071 Lisp_Object inst_list, enum spec_add_meth add_meth) | |
| 2072 { | |
| 440 | 2073 Lisp_Specifier *sp = XSPECIFIER (specifier); |
| 428 | 2074 enum spec_locale_type type = locale_type_from_locale (locale); |
| 2075 Lisp_Object *orig_inst_list, tem; | |
| 2076 Lisp_Object list_to_build_up = Qnil; | |
| 2077 struct gcpro gcpro1; | |
| 2078 | |
| 1015 | 2079 if (NILP (inst_list)) |
| 2080 return; | |
| 2081 | |
| 428 | 2082 GCPRO1 (list_to_build_up); |
| 2083 list_to_build_up = build_up_processed_list (specifier, locale, inst_list); | |
| 2084 /* Now handle REMOVE_LOCALE_TYPE and REMOVE_ALL. These are the | |
| 2085 add-meth types that affect locales other than this one. */ | |
| 2086 if (add_meth == SPEC_REMOVE_LOCALE_TYPE) | |
| 2087 specifier_remove_locale_type (specifier, type, Qnil, 0); | |
| 2088 else if (add_meth == SPEC_REMOVE_ALL) | |
| 2089 { | |
| 2090 specifier_remove_locale_type (specifier, LOCALE_BUFFER, Qnil, 0); | |
| 2091 specifier_remove_locale_type (specifier, LOCALE_WINDOW, Qnil, 0); | |
| 2092 specifier_remove_locale_type (specifier, LOCALE_FRAME, Qnil, 0); | |
| 2093 specifier_remove_locale_type (specifier, LOCALE_DEVICE, Qnil, 0); | |
| 2094 specifier_remove_spec (specifier, Qglobal, LOCALE_GLOBAL, Qnil, 0); | |
| 2095 } | |
| 2096 | |
| 2097 orig_inst_list = specifier_get_inst_list (specifier, locale, type); | |
| 2098 if (!orig_inst_list) | |
| 2099 orig_inst_list = specifier_new_spec (specifier, locale, type); | |
| 2100 add_meth = handle_multiple_add_insts (orig_inst_list, list_to_build_up, | |
| 2101 add_meth); | |
| 2102 | |
| 2103 if (add_meth == SPEC_PREPEND) | |
| 2104 tem = nconc2 (list_to_build_up, *orig_inst_list); | |
| 2105 else if (add_meth == SPEC_APPEND) | |
| 2106 tem = nconc2 (*orig_inst_list, list_to_build_up); | |
| 2107 else | |
| 442 | 2108 { |
| 2500 | 2109 ABORT (); |
| 442 | 2110 tem = Qnil; |
| 2111 } | |
| 428 | 2112 |
| 2113 *orig_inst_list = tem; | |
| 2114 | |
| 2115 UNGCPRO; | |
| 2116 | |
| 2117 /* call the after-change method */ | |
| 2118 MAYBE_SPECMETH (sp, after_change, | |
| 2119 (bodily_specifier (specifier), locale)); | |
| 2120 } | |
| 2121 | |
| 2122 static void | |
| 2123 specifier_copy_spec (Lisp_Object specifier, Lisp_Object dest, | |
| 2124 Lisp_Object locale, enum spec_locale_type type, | |
| 2125 Lisp_Object tag_set, int exact_p, | |
| 2126 enum spec_add_meth add_meth) | |
| 2127 { | |
| 2128 Lisp_Object inst_list = | |
| 2129 specifier_get_external_inst_list (specifier, locale, type, tag_set, | |
| 2130 exact_p, 0, 0); | |
| 2131 specifier_add_spec (dest, locale, inst_list, add_meth); | |
| 2132 } | |
| 2133 | |
| 2134 static void | |
| 2135 specifier_copy_locale_type (Lisp_Object specifier, Lisp_Object dest, | |
| 2136 enum spec_locale_type type, | |
| 2137 Lisp_Object tag_set, int exact_p, | |
| 2138 enum spec_add_meth add_meth) | |
| 2139 { | |
| 2140 Lisp_Object *src_list = SPECIFIER_GET_SPEC_LIST (specifier, type); | |
| 2141 Lisp_Object rest; | |
| 2142 | |
| 2143 /* This algorithm is O(n^2) in running time. | |
| 2144 It's certainly possible to implement an O(n log n) algorithm, | |
| 2145 but I doubt there's any need to. */ | |
| 2146 | |
| 2147 LIST_LOOP (rest, *src_list) | |
| 2148 { | |
| 2149 Lisp_Object spec = XCAR (rest); | |
| 2150 /* There may be dead objects floating around */ | |
| 2151 /* remember, dead windows can become alive again. */ | |
| 2152 if (WINDOWP (XCAR (spec)) || !object_dead_p (XCAR (spec))) | |
| 2153 specifier_add_spec | |
| 2154 (dest, XCAR (spec), | |
| 2155 specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 0), | |
| 2156 add_meth); | |
| 2157 } | |
| 2158 } | |
| 2159 | |
| 2160 /* map MAPFUN over the locales in SPECIFIER that are given in LOCALE. | |
| 2161 CLOSURE is passed unchanged to MAPFUN. LOCALE can be one of | |
| 2162 | |
| 3659 | 2163 -- nil (same as `all') |
| 2164 -- a single locale, locale type, or `all' | |
| 2165 -- a list of locales, locale types, and/or `all' | |
| 2953 | 2166 |
| 2167 MAPFUN is called for each locale and locale type given; for `all', | |
| 2168 it is called for the locale `global' and for the four possible | |
| 428 | 2169 locale types. In each invocation, either LOCALE will be a locale |
| 2170 and LOCALE_TYPE will be the locale type of this locale, | |
| 2171 or LOCALE will be nil and LOCALE_TYPE will be a locale type. | |
| 2172 If MAPFUN ever returns non-zero, the mapping is halted and the | |
| 2173 value returned is returned from map_specifier(). Otherwise, the | |
| 2174 mapping proceeds to the end and map_specifier() returns 0. | |
| 3659 | 2175 */ |
| 428 | 2176 |
| 2177 static int | |
| 2178 map_specifier (Lisp_Object specifier, Lisp_Object locale, | |
| 2179 int (*mapfun) (Lisp_Object specifier, | |
| 2180 Lisp_Object locale, | |
| 2181 enum spec_locale_type locale_type, | |
| 2182 Lisp_Object tag_set, | |
| 2183 int exact_p, | |
| 2184 void *closure), | |
| 2185 Lisp_Object tag_set, Lisp_Object exact_p, | |
| 2186 void *closure) | |
| 2187 { | |
| 2188 int retval = 0; | |
| 2189 Lisp_Object rest; | |
| 2190 struct gcpro gcpro1, gcpro2; | |
| 2191 | |
| 2192 GCPRO2 (tag_set, locale); | |
| 2193 locale = decode_locale_list (locale); | |
| 2194 tag_set = decode_specifier_tag_set (tag_set); | |
| 2195 tag_set = canonicalize_tag_set (tag_set); | |
| 2196 | |
| 2197 LIST_LOOP (rest, locale) | |
| 2198 { | |
| 2199 Lisp_Object theloc = XCAR (rest); | |
| 2200 if (!NILP (Fvalid_specifier_locale_p (theloc))) | |
| 2201 { | |
| 2202 retval = (*mapfun) (specifier, theloc, | |
| 2203 locale_type_from_locale (theloc), | |
| 2204 tag_set, !NILP (exact_p), closure); | |
| 2205 if (retval) | |
| 2206 break; | |
| 2207 } | |
| 2208 else if (!NILP (Fvalid_specifier_locale_type_p (theloc))) | |
| 2209 { | |
| 2210 retval = (*mapfun) (specifier, Qnil, | |
| 2211 decode_locale_type (theloc), tag_set, | |
| 2212 !NILP (exact_p), closure); | |
| 2213 if (retval) | |
| 2214 break; | |
| 2215 } | |
| 2216 else | |
| 2217 { | |
| 2218 assert (EQ (theloc, Qall)); | |
| 2219 retval = (*mapfun) (specifier, Qnil, LOCALE_BUFFER, tag_set, | |
| 2220 !NILP (exact_p), closure); | |
| 2221 if (retval) | |
| 2222 break; | |
| 2223 retval = (*mapfun) (specifier, Qnil, LOCALE_WINDOW, tag_set, | |
| 2224 !NILP (exact_p), closure); | |
| 2225 if (retval) | |
| 2226 break; | |
| 2227 retval = (*mapfun) (specifier, Qnil, LOCALE_FRAME, tag_set, | |
| 2228 !NILP (exact_p), closure); | |
| 2229 if (retval) | |
| 2230 break; | |
| 2231 retval = (*mapfun) (specifier, Qnil, LOCALE_DEVICE, tag_set, | |
| 2232 !NILP (exact_p), closure); | |
| 2233 if (retval) | |
| 2234 break; | |
| 2235 retval = (*mapfun) (specifier, Qglobal, LOCALE_GLOBAL, tag_set, | |
| 2236 !NILP (exact_p), closure); | |
| 2237 if (retval) | |
| 2238 break; | |
| 2239 } | |
| 2240 } | |
| 2241 | |
| 2242 UNGCPRO; | |
| 2243 return retval; | |
| 2244 } | |
| 2245 | |
| 2246 DEFUN ("add-spec-to-specifier", Fadd_spec_to_specifier, 2, 5, 0, /* | |
| 2247 Add a specification to SPECIFIER. | |
| 2248 The specification maps from LOCALE (which should be a window, buffer, | |
| 2953 | 2249 frame, device, or `global', and defaults to `global') to INSTANTIATOR, |
| 428 | 2250 whose allowed values depend on the type of the specifier. Optional |
| 2251 argument TAG-SET limits the instantiator to apply only to the specified | |
| 2252 tag set, which should be a list of tags all of which must match the | |
| 2253 device being instantiated over (tags are a device type, a device class, | |
| 2254 or tags defined with `define-specifier-tag'). Specifying a single | |
| 2255 symbol for TAG-SET is equivalent to specifying a one-element list | |
| 2256 containing that symbol. Optional argument HOW-TO-ADD specifies what to | |
| 2257 do if there are already specifications in the specifier. | |
| 2258 It should be one of | |
| 2259 | |
| 2953 | 2260 `prepend' Put at the beginning of the current list of |
| 428 | 2261 instantiators for LOCALE. |
| 2953 | 2262 `append' Add to the end of the current list of |
| 428 | 2263 instantiators for LOCALE. |
| 2953 | 2264 `remove-tag-set-prepend' (this is the default) |
| 428 | 2265 Remove any existing instantiators whose tag set is |
| 2266 the same as TAG-SET; then put the new instantiator | |
| 2267 at the beginning of the current list. ("Same tag | |
| 2268 set" means that they contain the same elements. | |
| 2269 The order may be different.) | |
| 2953 | 2270 `remove-tag-set-append' |
| 428 | 2271 Remove any existing instantiators whose tag set is |
| 2272 the same as TAG-SET; then put the new instantiator | |
| 2273 at the end of the current list. | |
| 2953 | 2274 `remove-locale' Remove all previous instantiators for this locale |
| 428 | 2275 before adding the new spec. |
| 2953 | 2276 `remove-locale-type' Remove all specifications for all locales of the |
| 428 | 2277 same type as LOCALE (this includes LOCALE itself) |
| 2278 before adding the new spec. | |
| 2953 | 2279 `remove-all' Remove all specifications from the specifier |
| 428 | 2280 before adding the new spec. |
| 2281 | |
| 2282 You can retrieve the specifications for a particular locale or locale type | |
| 2283 with the function `specifier-spec-list' or `specifier-specs'. | |
| 2284 */ | |
| 2285 (specifier, instantiator, locale, tag_set, how_to_add)) | |
| 2286 { | |
| 2287 enum spec_add_meth add_meth; | |
| 2288 Lisp_Object inst_list; | |
| 2289 struct gcpro gcpro1; | |
| 2290 | |
| 2291 CHECK_SPECIFIER (specifier); | |
| 2292 check_modifiable_specifier (specifier); | |
| 2293 | |
| 2294 locale = decode_locale (locale); | |
| 2295 check_valid_instantiator (instantiator, | |
| 2296 decode_specifier_type | |
| 2297 (Fspecifier_type (specifier), ERROR_ME), | |
| 2298 ERROR_ME); | |
| 2299 /* tag_set might be newly-created material, but it's part of inst_list | |
| 2300 so is properly GC-protected. */ | |
| 2301 tag_set = decode_specifier_tag_set (tag_set); | |
| 2302 add_meth = decode_how_to_add_specification (how_to_add); | |
| 2303 | |
| 2304 inst_list = list1 (Fcons (tag_set, instantiator)); | |
| 2305 GCPRO1 (inst_list); | |
| 2306 specifier_add_spec (specifier, locale, inst_list, add_meth); | |
| 2307 recompute_cached_specifier_everywhere (specifier); | |
| 2308 RETURN_UNGCPRO (Qnil); | |
| 2309 } | |
| 2310 | |
| 2311 DEFUN ("add-spec-list-to-specifier", Fadd_spec_list_to_specifier, 2, 3, 0, /* | |
| 444 | 2312 Add SPEC-LIST (a list of specifications) to SPECIFIER. |
| 2313 The format of SPEC-LIST is | |
| 428 | 2314 |
| 2315 ((LOCALE (TAG-SET . INSTANTIATOR) ...) ...) | |
| 2316 | |
| 2317 where | |
| 2953 | 2318 LOCALE := a window, a buffer, a frame, a device, or `global' |
| 428 | 2319 TAG-SET := an unordered list of zero or more TAGS, each of which |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2320 is a symbol |
| 428 | 2321 TAG := a device class (see `valid-device-class-p'), a device type |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2322 (see `valid-console-type-p'), or a tag defined with |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2323 `define-specifier-tag' |
| 428 | 2324 INSTANTIATOR := format determined by the type of specifier |
| 2325 | |
| 2326 The pair (TAG-SET . INSTANTIATOR) is called an `inst-pair'. | |
| 2327 A list of inst-pairs is called an `inst-list'. | |
| 2328 The pair (LOCALE . INST-LIST) is called a `specification' or `spec'. | |
| 2329 A spec-list, then, can be viewed as a list of specifications. | |
| 2330 | |
| 2331 HOW-TO-ADD specifies how to combine the new specifications with | |
| 2332 the existing ones, and has the same semantics as for | |
| 2333 `add-spec-to-specifier'. | |
| 2334 | |
| 2335 In many circumstances, the higher-level function `set-specifier' is | |
| 2336 more convenient and should be used instead. | |
| 2337 */ | |
| 2338 (specifier, spec_list, how_to_add)) | |
| 2339 { | |
| 2340 enum spec_add_meth add_meth; | |
| 2341 Lisp_Object rest; | |
| 2342 | |
| 2343 CHECK_SPECIFIER (specifier); | |
| 2344 check_modifiable_specifier (specifier); | |
| 2345 | |
| 2346 check_valid_spec_list (spec_list, | |
| 2347 decode_specifier_type | |
| 2348 (Fspecifier_type (specifier), ERROR_ME), | |
| 2349 ERROR_ME); | |
| 2350 add_meth = decode_how_to_add_specification (how_to_add); | |
| 2351 | |
| 2352 LIST_LOOP (rest, spec_list) | |
| 2353 { | |
| 2354 /* Placating the GCC god. */ | |
| 2355 Lisp_Object specification = XCAR (rest); | |
| 2356 Lisp_Object locale = XCAR (specification); | |
| 2357 Lisp_Object inst_list = XCDR (specification); | |
| 2358 | |
| 2359 specifier_add_spec (specifier, locale, inst_list, add_meth); | |
| 2360 } | |
| 2361 recompute_cached_specifier_everywhere (specifier); | |
| 2362 return Qnil; | |
| 2363 } | |
| 2364 | |
| 2365 void | |
| 2366 add_spec_to_ghost_specifier (Lisp_Object specifier, Lisp_Object instantiator, | |
| 2367 Lisp_Object locale, Lisp_Object tag_set, | |
| 2368 Lisp_Object how_to_add) | |
| 2369 { | |
| 2370 int depth = unlock_ghost_specifiers_protected (); | |
| 2371 Fadd_spec_to_specifier (XSPECIFIER(specifier)->fallback, | |
| 2372 instantiator, locale, tag_set, how_to_add); | |
| 771 | 2373 unbind_to (depth); |
| 428 | 2374 } |
| 2375 | |
| 2376 struct specifier_spec_list_closure | |
| 2377 { | |
| 2378 Lisp_Object head, tail; | |
| 2379 }; | |
| 2380 | |
| 2381 static int | |
| 2382 specifier_spec_list_mapfun (Lisp_Object specifier, | |
| 2383 Lisp_Object locale, | |
| 2384 enum spec_locale_type locale_type, | |
| 2385 Lisp_Object tag_set, | |
| 2386 int exact_p, | |
| 2387 void *closure) | |
| 2388 { | |
| 2389 struct specifier_spec_list_closure *cl = | |
| 2390 (struct specifier_spec_list_closure *) closure; | |
| 2391 Lisp_Object partial; | |
| 2392 | |
| 2393 if (NILP (locale)) | |
| 2394 partial = specifier_get_external_spec_list (specifier, | |
| 2395 locale_type, | |
| 2396 tag_set, exact_p); | |
| 2397 else | |
| 2398 { | |
| 2399 partial = specifier_get_external_inst_list (specifier, locale, | |
| 2400 locale_type, tag_set, | |
| 2401 exact_p, 0, 1); | |
| 2402 if (!NILP (partial)) | |
| 2403 partial = list1 (Fcons (locale, partial)); | |
| 2404 } | |
| 2405 if (NILP (partial)) | |
| 2406 return 0; | |
| 2407 | |
| 2408 /* tack on the new list */ | |
| 2409 if (NILP (cl->tail)) | |
| 2410 cl->head = cl->tail = partial; | |
| 2411 else | |
| 2412 XCDR (cl->tail) = partial; | |
| 2413 /* find the new tail */ | |
| 2414 while (CONSP (XCDR (cl->tail))) | |
| 2415 cl->tail = XCDR (cl->tail); | |
| 2416 return 0; | |
| 2417 } | |
| 2418 | |
| 2419 /* For the given SPECIFIER create and return a list of all specs | |
| 2420 contained within it, subject to LOCALE. If LOCALE is a locale, only | |
| 2421 specs in that locale will be returned. If LOCALE is a locale type, | |
| 2422 all specs in all locales of that type will be returned. If LOCALE is | |
| 2423 nil, all specs will be returned. This always copies lists and never | |
| 2424 returns the actual lists, because we do not want someone manipulating | |
| 2425 the actual objects. This may cause a slight loss of potential | |
| 2426 functionality but if we were to allow it then a user could manage to | |
| 2427 violate our assertion that the specs contained in the actual | |
| 2428 specifier lists are all valid. */ | |
| 2429 | |
| 2430 DEFUN ("specifier-spec-list", Fspecifier_spec_list, 1, 4, 0, /* | |
| 2431 Return the spec-list of specifications for SPECIFIER in LOCALE. | |
| 2432 | |
| 2433 If LOCALE is a particular locale (a buffer, window, frame, device, | |
| 2953 | 2434 or `global'), a spec-list consisting of the specification for that |
| 428 | 2435 locale will be returned. |
| 2436 | |
| 2953 | 2437 If LOCALE is a locale type (i.e. `buffer', `window', `frame', or `device'), |
| 428 | 2438 a spec-list of the specifications for all locales of that type will be |
| 2439 returned. | |
| 2440 | |
| 2953 | 2441 If LOCALE is nil or `all', a spec-list of all specifications in SPECIFIER |
| 428 | 2442 will be returned. |
| 2443 | |
| 2953 | 2444 LOCALE can also be a list of locales, locale types, and/or `all'; the |
| 428 | 2445 result is as if `specifier-spec-list' were called on each element of the |
| 2446 list and the results concatenated together. | |
| 2447 | |
| 2448 Only instantiators where TAG-SET (a list of zero or more tags) is a | |
| 2449 subset of (or possibly equal to) the instantiator's tag set are returned. | |
| 2450 \(The default value of nil is a subset of all tag sets, so in this case | |
| 2451 no instantiators will be screened out.) If EXACT-P is non-nil, however, | |
| 2452 TAG-SET must be equal to an instantiator's tag set for the instantiator | |
| 2453 to be returned. | |
| 2454 */ | |
| 3659 | 2455 (specifier, locale, tag_set, exact_p)) |
| 428 | 2456 { |
| 2457 struct specifier_spec_list_closure cl; | |
| 2458 struct gcpro gcpro1, gcpro2; | |
| 2459 | |
| 2460 CHECK_SPECIFIER (specifier); | |
| 2461 cl.head = cl.tail = Qnil; | |
| 2462 GCPRO2 (cl.head, cl.tail); | |
| 2463 map_specifier (specifier, locale, specifier_spec_list_mapfun, | |
| 2464 tag_set, exact_p, &cl); | |
| 2465 UNGCPRO; | |
| 2466 return cl.head; | |
| 2467 } | |
| 2468 | |
| 2469 | |
| 2470 DEFUN ("specifier-specs", Fspecifier_specs, 1, 4, 0, /* | |
| 2471 Return the specification(s) for SPECIFIER in LOCALE. | |
| 2472 | |
| 2473 If LOCALE is a single locale or is a list of one element containing a | |
| 2474 single locale, then a "short form" of the instantiators for that locale | |
| 2475 will be returned. Otherwise, this function is identical to | |
| 2476 `specifier-spec-list'. | |
| 2477 | |
| 2478 The "short form" is designed for readability and not for ease of use | |
| 2479 in Lisp programs, and is as follows: | |
| 2480 | |
| 2481 1. If there is only one instantiator, then an inst-pair (i.e. cons of | |
| 2482 tag and instantiator) will be returned; otherwise a list of | |
| 2483 inst-pairs will be returned. | |
| 2953 | 2484 2. For each inst-pair returned, if the instantiator's tag is `any', |
| 428 | 2485 the tag will be removed and the instantiator itself will be returned |
| 2486 instead of the inst-pair. | |
| 2487 3. If there is only one instantiator, its value is nil, and its tag is | |
| 2953 | 2488 `any', a one-element list containing nil will be returned rather |
| 428 | 2489 than just nil, to distinguish this case from there being no |
| 2490 instantiators at all. | |
| 2491 */ | |
| 2492 (specifier, locale, tag_set, exact_p)) | |
| 2493 { | |
| 2494 if (!NILP (Fvalid_specifier_locale_p (locale)) || | |
| 2495 (CONSP (locale) && !NILP (Fvalid_specifier_locale_p (XCAR (locale))) && | |
| 2496 NILP (XCDR (locale)))) | |
| 2497 { | |
| 2498 struct gcpro gcpro1; | |
| 2499 | |
| 2500 CHECK_SPECIFIER (specifier); | |
| 2501 if (CONSP (locale)) | |
| 2502 locale = XCAR (locale); | |
| 2503 GCPRO1 (tag_set); | |
| 2504 tag_set = decode_specifier_tag_set (tag_set); | |
| 2505 tag_set = canonicalize_tag_set (tag_set); | |
| 2506 RETURN_UNGCPRO | |
| 2507 (specifier_get_external_inst_list (specifier, locale, | |
| 2508 locale_type_from_locale (locale), | |
| 2509 tag_set, !NILP (exact_p), 1, 1)); | |
| 2510 } | |
| 2511 else | |
| 2512 return Fspecifier_spec_list (specifier, locale, tag_set, exact_p); | |
| 2513 } | |
| 2514 | |
| 2515 static int | |
| 2516 remove_specifier_mapfun (Lisp_Object specifier, | |
| 2517 Lisp_Object locale, | |
| 2518 enum spec_locale_type locale_type, | |
| 2519 Lisp_Object tag_set, | |
| 2520 int exact_p, | |
| 2286 | 2521 void *UNUSED (closure)) |
| 428 | 2522 { |
| 2523 if (NILP (locale)) | |
| 2524 specifier_remove_locale_type (specifier, locale_type, tag_set, exact_p); | |
| 2525 else | |
| 2526 specifier_remove_spec (specifier, locale, locale_type, tag_set, exact_p); | |
| 2527 return 0; | |
| 2528 } | |
| 2529 | |
| 2530 DEFUN ("remove-specifier", Fremove_specifier, 1, 4, 0, /* | |
| 2531 Remove specification(s) for SPECIFIER. | |
| 2532 | |
| 2533 If LOCALE is a particular locale (a window, buffer, frame, device, | |
| 2953 | 2534 or `global'), the specification for that locale will be removed. |
| 2535 | |
| 2536 If instead, LOCALE is a locale type (i.e. `window', `buffer', `frame', | |
| 2537 or `device'), the specifications for all locales of that type will be | |
| 428 | 2538 removed. |
| 2539 | |
| 2953 | 2540 If LOCALE is nil or `all', all specifications will be removed. |
| 2541 | |
| 2542 LOCALE can also be a list of locales, locale types, and/or `all'; this | |
| 428 | 2543 is equivalent to calling `remove-specifier' for each of the elements |
| 2544 in the list. | |
| 2545 | |
| 2546 Only instantiators where TAG-SET (a list of zero or more tags) is a | |
| 2547 subset of (or possibly equal to) the instantiator's tag set are removed. | |
| 2548 The default value of nil is a subset of all tag sets, so in this case | |
| 2549 no instantiators will be screened out. If EXACT-P is non-nil, however, | |
| 2550 TAG-SET must be equal to an instantiator's tag set for the instantiator | |
| 2551 to be removed. | |
| 2552 */ | |
| 2553 (specifier, locale, tag_set, exact_p)) | |
| 2554 { | |
| 2555 CHECK_SPECIFIER (specifier); | |
| 2556 check_modifiable_specifier (specifier); | |
| 2557 | |
| 2558 map_specifier (specifier, locale, remove_specifier_mapfun, | |
| 2559 tag_set, exact_p, 0); | |
| 2560 recompute_cached_specifier_everywhere (specifier); | |
| 2561 return Qnil; | |
| 2562 } | |
| 2563 | |
| 2564 void | |
| 2565 remove_ghost_specifier (Lisp_Object specifier, Lisp_Object locale, | |
| 2566 Lisp_Object tag_set, Lisp_Object exact_p) | |
| 2567 { | |
| 2568 int depth = unlock_ghost_specifiers_protected (); | |
| 2569 Fremove_specifier (XSPECIFIER(specifier)->fallback, | |
| 2570 locale, tag_set, exact_p); | |
| 771 | 2571 unbind_to (depth); |
| 428 | 2572 } |
| 2573 | |
| 2574 struct copy_specifier_closure | |
| 2575 { | |
| 2576 Lisp_Object dest; | |
| 2577 enum spec_add_meth add_meth; | |
| 2578 int add_meth_is_nil; | |
| 2579 }; | |
| 2580 | |
| 2581 static int | |
| 2582 copy_specifier_mapfun (Lisp_Object specifier, | |
| 2583 Lisp_Object locale, | |
| 2584 enum spec_locale_type locale_type, | |
| 2585 Lisp_Object tag_set, | |
| 2586 int exact_p, | |
| 2587 void *closure) | |
| 2588 { | |
| 2589 struct copy_specifier_closure *cl = | |
| 2590 (struct copy_specifier_closure *) closure; | |
| 2591 | |
| 2592 if (NILP (locale)) | |
| 2593 specifier_copy_locale_type (specifier, cl->dest, locale_type, | |
| 2594 tag_set, exact_p, | |
| 2595 cl->add_meth_is_nil ? | |
| 2596 SPEC_REMOVE_LOCALE_TYPE : | |
| 2597 cl->add_meth); | |
| 2598 else | |
| 2599 specifier_copy_spec (specifier, cl->dest, locale, locale_type, | |
| 2600 tag_set, exact_p, | |
| 2601 cl->add_meth_is_nil ? SPEC_REMOVE_LOCALE : | |
| 2602 cl->add_meth); | |
| 2603 return 0; | |
| 2604 } | |
| 2605 | |
| 2606 DEFUN ("copy-specifier", Fcopy_specifier, 1, 6, 0, /* | |
| 2607 Copy SPECIFIER to DEST, or create a new one if DEST is nil. | |
| 2608 | |
| 2609 If DEST is nil or omitted, a new specifier will be created and the | |
| 2610 specifications copied into it. Otherwise, the specifications will be | |
| 2611 copied into the existing specifier in DEST. | |
| 2612 | |
| 2953 | 2613 If LOCALE is nil or `all', all specifications will be copied. If LOCALE |
| 428 | 2614 is a particular locale, the specification for that particular locale will |
| 2615 be copied. If LOCALE is a locale type, the specifications for all locales | |
| 2616 of that type will be copied. LOCALE can also be a list of locales, | |
| 2953 | 2617 locale types, and/or `all'; this is equivalent to calling `copy-specifier' |
| 428 | 2618 for each of the elements of the list. See `specifier-spec-list' for more |
| 2619 information about LOCALE. | |
| 2620 | |
| 2621 Only instantiators where TAG-SET (a list of zero or more tags) is a | |
| 2622 subset of (or possibly equal to) the instantiator's tag set are copied. | |
| 2623 The default value of nil is a subset of all tag sets, so in this case | |
| 2624 no instantiators will be screened out. If EXACT-P is non-nil, however, | |
| 2625 TAG-SET must be equal to an instantiator's tag set for the instantiator | |
| 2626 to be copied. | |
| 2627 | |
| 2628 Optional argument HOW-TO-ADD specifies what to do with existing | |
| 2629 specifications in DEST. If nil, then whichever locales or locale types | |
| 2630 are copied will first be completely erased in DEST. Otherwise, it is | |
| 2631 the same as in `add-spec-to-specifier'. | |
| 2632 */ | |
| 2633 (specifier, dest, locale, tag_set, exact_p, how_to_add)) | |
| 2634 { | |
| 2635 struct gcpro gcpro1; | |
| 2636 struct copy_specifier_closure cl; | |
| 2637 | |
| 2638 CHECK_SPECIFIER (specifier); | |
| 2639 if (NILP (how_to_add)) | |
| 2640 cl.add_meth_is_nil = 1; | |
| 2641 else | |
| 2642 cl.add_meth_is_nil = 0; | |
| 2643 cl.add_meth = decode_how_to_add_specification (how_to_add); | |
| 2644 if (NILP (dest)) | |
| 2645 { | |
| 2646 /* #### What about copying the extra data? */ | |
| 2647 dest = make_specifier (XSPECIFIER (specifier)->methods); | |
| 2648 } | |
| 2649 else | |
| 2650 { | |
| 2651 CHECK_SPECIFIER (dest); | |
| 2652 check_modifiable_specifier (dest); | |
| 2653 if (XSPECIFIER (dest)->methods != XSPECIFIER (specifier)->methods) | |
| 3659 | 2654 invalid_argument ("Specifiers not of same type", Qunbound); |
| 428 | 2655 } |
| 2656 | |
| 2657 cl.dest = dest; | |
| 2658 GCPRO1 (dest); | |
| 2659 map_specifier (specifier, locale, copy_specifier_mapfun, | |
| 2660 tag_set, exact_p, &cl); | |
| 2661 UNGCPRO; | |
| 2662 recompute_cached_specifier_everywhere (dest); | |
| 2663 return dest; | |
| 2664 } | |
| 2665 | |
| 2666 | |
| 2667 /************************************************************************/ | |
| 2953 | 2668 /* Instantiation */ |
| 428 | 2669 /************************************************************************/ |
| 2670 | |
| 2671 static Lisp_Object | |
| 2672 call_validate_matchspec_method (Lisp_Object boxed_method, | |
| 2673 Lisp_Object matchspec) | |
| 2674 { | |
| 2675 ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (matchspec); | |
| 2676 return Qt; | |
| 2677 } | |
| 2678 | |
| 2679 static Lisp_Object | |
| 2680 check_valid_specifier_matchspec (Lisp_Object matchspec, | |
| 2681 struct specifier_methods *meths, | |
| 578 | 2682 Error_Behavior errb) |
| 428 | 2683 { |
| 2684 if (meths->validate_matchspec_method) | |
| 2685 { | |
| 2686 Lisp_Object retval; | |
| 2687 | |
| 2688 if (ERRB_EQ (errb, ERROR_ME)) | |
| 2689 { | |
| 2690 (meths->validate_matchspec_method) (matchspec); | |
| 2691 retval = Qt; | |
| 2692 } | |
| 2693 else | |
| 2694 { | |
| 2695 Lisp_Object opaque = | |
| 2696 make_opaque_ptr ((void *) meths->validate_matchspec_method); | |
| 2697 struct gcpro gcpro1; | |
| 2698 | |
| 2699 GCPRO1 (opaque); | |
| 2700 retval = call_with_suspended_errors | |
| 2701 ((lisp_fn_t) call_validate_matchspec_method, | |
| 2702 Qnil, Qspecifier, errb, 2, opaque, matchspec); | |
| 2703 | |
| 2704 free_opaque_ptr (opaque); | |
| 2705 UNGCPRO; | |
| 2706 } | |
| 2707 | |
| 2708 return retval; | |
| 2709 } | |
| 2710 else | |
| 2711 { | |
| 563 | 2712 maybe_sferror |
| 428 | 2713 ("Matchspecs not allowed for this specifier type", |
| 2714 intern (meths->name), Qspecifier, errb); | |
| 2715 return Qnil; | |
| 2716 } | |
| 2717 } | |
| 2718 | |
| 442 | 2719 DEFUN ("check-valid-specifier-matchspec", Fcheck_valid_specifier_matchspec, 2, |
| 2720 2, 0, /* | |
| 428 | 2721 Signal an error if MATCHSPEC is invalid for SPECIFIER-TYPE. |
| 2722 See `specifier-matching-instance' for a description of matchspecs. | |
| 2723 */ | |
| 2724 (matchspec, specifier_type)) | |
| 2725 { | |
| 2726 struct specifier_methods *meths = decode_specifier_type (specifier_type, | |
| 2727 ERROR_ME); | |
| 2728 | |
| 2729 return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME); | |
| 2730 } | |
| 2731 | |
| 2732 DEFUN ("valid-specifier-matchspec-p", Fvalid_specifier_matchspec_p, 2, 2, 0, /* | |
| 2733 Return non-nil if MATCHSPEC is valid for SPECIFIER-TYPE. | |
| 2734 See `specifier-matching-instance' for a description of matchspecs. | |
| 2735 */ | |
| 2736 (matchspec, specifier_type)) | |
| 2737 { | |
| 2738 struct specifier_methods *meths = decode_specifier_type (specifier_type, | |
| 2739 ERROR_ME); | |
| 2740 | |
| 2741 return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME_NOT); | |
| 2742 } | |
| 2743 | |
| 2744 /* This function is purposely not callable from Lisp. If a Lisp | |
| 2745 caller wants to set a fallback, they should just set the | |
| 2746 global value. */ | |
| 2747 | |
| 2748 void | |
| 2749 set_specifier_fallback (Lisp_Object specifier, Lisp_Object fallback) | |
| 2750 { | |
| 440 | 2751 Lisp_Specifier *sp = XSPECIFIER (specifier); |
| 428 | 2752 assert (SPECIFIERP (fallback) || |
| 2753 !NILP (Fvalid_inst_list_p (fallback, Fspecifier_type (specifier)))); | |
| 2754 if (SPECIFIERP (fallback)) | |
| 2755 assert (EQ (Fspecifier_type (specifier), Fspecifier_type (fallback))); | |
| 2756 if (BODILY_SPECIFIER_P (sp)) | |
| 2757 GHOST_SPECIFIER(sp)->fallback = fallback; | |
| 2758 else | |
| 2759 sp->fallback = fallback; | |
| 2760 /* call the after-change method */ | |
| 2761 MAYBE_SPECMETH (sp, after_change, | |
| 2762 (bodily_specifier (specifier), Qfallback)); | |
| 2763 recompute_cached_specifier_everywhere (specifier); | |
| 2764 } | |
| 2765 | |
| 2766 DEFUN ("specifier-fallback", Fspecifier_fallback, 1, 1, 0, /* | |
| 2767 Return the fallback value for SPECIFIER. | |
| 2768 Fallback values are provided by the C code for certain built-in | |
| 2953 | 2769 specifiers to make sure that instantiation won't fail even if all |
| 428 | 2770 specs are removed from the specifier, or to implement simple |
| 2771 inheritance behavior (e.g. this method is used to ensure that | |
| 2953 | 2772 faces other than `default' inherit their attributes from `default'). |
| 428 | 2773 By design, you cannot change the fallback value, and specifiers |
| 2774 created with `make-specifier' will never have a fallback (although | |
| 2775 a similar, Lisp-accessible capability may be provided in the future | |
| 2776 to allow for inheritance). | |
| 2777 | |
| 2953 | 2778 The fallback value will be an inst-list that is instantiated like |
| 428 | 2779 any other inst-list, a specifier of the same type as SPECIFIER |
| 2780 \(results in inheritance), or nil for no fallback. | |
| 2781 | |
| 2953 | 2782 When you instantiate a specifier, you can explicitly request that the |
| 428 | 2783 fallback not be consulted. (The C code does this, for example, when |
| 2784 merging faces.) See `specifier-instance'. | |
| 2785 */ | |
| 2786 (specifier)) | |
| 2787 { | |
| 2788 CHECK_SPECIFIER (specifier); | |
| 2789 return Fcopy_tree (XSPECIFIER (specifier)->fallback, Qt); | |
| 2790 } | |
| 2791 | |
| 2792 static Lisp_Object | |
| 2793 specifier_instance_from_inst_list (Lisp_Object specifier, | |
| 2794 Lisp_Object matchspec, | |
| 2795 Lisp_Object domain, | |
| 2796 Lisp_Object inst_list, | |
| 578 | 2797 Error_Behavior errb, int no_quit, |
| 2953 | 2798 Lisp_Object depth, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2799 Lisp_Object *instantiator, |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2800 int no_fallback) |
| 428 | 2801 { |
| 2802 /* This function can GC */ | |
| 440 | 2803 Lisp_Specifier *sp; |
| 3659 | 2804 Lisp_Object device, charset = Qnil, rest; |
| 2805 int count = specpdl_depth (), respected_charsets = 0; | |
| 428 | 2806 struct gcpro gcpro1, gcpro2; |
| 3659 | 2807 enum font_specifier_matchspec_stages stage = initial; |
| 2808 #ifdef DEBUG_XEMACS | |
| 2809 int non_ascii; | |
| 2810 #endif | |
| 428 | 2811 |
| 2812 GCPRO2 (specifier, inst_list); | |
| 2813 | |
| 2814 sp = XSPECIFIER (specifier); | |
| 442 | 2815 device = DOMAIN_DEVICE (domain); |
| 428 | 2816 |
| 2817 if (no_quit) | |
| 3659 | 2818 /* The instantiate method is allowed to call eval. Since it |
| 2819 is quite common for this function to get called from somewhere in | |
| 2820 redisplay we need to make sure that quits are ignored. Otherwise | |
| 2821 Fsignal will abort. */ | |
| 428 | 2822 specbind (Qinhibit_quit, Qt); |
| 2823 | |
| 3659 | 2824 #ifdef MULE |
| 3670 | 2825 if (CONSP(matchspec) && (CHARSETP(Ffind_charset(XCAR(matchspec))))) |
| 3659 | 2826 { |
| 2827 charset = Ffind_charset(XCAR(matchspec)); | |
| 2828 | |
| 2829 #ifdef DEBUG_XEMACS | |
| 2830 /* This is mostly to have somewhere to set debug breakpoints. */ | |
| 2831 if (!EQ(charset, Vcharset_ascii)) | |
| 2832 { | |
| 2833 non_ascii = 1; | |
| 2834 } | |
| 2835 #endif /* DEBUG_XEMACS */ | |
| 2836 | |
| 2837 if (!NILP(XCDR(matchspec))) | |
| 2838 { | |
| 2839 | |
| 2840 #define FROB(new_stage) if (EQ(Q##new_stage, XCDR(matchspec))) \ | |
| 2841 { \ | |
| 2842 stage = new_stage; \ | |
| 2843 } | |
| 2844 | |
| 2845 FROB(initial) | |
| 2846 else FROB(final) | |
| 2847 else assert(0); | |
| 2848 #undef FROB | |
| 2849 | |
| 2850 } | |
| 2851 } | |
| 2852 #endif /* MULE */ | |
| 2853 | |
| 2854 LIST_LOOP(rest, inst_list) | |
| 2855 { | |
| 2856 Lisp_Object tagged_inst = XCAR (rest); | |
| 2857 Lisp_Object tag_set = XCAR (tagged_inst); | |
| 2858 Lisp_Object val, the_instantiator; | |
| 2859 | |
| 2860 if (!device_matches_specifier_tag_set_p (device, tag_set)) | |
| 2861 { | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2862 continue; |
| 3659 | 2863 } |
| 2864 | |
| 2865 val = XCDR (tagged_inst); | |
| 2866 the_instantiator = val; | |
| 2867 | |
| 2868 if (!NILP(charset) && | |
| 2869 !(charset_matches_specifier_tag_set_p (charset, tag_set, stage))) | |
| 2870 { | |
| 2871 ++respected_charsets; | |
| 2872 continue; | |
| 2873 } | |
| 2874 | |
| 2875 if (HAS_SPECMETH_P (sp, instantiate)) | |
| 2876 val = call_with_suspended_errors | |
| 2877 ((lisp_fn_t) RAW_SPECMETH (sp, instantiate), | |
| 2878 Qunbound, Qspecifier, errb, 5, specifier, | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2879 matchspec, domain, val, depth, no_fallback); |
| 3659 | 2880 |
| 2881 if (!UNBOUNDP (val)) | |
| 2882 { | |
| 2883 unbind_to (count); | |
| 2884 UNGCPRO; | |
| 2885 if (instantiator) | |
| 2886 *instantiator = the_instantiator; | |
| 2887 return val; | |
| 2888 } | |
| 2889 } | |
| 2890 | |
| 2891 /* We've checked all the tag sets, and checking the charset part of the | |
| 2892 specifier never returned 0 (preventing the attempted instantiation), so | |
| 2893 there's no need to loop for the second time to avoid checking the | |
| 2894 charsets. */ | |
| 2895 if (!respected_charsets) | |
| 2896 { | |
| 2897 unbind_to (count); | |
| 2898 UNGCPRO; | |
| 2899 return Qunbound; | |
| 2900 } | |
| 2901 | |
| 2902 /* Right, didn't instantiate a specifier last time, perhaps because we | |
| 2903 paid attention to the charset-specific aspects of the specifier. Try | |
| 2904 again without checking the charset information. | |
| 2905 | |
| 2906 We can't emulate the approach for devices, defaulting to matching all | |
| 2907 character sets for a given specifier, because $random font instantiator | |
| 2908 cannot usefully show all character sets, and indeed having it try is a | |
| 2909 failure on our part. */ | |
| 428 | 2910 LIST_LOOP (rest, inst_list) |
| 2911 { | |
| 2912 Lisp_Object tagged_inst = XCAR (rest); | |
| 2913 Lisp_Object tag_set = XCAR (tagged_inst); | |
| 3659 | 2914 Lisp_Object val, the_instantiator; |
| 2915 | |
| 2916 if (!device_matches_specifier_tag_set_p (device, tag_set)) | |
| 428 | 2917 { |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2918 continue; |
| 3659 | 2919 } |
| 2920 | |
| 2921 val = XCDR (tagged_inst); | |
| 2922 the_instantiator = val; | |
| 2923 | |
| 2924 if (HAS_SPECMETH_P (sp, instantiate)) | |
| 2925 val = call_with_suspended_errors | |
| 2926 ((lisp_fn_t) RAW_SPECMETH (sp, instantiate), | |
| 2927 Qunbound, Qspecifier, errb, 5, specifier, | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2928 matchspec, domain, val, depth, no_fallback); |
| 3659 | 2929 |
| 2930 if (!UNBOUNDP (val)) | |
| 2931 { | |
| 2932 unbind_to (count); | |
| 2933 UNGCPRO; | |
| 2934 if (instantiator) | |
| 2935 *instantiator = the_instantiator; | |
| 2936 return val; | |
| 428 | 2937 } |
| 2938 } | |
| 2939 | |
| 771 | 2940 unbind_to (count); |
| 428 | 2941 UNGCPRO; |
| 2942 return Qunbound; | |
| 2943 } | |
| 2944 | |
| 2945 /* Given a SPECIFIER and a DOMAIN, return a specific instance for that | |
| 2946 specifier. Try to find one by checking the specifier types from most | |
| 4437 | 2947 specific (window) to most general (global). If we find an instance, |
| 428 | 2948 return it. Otherwise return Qunbound. */ |
| 2949 | |
| 2950 #define CHECK_INSTANCE_ENTRY(key, matchspec, type) do { \ | |
| 3659 | 2951 Lisp_Object *CIE_inst_list = \ |
| 2952 specifier_get_inst_list (specifier, key, type); \ | |
| 2953 if (CIE_inst_list) \ | |
| 2954 { \ | |
| 2955 Lisp_Object CIE_val = \ | |
| 2956 specifier_instance_from_inst_list (specifier, matchspec, \ | |
| 2957 domain, *CIE_inst_list, \ | |
| 2958 errb, no_quit, depth, \ | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2959 instantiator, no_fallback); \ |
| 3659 | 2960 if (!UNBOUNDP (CIE_val)) \ |
| 2961 return CIE_val; \ | |
| 2962 } \ | |
| 2963 } while (0) | |
| 428 | 2964 |
| 2965 /* We accept any window, frame or device domain and do our checking | |
| 2966 starting from as specific a locale type as we can determine from the | |
| 2967 domain we are passed and going on up through as many other locale types | |
| 2968 as we can determine. In practice, when called from redisplay the | |
| 2969 arg will usually be a window and occasionally a frame. If | |
| 2970 triggered by a user call, who knows what it will usually be. */ | |
| 2953 | 2971 |
| 2972 static Lisp_Object | |
| 2973 specifier_instance_1 (Lisp_Object specifier, Lisp_Object matchspec, | |
| 2974 Lisp_Object domain, Error_Behavior errb, int no_quit, | |
| 2975 int no_fallback, Lisp_Object depth, | |
| 2976 Lisp_Object *instantiator) | |
| 428 | 2977 { |
| 2978 Lisp_Object buffer = Qnil; | |
| 2979 Lisp_Object window = Qnil; | |
| 2980 Lisp_Object frame = Qnil; | |
| 2981 Lisp_Object device = Qnil; | |
| 444 | 2982 Lisp_Specifier *sp = XSPECIFIER (specifier); |
| 428 | 2983 |
| 2953 | 2984 if (instantiator) |
| 2985 *instantiator = Qunbound; | |
| 2986 | |
| 428 | 2987 /* Attempt to determine buffer, window, frame, and device from the |
| 2988 domain. */ | |
| 442 | 2989 /* #### get image instances out of domains! */ |
| 2990 if (IMAGE_INSTANCEP (domain)) | |
| 2991 window = DOMAIN_WINDOW (domain); | |
| 2992 else if (WINDOWP (domain)) | |
| 428 | 2993 window = domain; |
| 2994 else if (FRAMEP (domain)) | |
| 2995 frame = domain; | |
| 2996 else if (DEVICEP (domain)) | |
| 2997 device = domain; | |
| 2998 else | |
| 442 | 2999 /* dmoore writes: [dammit, this should just signal an error or something |
| 3000 shouldn't it?] | |
| 3001 | |
| 3002 No. Errors are handled in Lisp primitives implementation. | |
| 428 | 3003 Invalid domain is a design error here - kkm. */ |
| 2500 | 3004 ABORT (); |
| 428 | 3005 |
| 3006 if (NILP (buffer) && !NILP (window)) | |
| 444 | 3007 buffer = WINDOW_BUFFER (XWINDOW (window)); |
| 428 | 3008 if (NILP (frame) && !NILP (window)) |
| 3009 frame = XWINDOW (window)->frame; | |
| 3010 if (NILP (device)) | |
| 3011 /* frame had better exist; if device is undeterminable, something | |
| 3012 really went wrong. */ | |
| 444 | 3013 device = FRAME_DEVICE (XFRAME (frame)); |
| 428 | 3014 |
| 3015 /* device had better be determined by now; abort if not. */ | |
| 2286 | 3016 (void) DEVICE_CLASS (XDEVICE (device)); |
| 428 | 3017 |
| 3018 depth = make_int (1 + XINT (depth)); | |
| 3019 if (XINT (depth) > 20) | |
| 3020 { | |
| 563 | 3021 maybe_signal_error (Qstack_overflow, |
| 3022 "Apparent loop in specifier inheritance", | |
| 3023 Qunbound, Qspecifier, errb); | |
| 428 | 3024 /* The specification is fucked; at least try the fallback |
| 3025 (which better not be fucked, because it's not changeable | |
| 3026 from Lisp). */ | |
| 3027 depth = Qzero; | |
| 3028 goto do_fallback; | |
| 3029 } | |
| 3030 | |
| 434 | 3031 retry: |
| 428 | 3032 /* First see if we can generate one from the window specifiers. */ |
| 3033 if (!NILP (window)) | |
| 3034 CHECK_INSTANCE_ENTRY (window, matchspec, LOCALE_WINDOW); | |
| 3035 | |
| 3036 /* Next see if we can generate one from the buffer specifiers. */ | |
| 3037 if (!NILP (buffer)) | |
| 3038 CHECK_INSTANCE_ENTRY (buffer, matchspec, LOCALE_BUFFER); | |
| 3039 | |
| 3040 /* Next see if we can generate one from the frame specifiers. */ | |
| 3041 if (!NILP (frame)) | |
| 3042 CHECK_INSTANCE_ENTRY (frame, matchspec, LOCALE_FRAME); | |
| 3043 | |
| 3044 /* If we still haven't succeeded try with the device specifiers. */ | |
| 3045 CHECK_INSTANCE_ENTRY (device, matchspec, LOCALE_DEVICE); | |
| 3046 | |
| 3047 /* Last and least try the global specifiers. */ | |
| 3048 CHECK_INSTANCE_ENTRY (Qglobal, matchspec, LOCALE_GLOBAL); | |
| 3049 | |
| 434 | 3050 do_fallback: |
| 428 | 3051 /* We're out of specifiers and we still haven't generated an |
| 3052 instance. At least try the fallback ... If this fails, | |
| 3053 then we just return Qunbound. */ | |
| 3054 | |
| 3055 if (no_fallback || NILP (sp->fallback)) | |
| 3056 /* I said, I don't want the fallbacks. */ | |
| 3057 return Qunbound; | |
| 3058 | |
| 3059 if (SPECIFIERP (sp->fallback)) | |
| 3060 { | |
| 3061 /* If you introduced loops in the default specifier chain, | |
| 3062 then you're fucked, so you better not do this. */ | |
| 3063 specifier = sp->fallback; | |
| 3064 sp = XSPECIFIER (specifier); | |
| 3065 goto retry; | |
| 3066 } | |
| 3067 | |
| 3068 assert (CONSP (sp->fallback)); | |
| 3069 return specifier_instance_from_inst_list (specifier, matchspec, domain, | |
| 3070 sp->fallback, errb, no_quit, | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
3071 depth, instantiator, |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
3072 no_fallback); |
| 428 | 3073 } |
| 3074 #undef CHECK_INSTANCE_ENTRY | |
| 3075 | |
| 3076 Lisp_Object | |
| 2953 | 3077 specifier_instance (Lisp_Object specifier, Lisp_Object matchspec, |
| 3078 Lisp_Object domain, Error_Behavior errb, int no_quit, | |
| 3079 int no_fallback, Lisp_Object depth) | |
| 3080 { | |
| 3081 return specifier_instance_1 (specifier, matchspec, domain, errb, | |
| 3082 no_quit, no_fallback, depth, NULL); | |
| 3083 } | |
| 3084 | |
| 3085 Lisp_Object | |
| 428 | 3086 specifier_instance_no_quit (Lisp_Object specifier, Lisp_Object matchspec, |
| 578 | 3087 Lisp_Object domain, Error_Behavior errb, |
| 428 | 3088 int no_fallback, Lisp_Object depth) |
| 3089 { | |
| 2953 | 3090 return specifier_instance_1 (specifier, matchspec, domain, errb, |
| 3091 1, no_fallback, depth, NULL); | |
| 3092 } | |
| 3093 | |
| 3094 static Lisp_Object | |
| 3095 specifier_matching_foo (Lisp_Object specifier, | |
| 3096 Lisp_Object matchspec, | |
| 3097 Lisp_Object domain, | |
| 3098 Lisp_Object default_, | |
| 3099 Lisp_Object no_fallback, | |
| 3100 int want_instantiator) | |
| 3101 { | |
| 3102 Lisp_Object instance, instantiator; | |
| 3103 | |
| 3104 CHECK_SPECIFIER (specifier); | |
| 3105 if (!UNBOUNDP (matchspec)) | |
| 3106 check_valid_specifier_matchspec (matchspec, | |
| 3107 XSPECIFIER (specifier)->methods, | |
| 3108 ERROR_ME); | |
| 3109 domain = decode_domain (domain); | |
| 3110 | |
| 3111 instance = specifier_instance_1 (specifier, matchspec, domain, ERROR_ME, | |
| 3112 0, !NILP (no_fallback), Qzero, | |
| 3113 &instantiator); | |
| 3114 return UNBOUNDP (instance) ? default_ : want_instantiator ? instantiator : | |
| 3115 instance; | |
| 428 | 3116 } |
| 3117 | |
| 3118 DEFUN ("specifier-instance", Fspecifier_instance, 1, 4, 0, /* | |
| 3119 Instantiate SPECIFIER (return its value) in DOMAIN. | |
| 3120 If no instance can be generated for this domain, return DEFAULT. | |
| 3121 | |
| 2953 | 3122 DOMAIN is nearly always a window (defaulting to the selected window if |
| 3123 omitted), but can be a window, frame, or device. Other values that are legal | |
| 428 | 3124 as a locale (e.g. a buffer) are not valid as a domain because they do not |
| 3125 provide enough information to identify a particular device (see | |
| 2953 | 3126 `valid-specifier-domain-p'). Window domains are used internally in nearly |
| 3127 all circumstances when computing specifier instances of display properties. | |
| 3128 Frame domains are used in a few circumstances (such as when computing the | |
| 3129 geometry of a frame based on properties such as the toolbar widths), and | |
| 3130 device domains are rarely if ever used internally. | |
| 3131 | |
| 3132 This function looks through the specifications in SPECIFIER that correspond | |
| 3133 to DOMAIN, from most specific (specifications for DOMAIN itself) to most | |
| 3134 general (global specifications), for matching instantiators, and attempts | |
| 3135 to compute an instance value for each instantiator found. The first | |
| 3136 successfully computed value is returned. The corresponding instantiator | |
| 3137 can be returned using `specifier-instantiator'. | |
| 3138 | |
| 3139 A specifier is a generalized object for controlling the value of a property -- | |
| 3140 typically, but not necessarily, a display-related property -- that can vary | |
| 3141 over particular buffers, frames, device types, etc. | |
| 3142 | |
| 3143 A fundamental distinction must be made between the specification of a | |
| 3144 property's value, and the resulting value itself. This distinction is | |
| 3145 clearest in the case of an image -- the specification describes the source | |
| 3146 of the image (for example, a file of JPEG data), and the resulting value | |
| 3147 encapsulates a window-system object describing the image as displayed on a | |
| 3148 particular device (for example, a particular X display). The specification | |
| 3149 might also be an instruction of the form "use the background pixmap of the | |
| 3150 `modeline' face". A similar mapping exists between color strings and | |
| 3151 color-instance objects, and font strings and font-instance objects. In | |
| 3152 some cases, the specification and the resulting value are of the same type, | |
| 3153 but the distinction is still logically made. | |
| 3154 | |
| 3155 The specification of a value is called an instantiator, and the resulting | |
| 3156 value the instance. | |
| 428 | 3157 |
| 3158 "Instantiating" a specifier in a particular domain means determining | |
| 3159 the specifier's "value" in that domain. This is accomplished by | |
| 3160 searching through the specifications in the specifier that correspond | |
| 3161 to all locales that can be derived from the given domain, from specific | |
| 3162 to general. In most cases, the domain is an Emacs window. In that case | |
| 3163 specifications are searched for as follows: | |
| 3164 | |
| 3165 1. A specification whose locale is the window itself; | |
| 3166 2. A specification whose locale is the window's buffer; | |
| 3167 3. A specification whose locale is the window's frame; | |
| 3168 4. A specification whose locale is the window's frame's device; | |
| 2953 | 3169 5. A specification whose locale is `global'. |
| 428 | 3170 |
| 3171 If all of those fail, then the C-code-provided fallback value for | |
| 3172 this specifier is consulted (see `specifier-fallback'). If it is | |
| 3173 an inst-list, then this function attempts to instantiate that list | |
| 3174 just as when a specification is located in the first five steps above. | |
| 3175 If the fallback is a specifier, `specifier-instance' is called | |
| 3176 recursively on this specifier and the return value used. Note, | |
| 3177 however, that if the optional argument NO-FALLBACK is non-nil, | |
| 3178 the fallback value will not be consulted. | |
| 3179 | |
| 3180 Note that there may be more than one specification matching a particular | |
| 3181 locale; all such specifications are considered before looking for any | |
| 3182 specifications for more general locales. Any particular specification | |
| 3183 that is found may be rejected because its tag set does not match the | |
| 3184 device being instantiated over, or because the specification is not | |
| 3185 valid for the device of the given domain (e.g. the font or color name | |
| 3186 does not exist for this particular X server). | |
| 3187 | |
| 793 | 3188 NOTE: When errors occur in the process of trying a particular instantiator, |
| 3189 and the instantiator is thus skipped, warnings will be issued at level | |
| 3190 `debug'. Normally, such warnings are ignored entirely, but you can change | |
| 3191 this by setting `log-warning-minimum-level'. This is useful if you're | |
| 3192 trying to debug why particular instantiators are not being processed. | |
| 3193 | |
| 428 | 3194 The returned value is dependent on the type of specifier. For example, |
| 3195 for a font specifier (as returned by the `face-font' function), the returned | |
| 3196 value will be a font-instance object. For glyphs, the returned value | |
| 2953 | 3197 will be an image-instance object. |
| 428 | 3198 |
| 3199 See also `specifier-matching-instance'. | |
| 3200 */ | |
| 3201 (specifier, domain, default_, no_fallback)) | |
| 3202 { | |
| 2953 | 3203 return specifier_matching_foo (specifier, Qunbound, domain, default_, |
| 3204 no_fallback, 0); | |
| 3205 } | |
| 3206 | |
| 3207 DEFUN ("specifier-instantiator", Fspecifier_instantiator, 1, 4, 0, /* | |
| 3208 Return instantiator that would be used to instantiate SPECIFIER in DOMAIN. | |
| 3209 If no instance can be generated for this domain, return DEFAULT. | |
| 3210 | |
| 3211 DOMAIN should be a window, frame, or device. Other values that are legal | |
| 3212 as a locale (e.g. a buffer) are not valid as a domain because they do not | |
| 3213 provide enough information to identify a particular device (see | |
| 3214 `valid-specifier-domain-p'). DOMAIN defaults to the selected window | |
| 3215 if omitted. | |
| 3216 | |
| 3217 See `specifier-instance' for more information about the instantiation process. | |
| 3218 */ | |
| 3219 (specifier, domain, default_, no_fallback)) | |
| 3220 { | |
| 3221 return specifier_matching_foo (specifier, Qunbound, domain, default_, | |
| 3222 no_fallback, 1); | |
| 428 | 3223 } |
| 3224 | |
| 3225 DEFUN ("specifier-matching-instance", Fspecifier_matching_instance, 2, 5, 0, /* | |
| 3226 Return an instance for SPECIFIER in DOMAIN that matches MATCHSPEC. | |
| 3227 If no instance can be generated for this domain, return DEFAULT. | |
| 3228 | |
| 3229 This function is identical to `specifier-instance' except that a | |
| 3230 specification will only be considered if it matches MATCHSPEC. | |
| 3231 The definition of "match", and allowed values for MATCHSPEC, are | |
| 3232 dependent on the particular type of specifier. Here are some examples: | |
| 3233 | |
| 3234 -- For chartable (e.g. display table) specifiers, MATCHSPEC should be a | |
| 3235 character, and the specification (a chartable) must give a value for | |
| 3236 that character in order to be considered. This allows you to specify, | |
| 3237 e.g., a buffer-local display table that only gives values for particular | |
| 3238 characters. All other characters are handled as if the buffer-local | |
| 3239 display table is not there. (Chartable specifiers are not yet | |
| 3240 implemented.) | |
| 3241 | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
3242 -- For font specifiers, MATCHSPEC should be a cons (CHARSET . STAGE). |
| 3674 | 3243 The defined stages are currently `initial' and `final'. On X11, 'initial |
| 3244 is used when the font matching process is looking for fonts that match | |
| 3245 the desired registries of the charset--see the `charset-registries' | |
| 3246 function. If that match process fails, then the 'final stage comes into | |
| 3247 play; this means that a more general lookup is desired, and that a font | |
| 3248 doesn't necessarily have to match the desired XLFD for the face, just the | |
| 3249 charset repertoire for this charset. It also means that the charset | |
| 3250 registry and encoding used will be `iso10646-1', and the characters will | |
| 3251 be converted to display using that registry. | |
| 3252 | |
| 3253 See `define-specifier-tag' for details on how to create a tag that | |
| 3254 specifies a given character set and stage combination. You can supply | |
| 3255 such a tag to `set-face-font' in order to set a face's font for that | |
| 3256 character set and stage combination. | |
| 428 | 3257 */ |
| 3258 (specifier, matchspec, domain, default_, no_fallback)) | |
| 3259 { | |
| 2953 | 3260 return specifier_matching_foo (specifier, matchspec, domain, default_, |
| 3261 no_fallback, 0); | |
| 3262 } | |
| 3263 | |
| 3264 DEFUN ("specifier-matching-instantiator", Fspecifier_matching_instantiator, | |
| 3265 2, 5, 0, /* | |
| 3266 Return instantiator for instance of SPECIFIER in DOMAIN that matches MATCHSPEC. | |
| 3267 If no instance can be generated for this domain, return DEFAULT. | |
| 3268 | |
| 3269 This function is identical to `specifier-matching-instance' but returns | |
| 3270 the instantiator used to generate the instance, rather than the actual | |
| 3271 instance. | |
| 3272 */ | |
| 3273 (specifier, matchspec, domain, default_, no_fallback)) | |
| 3274 { | |
| 3275 return specifier_matching_foo (specifier, matchspec, domain, default_, | |
| 3276 no_fallback, 1); | |
| 3277 } | |
| 3278 | |
| 3279 static Lisp_Object | |
| 3280 specifier_matching_foo_from_inst_list (Lisp_Object specifier, | |
| 3281 Lisp_Object matchspec, | |
| 3282 Lisp_Object domain, | |
| 3283 Lisp_Object inst_list, | |
| 3284 Lisp_Object default_, | |
| 3285 int want_instantiator) | |
| 3286 { | |
| 3287 Lisp_Object val = Qunbound; | |
| 3288 Lisp_Specifier *sp = XSPECIFIER (specifier); | |
| 3289 struct gcpro gcpro1; | |
| 3290 Lisp_Object built_up_list = Qnil; | |
| 3291 Lisp_Object instantiator; | |
| 428 | 3292 |
| 3293 CHECK_SPECIFIER (specifier); | |
| 2953 | 3294 if (!UNBOUNDP (matchspec)) |
| 3295 check_valid_specifier_matchspec (matchspec, | |
| 3296 XSPECIFIER (specifier)->methods, | |
| 3297 ERROR_ME); | |
| 3298 check_valid_domain (domain); | |
| 3299 check_valid_inst_list (inst_list, sp->methods, ERROR_ME); | |
| 3300 GCPRO1 (built_up_list); | |
| 3301 built_up_list = build_up_processed_list (specifier, domain, inst_list); | |
| 3302 if (!NILP (built_up_list)) | |
| 3303 val = specifier_instance_from_inst_list (specifier, matchspec, domain, | |
| 3304 built_up_list, ERROR_ME, | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
3305 0, Qzero, &instantiator, 0); |
| 2953 | 3306 UNGCPRO; |
| 3307 return UNBOUNDP (val) ? default_ : want_instantiator ? instantiator : val; | |
| 3308 | |
| 428 | 3309 } |
| 3310 | |
| 3311 DEFUN ("specifier-instance-from-inst-list", Fspecifier_instance_from_inst_list, | |
| 3312 3, 4, 0, /* | |
| 3313 Attempt to convert a particular inst-list into an instance. | |
| 3314 This attempts to instantiate INST-LIST in the given DOMAIN, | |
| 3315 as if INST-LIST existed in a specification in SPECIFIER. If | |
| 3316 the instantiation fails, DEFAULT is returned. In most circumstances, | |
| 3317 you should not use this function; use `specifier-instance' instead. | |
| 3318 */ | |
| 3319 (specifier, domain, inst_list, default_)) | |
| 3320 { | |
| 2953 | 3321 return specifier_matching_foo_from_inst_list (specifier, Qunbound, |
| 3322 domain, inst_list, default_, | |
| 3323 0); | |
| 3324 } | |
| 3325 | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
3326 DEFUN ("specifier-instantiator-from-inst-list", |
| 3659 | 3327 Fspecifier_instantiator_from_inst_list, 3, 4, 0, /* |
| 2953 | 3328 Attempt to convert an inst-list into an instance; return instantiator. |
| 3329 This is identical to `specifier-instance-from-inst-list' but returns | |
| 3330 the instantiator used to generate the instance, rather than the instance | |
| 3331 itself. | |
| 3332 */ | |
| 3333 (specifier, domain, inst_list, default_)) | |
| 3334 { | |
| 3335 return specifier_matching_foo_from_inst_list (specifier, Qunbound, | |
| 3336 domain, inst_list, default_, | |
| 3337 1); | |
| 428 | 3338 } |
| 3339 | |
| 442 | 3340 DEFUN ("specifier-matching-instance-from-inst-list", |
| 3341 Fspecifier_matching_instance_from_inst_list, | |
| 428 | 3342 4, 5, 0, /* |
| 3343 Attempt to convert a particular inst-list into an instance. | |
| 3344 This attempts to instantiate INST-LIST in the given DOMAIN | |
| 3345 \(as if INST-LIST existed in a specification in SPECIFIER), | |
| 3346 matching the specifications against MATCHSPEC. | |
| 3347 | |
| 3348 This function is analogous to `specifier-instance-from-inst-list' | |
| 3349 but allows for specification-matching as in `specifier-matching-instance'. | |
| 3350 See that function for a description of exactly how the matching process | |
| 3351 works. | |
| 3352 */ | |
| 3353 (specifier, matchspec, domain, inst_list, default_)) | |
| 3354 { | |
| 2953 | 3355 return specifier_matching_foo_from_inst_list (specifier, matchspec, |
| 3356 domain, inst_list, default_, | |
| 3357 0); | |
| 3358 } | |
| 3359 | |
| 3360 DEFUN ("specifier-matching-instantiator-from-inst-list", | |
| 3361 Fspecifier_matching_instantiator_from_inst_list, | |
| 3362 4, 5, 0, /* | |
| 3363 Attempt to convert an inst-list into an instance; return instantiator. | |
| 3364 This is identical to `specifier-matching-instance-from-inst-list' but returns | |
| 3365 the instantiator used to generate the instance, rather than the instance | |
| 3366 itself. | |
| 3367 */ | |
| 3368 (specifier, matchspec, domain, inst_list, default_)) | |
| 3369 { | |
| 3370 return specifier_matching_foo_from_inst_list (specifier, matchspec, | |
| 3371 domain, inst_list, default_, | |
| 3372 1); | |
| 428 | 3373 } |
| 3374 | |
| 3375 | |
| 3376 /************************************************************************/ | |
| 3377 /* Caching in the struct window or frame */ | |
| 3378 /************************************************************************/ | |
| 3379 | |
| 853 | 3380 /* Cause the current value of SPECIFIER in the domain of each frame and/or |
| 3381 window to be cached in the struct frame at STRUCT_FRAME_OFFSET and the | |
| 3382 struct window at STRUCT_WINDOW_OFFSET. When the value changes in a | |
| 3383 particular window, VALUE_CHANGED_IN_WINDOW is called. When the value | |
| 3384 changes in a particular frame, VALUE_CHANGED_IN_FRAME is called. | |
| 3385 | |
| 3386 Either STRUCT_WINDOW_OFFSET or STRUCT_FRAME_OFFSET can be 0 to indicate | |
| 3387 no caching in that sort of object. However, if they're not 0, you | |
| 3388 must supply a corresponding value-changed function. (This is the case | |
| 3389 so that you are forced to consider the ramifications of a value change. | |
| 3390 You nearly always need to do something, e.g. set a dirty flag.) | |
| 3391 | |
| 3392 If you create a built-in specifier, you should do the following: | |
| 3393 | |
| 3394 - Make sure the file you create the specifier in has a | |
| 3659 | 3395 specifier_vars_of_foo() function. If not, create it, declare it in |
| 3396 symsinit.h, and make sure it's called in the appropriate place in | |
| 3397 emacs.c. | |
| 853 | 3398 - In specifier_vars_of_foo(), do a DEFVAR_SPECIFIER(), followed by |
| 3659 | 3399 initializing the specifier using Fmake_specifier(), followed by |
| 3400 set_specifier_fallback(), followed (optionally) by | |
| 3401 set_specifier_caching(). | |
| 853 | 3402 - If you used set_specifier_caching(), make sure to create the |
| 3659 | 3403 appropriate value-changed functions. Also make sure to add the |
| 3404 appropriate slots where the values are cached to frameslots.h and | |
| 3405 winslots.h. | |
| 853 | 3406 |
| 3407 Do a grep for menubar_visible_p for an example. | |
| 3408 */ | |
| 428 | 3409 |
| 3410 /* #### It would be nice if the specifier caching automatically knew | |
| 3411 about specifier fallbacks, so we didn't have to do it ourselves. */ | |
| 3412 | |
| 3413 void | |
| 3414 set_specifier_caching (Lisp_Object specifier, int struct_window_offset, | |
| 3415 void (*value_changed_in_window) | |
| 3416 (Lisp_Object specifier, struct window *w, | |
| 3417 Lisp_Object oldval), | |
| 3418 int struct_frame_offset, | |
| 3419 void (*value_changed_in_frame) | |
| 3420 (Lisp_Object specifier, struct frame *f, | |
| 444 | 3421 Lisp_Object oldval), |
| 3422 int always_recompute) | |
| 428 | 3423 { |
| 440 | 3424 Lisp_Specifier *sp = XSPECIFIER (specifier); |
| 428 | 3425 assert (!GHOST_SPECIFIER_P (sp)); |
| 3426 | |
| 3427 if (!sp->caching) | |
| 3092 | 3428 #ifdef NEW_GC |
|
5120
d1247f3cc363
latest work on lisp-object workspace;
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
3429 sp->caching = XSPECIFIER_CACHING (ALLOC_LISP_OBJECT (specifier_caching)); |
| 3092 | 3430 #else /* not NEW_GC */ |
| 3659 | 3431 sp->caching = xnew_and_zero (struct specifier_caching); |
| 3092 | 3432 #endif /* not NEW_GC */ |
| 428 | 3433 sp->caching->offset_into_struct_window = struct_window_offset; |
| 3434 sp->caching->value_changed_in_window = value_changed_in_window; | |
| 3435 sp->caching->offset_into_struct_frame = struct_frame_offset; | |
| 3436 sp->caching->value_changed_in_frame = value_changed_in_frame; | |
| 853 | 3437 if (struct_window_offset) |
| 3438 assert (value_changed_in_window); | |
| 3439 if (struct_frame_offset) | |
| 3440 assert (value_changed_in_frame); | |
| 444 | 3441 sp->caching->always_recompute = always_recompute; |
| 428 | 3442 Vcached_specifiers = Fcons (specifier, Vcached_specifiers); |
| 3443 if (BODILY_SPECIFIER_P (sp)) | |
| 3444 GHOST_SPECIFIER(sp)->caching = sp->caching; | |
| 3445 recompute_cached_specifier_everywhere (specifier); | |
| 3446 } | |
| 3447 | |
| 3448 static void | |
| 3449 recompute_one_cached_specifier_in_window (Lisp_Object specifier, | |
| 3450 struct window *w) | |
| 3451 { | |
| 3452 Lisp_Object window; | |
| 444 | 3453 Lisp_Object newval, *location, oldval; |
| 428 | 3454 |
| 3455 assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier))); | |
| 3456 | |
| 793 | 3457 window = wrap_window (w); |
| 428 | 3458 |
| 3459 newval = specifier_instance (specifier, Qunbound, window, ERROR_ME_WARN, | |
| 3460 0, 0, Qzero); | |
| 3461 /* If newval ended up Qunbound, then the calling functions | |
| 3462 better be able to deal. If not, set a default so this | |
| 3463 never happens or correct it in the value_changed_in_window | |
| 3464 method. */ | |
| 3465 location = (Lisp_Object *) | |
| 3466 ((char *) w + XSPECIFIER (specifier)->caching->offset_into_struct_window); | |
| 442 | 3467 /* #### What's the point of this check, other than to optimize image |
| 3468 instance instantiation? Unless you specify a caching instantiate | |
| 3469 method the instantiation that specifier_instance will do will | |
| 3470 always create a new copy. Thus EQ will always fail. Unfortunately | |
| 3471 calling equal is no good either as this doesn't take into account | |
| 3472 things attached to the specifier - for instance strings on | |
| 3473 extents. --andyp */ | |
| 444 | 3474 if (!EQ (newval, *location) || XSPECIFIER (specifier)->caching->always_recompute) |
| 428 | 3475 { |
| 444 | 3476 oldval = *location; |
| 428 | 3477 *location = newval; |
| 3478 (XSPECIFIER (specifier)->caching->value_changed_in_window) | |
| 3479 (specifier, w, oldval); | |
| 3480 } | |
| 3481 } | |
| 3482 | |
| 3483 static void | |
| 3484 recompute_one_cached_specifier_in_frame (Lisp_Object specifier, | |
| 3485 struct frame *f) | |
| 3486 { | |
| 3487 Lisp_Object frame; | |
| 444 | 3488 Lisp_Object newval, *location, oldval; |
| 428 | 3489 |
| 3490 assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier))); | |
| 3491 | |
| 793 | 3492 frame = wrap_frame (f); |
| 428 | 3493 |
| 3494 newval = specifier_instance (specifier, Qunbound, frame, ERROR_ME_WARN, | |
| 3495 0, 0, Qzero); | |
| 3496 /* If newval ended up Qunbound, then the calling functions | |
| 3497 better be able to deal. If not, set a default so this | |
| 3498 never happens or correct it in the value_changed_in_frame | |
| 3499 method. */ | |
| 3500 location = (Lisp_Object *) | |
| 3501 ((char *) f + XSPECIFIER (specifier)->caching->offset_into_struct_frame); | |
| 444 | 3502 if (!EQ (newval, *location) || XSPECIFIER (specifier)->caching->always_recompute) |
| 428 | 3503 { |
| 444 | 3504 oldval = *location; |
| 428 | 3505 *location = newval; |
| 3506 (XSPECIFIER (specifier)->caching->value_changed_in_frame) | |
| 3507 (specifier, f, oldval); | |
| 3508 } | |
| 3509 } | |
| 3510 | |
| 3511 void | |
| 3512 recompute_all_cached_specifiers_in_window (struct window *w) | |
| 3513 { | |
| 3514 Lisp_Object rest; | |
| 3515 | |
| 3516 LIST_LOOP (rest, Vcached_specifiers) | |
| 3517 { | |
| 3518 Lisp_Object specifier = XCAR (rest); | |
| 3519 if (XSPECIFIER (specifier)->caching->offset_into_struct_window) | |
| 3520 recompute_one_cached_specifier_in_window (specifier, w); | |
| 3521 } | |
| 3522 } | |
| 3523 | |
| 3524 void | |
| 3525 recompute_all_cached_specifiers_in_frame (struct frame *f) | |
| 3526 { | |
| 3527 Lisp_Object rest; | |
| 3528 | |
| 3529 LIST_LOOP (rest, Vcached_specifiers) | |
| 3530 { | |
| 3531 Lisp_Object specifier = XCAR (rest); | |
| 3532 if (XSPECIFIER (specifier)->caching->offset_into_struct_frame) | |
| 3533 recompute_one_cached_specifier_in_frame (specifier, f); | |
| 3534 } | |
| 3535 } | |
| 3536 | |
| 3537 static int | |
| 3538 recompute_cached_specifier_everywhere_mapfun (struct window *w, | |
| 3539 void *closure) | |
| 3540 { | |
| 3541 Lisp_Object specifier = Qnil; | |
| 3542 | |
| 826 | 3543 specifier = VOID_TO_LISP (closure); |
| 428 | 3544 recompute_one_cached_specifier_in_window (specifier, w); |
| 3545 return 0; | |
| 3546 } | |
| 3547 | |
| 3548 static void | |
| 3549 recompute_cached_specifier_everywhere (Lisp_Object specifier) | |
| 3550 { | |
| 3551 Lisp_Object frmcons, devcons, concons; | |
| 3552 | |
| 3553 specifier = bodily_specifier (specifier); | |
| 3554 | |
| 3555 if (!XSPECIFIER (specifier)->caching) | |
| 3556 return; | |
| 3557 | |
| 3558 if (XSPECIFIER (specifier)->caching->offset_into_struct_window) | |
| 3559 { | |
| 3560 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons) | |
| 3561 map_windows (XFRAME (XCAR (frmcons)), | |
| 3562 recompute_cached_specifier_everywhere_mapfun, | |
| 3563 LISP_TO_VOID (specifier)); | |
| 3564 } | |
| 3565 | |
| 3566 if (XSPECIFIER (specifier)->caching->offset_into_struct_frame) | |
| 3567 { | |
| 3568 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons) | |
| 3569 recompute_one_cached_specifier_in_frame (specifier, | |
| 3570 XFRAME (XCAR (frmcons))); | |
| 3571 } | |
| 3572 } | |
| 3573 | |
| 3574 DEFUN ("set-specifier-dirty-flag", Fset_specifier_dirty_flag, 1, 1, 0, /* | |
| 3575 Force recomputation of any caches associated with SPECIFIER. | |
| 3576 Note that this automatically happens whenever you change a specification | |
| 3577 in SPECIFIER; you do not have to call this function then. | |
| 3578 One example of where this function is useful is when you have a | |
| 3579 toolbar button whose `active-p' field is an expression to be | |
| 3580 evaluated. Calling `set-specifier-dirty-flag' on the | |
| 3581 toolbar specifier will force the `active-p' fields to be | |
| 3582 recomputed. | |
| 3583 */ | |
| 3584 (specifier)) | |
| 3585 { | |
| 3586 CHECK_SPECIFIER (specifier); | |
| 3587 recompute_cached_specifier_everywhere (specifier); | |
| 3588 return Qnil; | |
| 3589 } | |
| 3590 | |
| 3591 | |
| 3592 /************************************************************************/ | |
| 3593 /* Generic specifier type */ | |
| 3594 /************************************************************************/ | |
| 3595 | |
| 3596 DEFINE_SPECIFIER_TYPE (generic); | |
| 3597 | |
| 3598 #if 0 | |
| 3599 | |
| 3600 /* This is the string that used to be in `generic-specifier-p'. | |
| 3601 The idea is good, but it doesn't quite work in the form it's | |
| 3602 in. (One major problem is that validating an instantiator | |
| 3603 is supposed to require only that the specifier type is passed, | |
| 3604 while with this approach the actual specifier is needed.) | |
| 3605 | |
| 3606 What really needs to be done is to write a function | |
| 3607 `make-specifier-type' that creates new specifier types. | |
| 442 | 3608 |
| 3609 #### [I'll look into this for 19.14.] Well, sometime. (Currently | |
| 3610 May 2000, 21.2 is in development. 19.14 was released in June 1996.) */ | |
| 428 | 3611 |
| 3612 "A generic specifier is a generalized kind of specifier with user-defined\n" | |
| 3613 "semantics. The instantiator can be any kind of Lisp object, and the\n" | |
| 3614 "instance computed from it is likewise any kind of Lisp object. The\n" | |
| 3615 "SPECIFIER-DATA should be an alist of methods governing how the specifier\n" | |
| 3616 "works. All methods are optional, and reasonable default methods will be\n" | |
| 2953 | 3617 "provided. Currently there are two defined methods: `instantiate' and\n" |
| 3618 "`validate'.\n" | |
| 428 | 3619 "\n" |
| 2953 | 3620 "`instantiate' specifies how to do the instantiation; if omitted, the\n" |
| 428 | 3621 "instantiator itself is simply returned as the instance. The method\n" |
| 3622 "should be a function that accepts three parameters (a specifier, the\n" | |
| 3623 "instantiator that matched the domain being instantiated over, and that\n" | |
| 3624 "domain), and should return a one-element list containing the instance,\n" | |
| 3625 "or nil if no instance exists. Note that the domain passed to this function\n" | |
| 3626 "is the domain being instantiated over, which may not be the same as the\n" | |
| 3627 "locale contained in the specification corresponding to the instantiator\n" | |
| 3628 "(for example, the domain being instantiated over could be a window, but\n" | |
| 3629 "the locale corresponding to the passed instantiator could be the window's\n" | |
| 3630 "buffer or frame).\n" | |
| 3631 "\n" | |
| 2953 | 3632 "`validate' specifies whether a given instantiator is valid; if omitted,\n" |
| 428 | 3633 "all instantiators are considered valid. It should be a function of\n" |
| 3634 "two arguments: an instantiator and a flag CAN-SIGNAL-ERROR. If this\n" | |
| 3635 "flag is false, the function must simply return t or nil indicating\n" | |
| 3636 "whether the instantiator is valid. If this flag is true, the function\n" | |
| 3637 "is free to signal an error if it encounters an invalid instantiator\n" | |
| 3638 "(this can be useful for issuing a specific error about exactly why the\n" | |
| 3639 "instantiator is valid). It can also return nil to indicate an invalid\n" | |
| 3640 "instantiator; in this case, a general error will be signalled." | |
| 3641 | |
| 3642 #endif /* 0 */ | |
| 3643 | |
| 3644 DEFUN ("generic-specifier-p", Fgeneric_specifier_p, 1, 1, 0, /* | |
| 3645 Return non-nil if OBJECT is a generic specifier. | |
| 3646 | |
| 442 | 3647 See `make-generic-specifier' for a description of possible generic |
| 3648 instantiators. | |
| 428 | 3649 */ |
| 3650 (object)) | |
| 3651 { | |
| 3652 return GENERIC_SPECIFIERP (object) ? Qt : Qnil; | |
| 3653 } | |
| 3654 | |
| 3655 | |
| 3656 /************************************************************************/ | |
| 3657 /* Integer specifier type */ | |
| 3658 /************************************************************************/ | |
| 3659 | |
| 3660 DEFINE_SPECIFIER_TYPE (integer); | |
| 3661 | |
| 3662 static void | |
| 3663 integer_validate (Lisp_Object instantiator) | |
| 3664 { | |
| 3665 CHECK_INT (instantiator); | |
| 3666 } | |
| 3667 | |
| 3668 DEFUN ("integer-specifier-p", Finteger_specifier_p, 1, 1, 0, /* | |
| 3669 Return non-nil if OBJECT is an integer specifier. | |
| 442 | 3670 |
| 3671 See `make-integer-specifier' for a description of possible integer | |
| 3672 instantiators. | |
| 428 | 3673 */ |
| 3674 (object)) | |
| 3675 { | |
| 3676 return INTEGER_SPECIFIERP (object) ? Qt : Qnil; | |
| 3677 } | |
| 3678 | |
| 3679 /************************************************************************/ | |
| 3680 /* Non-negative-integer specifier type */ | |
| 3681 /************************************************************************/ | |
| 3682 | |
| 3683 DEFINE_SPECIFIER_TYPE (natnum); | |
| 3684 | |
| 3685 static void | |
| 3686 natnum_validate (Lisp_Object instantiator) | |
| 3687 { | |
| 3688 CHECK_NATNUM (instantiator); | |
| 3689 } | |
| 3690 | |
| 3691 DEFUN ("natnum-specifier-p", Fnatnum_specifier_p, 1, 1, 0, /* | |
| 3692 Return non-nil if OBJECT is a natnum (non-negative-integer) specifier. | |
| 442 | 3693 |
| 3694 See `make-natnum-specifier' for a description of possible natnum | |
| 3695 instantiators. | |
| 428 | 3696 */ |
| 3697 (object)) | |
| 3698 { | |
| 3699 return NATNUM_SPECIFIERP (object) ? Qt : Qnil; | |
| 3700 } | |
| 3701 | |
| 3702 /************************************************************************/ | |
| 3703 /* Boolean specifier type */ | |
| 3704 /************************************************************************/ | |
| 3705 | |
| 3706 DEFINE_SPECIFIER_TYPE (boolean); | |
| 3707 | |
| 3708 static void | |
| 3709 boolean_validate (Lisp_Object instantiator) | |
| 3710 { | |
| 3711 if (!EQ (instantiator, Qt) && !EQ (instantiator, Qnil)) | |
| 563 | 3712 invalid_constant ("Must be t or nil", instantiator); |
| 428 | 3713 } |
| 3714 | |
| 3715 DEFUN ("boolean-specifier-p", Fboolean_specifier_p, 1, 1, 0, /* | |
| 3716 Return non-nil if OBJECT is a boolean specifier. | |
| 442 | 3717 |
| 3718 See `make-boolean-specifier' for a description of possible boolean | |
| 3719 instantiators. | |
| 428 | 3720 */ |
| 3721 (object)) | |
| 3722 { | |
| 3723 return BOOLEAN_SPECIFIERP (object) ? Qt : Qnil; | |
| 3724 } | |
| 3725 | |
| 3726 /************************************************************************/ | |
| 3727 /* Display table specifier type */ | |
| 3728 /************************************************************************/ | |
| 3729 | |
| 3730 DEFINE_SPECIFIER_TYPE (display_table); | |
| 3731 | |
| 3659 | 3732 #define VALID_SINGLE_DISPTABLE_INSTANTIATOR_P(instantiator) \ |
| 3733 (VECTORP (instantiator) \ | |
| 3734 || (CHAR_TABLEP (instantiator) \ | |
| 3735 && (XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_CHAR \ | |
| 442 | 3736 || XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_GENERIC)) \ |
| 428 | 3737 || RANGE_TABLEP (instantiator)) |
| 3738 | |
| 3739 static void | |
| 3740 display_table_validate (Lisp_Object instantiator) | |
| 3741 { | |
| 3742 if (NILP (instantiator)) | |
| 3743 /* OK */ | |
| 3744 ; | |
| 3745 else if (CONSP (instantiator)) | |
| 3746 { | |
| 2367 | 3747 EXTERNAL_LIST_LOOP_2 (car, instantiator) |
| 428 | 3748 { |
| 3749 if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (car)) | |
| 3750 goto lose; | |
| 3751 } | |
| 3752 } | |
| 3753 else | |
| 3754 { | |
| 3755 if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (instantiator)) | |
| 3756 { | |
| 3757 lose: | |
| 442 | 3758 dead_wrong_type_argument |
| 3759 (display_table_specifier_methods->predicate_symbol, | |
| 3659 | 3760 instantiator); |
| 428 | 3761 } |
| 3762 } | |
| 3763 } | |
| 3764 | |
| 3765 DEFUN ("display-table-specifier-p", Fdisplay_table_specifier_p, 1, 1, 0, /* | |
| 3766 Return non-nil if OBJECT is a display-table specifier. | |
| 442 | 3767 |
| 3768 See `current-display-table' for a description of possible display-table | |
| 3769 instantiators. | |
| 428 | 3770 */ |
| 3771 (object)) | |
| 3772 { | |
| 3773 return DISPLAYTABLE_SPECIFIERP (object) ? Qt : Qnil; | |
| 3774 } | |
| 3775 | |
| 3776 | |
| 3777 /************************************************************************/ | |
| 3778 /* Initialization */ | |
| 3779 /************************************************************************/ | |
| 3780 | |
| 3781 void | |
| 3782 syms_of_specifier (void) | |
| 3783 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
3784 INIT_LISP_OBJECT (specifier); |
| 3092 | 3785 #ifdef NEW_GC |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
3786 INIT_LISP_OBJECT (specifier_caching); |
| 3092 | 3787 #endif /* NEW_GC */ |
| 442 | 3788 |
| 3789 DEFSYMBOL (Qspecifierp); | |
| 3790 | |
| 3791 DEFSYMBOL (Qconsole_type); | |
| 3792 DEFSYMBOL (Qdevice_class); | |
| 3793 | |
| 3794 /* specifier types defined in general.c. */ | |
| 428 | 3795 |
| 3796 DEFSUBR (Fvalid_specifier_type_p); | |
| 3797 DEFSUBR (Fspecifier_type_list); | |
| 3798 DEFSUBR (Fmake_specifier); | |
| 3799 DEFSUBR (Fspecifierp); | |
| 3800 DEFSUBR (Fspecifier_type); | |
| 3801 | |
| 3802 DEFSUBR (Fvalid_specifier_locale_p); | |
| 3803 DEFSUBR (Fvalid_specifier_domain_p); | |
| 3804 DEFSUBR (Fvalid_specifier_locale_type_p); | |
| 3805 DEFSUBR (Fspecifier_locale_type_from_locale); | |
| 3806 | |
| 3807 DEFSUBR (Fvalid_specifier_tag_p); | |
| 3808 DEFSUBR (Fvalid_specifier_tag_set_p); | |
| 3809 DEFSUBR (Fcanonicalize_tag_set); | |
| 3810 DEFSUBR (Fdevice_matches_specifier_tag_set_p); | |
| 3811 DEFSUBR (Fdefine_specifier_tag); | |
| 3812 DEFSUBR (Fdevice_matching_specifier_tag_list); | |
| 3673 | 3813 |
| 428 | 3814 DEFSUBR (Fspecifier_tag_list); |
| 3659 | 3815 DEFSUBR (Fspecifier_tag_device_predicate); |
| 3816 DEFSUBR (Fspecifier_tag_charset_predicate); | |
| 428 | 3817 |
| 3818 DEFSUBR (Fcheck_valid_instantiator); | |
| 3819 DEFSUBR (Fvalid_instantiator_p); | |
| 3820 DEFSUBR (Fcheck_valid_inst_list); | |
| 3821 DEFSUBR (Fvalid_inst_list_p); | |
| 3822 DEFSUBR (Fcheck_valid_spec_list); | |
| 3823 DEFSUBR (Fvalid_spec_list_p); | |
| 3824 DEFSUBR (Fadd_spec_to_specifier); | |
| 3825 DEFSUBR (Fadd_spec_list_to_specifier); | |
| 3826 DEFSUBR (Fspecifier_spec_list); | |
| 3827 DEFSUBR (Fspecifier_specs); | |
| 3828 DEFSUBR (Fremove_specifier); | |
| 3829 DEFSUBR (Fcopy_specifier); | |
| 3830 | |
| 3831 DEFSUBR (Fcheck_valid_specifier_matchspec); | |
| 3832 DEFSUBR (Fvalid_specifier_matchspec_p); | |
| 3833 DEFSUBR (Fspecifier_fallback); | |
| 3834 DEFSUBR (Fspecifier_instance); | |
| 2953 | 3835 DEFSUBR (Fspecifier_instantiator); |
| 428 | 3836 DEFSUBR (Fspecifier_matching_instance); |
| 2953 | 3837 DEFSUBR (Fspecifier_matching_instantiator); |
| 428 | 3838 DEFSUBR (Fspecifier_instance_from_inst_list); |
| 2953 | 3839 DEFSUBR (Fspecifier_instantiator_from_inst_list); |
| 428 | 3840 DEFSUBR (Fspecifier_matching_instance_from_inst_list); |
| 2953 | 3841 DEFSUBR (Fspecifier_matching_instantiator_from_inst_list); |
| 428 | 3842 DEFSUBR (Fset_specifier_dirty_flag); |
| 3843 | |
| 3844 DEFSUBR (Fgeneric_specifier_p); | |
| 3845 DEFSUBR (Finteger_specifier_p); | |
| 3846 DEFSUBR (Fnatnum_specifier_p); | |
| 3847 DEFSUBR (Fboolean_specifier_p); | |
| 3848 DEFSUBR (Fdisplay_table_specifier_p); | |
| 3849 | |
| 3850 /* Symbols pertaining to specifier creation. Specifiers are created | |
| 3851 in the syms_of() functions. */ | |
| 3852 | |
| 3853 /* locales are defined in general.c. */ | |
| 3854 | |
| 442 | 3855 /* some how-to-add flags in general.c. */ |
| 3856 DEFSYMBOL (Qremove_tag_set_prepend); | |
| 3857 DEFSYMBOL (Qremove_tag_set_append); | |
| 3858 DEFSYMBOL (Qremove_locale); | |
| 3859 DEFSYMBOL (Qremove_locale_type); | |
| 428 | 3860 } |
| 3861 | |
| 3862 void | |
| 3863 specifier_type_create (void) | |
| 3864 { | |
| 3865 the_specifier_type_entry_dynarr = Dynarr_new (specifier_type_entry); | |
| 2367 | 3866 dump_add_root_block_ptr (&the_specifier_type_entry_dynarr, &sted_description); |
| 428 | 3867 |
| 3868 Vspecifier_type_list = Qnil; | |
| 3869 staticpro (&Vspecifier_type_list); | |
| 3870 | |
| 3871 INITIALIZE_SPECIFIER_TYPE (generic, "generic", "generic-specifier-p"); | |
| 3872 | |
| 3873 INITIALIZE_SPECIFIER_TYPE (integer, "integer", "integer-specifier-p"); | |
| 3874 | |
| 3875 SPECIFIER_HAS_METHOD (integer, validate); | |
| 3876 | |
| 3877 INITIALIZE_SPECIFIER_TYPE (natnum, "natnum", "natnum-specifier-p"); | |
| 3878 | |
| 3879 SPECIFIER_HAS_METHOD (natnum, validate); | |
| 3880 | |
| 3881 INITIALIZE_SPECIFIER_TYPE (boolean, "boolean", "boolean-specifier-p"); | |
| 3882 | |
| 3883 SPECIFIER_HAS_METHOD (boolean, validate); | |
| 3884 | |
| 442 | 3885 INITIALIZE_SPECIFIER_TYPE (display_table, "display-table", |
| 3886 "display-table-p"); | |
| 428 | 3887 |
| 3888 SPECIFIER_HAS_METHOD (display_table, validate); | |
| 3889 } | |
| 3890 | |
| 3891 void | |
| 3892 reinit_specifier_type_create (void) | |
| 3893 { | |
| 3894 REINITIALIZE_SPECIFIER_TYPE (generic); | |
| 3895 REINITIALIZE_SPECIFIER_TYPE (integer); | |
| 3896 REINITIALIZE_SPECIFIER_TYPE (natnum); | |
| 3897 REINITIALIZE_SPECIFIER_TYPE (boolean); | |
| 3898 REINITIALIZE_SPECIFIER_TYPE (display_table); | |
| 3899 } | |
| 3900 | |
| 3901 void | |
| 3902 vars_of_specifier (void) | |
| 3903 { | |
| 3904 Vcached_specifiers = Qnil; | |
| 3905 staticpro (&Vcached_specifiers); | |
| 3906 | |
| 3907 /* Do NOT mark through this, or specifiers will never be GC'd. | |
| 3908 This is the same deal as for weak hash tables. */ | |
| 3909 Vall_specifiers = Qnil; | |
| 452 | 3910 dump_add_weak_object_chain (&Vall_specifiers); |
| 428 | 3911 |
| 3912 Vuser_defined_tags = Qnil; | |
| 3913 staticpro (&Vuser_defined_tags); | |
| 3914 | |
| 3915 Vunlock_ghost_specifiers = Qnil; | |
| 3916 staticpro (&Vunlock_ghost_specifiers); | |
| 3659 | 3917 |
| 3918 Vcharset_tag_lists = make_vector(NUM_LEADING_BYTES, Qnil); | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
3919 staticpro (&Vcharset_tag_lists); |
| 428 | 3920 } |