Mercurial > hg > xemacs-beta
annotate lisp/process.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 | 35aac3cef6af |
| children | 81975997fb1a |
| rev | line source |
|---|---|
| 428 | 1 ;;; process.el --- commands for subprocesses; split out of simple.el |
| 2 | |
| 3 ;; Copyright (C) 1985-7, 1993,4, 1997 Free Software Foundation, Inc. | |
| 853 | 4 ;; Copyright (C) 1995, 2000, 2001, 2002 Ben Wing. |
| 428 | 5 |
| 6 ;; Author: Ben Wing | |
| 7 ;; Maintainer: XEmacs Development Team | |
| 8 ;; Keywords: internal, processes, dumped | |
| 9 | |
| 10 ;; This file is part of XEmacs. | |
| 11 | |
| 12 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 13 ;; under the terms of the GNU General Public License as published by | |
| 14 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 15 ;; any later version. | |
| 16 | |
| 17 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 20 ;; General Public License for more details. | |
| 21 | |
| 22 ;; You should have received a copy of the GNU General Public License | |
| 444 | 23 ;; along with XEmacs; see the file COPYING. If not, write to the |
| 428 | 24 ;; Free Software Foundation, 59 Temple Place - Suite 330, |
| 25 ;; Boston, MA 02111-1307, USA. | |
| 26 | |
| 771 | 27 ;;; Synched up with: FSF 19.30, except for setenv/getenv (synched with FSF |
| 28 ;;; 21.0.105). | |
| 428 | 29 |
| 442 | 30 ;;; Authorship: |
| 31 | |
| 32 ;; Created 1995 by Ben Wing during Mule work -- some commands split out | |
| 33 ;; of simple.el and wrappers of *-internal functions created so they could | |
| 34 ;; be redefined in a Mule world. | |
| 35 ;; Lisp definition of call-process-internal added Mar. 2000 by Ben Wing. | |
| 36 | |
| 428 | 37 ;;; Commentary: |
| 38 | |
| 39 ;; This file is dumped with XEmacs. | |
| 40 | |
| 41 ;;; Code: | |
| 42 | |
| 43 | |
| 44 (defgroup processes nil | |
| 45 "Process, subshell, compilation, and job control support." | |
| 46 :group 'external | |
| 47 :group 'development) | |
| 48 | |
| 49 (defgroup processes-basics nil | |
| 50 "Basic stuff dealing with processes." | |
| 51 :group 'processes) | |
| 52 | |
| 53 (defgroup execute nil | |
| 54 "Executing external commands." | |
| 55 :group 'processes) | |
| 56 | |
| 611 | 57 ;; This may be changed to "/c" in win32-native.el. |
| 428 | 58 |
| 59 (defvar shell-command-switch "-c" | |
| 60 "Switch used to have the shell execute its command line argument.") | |
| 61 | |
| 62 (defun start-process-shell-command (name buffer &rest args) | |
| 63 "Start a program in a subprocess. Return the process object for it. | |
| 64 NAME is name for process. It is modified if necessary to make it unique. | |
| 65 BUFFER is the buffer or (buffer-name) to associate with the process. | |
| 66 Process output goes at end of that buffer, unless you specify | |
| 67 an output stream or filter function to handle the output. | |
| 68 BUFFER may be also nil, meaning that this process is not associated | |
| 2473 | 69 with any buffer. |
| 70 Variables `shell-file-name' and `shell-command-switch' are used to | |
| 71 start the process. | |
| 428 | 72 Remaining arguments are the arguments for the command. |
| 73 Wildcards and redirection are handled as usual in the shell." | |
| 74 ;; We used to use `exec' to replace the shell with the command, | |
| 75 ;; but that failed to handle (...) and semicolon, etc. | |
| 76 (start-process name buffer shell-file-name shell-command-switch | |
| 77 (mapconcat #'identity args " "))) | |
| 78 | |
| 862 | 79 (defun process-synchronize-point (proc) |
| 80 "Set the point(s) in buffer and stderr-buffer according to the process mark." | |
| 81 ;; We need this because the documentation says to insert *BEFORE* point, | |
| 82 ;; but we end up inserting after because only the process mark moves | |
| 83 ;; forward, not point. We synchronize after every place output might | |
| 84 ;; happen, in sentinels, and in an unwind-protect, to make *SURE* that | |
| 85 ;; point is correct. (We could do this more easily and perhaps more | |
| 86 ;; safely using a process filter, but that would create a LOT of garbage | |
| 87 ;; since all the data would get sent in strings.) We make this a separate | |
| 88 ;; function, not an flet, due to dynamic binding problems -- the flet may | |
| 89 ;; not still be in scope when the sentinel is called. | |
| 90 (let ((pb (process-buffer proc)) | |
| 91 (pm (process-mark proc))) | |
| 92 (if (and pb (buffer-live-p pb) (marker-buffer pm)) | |
| 93 (goto-char pm pb)) | |
| 94 (if (process-has-separate-stderr-p proc) | |
| 95 (let ((pseb (process-stderr-buffer proc)) | |
| 96 (psem (process-stderr-mark proc))) | |
| 97 (if (and pseb (not (eq pb pseb)) | |
| 98 (buffer-live-p pseb) | |
| 99 (marker-buffer psem)) | |
| 100 (goto-char psem pseb)))))) | |
| 101 | |
| 853 | 102 (defun call-process-internal (program &optional infile buffer display |
| 103 &rest args) | |
| 104 "Internal function to call PROGRAM synchronously in separate process. | |
| 105 Lisp callers should use `call-process' or `call-process-region'. | |
| 106 | |
| 442 | 107 The program's input comes from file INFILE (nil means `/dev/null'). |
| 853 | 108 XEmacs feature: INFILE can also be a list of (BUFFER [START [END]]), i.e. |
| 109 a list of one to three elements, consisting of a buffer and optionally | |
| 110 a start position or start and end position. In this case, input comes | |
| 111 from the buffer, starting from START (defaults to the beginning of the | |
| 112 buffer) and ending at END (defaults to the end of the buffer). | |
| 113 | |
| 442 | 114 Insert output in BUFFER before point; t means current buffer; |
| 115 nil for BUFFER means discard it; 0 means discard and don't wait. | |
| 853 | 116 If BUFFER is a string, then find or create a buffer with that name, |
| 117 then insert the output in that buffer, before point. | |
| 442 | 118 BUFFER can also have the form (REAL-BUFFER STDERR-FILE); in that case, |
| 119 REAL-BUFFER says what to do with standard output, as above, | |
| 120 while STDERR-FILE says what to do with standard error in the child. | |
| 121 STDERR-FILE may be nil (discard standard error output), | |
| 853 | 122 t (mix it with ordinary output), a file name string, or (XEmacs feature) |
| 123 a buffer object. If STDERR-FILE is a buffer object (but not the name of | |
| 124 a buffer, since that would be interpreted as a file), the standard error | |
| 125 output will be inserted into the buffer before point. | |
| 442 | 126 |
| 127 Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted. | |
| 128 Remaining arguments are strings passed as command arguments to PROGRAM. | |
| 129 | |
| 853 | 130 If BUFFER is 0, returns immediately with value nil. |
| 131 Otherwise waits for PROGRAM to terminate and returns a numeric exit status | |
| 132 or a signal description string. If you quit, the process is first killed | |
| 133 with SIGINT, then with SIGKILL if you quit again before the process exits. | |
| 134 | |
| 135 Coding systems for the process are the same as for `start-process-internal'." | |
| 136 (let (proc inbuf errbuf kill-inbuf kill-errbuf no-wait start end) | |
| 137 ;; first set up an unwind-protect to clean everything up. this will: | |
| 138 ;; | |
| 139 ;; -- kill the process. (when we're not waiting for it to finish, we | |
| 140 ;; set PROC to nil when we're ready to exit so this doesn't happen -- | |
| 141 ;; if we're interrupted before we're ready to exit, we should still | |
| 142 ;; kill the process) | |
| 143 ;; -- kill temporary buffers created to handle I/O to or from a file. | |
| 144 ;; KILL-INBUF/KILL-ERRBUF tell us if we should do so. | |
| 145 ;; | |
| 146 ;; note that we need to be *very* careful in this code to handle C-g | |
| 147 ;; at any point. | |
| 148 (unwind-protect | |
| 149 (progn | |
| 150 ;; first handle INFILE. | |
| 151 (cond ((stringp infile) | |
| 152 (setq infile (expand-file-name infile)) | |
| 153 (setq kill-inbuf t) | |
| 154 (setq inbuf (generate-new-buffer "*call-process*")) | |
| 155 ;; transfer the exact contents of the file to the process. | |
| 156 ;; we do that by reading in and writing out in | |
| 157 ;; binary. #### is this even correct? should we be doing | |
| 158 ;; the same thing with stderr? if so we'd need a way of | |
| 159 ;; controlling the stderr coding system separate from | |
| 160 ;; everything else. | |
| 161 (with-current-buffer inbuf | |
| 162 ;; Make sure this works with jka-compr | |
| 163 (let ((file-name-handler-alist nil)) | |
| 164 (insert-file-contents-internal infile nil nil nil nil | |
| 165 'binary)) | |
| 166 (setq start (point-min) end (point-max)))) | |
| 167 ((consp infile) | |
| 168 (setq inbuf (get-buffer (car infile))) | |
| 169 (setq start (or (nth 1 infile) (point-min inbuf))) | |
| 170 (setq end (or (nth 2 infile) (point-max inbuf)))) | |
| 171 ((null infile) nil) | |
| 172 (t | |
| 173 (error 'wrong-type-argument | |
| 174 "Must be filename or (BUFFER [START [END]])" | |
| 175 infile))) | |
| 176 ;; now handle BUFFER | |
| 177 (let ((stderr (if (consp buffer) (second buffer) t))) | |
| 178 (if (consp buffer) (setq buffer (car buffer))) | |
| 179 (setq buffer | |
| 180 (cond ((null buffer) nil) | |
| 181 ((eq buffer t) (current-buffer)) | |
| 182 ;; use integerp for compatibility with existing | |
| 183 ;; call-process rmsism. | |
| 184 ((integerp buffer) (setq no-wait t) nil) | |
| 185 (t (get-buffer-create buffer)))) | |
| 186 (when (and stderr (not (eq t stderr))) | |
| 187 ;; both ERRBUF and STDERR being non-nil indicates to the | |
| 188 ;; code below that STDERR is a file and we should write | |
| 189 ;; ERRBUF to it; so clear out STDERR if we don't want this. | |
| 190 (if (bufferp stderr) (setq errbuf stderr stderr nil) | |
| 442 | 191 (setq stderr (expand-file-name stderr)) |
| 853 | 192 (setq kill-errbuf t) |
| 193 (setq errbuf (generate-new-buffer "*call-process*")))) | |
| 194 ;; now start process. using a pty causes all sorts of | |
| 195 ;; weirdness, at least under cygwin, when there's input. #### i | |
| 196 ;; don't know what's going wrong and whether it's a cygwin-only | |
| 197 ;; problem. suffice to say that there were NO pty connections | |
| 198 ;; in the old version. | |
| 199 (let ((process-connection-type nil)) | |
| 442 | 200 (setq proc |
| 201 (apply 'start-process-internal "*call-process*" | |
| 853 | 202 (if (eq t stderr) buffer (list buffer errbuf)) |
| 203 program args))) | |
| 204 ;; see comment above where the data was read from the file. | |
| 205 (if kill-inbuf | |
| 206 (set-process-output-coding-system proc 'binary)) | |
| 207 ;; point mark/stderr-mark at the right place (by default it's | |
| 208 ;; end of buffer). | |
| 209 (if buffer | |
| 210 (set-marker (process-mark proc) (point buffer) buffer)) | |
| 211 (if errbuf | |
| 212 (set-marker (process-stderr-mark proc) (point errbuf) errbuf)) | |
| 859 | 213 ;; now do I/O, very carefully! the unwind-protect makes sure |
| 214 ;; to clear out the sentinel, since it does a `throw', which | |
| 215 ;; would have no catch (or writes to a file -- we only want | |
| 216 ;; this on normal exit) | |
| 862 | 217 (unwind-protect |
| 218 ;; if not NO-WAIT, set a sentinel to return the exit | |
| 219 ;; status. it will throw to this catch so we can exit | |
| 220 ;; properly. | |
| 221 (catch 'call-process-done | |
| 222 (set-process-sentinel | |
| 223 proc | |
| 224 (cond | |
| 225 ((and no-wait errbuf stderr) | |
| 226 ;; we're trying really really hard to emulate | |
| 227 ;; the old call-process, which would save the | |
| 228 ;; stderr to a file even if discarding output. so | |
| 229 ;; we set a sentinel to save the output when | |
| 230 ;; we finish. | |
| 231 ;; | |
| 232 ;; #### not clear if we should be doing this. | |
| 233 ;; | |
| 234 ;; NOTE NOTE NOTE: Due to the total bogosity of | |
| 235 ;; dynamic scoping, and the lack of closures, we | |
| 236 ;; have to be careful how we write the first | |
| 237 ;; sentinel below since it may be executed after | |
| 238 ;; this function has returned -- thus we fake a | |
| 239 ;; closure. (This doesn't apply to the second one, | |
| 240 ;; which only gets executed within the | |
| 241 ;; unwind-protect.) | |
| 242 `(lambda (proc status) | |
| 243 (set-process-sentinel proc nil) | |
| 244 (process-synchronize-point proc) | |
| 245 (with-current-buffer ,errbuf | |
| 246 (write-region-internal | |
| 247 1 (1+ (buffer-size)) | |
| 248 ,stderr | |
| 249 nil 'major-rms-kludge-city nil | |
| 250 coding-system-for-write)) | |
| 251 (kill-buffer ,errbuf))) | |
| 252 (no-wait nil) | |
| 253 (t | |
| 254 ;; normal sentinel: maybe write out stderr and return | |
| 255 ;; status. | |
| 256 #'(lambda (proc status) | |
| 257 (process-synchronize-point proc) | |
| 258 (when (and errbuf stderr) | |
| 259 (with-current-buffer errbuf | |
| 260 (write-region-internal | |
| 261 1 (1+ (buffer-size)) stderr | |
| 262 nil 'major-rms-kludge-city nil | |
| 263 coding-system-for-write))) | |
| 264 (cond ((eq 'exit (process-status proc)) | |
| 265 (set-process-sentinel proc nil) | |
| 266 (throw 'call-process-done | |
| 267 (process-exit-status proc))) | |
| 268 ((eq 'signal (process-status proc)) | |
| 269 (set-process-sentinel proc nil) | |
| 270 (throw 'call-process-done status))))))) | |
| 271 (if (not no-wait) | |
| 272 ;; we're waiting. send the input and loop forever, | |
| 273 ;; handling process output and maybe redisplaying. | |
| 274 ;; exit happens through the sentinel or C-g. if | |
| 275 ;; C-g, send SIGINT the first time, EOF if not | |
| 276 ;; already done so (might make the process exit), | |
| 277 ;; and keep waiting. Another C-g will exit the | |
| 278 ;; whole function, and the unwind-protect will | |
| 279 ;; kill the process. (Hence the documented semantics | |
| 280 ;; of SIGINT/SIGKILL.) | |
| 281 (let (eof-sent) | |
| 282 (condition-case nil | |
| 283 (progn | |
| 284 (when inbuf | |
| 285 (process-send-region proc start end inbuf)) | |
| 286 (process-send-eof proc) | |
| 287 (setq eof-sent t) | |
| 288 (while t | |
| 289 (accept-process-output proc) | |
| 290 (process-synchronize-point proc) | |
| 291 (if display (sit-for 0)))) | |
| 292 (quit | |
| 293 (process-send-signal 'SIGINT proc) | |
| 294 (unless eof-sent | |
| 295 (process-send-eof proc)) | |
| 296 (while t | |
| 297 (accept-process-output proc) | |
| 298 (process-synchronize-point proc) | |
| 299 (if display (sit-for 0)))))) | |
| 300 ;; discard and no wait: send the input, set PROC | |
| 301 ;; and ERRBUF to nil so that the unwind-protect | |
| 302 ;; forms don't erase the sentinel, kill the process, | |
| 303 ;; or kill ERRBUF (the sentinel does that), and exit. | |
| 304 (when inbuf | |
| 305 (process-send-region proc start end inbuf)) | |
| 306 (process-send-eof proc) | |
| 307 (setq errbuf nil) | |
| 308 (setq proc nil))) | |
| 309 ;; inner unwind-protect, once we're ready to do I/O. | |
| 310 (when proc | |
| 311 (set-process-sentinel proc nil) | |
| 312 (process-synchronize-point proc))))) | |
| 859 | 313 ;; outer unwind-protect forms, to make sure we always clean up. |
| 853 | 314 (if (and inbuf kill-inbuf) (kill-buffer inbuf)) |
| 315 (if (and errbuf kill-errbuf) (kill-buffer errbuf)) | |
| 316 (condition-case nil | |
| 317 (if (and proc (process-live-p proc)) (kill-process proc)) | |
| 318 (error nil))))) | |
| 428 | 319 |
| 320 | |
| 321 (defun shell-command (command &optional output-buffer) | |
| 322 "Execute string COMMAND in inferior shell; display output, if any. | |
| 323 | |
| 324 If COMMAND ends in ampersand, execute it asynchronously. | |
| 325 The output appears in the buffer `*Async Shell Command*'. | |
| 326 That buffer is in shell mode. | |
| 327 | |
| 328 Otherwise, COMMAND is executed synchronously. The output appears in the | |
| 329 buffer `*Shell Command Output*'. | |
| 330 If the output is one line, it is displayed in the echo area *as well*, | |
| 331 but it is nonetheless available in buffer `*Shell Command Output*', | |
| 332 even though that buffer is not automatically displayed. | |
| 333 If there is no output, or if output is inserted in the current buffer, | |
| 334 then `*Shell Command Output*' is deleted. | |
| 335 | |
| 336 The optional second argument OUTPUT-BUFFER, if non-nil, | |
| 337 says to put the output in some other buffer. | |
| 338 If OUTPUT-BUFFER is a buffer or buffer name, put the output there. | |
| 339 If OUTPUT-BUFFER is not a buffer and not nil, | |
| 340 insert output in current buffer. (This cannot be done asynchronously.) | |
| 341 In either case, the output is inserted after point (leaving mark after it)." | |
| 342 (interactive (list (read-shell-command "Shell command: ") | |
| 343 current-prefix-arg)) | |
| 344 (if (and output-buffer | |
| 345 (not (or (bufferp output-buffer) (stringp output-buffer)))) | |
| 346 (progn (barf-if-buffer-read-only) | |
| 444 | 347 (push-mark nil (not (interactive-p))) |
| 428 | 348 ;; We do not use -f for csh; we will not support broken use of |
| 349 ;; .cshrcs. Even the BSD csh manual says to use | |
| 350 ;; "if ($?prompt) exit" before things which are not useful | |
| 351 ;; non-interactively. Besides, if someone wants their other | |
| 352 ;; aliases for shell commands then they can still have them. | |
| 353 (call-process shell-file-name nil t nil | |
| 354 shell-command-switch command) | |
| 355 (exchange-point-and-mark t)) | |
| 356 ;; Preserve the match data in case called from a program. | |
| 357 (save-match-data | |
| 358 (if (string-match "[ \t]*&[ \t]*$" command) | |
| 359 ;; Command ending with ampersand means asynchronous. | |
| 360 (progn | |
| 776 | 361 (if-fboundp 'background |
| 362 (background (substring command 0 | |
| 363 (match-beginning 0))) | |
| 364 (error | |
| 365 'unimplemented | |
| 366 "backgrounding a shell command requires package `background'"))) | |
| 367 | |
| 428 | 368 (shell-command-on-region (point) (point) command output-buffer))))) |
| 369 | |
| 370 ;; We have a sentinel to prevent insertion of a termination message | |
| 371 ;; in the buffer itself. | |
| 372 (defun shell-command-sentinel (process signal) | |
| 373 (if (memq (process-status process) '(exit signal)) | |
| 374 (message "%s: %s." | |
| 375 (car (cdr (cdr (process-command process)))) | |
| 376 (substring signal 0 -1)))) | |
| 377 | |
| 378 (defun shell-command-on-region (start end command | |
| 379 &optional output-buffer replace) | |
| 380 "Execute string COMMAND in inferior shell with region as input. | |
| 381 Normally display output (if any) in temp buffer `*Shell Command Output*'; | |
| 382 Prefix arg means replace the region with it. | |
| 383 | |
| 384 The noninteractive arguments are START, END, COMMAND, OUTPUT-BUFFER, REPLACE. | |
| 385 If REPLACE is non-nil, that means insert the output | |
| 386 in place of text from START to END, putting point and mark around it. | |
| 387 | |
| 388 If the output is one line, it is displayed in the echo area, | |
| 389 but it is nonetheless available in buffer `*Shell Command Output*' | |
| 390 even though that buffer is not automatically displayed. | |
| 391 If there is no output, or if output is inserted in the current buffer, | |
| 392 then `*Shell Command Output*' is deleted. | |
| 393 | |
| 394 If the optional fourth argument OUTPUT-BUFFER is non-nil, | |
| 395 that says to put the output in some other buffer. | |
| 396 If OUTPUT-BUFFER is a buffer or buffer name, put the output there. | |
| 397 If OUTPUT-BUFFER is not a buffer and not nil, | |
| 398 insert output in the current buffer. | |
| 399 In either case, the output is inserted after point (leaving mark after it)." | |
| 400 (interactive (let ((string | |
| 401 ;; Do this before calling region-beginning | |
| 402 ;; and region-end, in case subprocess output | |
| 403 ;; relocates them while we are in the minibuffer. | |
| 404 (read-shell-command "Shell command on region: "))) | |
| 405 ;; call-interactively recognizes region-beginning and | |
| 406 ;; region-end specially, leaving them in the history. | |
| 407 (list (region-beginning) (region-end) | |
| 408 string | |
| 409 current-prefix-arg | |
| 410 current-prefix-arg))) | |
| 411 (if (or replace | |
| 412 (and output-buffer | |
| 413 (not (or (bufferp output-buffer) (stringp output-buffer))))) | |
| 414 ;; Replace specified region with output from command. | |
| 415 (let ((swap (and replace (< start end)))) | |
| 416 ;; Don't muck with mark unless REPLACE says we should. | |
| 417 (goto-char start) | |
| 418 (and replace (push-mark)) | |
| 419 (call-process-region start end shell-file-name t t nil | |
| 420 shell-command-switch command) | |
| 421 (let ((shell-buffer (get-buffer "*Shell Command Output*"))) | |
| 422 (and shell-buffer (not (eq shell-buffer (current-buffer))) | |
| 423 (kill-buffer shell-buffer))) | |
| 424 ;; Don't muck with mark unless REPLACE says we should. | |
| 425 (and replace swap (exchange-point-and-mark t))) | |
| 426 ;; No prefix argument: put the output in a temp buffer, | |
| 427 ;; replacing its entire contents. | |
| 428 (let ((buffer (get-buffer-create | |
| 429 (or output-buffer "*Shell Command Output*"))) | |
| 430 (success nil) | |
| 431 (exit-status nil) | |
| 432 (directory default-directory)) | |
| 433 (unwind-protect | |
| 434 (if (eq buffer (current-buffer)) | |
| 435 ;; If the input is the same buffer as the output, | |
| 436 ;; delete everything but the specified region, | |
| 437 ;; then replace that region with the output. | |
| 438 (progn (setq buffer-read-only nil) | |
| 439 (delete-region (max start end) (point-max)) | |
| 921 | 440 (delete-region (point-min) (min start end)) |
| 428 | 441 (setq exit-status |
| 442 (call-process-region (point-min) (point-max) | |
| 443 shell-file-name t t nil | |
| 444 shell-command-switch command)) | |
| 445 (setq success t)) | |
| 446 ;; Clear the output buffer, | |
| 447 ;; then run the command with output there. | |
| 448 (save-excursion | |
| 449 (set-buffer buffer) | |
| 450 (setq buffer-read-only nil) | |
| 451 ;; XEmacs change | |
| 452 (setq default-directory directory) | |
| 453 (erase-buffer)) | |
| 454 (setq exit-status | |
| 455 (call-process-region start end shell-file-name | |
| 456 nil buffer nil | |
| 457 shell-command-switch command)) | |
| 458 (setq success t)) | |
| 459 ;; Report the amount of output. | |
| 460 (let ((lines (save-excursion | |
| 461 (set-buffer buffer) | |
| 462 (if (= (buffer-size) 0) | |
| 463 0 | |
| 464 (count-lines (point-min) (point-max)))))) | |
| 465 (cond ((= lines 0) | |
| 466 (if success | |
| 467 (display-message | |
| 468 'command | |
| 469 (if (eql exit-status 0) | |
| 470 "(Shell command succeeded with no output)" | |
| 471 "(Shell command failed with no output)"))) | |
| 472 (kill-buffer buffer)) | |
| 473 ((and success (= lines 1)) | |
| 474 (message "%s" | |
| 475 (save-excursion | |
| 476 (set-buffer buffer) | |
| 477 (goto-char (point-min)) | |
| 478 (buffer-substring (point) | |
| 479 (progn (end-of-line) | |
| 480 (point)))))) | |
| 481 (t | |
| 482 (set-window-start (display-buffer buffer) 1)))))))) | |
| 483 | |
| 484 (defun shell-quote-argument (argument) | |
| 485 "Quote an argument for passing as argument to an inferior shell." | |
| 442 | 486 (if (and (eq system-type 'windows-nt) |
| 487 (let ((progname (downcase (file-name-nondirectory | |
| 488 shell-file-name)))) | |
| 489 (or (equal progname "command.com") | |
| 490 (equal progname "cmd.exe")))) | |
| 491 ;; the expectation is that you can take the result of | |
| 492 ;; shell-quote-argument and pass it to as an arg to | |
| 493 ;; (start-process shell-quote-argument ...) and have it end | |
| 494 ;; up as-is in the program's argv[] array. to do this, we | |
| 495 ;; need to protect against both the shell's and the program's | |
| 496 ;; quoting conventions (and our own conventions in | |
| 497 ;; mswindows-construct-process-command-line!). Putting quotes | |
| 498 ;; around shell metachars gets through the last two, and applying | |
| 499 ;; the normal VC runtime quoting works with practically all apps. | |
| 776 | 500 (declare-fboundp (mswindows-quote-one-vc-runtime-arg argument t)) |
| 611 | 501 (if (equal argument "") |
| 502 "\"\"" | |
| 503 ;; Quote everything except POSIX filename characters. | |
| 504 ;; This should be safe enough even for really weird shells. | |
| 505 (let ((result "") (start 0) end) | |
| 506 (while (string-match "[^-0-9a-zA-Z_./]" argument start) | |
| 507 (setq end (match-beginning 0) | |
| 508 result (concat result (substring argument start end) | |
| 509 "\\" (substring argument end (1+ end))) | |
| 510 start (1+ end))) | |
| 511 (concat result (substring argument start)))))) | |
| 428 | 512 |
| 438 | 513 (defun shell-command-to-string (command) |
| 514 "Execute shell command COMMAND and return its output as a string." | |
| 428 | 515 (with-output-to-string |
| 1189 | 516 (with-current-buffer standard-output |
| 517 (call-process shell-file-name nil t nil shell-command-switch command)))) | |
| 428 | 518 |
| 438 | 519 (defalias 'exec-to-string 'shell-command-to-string) |
| 771 | 520 |
| 521 | |
| 522 ;; History list for environment variable names. | |
| 523 (defvar read-envvar-name-history nil) | |
| 524 | |
| 525 (defun read-envvar-name (prompt &optional mustmatch) | |
| 526 "Read environment variable name, prompting with PROMPT. | |
| 527 Optional second arg MUSTMATCH, if non-nil, means require existing envvar name. | |
| 528 If it is also not t, RET does not exit if it does non-null completion." | |
| 529 (completing-read prompt | |
| 530 (mapcar (function | |
| 531 (lambda (enventry) | |
| 532 (list (substring enventry 0 | |
| 533 (string-match "=" enventry))))) | |
| 534 process-environment) | |
| 535 nil mustmatch nil 'read-envvar-name-history)) | |
| 536 | |
| 537 ;; History list for VALUE argument to setenv. | |
| 538 (defvar setenv-history nil) | |
| 539 | |
| 930 | 540 (defun substitute-env-vars (string) |
| 541 "Substitute environment variables referred to in STRING. | |
| 542 `$FOO' where FOO is an environment variable name means to substitute | |
| 543 the value of that variable. The variable name should be terminated | |
| 544 with a character not a letter, digit or underscore; otherwise, enclose | |
| 545 the entire variable name in braces. Use `$$' to insert a single | |
| 546 dollar sign." | |
| 547 (let ((start 0)) | |
| 548 (while (string-match | |
| 549 ;; XEmacs change - FSF use their rx macro to generate this regexp | |
| 550 "\\(?:\\$\\(\\(?:[a-zA-Z0-9_]\\)+\\)\\)\\|\\(?:\\${\\(\\(?:.\\|\n\\)*?\\)}\\)\\|\\$\\$" | |
| 551 string start) | |
| 552 (cond ((match-beginning 1) | |
| 553 (let ((value (getenv (match-string 1 string)))) | |
| 554 (setq string (replace-match (or value "") t t string) | |
| 555 start (+ (match-beginning 0) (length value))))) | |
| 556 ((match-beginning 2) | |
| 557 (let ((value (getenv (match-string 2 string)))) | |
| 558 (setq string (replace-match (or value "") t t string) | |
| 559 start (+ (match-beginning 0) (length value))))) | |
| 560 (t | |
| 561 (setq string (replace-match "$" t t string) | |
| 562 start (+ (match-beginning 0) 1))))) | |
| 563 string)) | |
| 564 | |
| 565 (defun setenv (variable &optional value unset substitute-env-vars) | |
| 771 | 566 "Set the value of the environment variable named VARIABLE to VALUE. |
| 567 VARIABLE should be a string. VALUE is optional; if not provided or is | |
| 568 `nil', the environment variable VARIABLE will be removed. | |
| 569 | |
| 930 | 570 UNSET, if non-nil, means to remove VARIABLE from the environment. |
| 571 SUBSTITUTE-ENV-VARS, if non-nil, means to substitute environment | |
| 572 variables in VALUE using `substitute-env-vars'. | |
| 573 | |
| 771 | 574 Interactively, a prefix argument means to unset the variable. |
| 575 Interactively, the current value (if any) of the variable | |
| 576 appears at the front of the history list when you type in the new value. | |
| 577 | |
| 578 This function works by modifying `process-environment'." | |
| 579 (interactive | |
| 580 (if current-prefix-arg | |
| 581 (list (read-envvar-name "Clear environment variable: " 'exact) nil t) | |
| 582 (let ((var (read-envvar-name "Set environment variable: " nil))) | |
| 583 ;; Here finally we specify the args to call setenv with. | |
| 584 (list var (read-from-minibuffer (format "Set %s to value: " var) | |
| 585 nil nil nil 'setenv-history | |
| 586 (getenv var)))))) | |
| 930 | 587 (if unset |
| 588 (setq value nil) | |
| 589 (if substitute-env-vars | |
| 590 (setq value (substitute-env-vars value)))) | |
| 771 | 591 (if (string-match "=" variable) |
| 592 (error "Environment variable name `%s' contains `='" variable) | |
| 593 (let ((pattern (concat "\\`" (regexp-quote (concat variable "=")))) | |
| 594 (case-fold-search nil) | |
| 595 (scan process-environment) | |
| 596 found) | |
| 597 (if (string-equal "TZ" variable) | |
| 598 (set-time-zone-rule value)) | |
| 599 (while scan | |
| 600 (cond ((string-match pattern (car scan)) | |
| 601 (setq found t) | |
| 602 (if (eq nil value) | |
| 603 (setq process-environment (delq (car scan) process-environment)) | |
| 604 (setcar scan (concat variable "=" value))) | |
| 605 (setq scan nil))) | |
| 606 (setq scan (cdr scan))) | |
| 607 (or found | |
| 608 (if value | |
| 609 (setq process-environment | |
| 610 (cons (concat variable "=" value) | |
| 611 process-environment))))))) | |
| 612 | |
| 613 ;; already in C. Can't move it to Lisp too easily because it's needed | |
| 614 ;; extremely early in the Lisp loadup sequence. | |
| 615 | |
| 616 ; (defun getenv (variable) | |
| 617 ; "Get the value of environment variable VARIABLE. | |
| 618 ; VARIABLE should be a string. Value is nil if VARIABLE is undefined in | |
| 619 ; the environment. Otherwise, value is a string. | |
| 620 ; | |
| 621 ; This function consults the variable `process-environment' | |
| 622 ; for its value." | |
| 623 ; (interactive (list (read-envvar-name "Get environment variable: " t))) | |
| 624 ; (let ((value (getenv-internal variable))) | |
| 625 ; (when (interactive-p) | |
| 626 ; (message "%s" (if value value "Not set"))) | |
| 627 ; value)) | |
| 628 | |
| 629 (provide 'env) ;; Yuck. Formerly the above were in env.el, which did this | |
| 630 ;; provide. | |
| 428 | 631 |
| 632 ;;; process.el ends here |