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