Mercurial > hg > xemacs-beta
annotate lisp/compat.el @ 2720:6fa9919a9a0b
[xemacs-hg @ 2005-04-08 23:10:01 by crestani]
ChangeLog addition:
2005-04-01 Marcus Crestani <crestani@xemacs.org>
The new allocator.
New configure flag: `MC_ALLOC':
* configure.ac (XE_COMPLEX_ARG_ENABLE): Add `--enable-mc-alloc' as
a new configure flag.
* configure.in (AC_INIT_PARSE_ARGS): Add `--mc-alloc' as a new
configure flag.
* configure.usage: Add description for `mc-alloc'.
DUMP_IN_EXEC:
* Makefile.in.in: Condition the installation of a separate dump
file on !DUMP_ON_EXEC.
* configure.ac (XE_COMPLEX_ARG_ENABLE): Add
`--enable-dump-in-exec' as a new configure flag.
* configure.ac: DUMP_IN_EXEC is define as default for PDUMP but
not default for MC_ALLOC.
* configure.in (AC_INIT_PARSE_ARGS): Add `--dump-in-exec' as a
new configure flag.
* configure.in: DUMP_IN_EXEC is define as default for PDUMP but
not default for MC_ALLOC.
* configure.usage: Add description for `dump-in-exec'.
lib-src/ChangeLog addition:
2005-04-01 Marcus Crestani <crestani@xemacs.org>
The new allocator.
DUMP_IN_EXEC:
* Makefile.in.in: Only compile insert-data-in-exec if
DUMP_IN_EXEC is defined.
lisp/ChangeLog addition:
2005-04-01 Marcus Crestani <crestani@xemacs.org>
The new allocator.
MEMORY_USAGE_STATS
* diagnose.el: Add new lisp function to pretty print statistics
about the new allocator.
* diagnose.el (show-mc-alloc-memory-usage): New.
modules/ChangeLog addition:
2005-04-01 Marcus Crestani <crestani@xemacs.org>
The new allocator.
Remove Lcrecords:
* postgresql/postgresql.c (allocate_pgconn): Allocate with new
allocator.
* postgresql/postgresql.c (allocate_pgresult): Allocate PGresult
with new allocator.
* postgresql/postgresql.h (struct Lisp_PGconn): Add
lrecord_header.
* postgresql/postgresql.h (struct Lisp_PGresult): Add
lrecord_header.
* ldap/eldap.c (allocate_ldap): Allocate with new allocator.
* ldap/eldap.h (struct Lisp_LDAP): Add lrecord_header.
nt/ChangeLog addition:
2005-04-01 Marcus Crestani <crestani@xemacs.org>
The new allocator.
New configure flag: `MC_ALLOC':
* config.inc.samp: Add new flag `MC_ALLOC'.
* xemacs.mak: Add flag and configuration output for `MC_ALLOC'.
New files:
* xemacs.dsp: Add source files mc-alloc.c and mc-alloc.h.
* xemacs.mak: Add new object file mc-alloc.obj to dependencies.
src/ChangeLog addition:
2005-04-01 Marcus Crestani <crestani@xemacs.org>
The new allocator.
New configure flag: `MC_ALLOC':
* config.h.in: Add new flag `MC_ALLOC'.
New files:
* Makefile.in.in: Add new object file mc-alloc.o.
* depend: Add new files to dependencies.
* mc-alloc.c: New.
* mc-alloc.h: New.
Running the new allocator from XEmacs:
* alloc.c (deadbeef_memory): Moved to mc-alloc.c.
* emacs.c (main_1): Initialize the new allocator and add
syms_of_mc_alloc.
* symsinit.h: Add syms_of_mc_alloc.
New lrecord allocation and free functions:
* alloc.c (alloc_lrecord): New. Allocates an lrecord, includes
type checking and initializing of the lrecord_header.
* alloc.c (noseeum_alloc_lrecord): Same as above, but increments
the NOSEEUM cons counter.
* alloc.c (free_lrecord): New. Calls the finalizer and frees the
lrecord.
* lrecord.h: Add lrecord allocation prototypes and comments.
Remove old lrecord FROB block allocation:
* alloc.c (allocate_lisp_storage): Former function to expand
heap. Not needed anymore, remove.
* alloc.c: Completely remove `Fixed-size type macros'
* alloc.c (release_breathing_space): Remove.
* alloc.c (memory_full): Remove release_breathing_space.
* alloc.c (refill_memory_reserve): Remove.
* alloc.c (TYPE_ALLOC_SIZE): Remove.
* alloc.c (DECLARE_FIXED_TYPE_ALLOC): Remove.
* alloc.c (ALLOCATE_FIXED_TYPE_FROM_BLOCK): Remove.
* alloc.c (ALLOCATE_FIXED_TYPE_1): Remove.
* alloc.c (ALLOCATE_FIXED_TYPE): Remove.
* alloc.c (NOSEEUM_ALLOCATE_FIXED_TYPE): Remove.
* alloc.c (struct Lisp_Free): Remove.
* alloc.c (LRECORD_FREE_P): Remove.
* alloc.c (MARK_LRECORD_AS_FREE): Remove.
* alloc.c (MARK_LRECORD_AS_NOT_FREE): Remove.
* alloc.c (PUT_FIXED_TYPE_ON_FREE_LIST): Remove.
* alloc.c (FREE_FIXED_TYPE): Remove.
* alloc.c (FREE_FIXED_TYPE_WHEN_NOT_IN_GC): Remove.
Allocate old lrecords with new allocator:
* alloc.c: DECLARE_FIXED_TYPE_ALLOC removed for all lrecords
defined in alloc.c.
* alloc.c (Fcons): Allocate with new allocator.
* alloc.c (noseeum_cons): Allocate with new allocator.
* alloc.c (make_float): Allocate with new allocator.
* alloc.c (make_bignum): Allocate with new allocator.
* alloc.c (make_bignum_bg): Allocate with new allocator.
* alloc.c (make_ratio): Allocate with new allocator.
* alloc.c (make_ratio_bg): Allocate with new allocator.
* alloc.c (make_ratio_rt): Allocate with new allocator.
* alloc.c (make_bigfloat): Allocate with new allocator.
* alloc.c (make_bigfloat_bf): Allocate with new allocator.
* alloc.c (make_compiled_function): Allocate with new allocator.
* alloc.c (Fmake_symbol): Allocate with new allocator.
* alloc.c (allocate_extent): Allocate with new allocator.
* alloc.c (allocate_event): Allocate with new allocator.
* alloc.c (make_key_data): Allocate with new allocator.
* alloc.c (make_button_data): Allocate with new allocator.
* alloc.c (make_motion_data): Allocate with new allocator.
* alloc.c (make_process_data): Allocate with new allocator.
* alloc.c (make_timeout_data): Allocate with new allocator.
* alloc.c (make_magic_data): Allocate with new allocator.
* alloc.c (make_magic_eval_data): Allocate with new allocator.
* alloc.c (make_eval_data): Allocate with new allocator.
* alloc.c (make_misc_user_data): Allocate with new allocator.
* alloc.c (Fmake_marker): Allocate with new allocator.
* alloc.c (noseeum_make_marker): Allocate with new allocator.
* alloc.c (make_uninit_string): Allocate with new allocator.
* alloc.c (resize_string): Allocate with new allocator.
* alloc.c (make_string_nocopy): Allocate with new allocator.
Garbage Collection:
* alloc.c (GC_CHECK_NOT_FREE): Remove obsolete assertions.
* alloc.c (SWEEP_FIXED_TYPE_BLOCK): Remove.
* alloc.c (SWEEP_FIXED_TYPE_BLOCK_1): Remove.
* alloc.c (sweep_conses): Remove.
* alloc.c (free_cons): Use new allocator to free.
* alloc.c (sweep_compiled_functions): Remove.
* alloc.c (sweep_floats): Remove.
* alloc.c (sweep_bignums): Remove.
* alloc.c (sweep_ratios): Remove.
* alloc.c (sweep_bigfloats): Remove.
* alloc.c (sweep_symbols): Remove.
* alloc.c (sweep_extents): Remove.
* alloc.c (sweep_events): Remove.
* alloc.c (sweep_key_data): Remove.
* alloc.c (free_key_data): Use new allocator to free.
* alloc.c (sweep_button_data): Remove.
* alloc.c (free_button_data): Use new allocator to free.
* alloc.c (sweep_motion_data): Remove.
* alloc.c (free_motion_data): Use new allocator to free.
* alloc.c (sweep_process_data): Remove.
* alloc.c (free_process_data): Use new allocator to free.
* alloc.c (sweep_timeout_data): Remove.
* alloc.c (free_timeout_data): Use new allocator to free.
* alloc.c (sweep_magic_data): Remove.
* alloc.c (free_magic_data): Use new allocator to free.
* alloc.c (sweep_magic_eval_data): Remove.
* alloc.c (free_magic_eval_data): Use new allocator to free.
* alloc.c (sweep_eval_data): Remove.
* alloc.c (free_eval_data): Use new allocator to free.
* alloc.c (sweep_misc_user_data): Remove.
* alloc.c (free_misc_user_data): Use new allocator to free.
* alloc.c (sweep_markers): Remove.
* alloc.c (free_marker): Use new allocator to free.
* alloc.c (garbage_collect_1): Remove release_breathing_space.
* alloc.c (gc_sweep): Remove all the old lcrecord and lrecord
related stuff. Sweeping now works like this: compact string
chars, finalize, sweep.
* alloc.c (common_init_alloc_early): Remove old lrecord
initializations, remove breathing_space.
* emacs.c (Fdump_emacs): Remove release_breathing_space.
* lisp.h: Remove prototype for release_breathing_space.
* lisp.h: Adjust the special cons mark makros.
Lrecord Finalizer:
* alloc.c: Add finalizer to lrecord definition.
* alloc.c (finalize_string): Add finalizer for string.
* bytecode.c: Add finalizer to lrecord definition.
* bytecode.c (finalize_compiled_function): Add finalizer for
compiled function.
* marker.c: Add finalizer to lrecord definition.
* marker.c (finalize_marker): Add finalizer for marker.
These changes build the interface to mc-alloc:
* lrecord.h (MC_ALLOC_CALL_FINALIZER): Tell mc-alloc how to
finalize lrecords.
* lrecord.h (MC_ALLOC_CALL_FINALIZER_FOR_DISKSAVE): Tell
mc-alloc how to finalize for disksave.
Unify lrecords and lcrecords:
* lisp.h (struct Lisp_String): Adjust string union hack to
new lrecord header.
* lrecord.h: Adjust comments.
* lrecord.h (struct lrecord_header): The new lrecord header
includes type, lisp-readonly, free, and uid.
* lrecord.h (set_lheader_implementation): Adjust to new
lrecord_header.
* lrecord.h (struct lrecord_implementation): The field basic_p
for indication of an old lrecord is not needed anymore, remove.
* lrecord.h (MAKE_LRECORD_IMPLEMENTATION): Remove basic_p.
* lrecord.h (MAKE_EXTERNAL_LRECORD_IMPLEMENTATION): Remove
basic_p.
* lrecord.h (copy_sized_lrecord): Remove distinction between
old lrecords and lcrecords.
* lrecord.h (copy_lrecord): Remove distinction between old
lrecords and lcrecords.
* lrecord.h (zero_sized_lrecord): Remove distinction between
old lrecords and lcrecords.
* lrecord.h (zero_lrecord): Remove distinction between old
lrecords and lcrecords.
Remove lcrecords and lcrecord lists:
* alloc.c (basic_alloc_lcrecord): Not needed anymore, remove.
* alloc.c (very_old_free_lcrecord): Not needed anymore, remove.
* alloc.c (copy_lisp_object): No more distinction between
lrecords and lcrecords.
* alloc.c (all_lcrecords): Not needed anymore, remove.
* alloc.c (make_vector_internal): Allocate as lrecord.
* alloc.c (make_bit_vector_internal): Allocate as lrecord.
* alloc.c: Completely remove `lcrecord lists'.
* alloc.c (free_description): Remove.
* alloc.c (lcrecord_list_description): Remove.
* alloc.c (mark_lcrecord_list): Remove.
* alloc.c (make_lcrecord_list): Remove.
* alloc.c (alloc_managed_lcrecord): Remove.
* alloc.c (free_managed_lcrecord): Remove.
* alloc.c (alloc_automanaged_lcrecord): Remove.
* alloc.c (free_lcrecord): Remove.
* alloc.c (lcrecord_stats): Remove.
* alloc.c (tick_lcrecord_stats): Remove.
* alloc.c (disksave_object_finalization_1): Add call to
mc_finalize_for_disksave. Remove the lcrecord way to visit all
objects.
* alloc.c (kkcc_marking): Remove XD_FLAG_FREE_LISP_OBJECT
* alloc.c (sweep_lcrecords_1): Remove.
* alloc.c (common_init_alloc_early): Remove everything related
to lcrecords, remove old lrecord initializations,
* alloc.c (init_lcrecord_lists): Not needed anymore, remove.
* alloc.c (reinit_alloc_early): Remove everything related to
lcrecords.
* alloc.c (init_alloc_once_early): Remove everything related to
lcrecords.
* buffer.c (allocate_buffer): Allocate as lrecord.
* buffer.c (nuke_all_buffer_slots): Use lrecord functions.
* buffer.c (common_init_complex_vars_of_buffer): Allocate as
lrecord.
* buffer.h (struct buffer): Add lrecord_header.
* casetab.c (allocate_case_table): Allocate as lrecord.
* casetab.h (struct Lisp_Case_Table): Add lrecord_header.
* charset.h (struct Lisp_Charset): Add lrecord_header.
* chartab.c (fill_char_table): Use lrecord functions.
* chartab.c (Fmake_char_table): Allocate as lrecord.
* chartab.c (make_char_table_entry): Allocate as lrecord.
* chartab.c (copy_char_table_entry): Allocate as lrecord.
* chartab.c (Fcopy_char_table): Allocate as lrecord.
* chartab.c (put_char_table): Use lrecord functions.
* chartab.h (struct Lisp_Char_Table_Entry): Add lrecord_header.
* chartab.h (struct Lisp_Char_Table): Add lrecord_header.
* console-impl.h (struct console): Add lrecord_header.
* console-msw-impl.h (struct Lisp_Devmode): Add lrecord_header.
* console-msw-impl.h (struct mswindows_dialog_id): Add
lrecord_header.
* console.c (allocate_console): Allocate as lrecord.
* console.c (nuke_all_console_slots): Use lrecord functions.
* console.c (common_init_complex_vars_of_console): Allocate as
lrecord.
* data.c (make_weak_list): Allocate as lrecord.
* data.c (make_weak_box): Allocate as lrecord.
* data.c (make_ephemeron): Allocate as lrecord.
* database.c (struct Lisp_Database): Add lrecord_header.
* database.c (allocate_database): Allocate as lrecord.
* device-impl.h (struct device): Add lrecord_header.
* device-msw.c (allocate_devmode): Allocate as lrecord.
* device.c (nuke_all_device_slots): Use lrecord functions.
* device.c (allocate_device): Allocate as lrecord.
* dialog-msw.c (handle_question_dialog_box): Allocate as lrecord.
* elhash.c (struct Lisp_Hash_Table): Add lrecord_header.
* elhash.c (make_general_lisp_hash_table): Allocate as lrecord.
* elhash.c (Fcopy_hash_table): Allocate as lrecord.
* event-stream.c: Lcrecord lists Vcommand_builder_free_list and
Vtimeout_free_list are no longer needed. Remove.
* event-stream.c (allocate_command_builder): Allocate as lrecord.
* event-stream.c (free_command_builder): Use lrecord functions.
* event-stream.c (event_stream_generate_wakeup): Allocate as
lrecord.
* event-stream.c (event_stream_resignal_wakeup): Use lrecord
functions.
* event-stream.c (event_stream_disable_wakeup): Use lrecord
functions.
* event-stream.c (reinit_vars_of_event_stream): Lcrecord lists
remove.
* events.h (struct Lisp_Timeout): Add lrecord_header.
* events.h (struct command_builder): Add lrecord_header.
* extents-impl.h (struct extent_auxiliary): Add lrecord_header.
* extents-impl.h (struct extent_info): Add lrecord_header.
* extents.c (allocate_extent_auxiliary): Allocate as lrecord.
* extents.c (allocate_extent_info): Allocate as lrecord.
* extents.c (copy_extent): Allocate as lrecord.
* faces.c (allocate_face): Allocate as lrecord.
* faces.h (struct Lisp_Face): Add lrecord_header.
* file-coding.c (allocate_coding_system): Allocate as lrecord.
* file-coding.c (Fcopy_coding_system): Allocate as lrecord.
* file-coding.h (struct Lisp_Coding_System): Add lrecord_header.
* fns.c (Ffillarray): Allocate as lrecord.
* frame-impl.h (struct frame): Add lrecord_header.
* frame.c (nuke_all_frame_slots): Use lrecord functions.
* frame.c (allocate_frame_core): Allocate as lrecord.
* glyphs.c (allocate_image_instance): Allocate as lrecord.
* glyphs.c (Fcolorize_image_instance): Allocate as lrecord.
* glyphs.c (allocate_glyph): Allocate as lrecord.
* glyphs.h (struct Lisp_Image_Instance): Add lrecord_header.
* glyphs.h (struct Lisp_Glyph): Add lrecord_header.
* gui.c (allocate_gui_item): Allocate as lrecord.
* gui.h (struct Lisp_Gui_Item): Add lrecord_header.
* keymap.c (struct Lisp_Keymap): Add lrecord_header.
* keymap.c (make_keymap): Allocate as lrecord.
* lisp.h (struct Lisp_Vector): Add lrecord_header.
* lisp.h (struct Lisp_Bit_Vector): Add lrecord_header.
* lisp.h (struct weak_box): Add lrecord_header.
* lisp.h (struct ephemeron): Add lrecord_header.
* lisp.h (struct weak_list): Add lrecord_header.
* lrecord.h (struct lcrecord_header): Not used, remove.
* lrecord.h (struct free_lcrecord_header): Not used, remove.
* lrecord.h (struct lcrecord_list): Not needed anymore, remove.
* lrecord.h (lcrecord_list): Not needed anymore, remove.
* lrecord.h: (enum data_description_entry_flags): Remove
XD_FLAG_FREE_LISP_OBJECT.
* lstream.c: Lrecord list Vlstream_free_list remove.
* lstream.c (Lstream_new): Allocate as lrecord.
* lstream.c (Lstream_delete): Use lrecod functions.
* lstream.c (reinit_vars_of_lstream): Vlstream_free_list
initialization remove.
* lstream.h (struct lstream): Add lrecord_header.
* emacs.c (main_1): Remove lstream initialization.
* mule-charset.c (make_charset): Allocate as lrecord.
* objects-impl.h (struct Lisp_Color_Instance): Add
lrecord_header.
* objects-impl.h (struct Lisp_Font_Instance): Add lrecord_header.
* objects.c (Fmake_color_instance): Allocate as lrecord.
* objects.c (Fmake_font_instance): Allocate as lrecord.
* objects.c (reinit_vars_of_objects): Allocate as lrecord.
* opaque.c: Lcreord list Vopaque_ptr_list remove.
* opaque.c (make_opaque): Allocate as lrecord.
* opaque.c (make_opaque_ptr): Allocate as lrecord.
* opaque.c (free_opaque_ptr): Use lrecord functions.
* opaque.c (reinit_opaque_early):
* opaque.c (init_opaque_once_early): Vopaque_ptr_list
initialization remove.
* opaque.h (Lisp_Opaque): Add lrecord_header.
* opaque.h (Lisp_Opaque_Ptr): Add lrecord_header.
* emacs.c (main_1): Remove opaque variable initialization.
* print.c (default_object_printer): Use new lrecord_header.
* print.c (print_internal): Use new lrecord_header.
* print.c (debug_p4): Use new lrecord_header.
* process.c (make_process_internal): Allocate as lrecord.
* procimpl.h (struct Lisp_Process): Add lrecord_header.
* rangetab.c (Fmake_range_table): Allocate as lrecord.
* rangetab.c (Fcopy_range_table): Allocate as lrecord.
* rangetab.h (struct Lisp_Range_Table): Add lrecord_header.
* scrollbar.c (create_scrollbar_instance): Allocate as lrecord.
* scrollbar.h (struct scrollbar_instance): Add lrecord_header.
* specifier.c (make_specifier_internal): Allocate as lrecord.
* specifier.h (struct Lisp_Specifier): Add lrecord_header.
* symbols.c:
* symbols.c (Fmake_variable_buffer_local): Allocate as lrecord.
* symbols.c (Fdontusethis_set_symbol_value_handler): Allocate
as lrecord.
* symbols.c (Fdefvaralias): Allocate as lrecord.
* symeval.h (struct symbol_value_magic): Add lrecord_header.
* toolbar.c (update_toolbar_button): Allocate as lrecord.
* toolbar.h (struct toolbar_button): Add lrecord_header.
* tooltalk.c (struct Lisp_Tooltalk_Message): Add lrecord_header.
* tooltalk.c (make_tooltalk_message): Allocate as lrecord.
* tooltalk.c (struct Lisp_Tooltalk_Pattern): Add lrecord_header.
* tooltalk.c (make_tooltalk_pattern): Allocate as lrecord.
* ui-gtk.c (allocate_ffi_data): Allocate as lrecord.
* ui-gtk.c (allocate_emacs_gtk_object_data): Allocate as lrecord.
* ui-gtk.c (allocate_emacs_gtk_boxed_data): Allocate as lrecord.
* ui-gtk.h (structs): Add lrecord_header.
* window-impl.h (struct window): Add lrecord_header.
* window-impl.h (struct window_mirror): Add lrecord_header.
* window.c (allocate_window): Allocate as lrecord.
* window.c (new_window_mirror): Allocate as lrecord.
* window.c (make_dummy_parent): Allocate as lrecord.
MEMORY_USAGE_STATS
* alloc.c (fixed_type_block_overhead): Not used anymore, remove.
* buffer.c (compute_buffer_usage): Get storage size from new
allocator.
* marker.c (compute_buffer_marker_usage): Get storage size from
new allocator.
* mule-charset.c (compute_charset_usage): Get storage size from
new allocator.
* scrollbar-gtk.c (gtk_compute_scrollbar_instance_usage): Get
storage size from new allocator.
* scrollbar-msw.c (mswindows_compute_scrollbar_instance_usage):
Get storage size from new allocator.
* scrollbar-x.c (x_compute_scrollbar_instance_usage): Get
storage size from new allocator.
* scrollbar.c (compute_scrollbar_instance_usage): Get storage
size from new allocator.
* unicode.c (compute_from_unicode_table_size_1): Get storage
size from new allocator.
* unicode.c (compute_to_unicode_table_size_1): Get storage size
from new allocator.
* window.c (compute_window_mirror_usage): Get storage size from
new allocator.
* window.c (compute_window_usage): Get storage size from new
allocator.
MC_ALLOC_TYPE_STATS:
* alloc.c (alloc_lrecord): Bump lrecord count.
* alloc.c (noseeum_alloc_lrecord): Bump lrecord count.
* alloc.c (struct lrecord_stats): Storage for counts.
* alloc.c (init_lrecord_stats): Zero statistics.
* alloc.c (inc_lrecord_stats): Increase the statistic.
* alloc.c (dec_lrecord_stats): Decrease the statistic.
* alloc.c (gc_plist_hack): Used to print the information.
* alloc.c (Fgarbage_collect): Return the collected information.
* mc-alloc.c (remove_cell): Decrease lrecord count.
* mc-alloc.h: Set flag MC_ALLOC_TYPE_STATS.
* emacs.c (main_1): Init lrecord statistics.
* lrecord.h: Add prototypes for *_lrecord_stats.
Strings:
* alloc.c (Fmake_string): Initialize ascii_begin to zero.
* alloc.c (gc_count_num_short_string_in_use): Remove.
* alloc.c (gc_count_string_total_size): Remove.
* alloc.c (gc_count_short_string_total_size): Remove.
* alloc.c (debug_string_purity): Remove.
* alloc.c (debug_string_purity_print): Remove.
* alloc.c (sweep_strings): Remove.
Remove static C-readonly Lisp objects:
* alloc.c (c_readonly): Not needed anymore, remove.
* alloc.c (GC_CHECK_LHEADER_INVARIANTS): Remove some obsolete
lheader invariants assertions.
* buffer.c (DEFVAR_BUFFER_LOCAL_1): Allocate dynamically.
* console.c (DEFVAR_CONSOLE_LOCAL_1): Allocate dynamically.
* gpmevent.c: Indirection via MC_ALLOC_Freceive_gpm_event.
* gpmevent.c (Fgpm_enable): Allocate dynamically.
* gpmevent.c (syms_of_gpmevent): Allocate dynamically.
* lisp.h (C_READONLY): Not needed anymore, remove.
* lisp.h (DEFUN): Allocate dynamically.
* lrecord.h (C_READONLY_RECORD_HEADER_P): Not needed anymore,
remove.
* lrecord.h (SET_C_READONLY_RECORD_HEADER): Not needed anymore,
remove.
* symbols.c (guts_of_unbound_marker):
* symeval.h (defsubr): Allocate dynamically.
* symeval.h (DEFSUBR_MACRO): Allocate dynamically.
* symeval.h (DEFVAR_ SYMVAL_FWD): Allocate dynamically.
* tests.c (TESTS_DEFSUBR): Allocate dynamically.
Definition of mcpro:
* lisp.h: Add mcpro prototypes.
* alloc.c (common_init_alloc_early): Add initialization for
mcpros.
* alloc.c (mcpro_description_1): New.
* alloc.c (mcpro_description): New.
* alloc.c (mcpros_description_1): New.
* alloc.c (mcpros_description): New.
* alloc.c (mcpro_one_name_description_1): New.
* alloc.c (mcpro_one_name_description): New.
* alloc.c (mcpro_names_description_1): New.
* alloc.c (mcpro_names_description): New.
* alloc.c (mcpros): New.
* alloc.c (mcpro_names): New.
* alloc.c (mcpro_1): New.
* alloc.c (mc_pro): New.
* alloc.c (garbage_collect_1): Add mcpros to root set.
Usage of mcpro:
* alloc.c (make_string_nocopy): Add string to root set.
* symbols.c (init_symbols_once_early): Add Qunbound to root set.
Changes to the Portable Dumper:
* alloc.c (FREE_OR_REALLOC_BEGIN): Since dumped objects can be
freed with the new allocator, remove assertion for !DUMPEDP.
* dumper.c: Adjust comments, increase PDUMP_HASHSIZE.
* dumper.c (pdump_make_hash): Shift address only 2 bytes, to
avoid collisions.
* dumper.c (pdump_objects_unmark): No more mark bits within
the object, remove.
* dumper.c (mc_addr_elt): New. Element data structure for mc
hash table.
* dumper.c (pdump_mc_hash): New hash table: `lookup table'.
* dumper.c (pdump_get_mc_addr): New. Lookup for hash table.
* dumper.c (pdump_get_indirect_mc_addr): New. Lookup for
convertibles.
* dumper.c (pdump_put_mc_addr): New. Putter for hash table.
* dumper.c (pdump_dump_mc_data): New. Writes the table for
relocation at load time to the dump file.
* dumper.c (pdump_scan_lisp_objects_by_alignment): New.
Visits all dumped Lisp objects.
* dumper.c (pdump_scan_non_lisp_objects_by_alignment): New.
Visits all other dumped objects.
* dumper.c (pdump_reloc_one_mc): New. Updates all pointers
of an object by using the hash table pdump_mc_hash.
* dumper.c (pdump_reloc_one): Replaced by pdump_reloc_one_mc.
* dumper.c (pdump): Change the structure of the dump file, add
the mc post dump relocation table to dump file.
* dumper.c (pdump_load_finish): Hand all dumped objects to the
new allocator and use the mc post dump relocation table for
relocating the dumped objects at dump file load time, free not
longer used data structures.
* dumper.c (pdump_load): Free the dump file.
* dumper.h: Remove pdump_objects_unmark.
* lrecord.h (DUMPEDP): Dumped objects can be freed, remove.
DUMP_IN_EXEC:
* Makefile.in.in: Linking for and with dump in executable only if
DUMP_IN_EXEC is defined.
* config.h.in: Add new flag `DUMP_IN_EXEC'
* emacs.c: Condition dump-data.h on DUMP_IN_EXEC.
* emacs.c (main_1): Flag `-si' only works if dump image is
written into executable.
Miscellanious
* lrecord.h (enum lrecord_type): Added numbers to all types,
very handy for debugging.
* xemacs.def.in.in: Add mc-alloc functions to make them visible
to the modules.
| author | crestani |
|---|---|
| date | Fri, 08 Apr 2005 23:11:35 +0000 |
| parents | 6728e641994e |
| children | 2e528066e2fc |
| rev | line source |
|---|---|
| 410 | 1 ;;; compat.el --- Mechanism for non-intrusively providing compatibility funs. |
| 2 | |
| 826 | 3 ;; Copyright (C) 2000, 2002 Ben Wing. |
| 410 | 4 |
| 5 ;; Author: Ben Wing <ben@xemacs.org> | |
| 6 ;; Maintainer: Ben Wing | |
| 7 ;; Keywords: internal | |
| 8 | |
| 9 ;; This file is part of XEmacs. | |
| 10 | |
| 11 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 12 ;; under the terms of the GNU General Public License as published by | |
| 13 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 14 ;; any later version. | |
| 15 | |
| 16 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 19 ;; General Public License for more details. | |
| 20 | |
| 21 ;; You should have received a copy of the GNU General Public License | |
| 22 ;; along with XEmacs; see the file COPYING. If not, write to the | |
| 23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 24 ;; Boston, MA 02111-1307, USA. | |
| 25 | |
| 26 ;;; Synched up with: Not in FSF. | |
| 27 | |
| 28 ;;; Authorship: | |
| 29 | |
| 30 ; Written May 2000 by Ben Wing. | |
| 31 | |
| 32 ;;; Commentary: | |
| 33 | |
| 826 | 34 ;; The idea is to provide emulation of API's in a namespace-clean way. Lots of packages are filled with declarations such as |
| 35 | |
| 36 ;; (defalias 'gnus-overlay-get 'extent-property) | |
| 37 | |
| 38 ; There should be a single package to provide such compatibility code. The | |
| 39 ; tricky part is how to do it in a clean way, without packages interfering | |
| 40 ; with each other. | |
| 41 | |
| 42 ; The basic usage of compat is: | |
| 43 | |
| 44 ; (1) Each package copies compat.el and renames it, e.g. gnus-compat.el. | |
| 45 | |
| 46 ; (2) `compat' defines various API's that can be activated. To use them in a | |
| 47 ; file, first place code like this at the top of the file: | |
| 48 | |
| 49 ;(let ((compat-current-package 'Gnus)) | |
| 50 ; (require 'gnus-compat)) | |
| 51 | |
| 52 ; then wrap the rest of the code like this: | |
| 53 | |
| 54 ; (Gnus-compat-wrap '(overlays events) | |
| 55 | |
| 56 ;;; Commentary | |
| 57 | |
| 58 ;; blah | |
| 59 | |
| 60 ;;; Code | |
| 61 | |
| 62 ;(defun random-module-my-fun (bar baz) | |
| 63 ; ... | |
| 64 ; (overlay-put overlay 'face 'bold) | |
| 65 ; ... | |
| 66 ;) | |
| 67 ; | |
| 68 ;(defun ... | |
| 69 ;) | |
| 70 ; | |
| 71 ; | |
| 72 ; | |
| 73 ; | |
| 74 ;) ;; end of (Gnus-compat) | |
| 75 | |
| 76 ;;;; random-module.el ends here | |
| 77 | |
| 78 ; (3) What this does is implement the requested API's (in this case, the | |
| 79 ; overlay API from GNU Emacs and event API from XEmacs) in whichever | |
| 80 ; version of Emacs is running, with names such as | |
| 81 ; `Gnus-compat-overlay-put', and then it uses `macrolet' to map the | |
| 82 ; generic names in the wrapped code into namespace-clean names. The | |
| 83 ; result of loading `gnus-compat' leaves around only functions beginning | |
| 84 ; with `Gnus-compat' (or whatever prefix was specified in | |
| 85 ; `compat-current-package'). This way, various packages, with various | |
| 86 ; versions of `compat' as part of them, can coexist, with each package | |
| 87 ; running the version of `compat' that it's been tested with. The use of | |
| 88 ; `macrolet' ensures that only code that's lexically wrapped -- not code | |
| 89 ; that's called from that code -- is affected by the API mapping. | |
| 90 | |
| 410 | 91 ;; Typical usage: |
| 92 | |
| 93 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 94 ;; 1. Wrap modules that define compatibility functions like this: ;; | |
| 95 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 96 | |
| 97 ;(compat-define-group 'fsf-compat) | |
| 98 | |
| 99 ;(compat-define-functions 'fsf-compat | |
| 100 | |
| 826 | 101 ;(defun overlay-put (overlay prop value) |
| 102 ; "Set property PROP to VALUE in overlay OVERLAY." | |
| 103 ; (set-extent-property overlay prop value)) | |
| 410 | 104 |
| 105 ;(defun make-overlay (beg end &optional buffer front-advance rear-advance) | |
| 106 ; ...) | |
| 107 | |
| 108 ;... | |
| 109 | |
| 110 ;) ;; end of (compat-define-group 'fsf-compat) | |
| 111 | |
| 112 ;;;; overlay.el ends here | |
| 113 | |
| 114 | |
| 115 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 116 ;; 2. Wrap modules that use the compatibility functions like this: ;; | |
| 117 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 118 | |
| 826 | 119 ;(let ((compat-current-package 'gnus)) |
| 120 ; (require 'gnus-compat)) | |
| 121 ; | |
| 122 ;(gnus-compat 'fsf-compat | |
| 123 ; | |
| 124 ;; Code: | |
| 125 ;; | |
| 126 ;; | |
| 410 | 127 ;(defun random-module-my-fun (bar baz) |
| 826 | 128 ; ... |
| 129 ; (overlay-put overlay 'face 'bold) | |
| 130 ; ... | |
| 131 ;) | |
| 132 ; | |
| 133 ;(defun ... | |
| 134 ;) | |
| 135 ; | |
| 136 ; | |
| 137 ; | |
| 138 ; | |
| 410 | 139 ;) ;; end of (compat 'fsf-compat) |
| 140 | |
| 141 ;;;; random-module.el ends here | |
| 142 | |
| 826 | 143 (defvar compat-current-package) |
| 144 | |
| 145 (eval-when-compile | |
| 146 (setq compat-current-package 'compat)) | |
| 147 | |
| 148 ;; #### not yet working | |
| 149 '( | |
| 150 | |
| 151 (defmacro compat-define-compat-functions (&rest body) | |
| 152 "Define the functions of the `compat' package in a namespace-clean way. | |
| 153 This relies on `compat-current-package' being set. If `compat-current-package' | |
| 154 is equal to the symbol `foo', and within BODY is something like | |
| 155 | |
| 156 \(defmacro compat-define-group (group) | |
| 157 ... | |
| 158 ) | |
| 159 | |
| 160 then this turns into | |
| 161 | |
| 162 \(defmacro foo-compat-define-group (group) | |
| 163 ... | |
| 164 ) | |
| 165 | |
| 166 and all calls are replaced accordingly. | |
| 167 | |
| 168 | |
| 169 | |
| 170 | |
| 171 Functions such as | |
| 172 compatibility functions in GROUP. | |
| 173 You should simply wrap this around the code that defines the functions. | |
| 174 Any functions and macros defined at top level using `defun' or `defmacro' | |
| 175 will be noticed and added to GROUP. Other top-level code will be executed | |
| 176 normally. All code and definitions in this group can safely reference any | |
| 177 other functions in this group -- the code is effectively wrapped in a | |
| 178 `compat' call. You can call `compat-define-functions' more than once, if | |
| 179 necessary, for a single group. | |
| 180 | |
| 181 What actually happens is that the functions and macros defined here are in | |
| 182 fact defined using names prefixed with GROUP. To use these functions, | |
| 183 wrap any calling code with the `compat' macro, which lexically renames | |
| 184 the function and macro calls appropriately." | |
| 185 (let ((prefix (if (boundp 'compat-current-package) | |
| 186 compat-current-package | |
| 187 (error | |
| 188 "`compat-current-package' must be defined when loading this module"))) | |
| 189 (defs-to-munge '(defun defmacro)) | |
| 190 mappings) | |
| 191 (if (symbolp prefix) (setq prefix (symbol-name prefix))) | |
| 192 ;; first, note all defuns and defmacros | |
| 193 (let (fundef | |
| 194 (body-tail body)) | |
| 195 (while body-tail | |
| 196 (setq fundef (car body-tail)) | |
| 197 (when (and (consp fundef) (memq (car fundef) defs-to-munge)) | |
| 198 (push (cons (second fundef) (third fundef)) mappings)) | |
| 199 (setq body-tail (cdr body-tail)))) | |
| 200 ;; now, munge the definitions with the new names | |
| 201 (let (fundef | |
| 202 (body-tail body) | |
| 203 result | |
| 204 defs) | |
| 205 (while body-tail | |
| 206 (setq fundef (car body-tail)) | |
| 207 (push | |
| 208 (cond ((and (consp fundef) (memq (car fundef) defs-to-munge)) | |
| 209 (nconc (list (car fundef) | |
| 210 (intern (concat prefix "-" | |
| 211 (symbol-name (second fundef)))) | |
| 212 (third fundef)) | |
| 213 (nthcdr 3 fundef))) | |
| 214 (t fundef)) | |
| 215 result) | |
| 216 (setq body-tail (cdr body-tail))) | |
| 217 (setq result (nreverse result)) | |
| 218 ;; now, generate the munged code, with the references to the functions | |
| 219 ;; macroletted | |
| 220 (mapc | |
| 221 #'(lambda (acons) | |
| 222 (let ((fun (car acons)) | |
| 223 (args (cdr acons))) | |
| 224 (push | |
| 225 (list fun args | |
| 226 (nconc | |
| 227 (list 'list | |
| 228 (list 'quote | |
| 229 (intern (concat prefix "-" | |
| 230 (symbol-name fun))))) | |
| 231 args)) | |
| 232 defs))) | |
| 233 mappings) | |
| 234 ;; it would be cleaner to use `lexical-let' instead of `let', but that | |
| 235 ;; causes function definitions to have obnoxious, unreadable junk in | |
| 236 ;; them. #### Move `lexical-let' into C!!! | |
| 237 `(macrolet ((compat-current-package () ,compat-current-package) | |
| 238 ,@defs) | |
| 239 ,@result)))) | |
| 240 | |
| 241 (compat-define-compat-functions | |
| 410 | 242 |
| 243 (defun compat-hash-table (group) | |
| 244 (get group 'compat-table)) | |
| 245 | |
| 246 (defun compat-make-hash-table (group) | |
| 247 (put group 'compat-table (make-hash-table))) | |
| 248 | |
| 826 | 249 (defmacro compat-define-group (group &rest body) |
| 410 | 250 "Define GROUP as a group of compatibility functions. |
| 826 | 251 This macro should wrap individual Individual functions are defined using `compat-define-functions'. |
| 410 | 252 Once defined, the functions can be used by wrapping your code in the |
| 253 `compat' macro. | |
| 254 | |
| 255 If GROUP is already defined, nothing happens." | |
| 256 (let ((group (eval group))) | |
| 257 (or (hash-table-p (compat-hash-table group)) | |
| 258 (compat-make-hash-table group)))) | |
| 259 | |
| 260 (defmacro compat-clear-functions (group) | |
| 261 "Clear all defined functions and macros out of GROUP." | |
| 262 (let ((group (eval group))) | |
| 263 (clrhash (compat-hash-table group)))) | |
| 264 | |
| 826 | 265 (defmacro compat-defun (args &rest body) |
| 266 | |
| 267 (defmacro compat-define-function (props name arglist &rest body) | |
| 268 "Define a compatibility function. | |
| 269 PROPS are properties controlling how the function should be defined. | |
| 270 control how the should simply wrap this around the code that defines the functions. | |
| 410 | 271 Any functions and macros defined at top level using `defun' or `defmacro' |
| 272 will be noticed and added to GROUP. Other top-level code will be executed | |
| 273 normally. All code and definitions in this group can safely reference any | |
| 274 other functions in this group -- the code is effectively wrapped in a | |
| 275 `compat' call. You can call `compat-define-functions' more than once, if | |
| 276 necessary, for a single group. | |
| 277 | |
| 278 What actually happens is that the functions and macros defined here are in | |
| 279 fact defined using names prefixed with GROUP. To use these functions, | |
| 280 wrap any calling code with the `compat' macro, which lexically renames | |
| 281 the function and macro calls appropriately." | |
| 826 | 282 (let ((group (eval group)) |
| 283 (defs-to-munge '(defun defmacro)) | |
| 284 ) | |
| 410 | 285 (let (fundef |
| 286 (body-tail body)) | |
| 287 (while body-tail | |
| 288 (setq fundef (car body-tail)) | |
| 826 | 289 (when (and (consp fundef) (memq (car fundef) defs-to-munge)) |
| 410 | 290 (puthash (second fundef) (third fundef) (compat-hash-table group))) |
| 291 (setq body-tail (cdr body-tail)))) | |
| 292 (let (fundef | |
| 293 (body-tail body) | |
| 294 result) | |
| 295 (while body-tail | |
| 296 (setq fundef (car body-tail)) | |
| 297 (push | |
| 826 | 298 (cond ((and (consp fundef) (memq (car fundef) defs-to-munge)) |
| 299 (nconc (list (car fundef) | |
| 410 | 300 (intern (concat (symbol-name group) "-" |
| 301 (symbol-name (second fundef)))) | |
| 302 (third fundef)) | |
| 303 (nthcdr 3 fundef))) | |
| 304 (t fundef)) | |
| 305 result) | |
| 306 (setq body-tail (cdr body-tail))) | |
| 826 | 307 (nconc (list 'compat-wrap (list 'quote group)) (nreverse result))))) |
| 410 | 308 |
| 309 (defvar compat-active-groups nil) | |
| 310 | |
| 311 (defun compat-fboundp (groups fun) | |
| 312 "T if FUN is either `fboundp' or one of the compatibility funs in GROUPS. | |
| 313 GROUPS is a list of compatibility groups as defined using | |
| 314 `compat-define-group'." | |
| 315 (or (fboundp fun) | |
| 316 (block nil | |
| 317 (mapcar #'(lambda (group) | |
| 318 (if (gethash fun (compat-hash-table group)) | |
| 319 (return t))) | |
| 320 groups)))) | |
| 321 | |
| 826 | 322 (defmacro compat-wrap-runtime (groups &rest body)) |
| 323 | |
| 324 (defmacro compat-wrap (groups &rest body) | |
| 325 "Make use of compatibility functions and macros in GROUPS. | |
| 326 GROUPS is a symbol, an API group, or list of API groups. Each API group | |
| 327 defines a set of functions, macros, variables, etc. and that will (or | |
| 328 should ideally) work on all recent versions of both GNU Emacs and XEmacs, | |
| 329 and (to some extent, depending on how the functions were designed) on older | |
| 330 version. When this function is used, it will generally not be named | |
| 331 `compat-wrap', but have some name such as `Gnus-compat-wrap', if this is | |
| 332 wrapping something in `gnus'. (The renaming happened when the `compat' | |
| 333 package was loaded -- see discussion at top). | |
| 334 | |
| 335 To use `compat' in your package (assume your package is `gnus'), you first | |
| 336 have to do a bit if setup. | |
| 337 | |
| 338 -- Copy and rename compat.el, e.g. to `gnus-compat.el'. The name must be | |
| 339 globally unique across everything on the load path (that means all | |
| 340 packages). | |
| 341 -- Incude this file in your package. It will not interfere with any other | |
| 342 versions of compat (earlier, later, etc.) provided in other packages | |
| 343 and similarly renamed. | |
| 344 | |
| 345 To make use of the API's provided: | |
| 346 | |
| 347 -- First place code like this at the top of the file, after the copyright | |
| 348 notices and comments: | |
| 349 | |
| 350 \(let ((compat-current-package 'Gnus)) | |
| 351 (require 'gnus-compat)) | |
| 352 | |
| 353 -- then wrap the rest of the code like this, assuming you want access to | |
| 354 the GNU Emacs overlays API, and the XEmacs events API: | |
| 355 | |
| 356 \(Gnus-compat-wrap '(overlays xem-events) | |
| 357 | |
| 358 ... | |
| 359 ... | |
| 360 ... | |
| 361 | |
| 362 \(defun gnus-random-fun (overlay baz) | |
| 363 ... | |
| 364 (overlay-put overlay 'face 'bold) | |
| 365 ... | |
| 366 ) | |
| 367 | |
| 368 ... | |
| 369 ... | |
| 370 | |
| 371 \(defun gnus-random-fun-2 (event) | |
| 372 (interactive "e") | |
| 373 (let ((x (event-x event)) | |
| 374 (y (event-y event))) | |
| 375 ... | |
| 376 ) | |
| 377 ) | |
| 378 | |
| 379 ) ;; end of (Gnus-compat) | |
| 380 | |
| 381 ;;;; random-module.el ends here | |
| 382 | |
| 383 Both the requested API's will be implemented whichever version of Emacs | |
| 384 \(GNU Emacs, XEmacs, etc.) is running, and (with limitations) on older | |
| 385 versions as well. Furthermore, the API's are provided *ONLY* to code | |
| 386 that's actually, lexically wrapped by `compat-wrap' (or its renamed | |
| 387 version). All other code, including code that's called by the wrapped | |
| 388 code, is not affected -- e.g. if we're on XEmacs, and `overlay-put' isn't | |
| 389 normally defined, then it won't be defined in code other than the wrapped | |
| 390 code, even if the wrapped code calls that code. Clever, huh? | |
| 391 | |
| 392 What happens is that the `compat-wrap' actually uses `macrolet' to | |
| 393 inline-substitute calls to `overlay-put' to (in this case) | |
| 394 `Gnus-compat-overlay-put', which was defined when `gnus-compat' was loaded. | |
| 395 | |
| 396 What happens is that is implement the requested API's (in this case, the | |
| 397 overlay API from GNU Emacs and event API from XEmacs) in whichever | |
| 398 version of Emacs is running, with names such as | |
| 399 `Gnus-compat-overlay-put', and then it uses `macrolet' to map the | |
| 400 generic names in the wrapped code into namespace-clean names. The | |
| 401 result of loading `gnus-compat' leaves around only functions beginning | |
| 402 with `Gnus-compat' (or whatever prefix was specified in | |
| 403 `compat-current-package'). This way, various packages, with various | |
| 404 versions of `compat' as part of them, can coexist, with each package | |
| 405 running the version of `compat' that it's been tested with. The use of | |
| 406 `macrolet' ensures that only code that's lexically wrapped -- not code | |
| 407 that's called from that code -- is affected by the API mapping. | |
| 408 | |
| 409 Before using `compat' | |
| 410 | |
| 411 For any file where you want to make use of one or more API's provided by | |
| 412 `compat', first do this: | |
| 413 | |
| 414 Wrap a call to `compat-wrap' around your entire file, like this: | |
| 415 | |
| 416 ;; First, you copied compat.el into your package -- we're assuming \"gnus\" -- | |
| 417 ;; and renamed it, e.g. gnus-compat.el. Now we load it and tell it to | |
| 418 ;; use `Gnus' as the prefix for all stuff it defines. (Use a capital letter | |
| 419 ;; or some similar convention so that these names are not so easy to see.) | |
| 420 | |
| 421 \(let ((current-compat-package 'Gnus)) | |
| 422 (require 'gnus-compat)) | |
| 423 | |
| 424 ;; The function `compat-wrap' was mapped to `Gnus-compat-wrap'. The idea | |
| 425 ;; is that the raw functions beginning with `compat-' are never actually | |
| 426 ;; defined. They may appear as function calls inside of functions, but | |
| 427 ;; they will always be mapped to something beginning with the given prefix. | |
| 428 | |
| 429 \(Gnus-compat-wrap '(overlays xem-events) | |
| 430 | |
| 431 ... | |
| 432 | |
| 433 ) | |
| 434 | |
| 410 | 435 You should simply wrap this around the code that uses the functions |
| 826 | 436 and macros in GROUPS. Typically, a call to `compat' should be placed |
| 410 | 437 at the top of an ELisp module, with the closing parenthesis at the |
| 438 bottom; use this in place of a `require' statement. Wrapped code can | |
| 439 be either function or macro definitions or other ELisp code, and | |
| 440 wrapped function or macro definitions need not be at top level. All | |
| 441 calls to the compatibility functions or macros will be noticed anywhere | |
| 442 within the wrapped code. Calls to `fboundp' within the wrapped code | |
| 443 will also behave correctly when called on compatibility functions and | |
| 444 macros, even though they would return nil elsewhere (including in code | |
| 445 in other modules called dynamically from the wrapped code). | |
| 446 | |
| 447 The functions and macros define in GROUP are actually defined under | |
| 448 prefixed names, to avoid namespace clashes and bad interactions with | |
| 449 other code that calls `fboundp'. All calls inside of the wrapped code | |
| 450 to the compatibility functions and macros in GROUP are lexically | |
| 451 mapped to the prefixed names. Since this is a lexical mapping, code | |
| 452 in other modules that is called by functions in this module will not | |
| 453 be affected." | |
| 454 (let ((group (eval group)) | |
| 455 defs) | |
| 456 (maphash | |
| 457 #'(lambda (fun args) | |
| 458 (push | |
| 459 (list fun args | |
| 460 (nconc | |
| 461 (list 'list | |
| 462 (list 'quote | |
| 463 (intern (concat (symbol-name group) "-" | |
| 464 (symbol-name fun))))) | |
| 465 args)) | |
| 466 defs)) | |
| 467 (compat-hash-table group)) | |
| 468 ;; it would be cleaner to use `lexical-let' instead of `let', but that | |
| 469 ;; causes function definitions to have obnoxious, unreadable junk in | |
| 470 ;; them. #### Move `lexical-let' into C!!! | |
| 471 `(let ((compat-active-groups (cons ',group compat-active-groups))) | |
| 472 (macrolet ((fboundp (fun) `(compat-fboundp ',compat-active-groups ,fun)) | |
| 473 ,@defs) | |
| 474 ,@body)))) | |
| 826 | 475 |
| 476 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 477 ;; Define the compat groups ;; | |
| 478 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 479 | |
| 480 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; overlays ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 481 | |
| 482 (compat-define-group 'overlays | |
| 483 | |
| 484 (defun-compat overlayp (object) | |
| 485 "Return t if OBJECT is an overlay." | |
| 486 (and (extentp object) | |
| 487 (extent-property object 'overlay))) | |
| 488 | |
| 489 (defun-compat make-overlay (beg end &optional buffer front-advance rear-advance) | |
| 490 "Create a new overlay with range BEG to END in BUFFER. | |
| 491 If omitted, BUFFER defaults to the current buffer. | |
| 492 BEG and END may be integers or markers. | |
| 493 The fourth arg FRONT-ADVANCE, if non-nil, makes the | |
| 494 front delimiter advance when text is inserted there. | |
| 495 The fifth arg REAR-ADVANCE, if non-nil, makes the | |
| 496 rear delimiter advance when text is inserted there." | |
| 497 (if (null buffer) | |
| 498 (setq buffer (current-buffer)) | |
| 499 (check-argument-type 'bufferp buffer)) | |
| 500 (when (> beg end) | |
| 501 (setq beg (prog1 end (setq end beg)))) | |
| 502 | |
| 503 (let ((overlay (make-extent beg end buffer))) | |
| 504 (set-extent-property overlay 'overlay t) | |
| 505 (if front-advance | |
| 506 (set-extent-property overlay 'start-open t) | |
| 507 (set-extent-property overlay 'start-closed t)) | |
| 508 (if rear-advance | |
| 509 (set-extent-property overlay 'end-closed t) | |
| 510 (set-extent-property overlay 'end-open t)) | |
| 511 | |
| 512 overlay)) | |
| 513 | |
| 514 (defun-compat move-overlay (overlay beg end &optional buffer) | |
| 515 "Set the endpoints of OVERLAY to BEG and END in BUFFER. | |
| 516 If BUFFER is omitted, leave OVERLAY in the same buffer it inhabits now. | |
| 517 If BUFFER is omitted, and OVERLAY is in no buffer, put it in the current | |
| 518 buffer." | |
| 519 (check-argument-type 'overlayp overlay) | |
| 520 (if (null buffer) | |
| 521 (setq buffer (extent-object overlay))) | |
| 522 (if (null buffer) | |
| 523 (setq buffer (current-buffer))) | |
| 524 (check-argument-type 'bufferp buffer) | |
| 525 (and (= beg end) | |
| 526 (extent-property overlay 'evaporate) | |
| 527 (delete-overlay overlay)) | |
| 528 (when (> beg end) | |
| 529 (setq beg (prog1 end (setq end beg)))) | |
| 530 (set-extent-endpoints overlay beg end buffer) | |
| 531 overlay) | |
| 532 | |
| 533 (defun-compat delete-overlay (overlay) | |
| 534 "Delete the overlay OVERLAY from its buffer." | |
| 535 (check-argument-type 'overlayp overlay) | |
| 536 (detach-extent overlay) | |
| 537 nil) | |
| 538 | |
| 539 (defun-compat overlay-start (overlay) | |
| 540 "Return the position at which OVERLAY starts." | |
| 541 (check-argument-type 'overlayp overlay) | |
| 542 (extent-start-position overlay)) | |
| 543 | |
| 544 (defun-compat overlay-end (overlay) | |
| 545 "Return the position at which OVERLAY ends." | |
| 546 (check-argument-type 'overlayp overlay) | |
| 547 (extent-end-position overlay)) | |
| 548 | |
| 549 (defun-compat overlay-buffer (overlay) | |
| 550 "Return the buffer OVERLAY belongs to." | |
| 551 (check-argument-type 'overlayp overlay) | |
| 552 (extent-object overlay)) | |
| 553 | |
| 554 (defun-compat overlay-properties (overlay) | |
| 555 "Return a list of the properties on OVERLAY. | |
| 556 This is a copy of OVERLAY's plist; modifying its conses has no effect on | |
| 557 OVERLAY." | |
| 558 (check-argument-type 'overlayp overlay) | |
| 559 (extent-properties overlay)) | |
| 560 | |
| 561 (defun-compat overlays-at (pos) | |
| 562 "Return a list of the overlays that contain position POS." | |
| 563 (overlays-in pos pos)) | |
| 564 | |
| 565 (defun-compat overlays-in (beg end) | |
| 566 "Return a list of the overlays that overlap the region BEG ... END. | |
| 567 Overlap means that at least one character is contained within the overlay | |
| 568 and also contained within the specified region. | |
| 569 Empty overlays are included in the result if they are located at BEG | |
| 570 or between BEG and END." | |
| 571 (if (featurep 'xemacs) | |
| 572 (mapcar-extents #'identity nil nil beg end | |
| 573 'all-extents-closed-open 'overlay) | |
| 574 (let ((ovls (overlay-lists)) | |
| 575 tmp retval) | |
| 576 (if (< end beg) | |
| 577 (setq tmp end | |
| 578 end beg | |
| 579 beg tmp)) | |
| 580 (setq ovls (nconc (car ovls) (cdr ovls))) | |
| 581 (while ovls | |
| 582 (setq tmp (car ovls) | |
| 583 ovls (cdr ovls)) | |
| 584 (if (or (and (<= (overlay-start tmp) end) | |
| 585 (>= (overlay-start tmp) beg)) | |
| 586 (and (<= (overlay-end tmp) end) | |
| 587 (>= (overlay-end tmp) beg))) | |
| 588 (setq retval (cons tmp retval)))) | |
| 589 retval))) | |
| 590 | |
| 591 (defun-compat next-overlay-change (pos) | |
| 592 "Return the next position after POS where an overlay starts or ends. | |
| 593 If there are no more overlay boundaries after POS, return (point-max)." | |
| 594 (let ((next (point-max)) | |
| 595 tmp) | |
| 596 (map-extents | |
| 597 (lambda (overlay ignore) | |
| 598 (when (or (and (< (setq tmp (extent-start-position overlay)) next) | |
| 599 (> tmp pos)) | |
| 600 (and (< (setq tmp (extent-end-position overlay)) next) | |
| 601 (> tmp pos))) | |
| 602 (setq next tmp)) | |
| 603 nil) | |
| 604 nil pos nil nil 'all-extents-closed-open 'overlay) | |
| 605 next)) | |
| 606 | |
| 607 (defun-compat previous-overlay-change (pos) | |
| 608 "Return the previous position before POS where an overlay starts or ends. | |
| 609 If there are no more overlay boundaries before POS, return (point-min)." | |
| 610 (let ((prev (point-min)) | |
| 611 tmp) | |
| 612 (map-extents | |
| 613 (lambda (overlay ignore) | |
| 614 (when (or (and (> (setq tmp (extent-end-position overlay)) prev) | |
| 615 (< tmp pos)) | |
| 616 (and (> (setq tmp (extent-start-position overlay)) prev) | |
| 617 (< tmp pos))) | |
| 618 (setq prev tmp)) | |
| 619 nil) | |
| 620 nil nil pos nil 'all-extents-closed-open 'overlay) | |
| 621 prev)) | |
| 622 | |
| 623 (defun-compat overlay-lists () | |
| 624 "Return a pair of lists giving all the overlays of the current buffer. | |
| 625 The car has all the overlays before the overlay center; | |
| 626 the cdr has all the overlays after the overlay center. | |
| 627 Recentering overlays moves overlays between these lists. | |
| 628 The lists you get are copies, so that changing them has no effect. | |
| 629 However, the overlays you get are the real objects that the buffer uses." | |
| 630 (or (boundp 'xemacs-internal-overlay-center-pos) | |
| 631 (overlay-recenter (1+ (/ (- (point-max) (point-min)) 2)))) | |
| 632 (let ((pos xemacs-internal-overlay-center-pos) | |
| 633 before after) | |
| 634 (map-extents (lambda (overlay ignore) | |
| 635 (if (> pos (extent-end-position overlay)) | |
| 636 (push overlay before) | |
| 637 (push overlay after)) | |
| 638 nil) | |
| 639 nil nil nil nil 'all-extents-closed-open 'overlay) | |
| 640 (cons (nreverse before) (nreverse after)))) | |
| 641 | |
| 642 (defun-compat overlay-recenter (pos) | |
| 643 "Recenter the overlays of the current buffer around position POS." | |
| 644 (set (make-local-variable 'xemacs-internal-overlay-center-pos) pos)) | |
| 645 | |
| 646 (defun-compat overlay-get (overlay prop) | |
| 647 "Get the property of overlay OVERLAY with property name PROP." | |
| 648 (check-argument-type 'overlayp overlay) | |
| 649 (let ((value (extent-property overlay prop)) | |
| 650 category) | |
| 651 (if (and (null value) | |
| 652 (setq category (extent-property overlay 'category))) | |
| 653 (get category prop) | |
| 654 value))) | |
| 655 | |
| 656 (defun-compat overlay-put (overlay prop value) | |
| 657 "Set one property of overlay OVERLAY: give property PROP value VALUE." | |
| 658 (check-argument-type 'overlayp overlay) | |
| 659 (cond ((eq prop 'evaporate) | |
| 660 (set-extent-property overlay 'detachable value)) | |
| 661 ((eq prop 'before-string) | |
| 662 (set-extent-property overlay 'begin-glyph | |
| 663 (make-glyph (vector 'string :data value)))) | |
| 664 ((eq prop 'after-string) | |
| 665 (set-extent-property overlay 'end-glyph | |
| 666 (make-glyph (vector 'string :data value)))) | |
| 667 ((eq prop 'local-map) | |
| 668 (set-extent-property overlay 'keymap value)) | |
| 669 ((memq prop '(window insert-in-front-hooks insert-behind-hooks | |
| 670 modification-hooks)) | |
| 671 (error "cannot support overlay '%s property under XEmacs" | |
| 672 prop))) | |
| 673 (set-extent-property overlay prop value)) | |
| 674 ) | |
| 675 | |
| 676 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; extents ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 677 | |
| 678 (defalias-compat 'delete-extent 'delete-overlay) | |
| 679 (defalias-compat 'extent-end-position 'overlay-end) | |
| 680 (defalias-compat 'extent-start-position 'overlay-start) | |
| 681 (defalias-compat 'set-extent-endpoints 'move-overlay) | |
| 682 (defalias-compat 'set-extent-property 'overlay-put) | |
| 683 (defalias-compat 'make-extent 'make-overlay) | |
| 684 | |
| 685 (defun-compat extent-property (extent property &optional default) | |
| 686 (or (overlay-get extent property) default)) | |
| 687 | |
| 688 (defun-compat extent-at (pos &optional object property before at-flag) | |
| 689 (let ((tmp (overlays-at (point))) | |
| 690 ovls) | |
| 691 (if property | |
| 692 (while tmp | |
| 693 (if (extent-property (car tmp) property) | |
| 694 (setq ovls (cons (car tmp) ovls))) | |
| 695 (setq tmp (cdr tmp))) | |
| 696 (setq ovls tmp | |
| 697 tmp nil)) | |
| 698 (car-safe | |
| 699 (sort ovls | |
| 700 (function | |
| 701 (lambda (a b) | |
| 702 (< (- (extent-end-position a) (extent-start-position a)) | |
| 703 (- (extent-end-position b) (extent-start-position b))))))))) | |
| 704 | |
| 705 (defun-compat map-extents (function &optional object from to | |
| 706 maparg flags property value) | |
| 707 (let ((tmp (overlays-in (or from (point-min)) | |
| 708 (or to (point-max)))) | |
| 709 ovls) | |
| 710 (if property | |
| 711 (while tmp | |
| 712 (if (extent-property (car tmp) property) | |
| 713 (setq ovls (cons (car tmp) ovls))) | |
| 714 (setq tmp (cdr tmp))) | |
| 715 (setq ovls tmp | |
| 716 tmp nil)) | |
| 717 (catch 'done | |
| 718 (while ovls | |
| 719 (setq tmp (funcall function (car ovls) maparg) | |
| 720 ovls (cdr ovls)) | |
| 721 (if tmp | |
| 722 (throw 'done tmp)))))) | |
| 723 | |
| 724 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; extents ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 725 | |
| 726 | |
| 727 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; events ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 728 | |
| 729 ) ;; group overlays | |
| 730 | |
| 731 ) ;; compat-define-compat-functions | |
| 732 | |
| 733 (fmakunbound 'compat-define-compat-functions) | |
| 734 | |
| 735 ) |