Mercurial > hg > xemacs-beta
annotate lisp/frame.el @ 5127:a9c41067dd88 ben-lisp-object
more cleanups, terminology clarification, lots of doc work
-------------------- ChangeLog entries follow: --------------------
man/ChangeLog addition:
2010-03-05 Ben Wing <ben@xemacs.org>
* internals/internals.texi (Introduction to Allocation):
* internals/internals.texi (Integers and Characters):
* internals/internals.texi (Allocation from Frob Blocks):
* internals/internals.texi (lrecords):
* internals/internals.texi (Low-level allocation):
Rewrite section on allocation of Lisp objects to reflect the new
reality. Remove references to nonexistent XSETINT and XSETCHAR.
modules/ChangeLog addition:
2010-03-05 Ben Wing <ben@xemacs.org>
* postgresql/postgresql.c (allocate_pgconn):
* postgresql/postgresql.c (allocate_pgresult):
* postgresql/postgresql.h (struct Lisp_PGconn):
* postgresql/postgresql.h (struct Lisp_PGresult):
* ldap/eldap.c (allocate_ldap):
* ldap/eldap.h (struct Lisp_LDAP):
Same changes as in src/ dir. See large log there in ChangeLog,
but basically:
ALLOC_LISP_OBJECT -> ALLOC_NORMAL_LISP_OBJECT
LISP_OBJECT_HEADER -> NORMAL_LISP_OBJECT_HEADER
../hlo/src/ChangeLog addition:
2010-03-05 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (old_alloc_sized_lcrecord):
* alloc.c (very_old_free_lcrecord):
* alloc.c (copy_lisp_object):
* alloc.c (zero_sized_lisp_object):
* alloc.c (zero_nonsized_lisp_object):
* alloc.c (lisp_object_storage_size):
* alloc.c (free_normal_lisp_object):
* alloc.c (FREE_FIXED_TYPE_WHEN_NOT_IN_GC):
* alloc.c (ALLOC_FROB_BLOCK_LISP_OBJECT):
* alloc.c (Fcons):
* alloc.c (noseeum_cons):
* alloc.c (make_float):
* alloc.c (make_bignum):
* alloc.c (make_bignum_bg):
* alloc.c (make_ratio):
* alloc.c (make_ratio_bg):
* alloc.c (make_ratio_rt):
* alloc.c (make_bigfloat):
* alloc.c (make_bigfloat_bf):
* alloc.c (size_vector):
* alloc.c (make_compiled_function):
* alloc.c (Fmake_symbol):
* alloc.c (allocate_extent):
* alloc.c (allocate_event):
* alloc.c (make_key_data):
* alloc.c (make_button_data):
* alloc.c (make_motion_data):
* alloc.c (make_process_data):
* alloc.c (make_timeout_data):
* alloc.c (make_magic_data):
* alloc.c (make_magic_eval_data):
* alloc.c (make_eval_data):
* alloc.c (make_misc_user_data):
* alloc.c (Fmake_marker):
* alloc.c (noseeum_make_marker):
* alloc.c (size_string_direct_data):
* alloc.c (make_uninit_string):
* alloc.c (make_string_nocopy):
* alloc.c (mark_lcrecord_list):
* alloc.c (alloc_managed_lcrecord):
* alloc.c (free_managed_lcrecord):
* alloc.c (sweep_lcrecords_1):
* alloc.c (malloced_storage_size):
* buffer.c (allocate_buffer):
* buffer.c (compute_buffer_usage):
* buffer.c (DEFVAR_BUFFER_LOCAL_1):
* buffer.c (nuke_all_buffer_slots):
* buffer.c (common_init_complex_vars_of_buffer):
* buffer.h (struct buffer_text):
* buffer.h (struct buffer):
* bytecode.c:
* bytecode.c (make_compiled_function_args):
* bytecode.c (size_compiled_function_args):
* bytecode.h (struct compiled_function_args):
* casetab.c (allocate_case_table):
* casetab.h (struct Lisp_Case_Table):
* charset.h (struct Lisp_Charset):
* chartab.c (fill_char_table):
* chartab.c (Fmake_char_table):
* chartab.c (make_char_table_entry):
* chartab.c (copy_char_table_entry):
* chartab.c (Fcopy_char_table):
* chartab.c (put_char_table):
* chartab.h (struct Lisp_Char_Table_Entry):
* chartab.h (struct Lisp_Char_Table):
* console-gtk-impl.h (struct gtk_device):
* console-gtk-impl.h (struct gtk_frame):
* console-impl.h (struct console):
* console-msw-impl.h (struct Lisp_Devmode):
* console-msw-impl.h (struct mswindows_device):
* console-msw-impl.h (struct msprinter_device):
* console-msw-impl.h (struct mswindows_frame):
* console-msw-impl.h (struct mswindows_dialog_id):
* console-stream-impl.h (struct stream_console):
* console-stream.c (stream_init_console):
* console-tty-impl.h (struct tty_console):
* console-tty-impl.h (struct tty_device):
* console-tty.c (allocate_tty_console_struct):
* console-x-impl.h (struct x_device):
* console-x-impl.h (struct x_frame):
* console.c (allocate_console):
* console.c (nuke_all_console_slots):
* console.c (DEFVAR_CONSOLE_LOCAL_1):
* console.c (common_init_complex_vars_of_console):
* data.c (make_weak_list):
* data.c (make_weak_box):
* data.c (make_ephemeron):
* database.c:
* database.c (struct Lisp_Database):
* database.c (allocate_database):
* database.c (finalize_database):
* device-gtk.c (allocate_gtk_device_struct):
* device-impl.h (struct device):
* device-msw.c:
* device-msw.c (mswindows_init_device):
* device-msw.c (msprinter_init_device):
* device-msw.c (finalize_devmode):
* device-msw.c (allocate_devmode):
* device-tty.c (allocate_tty_device_struct):
* device-x.c (allocate_x_device_struct):
* device.c:
* device.c (nuke_all_device_slots):
* device.c (allocate_device):
* dialog-msw.c (handle_question_dialog_box):
* elhash.c:
* elhash.c (struct Lisp_Hash_Table):
* elhash.c (finalize_hash_table):
* elhash.c (make_general_lisp_hash_table):
* elhash.c (Fcopy_hash_table):
* elhash.h (htentry):
* emacs.c (main_1):
* eval.c:
* eval.c (size_multiple_value):
* event-stream.c (finalize_command_builder):
* event-stream.c (allocate_command_builder):
* event-stream.c (free_command_builder):
* event-stream.c (event_stream_generate_wakeup):
* event-stream.c (event_stream_resignal_wakeup):
* event-stream.c (event_stream_disable_wakeup):
* event-stream.c (event_stream_wakeup_pending_p):
* events.h (struct Lisp_Timeout):
* events.h (struct command_builder):
* extents-impl.h:
* extents-impl.h (struct extent_auxiliary):
* extents-impl.h (struct extent_info):
* extents-impl.h (set_extent_no_chase_aux_field):
* extents-impl.h (set_extent_no_chase_normal_field):
* extents.c:
* extents.c (gap_array_marker):
* extents.c (gap_array):
* extents.c (extent_list_marker):
* extents.c (extent_list):
* extents.c (stack_of_extents):
* extents.c (gap_array_make_marker):
* extents.c (extent_list_make_marker):
* extents.c (allocate_extent_list):
* extents.c (SLOT):
* extents.c (mark_extent_auxiliary):
* extents.c (allocate_extent_auxiliary):
* extents.c (attach_extent_auxiliary):
* extents.c (size_gap_array):
* extents.c (finalize_extent_info):
* extents.c (allocate_extent_info):
* extents.c (uninit_buffer_extents):
* extents.c (allocate_soe):
* extents.c (copy_extent):
* extents.c (vars_of_extents):
* extents.h:
* faces.c (allocate_face):
* faces.h (struct Lisp_Face):
* faces.h (struct face_cachel):
* file-coding.c:
* file-coding.c (finalize_coding_system):
* file-coding.c (sizeof_coding_system):
* file-coding.c (Fcopy_coding_system):
* file-coding.h (struct Lisp_Coding_System):
* file-coding.h (MARKED_SLOT):
* fns.c (size_bit_vector):
* font-mgr.c:
* font-mgr.c (finalize_fc_pattern):
* font-mgr.c (print_fc_pattern):
* font-mgr.c (Ffc_pattern_p):
* font-mgr.c (Ffc_pattern_create):
* font-mgr.c (Ffc_name_parse):
* font-mgr.c (Ffc_name_unparse):
* font-mgr.c (Ffc_pattern_duplicate):
* font-mgr.c (Ffc_pattern_add):
* font-mgr.c (Ffc_pattern_del):
* font-mgr.c (Ffc_pattern_get):
* font-mgr.c (fc_config_create_using):
* font-mgr.c (fc_strlist_to_lisp_using):
* font-mgr.c (fontset_to_list):
* font-mgr.c (Ffc_config_p):
* font-mgr.c (Ffc_config_up_to_date):
* font-mgr.c (Ffc_config_build_fonts):
* font-mgr.c (Ffc_config_get_cache):
* font-mgr.c (Ffc_config_get_fonts):
* font-mgr.c (Ffc_config_set_current):
* font-mgr.c (Ffc_config_get_blanks):
* font-mgr.c (Ffc_config_get_rescan_interval):
* font-mgr.c (Ffc_config_set_rescan_interval):
* font-mgr.c (Ffc_config_app_font_add_file):
* font-mgr.c (Ffc_config_app_font_add_dir):
* font-mgr.c (Ffc_config_app_font_clear):
* font-mgr.c (size):
* font-mgr.c (Ffc_config_substitute):
* font-mgr.c (Ffc_font_render_prepare):
* font-mgr.c (Ffc_font_match):
* font-mgr.c (Ffc_font_sort):
* font-mgr.c (finalize_fc_config):
* font-mgr.c (print_fc_config):
* font-mgr.h:
* font-mgr.h (struct fc_pattern):
* font-mgr.h (XFC_PATTERN):
* font-mgr.h (struct fc_config):
* font-mgr.h (XFC_CONFIG):
* frame-gtk.c (allocate_gtk_frame_struct):
* frame-impl.h (struct frame):
* frame-msw.c (mswindows_init_frame_1):
* frame-x.c (allocate_x_frame_struct):
* frame.c (nuke_all_frame_slots):
* frame.c (allocate_frame_core):
* gc.c:
* gc.c (GC_CHECK_NOT_FREE):
* glyphs.c (finalize_image_instance):
* glyphs.c (allocate_image_instance):
* glyphs.c (Fcolorize_image_instance):
* glyphs.c (allocate_glyph):
* glyphs.c (unmap_subwindow_instance_cache_mapper):
* glyphs.c (register_ignored_expose):
* glyphs.h (struct Lisp_Image_Instance):
* glyphs.h (struct Lisp_Glyph):
* glyphs.h (struct glyph_cachel):
* glyphs.h (struct expose_ignore):
* gui.c (allocate_gui_item):
* gui.h (struct Lisp_Gui_Item):
* keymap.c (struct Lisp_Keymap):
* keymap.c (make_keymap):
* lisp.h:
* lisp.h (struct Lisp_String_Direct_Data):
* lisp.h (struct Lisp_String_Indirect_Data):
* lisp.h (struct Lisp_Vector):
* lisp.h (struct Lisp_Bit_Vector):
* lisp.h (DECLARE_INLINE_LISP_BIT_VECTOR):
* lisp.h (struct weak_box):
* lisp.h (struct ephemeron):
* lisp.h (struct weak_list):
* lrecord.h:
* lrecord.h (struct lrecord_implementation):
* lrecord.h (MC_ALLOC_CALL_FINALIZER):
* lrecord.h (struct lcrecord_list):
* lstream.c (finalize_lstream):
* lstream.c (sizeof_lstream):
* lstream.c (Lstream_new):
* lstream.c (Lstream_delete):
* lstream.h (struct lstream):
* marker.c:
* marker.c (finalize_marker):
* marker.c (compute_buffer_marker_usage):
* mule-charset.c:
* mule-charset.c (make_charset):
* mule-charset.c (compute_charset_usage):
* objects-impl.h (struct Lisp_Color_Instance):
* objects-impl.h (struct Lisp_Font_Instance):
* objects-tty-impl.h (struct tty_color_instance_data):
* objects-tty-impl.h (struct tty_font_instance_data):
* objects-tty.c (tty_initialize_color_instance):
* objects-tty.c (tty_initialize_font_instance):
* objects.c (finalize_color_instance):
* objects.c (Fmake_color_instance):
* objects.c (finalize_font_instance):
* objects.c (Fmake_font_instance):
* objects.c (reinit_vars_of_objects):
* opaque.c:
* opaque.c (sizeof_opaque):
* opaque.c (make_opaque_ptr):
* opaque.c (free_opaque_ptr):
* opaque.h:
* opaque.h (Lisp_Opaque):
* opaque.h (Lisp_Opaque_Ptr):
* print.c (printing_unreadable_lcrecord):
* print.c (external_object_printer):
* print.c (debug_p4):
* process.c (finalize_process):
* process.c (make_process_internal):
* procimpl.h (struct Lisp_Process):
* rangetab.c (Fmake_range_table):
* rangetab.c (Fcopy_range_table):
* rangetab.h (struct Lisp_Range_Table):
* scrollbar.c:
* scrollbar.c (create_scrollbar_instance):
* scrollbar.c (compute_scrollbar_instance_usage):
* scrollbar.h (struct scrollbar_instance):
* specifier.c (finalize_specifier):
* specifier.c (sizeof_specifier):
* specifier.c (set_specifier_caching):
* specifier.h (struct Lisp_Specifier):
* specifier.h (struct specifier_caching):
* symeval.h:
* symeval.h (SYMBOL_VALUE_MAGIC_P):
* symeval.h (DEFVAR_SYMVAL_FWD):
* symsinit.h:
* syntax.c (init_buffer_syntax_cache):
* syntax.h (struct syntax_cache):
* toolbar.c:
* toolbar.c (allocate_toolbar_button):
* toolbar.c (update_toolbar_button):
* toolbar.h (struct toolbar_button):
* tooltalk.c (struct Lisp_Tooltalk_Message):
* tooltalk.c (make_tooltalk_message):
* tooltalk.c (struct Lisp_Tooltalk_Pattern):
* tooltalk.c (make_tooltalk_pattern):
* ui-gtk.c:
* ui-gtk.c (allocate_ffi_data):
* ui-gtk.c (emacs_gtk_object_finalizer):
* ui-gtk.c (allocate_emacs_gtk_object_data):
* ui-gtk.c (allocate_emacs_gtk_boxed_data):
* ui-gtk.h:
* window-impl.h (struct window):
* window-impl.h (struct window_mirror):
* window.c (finalize_window):
* window.c (allocate_window):
* window.c (new_window_mirror):
* window.c (mark_window_as_deleted):
* window.c (make_dummy_parent):
* window.c (compute_window_mirror_usage):
* window.c (compute_window_usage):
Overall point of this change and previous ones in this repository:
(1) Introduce new, clearer terminology: everything other than int
or char is a "record" object, which comes in two types: "normal
objects" and "frob-block objects". Fix up all places that
referred to frob-block objects as "simple", "basic", etc.
(2) Provide an advertised interface for doing operations on Lisp
objects, including creating new types, that is clean and
consistent in its naming, uses the above-referenced terms and
avoids referencing "lrecords", "old lcrecords", etc., which should
hide under the surface.
(3) Make the size_in_bytes and finalizer methods take a
Lisp_Object rather than a void * for consistency with other methods.
(4) Separate finalizer method into finalizer and disksaver, so
that normal finalize methods don't have to worry about disksaving.
Other specifics:
(1) Renaming:
LISP_OBJECT_HEADER -> NORMAL_LISP_OBJECT_HEADER
ALLOC_LISP_OBJECT -> ALLOC_NORMAL_LISP_OBJECT
implementation->basic_p -> implementation->frob_block_p
ALLOCATE_FIXED_TYPE_AND_SET_IMPL -> ALLOC_FROB_BLOCK_LISP_OBJECT
*FCCONFIG*, wrap_fcconfig -> *FC_CONFIG*, wrap_fc_config
*FCPATTERN*, wrap_fcpattern -> *FC_PATTERN*, wrap_fc_pattern
(the last two changes make the naming of these macros consistent
with the naming of all other macros, since the objects are named
fc-config and fc-pattern with a hyphen)
(2) Lots of documentation fixes in lrecord.h.
(3) Eliminate macros for copying, freeing, zeroing objects, getting
their storage size. Instead, new functions:
zero_sized_lisp_object()
zero_nonsized_lisp_object()
lisp_object_storage_size()
free_normal_lisp_object()
(copy_lisp_object() already exists)
LISP_OBJECT_FROB_BLOCK_P() (actually a macro)
Eliminated:
free_lrecord()
zero_lrecord()
copy_lrecord()
copy_sized_lrecord()
old_copy_lcrecord()
old_copy_sized_lcrecord()
old_zero_lcrecord()
old_zero_sized_lcrecord()
LISP_OBJECT_STORAGE_SIZE()
COPY_SIZED_LISP_OBJECT()
COPY_SIZED_LCRECORD()
COPY_LISP_OBJECT()
ZERO_LISP_OBJECT()
FREE_LISP_OBJECT()
(4) Catch the remaining places where lrecord stuff was used directly
and use the advertised interface, e.g. alloc_sized_lrecord() ->
ALLOC_SIZED_LISP_OBJECT().
(5) Make certain statically-declared pseudo-objects
(buffer_local_flags, console_local_flags) have their lheader
initialized correctly, so things like copy_lisp_object() can work
on them. Make extent_auxiliary_defaults a proper heap object
Vextent_auxiliary_defaults, and make extent auxiliaries dumpable
so that this object can be dumped. allocate_extent_auxiliary()
now just creates the object, and attach_extent_auxiliary()
creates an extent auxiliary and attaches to an extent, like the
old allocate_extent_auxiliary().
(6) Create EXTENT_AUXILIARY_SLOTS macro, similar to the foo-slots.h
files but in a macro instead of a file. The purpose is to avoid
duplication when iterating over all the slots in an extent auxiliary.
Use it.
(7) In lstream.c, don't zero out object after allocation because
allocation routines take care of this.
(8) In marker.c, fix a mistake in computing marker overhead.
(9) In print.c, clean up printing_unreadable_lcrecord(),
external_object_printer() to avoid lots of ifdef NEW_GC's.
(10) Separate toolbar-button allocation into a separate
allocate_toolbar_button() function for use in the example code
in lrecord.h.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Fri, 05 Mar 2010 04:08:17 -0600 |
| parents | e29fcfd8df5f |
| children | 5502045ec510 |
| rev | line source |
|---|---|
| 428 | 1 ;;; frame.el --- multi-frame management independent of window systems. |
| 2 | |
| 1942 | 3 ;; Copyright (C) 1993, 1994, 1996, 1997, 2000, 2001, 2003 |
| 4 ;; Free Software Foundation, Inc. | |
| 428 | 5 ;; Copyright (C) 1995, 1996 Ben Wing. |
| 6 | |
| 7 ;; Maintainer: XEmacs Development Team | |
| 8 ;; Keywords: internal, 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 | |
| 23 ;; along with XEmacs; see the file COPYING. If not, write to the | |
| 1942 | 24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
| 428 | 25 ;; Boston, MA 02111-1307, USA. |
| 26 | |
| 1942 | 27 ;;; Synched up with: FSF 21.3. |
| 428 | 28 |
| 29 ;;; Commentary: | |
| 30 | |
| 31 ;; This file is dumped with XEmacs. | |
| 32 | |
| 33 ;;; Code: | |
| 34 | |
| 1942 | 35 ;; XEmacs addition |
| 428 | 36 (defgroup frames nil |
| 37 "Support for Emacs frames and window systems." | |
| 38 :group 'environment) | |
| 39 | |
| 1942 | 40 ;; XEmacs change: No need for `frame-creation-function'. |
| 428 | 41 |
| 1942 | 42 ;; XEmacs change: Emacs no longer specifies the minibuffer property here. |
| 428 | 43 ;;; The initial value given here for this must ask for a minibuffer. |
| 44 ;;; There must always exist a frame with a minibuffer, and after we | |
| 45 ;;; delete the terminal frame, this will be the only frame. | |
| 46 (defcustom initial-frame-plist '(minibuffer t) | |
| 47 "Plist of frame properties for creating the initial X window frame. | |
| 48 You can set this in your `.emacs' file; for example, | |
| 49 (setq initial-frame-plist '(top 1 left 1 width 80 height 55)) | |
| 50 Properties specified here supersede the values given in `default-frame-plist'. | |
| 51 The format of this can also be an alist for backward compatibility. | |
| 52 | |
| 53 If the value calls for a frame without a minibuffer, and you have not created | |
| 54 a minibuffer frame on your own, one is created according to | |
| 55 `minibuffer-frame-plist'. | |
| 56 | |
| 57 You can specify geometry-related options for just the initial frame | |
| 58 by setting this variable in your `.emacs' file; however, they won't | |
| 59 take effect until Emacs reads `.emacs', which happens after first creating | |
| 60 the frame. If you want the frame to have the proper geometry as soon | |
| 61 as it appears, you need to use this three-step process: | |
| 62 * Specify X resources to give the geometry you want. | |
| 63 * Set `default-frame-plist' to override these options so that they | |
| 64 don't affect subsequent frames. | |
| 65 * Set `initial-frame-plist' in a way that matches the X resources, | |
| 66 to override what you put in `default-frame-plist'." | |
| 67 :type 'plist | |
| 68 :group 'frames) | |
| 69 | |
| 70 (defcustom minibuffer-frame-plist '(width 80 height 2 menubar-visible-p nil | |
| 1942 | 71 default-toolbar-visible-p nil) |
| 428 | 72 "Plist of frame properties for initially creating a minibuffer frame. |
| 73 You can set this in your `.emacs' file; for example, | |
| 74 (setq minibuffer-frame-plist '(top 1 left 1 width 80 height 2)) | |
| 75 Properties specified here supersede the values given in | |
| 76 `default-frame-plist'. | |
| 77 The format of this can also be an alist for backward compatibility." | |
| 78 :type 'plist | |
| 79 :group 'frames) | |
| 80 | |
| 81 (defcustom pop-up-frame-plist nil | |
| 82 "Plist of frame properties used when creating pop-up frames. | |
| 83 Pop-up frames are used for completions, help, and the like. | |
| 84 This variable can be set in your init file, like this: | |
| 85 (setq pop-up-frame-plist '(width 80 height 20)) | |
| 1942 | 86 These supersede the values given in `default-frame-plist', for pop-up frames. |
| 428 | 87 The format of this can also be an alist for backward compatibility." |
| 88 :type 'plist | |
| 89 :group 'frames) | |
| 90 | |
| 91 (setq pop-up-frame-function | |
| 1942 | 92 #'(lambda () |
| 93 (make-frame pop-up-frame-plist))) | |
| 428 | 94 |
| 95 (defcustom special-display-frame-plist '(height 14 width 80 unsplittable t) | |
| 96 "*Plist of frame properties used when creating special frames. | |
| 97 Special frames are used for buffers whose names are in | |
| 98 `special-display-buffer-names' and for buffers whose names match | |
| 99 one of the regular expressions in `special-display-regexps'. | |
| 100 This variable can be set in your init file, like this: | |
| 101 (setq special-display-frame-plist '(width 80 height 20)) | |
| 102 These supersede the values given in `default-frame-plist'. | |
| 103 The format of this can also be an alist for backward compatibility." | |
| 104 :type 'plist | |
| 105 :group 'frames) | |
| 106 | |
| 1942 | 107 ;; XEmacs addition |
| 428 | 108 (defun safe-alist-to-plist (cruftiness) |
| 109 (if (consp (car cruftiness)) | |
| 110 (alist-to-plist cruftiness) | |
| 111 cruftiness)) | |
| 112 | |
| 1942 | 113 ;; XEmacs change: require args to be a plist instead of an alist. |
| 428 | 114 (defun special-display-popup-frame (buffer &optional args) |
| 1942 | 115 "Display BUFFER in its own frame, reusing an existing window if any. |
| 116 Return the window chosen. | |
| 117 Currently we do not insist on selecting the window within its frame. | |
| 118 If ARGS is a plist, use it as a list of frame property specs. | |
| 119 If ARGS is a list whose car is t, | |
| 120 use (cadr ARGS) as a function to do the work. | |
| 121 Pass it BUFFER as first arg, and (cddr ARGS) gives the rest of the args." | |
| 428 | 122 ;; if we can't display simultaneous multiple frames, just return |
| 123 ;; nil and let the normal behavior take over. | |
| 124 (and (device-on-window-system-p) | |
| 125 (if (and args (eq t (car args))) | |
| 126 (apply (cadr args) buffer (cddr args)) | |
| 127 (let ((window (get-buffer-window buffer t))) | |
| 1942 | 128 (setq args (safe-alist-to-plist args)) |
| 129 (or | |
| 130 ;; If we have a window already, make it visible. | |
| 131 (when window | |
| 132 (let ((frame (window-frame window))) | |
| 133 (make-frame-visible frame) | |
| 134 (raise-frame frame) | |
| 135 window)) | |
| 136 ;; Reuse the current window if the user requested it. | |
| 137 (when (lax-plist-get args 'same-window) | |
| 138 (condition-case nil | |
| 139 (progn (switch-to-buffer buffer) (selected-window)) | |
| 140 (error nil))) | |
| 141 ;; Stay on the same frame if requested. | |
| 142 (when (or (lax-plist-get args 'same-frame) | |
| 143 (lax-plist-get args 'same-window)) | |
| 144 (let* ((pop-up-frames nil) (pop-up-windows t) | |
| 145 special-display-regexps special-display-buffer-names | |
| 146 (window (display-buffer buffer))) | |
| 147 ;; (set-window-dedicated-p window t) | |
| 148 window)) | |
| 149 ;; If no window yet, make one in a new frame. | |
| 150 (let ((frame (make-frame (append args | |
| 151 (safe-alist-to-plist | |
| 152 special-display-frame-plist))))) | |
| 153 (set-window-buffer (frame-selected-window frame) buffer) | |
| 154 (set-window-dedicated-p (frame-selected-window frame) t) | |
| 155 (frame-selected-window frame))))))) | |
| 428 | 156 |
| 1942 | 157 ;; XEmacs change: comment out |
| 428 | 158 ;(defun handle-delete-frame (event) |
| 1942 | 159 ; "Handle delete-frame events from the X server." |
| 428 | 160 ; (interactive "e") |
| 161 ; (let ((frame (posn-window (event-start event))) | |
| 162 ; (i 0) | |
| 163 ; (tail (frame-list))) | |
| 164 ; (while tail | |
| 165 ; (and (frame-visible-p (car tail)) | |
| 166 ; (not (eq (car tail) frame)) | |
| 167 ; (setq i (1+ i))) | |
| 168 ; (setq tail (cdr tail))) | |
| 169 ; (if (> i 0) | |
| 170 ; (delete-frame frame t) | |
| 1942 | 171 ; ;; Gildea@x.org says it is ok to ask questions before terminating. |
| 172 ; (save-buffers-kill-emacs)))) | |
| 428 | 173 |
| 174 ;;;; Arrangement of frames at startup | |
| 175 | |
| 1942 | 176 ;; 1) Load the window system startup file from the lisp library and read the |
| 177 ;; high-priority arguments (-q and the like). The window system startup | |
| 178 ;; file should create any frames specified in the window system defaults. | |
| 179 ;; | |
| 180 ;; 2) If no frames have been opened, we open an initial text frame. | |
| 181 ;; | |
| 182 ;; 3) Once the init file is done, we apply any newly set properties | |
| 183 ;; in initial-frame-plist to the frame. | |
| 428 | 184 |
| 1942 | 185 ;; These are now called explicitly at the proper times, |
| 186 ;; since that is easier to understand. | |
| 187 ;; Actually using hooks within Emacs is bad for future maintenance. --rms. | |
| 188 ;; (add-hook 'before-init-hook 'frame-initialize) | |
| 189 ;; (add-hook 'window-setup-hook 'frame-notice-user-settings) | |
| 190 | |
| 191 ;; If we create the initial frame, this is it. | |
| 428 | 192 (defvar frame-initial-frame nil) |
| 193 | |
| 194 ;; Record the properties used in frame-initialize to make the initial frame. | |
| 195 (defvar frame-initial-frame-plist) | |
| 196 | |
| 197 (defvar frame-initial-geometry-arguments nil) | |
| 198 | |
| 1942 | 199 ;; XEmacs addition |
| 428 | 200 (defun canonicalize-frame-plists () |
| 201 (setq initial-frame-plist (safe-alist-to-plist initial-frame-plist)) | |
| 202 (setq default-frame-plist (safe-alist-to-plist default-frame-plist))) | |
| 203 | |
| 1942 | 204 ;; startup.el calls this function before loading the user's init |
| 205 ;; file - if there is no frame with a minibuffer open now, create | |
| 206 ;; one to display messages while loading the init file. | |
| 428 | 207 (defun frame-initialize () |
| 1942 | 208 "Create an initial frame if necessary." |
| 428 | 209 ;; In batch mode, we actually use the initial terminal device for output. |
| 1942 | 210 ;; XEmacs addition |
| 428 | 211 (canonicalize-frame-plists) |
| 1942 | 212 |
| 428 | 213 (if (not (noninteractive)) |
| 214 (progn | |
| 1942 | 215 ;; Turn on special-display processing only if there's a window system. |
| 216 (setq special-display-function 'special-display-popup-frame) | |
| 428 | 217 |
| 218 ;; If there is no frame with a minibuffer besides the terminal | |
| 219 ;; frame, then we need to create the opening frame. Make sure | |
| 220 ;; it has a minibuffer, but let initial-frame-plist omit the | |
| 221 ;; minibuffer spec. | |
| 222 (or (delq terminal-frame (minibuffer-frame-list)) | |
| 223 (progn | |
| 224 (setq frame-initial-frame-plist | |
| 225 (append initial-frame-plist default-frame-plist)) | |
| 1942 | 226 ;; XEmacs change: omit the scrollbar settings |
| 227 ; (or (assq 'horizontal-scroll-bars frame-initial-frame-alist) | |
| 228 ; (setq frame-initial-frame-alist | |
| 229 ; (cons '(horizontal-scroll-bars . t) | |
| 230 ; frame-initial-frame-alist))) | |
| 428 | 231 (setq default-minibuffer-frame |
| 232 (setq frame-initial-frame | |
| 233 (make-frame initial-frame-plist | |
| 234 (car (delq terminal-device | |
| 235 (device-list)))))) | |
| 236 ;; Delete any specifications for window geometry properties | |
| 237 ;; so that we won't reapply them in frame-notice-user-settings. | |
| 238 ;; It would be wrong to reapply them then, | |
| 239 ;; because that would override explicit user resizing. | |
| 240 (setq initial-frame-plist | |
| 241 (frame-remove-geometry-props initial-frame-plist)))) | |
| 242 ;; At this point, we know that we have a frame open, so we | |
| 1942 | 243 ;; can delete the terminal frame. |
| 244 ;; XEmacs change: Do it the same way Fkill_emacs does it. -slb | |
| 428 | 245 (delete-console terminal-console) |
| 1942 | 246 (setq terminal-frame nil)) |
| 428 | 247 |
| 1942 | 248 ;; XEmacs change: omit the pc window-system stuff. |
| 249 ; ;; No, we're not running a window system. Use make-terminal-frame if | |
| 250 ; ;; we support that feature, otherwise arrange to cause errors. | |
| 251 ; (or (eq window-system 'pc) | |
| 252 ; (setq frame-creation-function | |
| 253 ; (if (fboundp 'tty-create-frame-with-faces) | |
| 254 ; 'tty-create-frame-with-faces | |
| 255 ; (function | |
| 256 ; (lambda (parameters) | |
| 257 ; (error | |
| 258 ; "Can't create multiple frames without a window system")))))) | |
| 259 )) | |
| 260 | |
| 261 (defvar frame-notice-user-settings t | |
| 262 "Non-nil means function `frame-notice-user-settings' wasn't run yet.") | |
| 428 | 263 |
| 1942 | 264 ;; startup.el calls this function after loading the user's init |
| 265 ;; file. Now default-frame-plist and initial-frame-plist contain | |
| 266 ;; information to which we must react; do what needs to be done. | |
| 428 | 267 (defun frame-notice-user-settings () |
| 1942 | 268 "Act on user's init file settings of frame parameters. |
| 269 React to settings of `default-frame-plist', `initial-frame-plist' there." | |
| 270 ;; XEmacs addition | |
| 271 (canonicalize-frame-plists) | |
| 428 | 272 |
| 1942 | 273 ;; XEmacs change: omit menu-bar manipulations. |
| 274 ; ;; Make menu-bar-mode and default-frame-alist consistent. | |
| 275 ; (when (boundp 'menu-bar-mode) | |
| 276 ; (let ((default (assq 'menu-bar-lines default-frame-alist))) | |
| 277 ; (if default | |
| 278 ; (setq menu-bar-mode (not (eq (cdr default) 0))) | |
| 279 ; (setq default-frame-alist | |
| 280 ; (cons (cons 'menu-bar-lines (if menu-bar-mode 1 0)) | |
| 281 ; default-frame-alist))))) | |
| 428 | 282 |
| 1942 | 283 ;; XEmacs change: omit tool-bar manipulations. |
| 284 ; ;; Make tool-bar-mode and default-frame-alist consistent. Don't do | |
| 285 ; ;; it in batch mode since that would leave a tool-bar-lines | |
| 286 ; ;; parameter in default-frame-alist in a dumped Emacs, which is not | |
| 287 ; ;; what we want. | |
| 288 ; (when (and (boundp 'tool-bar-mode) | |
| 289 ; (not noninteractive)) | |
| 290 ; (let ((default (assq 'tool-bar-lines default-frame-alist))) | |
| 291 ; (if default | |
| 292 ; (setq tool-bar-mode (not (eq (cdr default) 0))) | |
| 293 ; (setq default-frame-alist | |
| 294 ; (cons (cons 'tool-bar-lines (if tool-bar-mode 1 0)) | |
| 295 ; default-frame-alist))))) | |
| 428 | 296 |
| 297 ;; Creating and deleting frames may shift the selected frame around, | |
| 298 ;; and thus the current buffer. Protect against that. We don't | |
| 299 ;; want to use save-excursion here, because that may also try to set | |
| 300 ;; the buffer of the selected window, which fails when the selected | |
| 301 ;; window is the minibuffer. | |
| 302 (let ((old-buffer (current-buffer))) | |
| 303 | |
| 1942 | 304 ;; XEmacs change: omit special handling for MS-DOS |
| 305 ; (when (and frame-notice-user-settings | |
| 306 ; (null frame-initial-frame)) | |
| 307 ; ;; This case happens when we don't have a window system, and | |
| 308 ; ;; also for MS-DOS frames. | |
| 309 ; (let ((parms (frame-parameters frame-initial-frame))) | |
| 310 ; ;; Don't change the frame names. | |
| 311 ; (setq parms (delq (assq 'name parms) parms)) | |
| 312 ; ;; Can't modify the minibuffer parameter, so don't try. | |
| 313 ; (setq parms (delq (assq 'minibuffer parms) parms)) | |
| 314 ; (modify-frame-parameters nil | |
| 315 ; (if (null window-system) | |
| 316 ; (append initial-frame-alist | |
| 317 ; default-frame-alist | |
| 318 ; parms | |
| 319 ; nil) | |
| 320 ; ;; initial-frame-alist and | |
| 321 ; ;; default-frame-alist were already | |
| 322 ; ;; applied in pc-win.el. | |
| 323 ; parms)) | |
| 324 ; (if (null window-system) ;; MS-DOS does this differently in pc-win.el | |
| 325 ; (let ((newparms (frame-parameters)) | |
| 326 ; (frame (selected-frame))) | |
| 327 ; (tty-handle-reverse-video frame newparms) | |
| 328 ; ;; If we changed the background color, we need to update | |
| 329 ; ;; the background-mode parameter, and maybe some faces, | |
| 330 ; ;; too. | |
| 331 ; (when (assq 'background-color newparms) | |
| 332 ; (unless (or (assq 'background-mode initial-frame-alist) | |
| 333 ; (assq 'background-mode default-frame-alist)) | |
| 334 ; (frame-set-background-mode frame)) | |
| 335 ; (face-set-after-frame-default frame)))))) | |
| 336 | |
| 428 | 337 ;; If the initial frame is still around, apply initial-frame-plist |
| 338 ;; and default-frame-plist to it. | |
| 1942 | 339 (when (frame-live-p frame-initial-frame) |
| 340 | |
| 341 ;; XEmacs change: omit the tool-bar manipulations | |
| 342 ; ;; When tool-bar has been switched off, correct the frame size | |
| 343 ; ;; by the lines added in x-create-frame for the tool-bar and | |
| 344 ; ;; switch `tool-bar-mode' off. | |
| 345 ; (when (display-graphic-p) | |
| 346 ; (let ((tool-bar-lines (or (assq 'tool-bar-lines initial-frame-alist) | |
| 347 ; (assq 'tool-bar-lines default-frame-alist)))) | |
| 348 ; (when (and tool-bar-originally-present | |
| 349 ; (or (null tool-bar-lines) | |
| 350 ; (null (cdr tool-bar-lines)) | |
| 351 ; (eq 0 (cdr tool-bar-lines)))) | |
| 352 ; (let* ((char-height (frame-char-height frame-initial-frame)) | |
| 353 ; (image-height tool-bar-images-pixel-height) | |
| 354 ; (margin (cond ((and (consp tool-bar-button-margin) | |
| 355 ; (integerp (cdr tool-bar-button-margin)) | |
| 356 ; (> tool-bar-button-margin 0)) | |
| 357 ; (cdr tool-bar-button-margin)) | |
| 358 ; ((and (integerp tool-bar-button-margin) | |
| 359 ; (> tool-bar-button-margin 0)) | |
| 360 ; tool-bar-button-margin) | |
| 361 ; (t 0))) | |
| 362 ; (relief (if (and (integerp tool-bar-button-relief) | |
| 363 ; (> tool-bar-button-relief 0)) | |
| 364 ; tool-bar-button-relief 3)) | |
| 365 ; (lines (/ (+ image-height | |
| 366 ; (* 2 margin) | |
| 367 ; (* 2 relief) | |
| 368 ; (1- char-height)) | |
| 369 ; char-height)) | |
| 370 ; (height (frame-parameter frame-initial-frame 'height)) | |
| 371 ; (newparms (list (cons 'height (- height lines)))) | |
| 372 ; (initial-top (cdr (assq 'top | |
| 373 ; frame-initial-geometry-arguments))) | |
| 374 ; (top (frame-parameter frame-initial-frame 'top))) | |
| 375 ; (when (and (consp initial-top) (eq '- (car initial-top))) | |
| 376 ; (let ((adjusted-top | |
| 377 ; (cond ((and (consp top) | |
| 378 ; (eq '+ (car top))) | |
| 379 ; (list '+ | |
| 380 ; (+ (cadr top) | |
| 381 ; (* lines char-height)))) | |
| 382 ; ((and (consp top) | |
| 383 ; (eq '- (car top))) | |
| 384 ; (list '- | |
| 385 ; (- (cadr top) | |
| 386 ; (* lines char-height)))) | |
| 387 ; (t (+ top (* lines char-height)))))) | |
| 388 ; (setq newparms | |
| 389 ; (append newparms | |
| 390 ; `((top . ,adjusted-top)) | |
| 391 ; nil)))) | |
| 392 ; (modify-frame-parameters frame-initial-frame newparms) | |
| 393 ; (tool-bar-mode -1))))) | |
| 428 | 394 |
| 395 ;; The initial frame we create above always has a minibuffer. | |
| 396 ;; If the user wants to remove it, or make it a minibuffer-only | |
| 397 ;; frame, then we'll have to delete the selected frame and make a | |
| 398 ;; new one; you can't remove or add a root window to/from an | |
| 399 ;; existing frame. | |
| 400 ;; | |
| 401 ;; NOTE: default-frame-plist was nil when we created the | |
| 402 ;; existing frame. We need to explicitly include | |
| 403 ;; default-frame-plist in the properties of the screen we | |
| 404 ;; create here, so that its new value, gleaned from the user's | |
| 405 ;; .emacs file, will be applied to the existing screen. | |
| 406 (if (not (eq (car | |
| 407 (or (and (lax-plist-member | |
| 408 initial-frame-plist 'minibuffer) | |
| 409 (list (lax-plist-get initial-frame-plist | |
| 410 'minibuffer))) | |
| 411 (and (lax-plist-member default-frame-plist | |
| 412 'minibuffer) | |
| 413 (list (lax-plist-get default-frame-plist | |
| 414 'minibuffer))) | |
| 415 '(t))) | |
| 416 t)) | |
| 417 ;; Create the new frame. | |
| 2367 | 418 (let (props ;new |
| 419 ) | |
| 428 | 420 ;; If the frame isn't visible yet, wait till it is. |
| 421 ;; If the user has to position the window, | |
| 422 ;; Emacs doesn't know its real position until | |
| 423 ;; the frame is seen to be visible. | |
| 424 | |
| 1942 | 425 ;; XEmacs change: check the initially-unmapped property |
| 428 | 426 (if (frame-property frame-initial-frame 'initially-unmapped) |
| 427 nil | |
| 428 (while (not (frame-visible-p frame-initial-frame)) | |
| 429 (sleep-for 1))) | |
| 430 (setq props (frame-properties frame-initial-frame)) | |
| 1942 | 431 |
| 428 | 432 ;; Get rid of `name' unless it was specified explicitly before. |
| 433 (or (lax-plist-member frame-initial-frame-plist 'name) | |
| 434 (setq props (lax-plist-remprop props 'name))) | |
| 1942 | 435 |
| 436 (setq props (append initial-frame-plist | |
| 437 default-frame-plist | |
| 428 | 438 props |
| 439 nil)) | |
| 1942 | 440 |
| 428 | 441 ;; Get rid of `reverse', because that was handled |
| 442 ;; when we first made the frame. | |
| 443 (laxputf props 'reverse nil) | |
| 1942 | 444 |
| 445 ;; XEmacs addition: Get rid of `window-id', otherwise make-frame | |
| 446 ;; will think we're trying to setup an external widget. | |
| 428 | 447 (laxremf props 'window-id) |
| 1942 | 448 |
| 428 | 449 (if (lax-plist-member frame-initial-geometry-arguments 'height) |
| 450 (laxremf props 'height)) | |
| 451 (if (lax-plist-member frame-initial-geometry-arguments 'width) | |
| 452 (laxremf props 'width)) | |
| 453 (if (lax-plist-member frame-initial-geometry-arguments 'left) | |
| 454 (laxremf props 'left)) | |
| 455 (if (lax-plist-member frame-initial-geometry-arguments 'top) | |
| 456 (laxremf props 'top)) | |
| 457 ;; Now create the replacement initial frame. | |
| 2367 | 458 ;(setq new |
| 459 (make-frame | |
| 460 ;; Use the geometry args that created the existing | |
| 461 ;; frame, rather than the props we get for it. | |
| 462 (append '(user-size t user-position t) | |
| 463 frame-initial-geometry-arguments | |
| 464 props)) | |
| 465 ;) | |
| 428 | 466 ;; The initial frame, which we are about to delete, may be |
| 467 ;; the only frame with a minibuffer. If it is, create a | |
| 468 ;; new one. | |
| 469 (or (delq frame-initial-frame (minibuffer-frame-list)) | |
| 470 (make-initial-minibuffer-frame nil)) | |
| 471 | |
| 472 ;; If the initial frame is serving as a surrogate | |
| 473 ;; minibuffer frame for any frames, we need to wean them | |
| 474 ;; onto a new frame. The default-minibuffer-frame | |
| 475 ;; variable must be handled similarly. | |
| 476 (let ((users-of-initial | |
| 477 (filtered-frame-list | |
| 478 #'(lambda (frame) | |
| 479 (and (not (eq frame frame-initial-frame)) | |
| 480 (eq (window-frame | |
| 481 (minibuffer-window frame)) | |
| 482 frame-initial-frame)))))) | |
| 483 (if (or users-of-initial | |
| 484 (eq default-minibuffer-frame frame-initial-frame)) | |
| 485 | |
| 486 ;; Choose an appropriate frame. Prefer frames which | |
| 487 ;; are only minibuffers. | |
| 488 (let* ((new-surrogate | |
| 489 (car | |
| 490 (or (filtered-frame-list | |
| 491 #'(lambda (frame) | |
| 492 (eq 'only | |
| 493 (frame-property frame 'minibuffer)))) | |
| 494 (minibuffer-frame-list)))) | |
| 495 (new-minibuffer (minibuffer-window new-surrogate))) | |
| 496 | |
| 497 (if (eq default-minibuffer-frame frame-initial-frame) | |
| 498 (setq default-minibuffer-frame new-surrogate)) | |
| 499 | |
| 500 ;; Wean the frames using frame-initial-frame as | |
| 501 ;; their minibuffer frame. | |
|
4783
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4759
diff
changeset
|
502 (mapc |
| 1942 | 503 #'(lambda (frame) |
| 504 (set-frame-property frame 'minibuffer | |
| 505 new-minibuffer)) | |
| 506 users-of-initial)))) | |
| 428 | 507 |
| 508 ;; Redirect events enqueued at this frame to the new frame. | |
| 509 ;; Is this a good idea? | |
| 510 ;; Probably not, since this whole redirect-frame-focus | |
| 511 ;; stuff is a load of trash, and so is this function we're in. | |
| 512 ;; --ben | |
| 513 ;(redirect-frame-focus frame-initial-frame new) | |
| 514 | |
| 515 ;; Finally, get rid of the old frame. | |
| 516 (delete-frame frame-initial-frame t)) | |
| 517 | |
| 518 ;; Otherwise, we don't need all that rigamarole; just apply | |
| 519 ;; the new properties. | |
| 520 (let (newprops allprops tail) | |
| 521 (setq allprops (append initial-frame-plist | |
| 522 default-frame-plist)) | |
| 523 (if (lax-plist-member frame-initial-geometry-arguments 'height) | |
| 524 (laxremf allprops 'height)) | |
| 525 (if (lax-plist-member frame-initial-geometry-arguments 'width) | |
| 526 (remf allprops 'width)) | |
| 527 (if (lax-plist-member frame-initial-geometry-arguments 'left) | |
| 528 (laxremf allprops 'left)) | |
| 529 (if (lax-plist-member frame-initial-geometry-arguments 'top) | |
| 530 (laxremf allprops 'top)) | |
| 531 (setq tail allprops) | |
| 532 ;; Find just the props that have changed since we first | |
| 533 ;; made this frame. Those are the ones actually set by | |
| 534 ;; the init file. For those props whose values we already knew | |
| 535 ;; (such as those spec'd by command line options) | |
| 536 ;; it is undesirable to specify the parm again | |
| 537 ;; once the user has seen the frame and been able to alter it | |
| 538 ;; manually. | |
| 539 (while tail | |
| 540 (let (newval oldval) | |
| 541 (setq oldval (lax-plist-get frame-initial-frame-plist | |
| 542 (car tail))) | |
| 543 (setq newval (lax-plist-get allprops (car tail))) | |
| 544 (or (eq oldval newval) | |
| 545 (laxputf newprops (car tail) newval))) | |
| 546 (setq tail (cddr tail))) | |
| 547 (set-frame-properties frame-initial-frame newprops) | |
| 1942 | 548 ;; XEmacs change: omit the background manipulation |
| 549 ; ;; If we changed the background color, | |
| 550 ; ;; we need to update the background-mode parameter | |
| 551 ; ;; and maybe some faces too. | |
| 552 ; (when (assq 'background-color newparms) | |
| 553 ; (unless (assq 'background-mode newparms) | |
| 554 ; (frame-set-background-mode frame-initial-frame)) | |
| 555 ; (face-set-after-frame-default frame-initial-frame))))) | |
| 428 | 556 ))) |
| 557 | |
| 558 ;; Restore the original buffer. | |
| 559 (set-buffer old-buffer) | |
| 560 | |
| 561 ;; Make sure the initial frame can be GC'd if it is ever deleted. | |
| 562 ;; Make sure frame-notice-user-settings does nothing if called twice. | |
| 1942 | 563 (setq frame-notice-user-settings nil) |
| 428 | 564 (setq frame-initial-frame nil))) |
| 565 | |
| 566 (defun make-initial-minibuffer-frame (device) | |
| 567 (let ((props (append '(minibuffer only) | |
| 568 (safe-alist-to-plist minibuffer-frame-plist)))) | |
| 569 (make-frame props device))) | |
| 570 | |
| 571 | |
| 572 ;;;; Creation of additional frames, and other frame miscellanea | |
| 573 | |
| 1942 | 574 (defun modify-all-frames-properties (plist) |
| 575 "Modify all current and future frames' parameters according to PLIST. | |
| 576 This changes `default-frame-plist' and possibly `initial-frame-plist'. | |
| 577 See `set-frame-properties' for more information." | |
| 578 (dolist (frame (frame-list)) | |
| 579 (set-frame-properties frame plist)) | |
| 580 | |
| 581 ;; XEmacs change: iterate over plists instead of alists | |
| 582 (map-plist | |
| 583 #'(lambda (prop val) | |
| 584 ;; initial-frame-plist needs setting only when | |
| 585 ;; frame-notice-user-settings is true | |
| 586 (and frame-notice-user-settings | |
| 587 (lax-plist-remprop initial-frame-plist prop)) | |
| 588 (lax-plist-remprop default-frame-plist prop)) | |
| 589 plist) | |
| 590 | |
| 591 (and frame-notice-user-settings | |
| 592 (setq initial-frame-plist (append initial-frame-plist plist))) | |
| 593 (setq default-frame-plist (append default-frame-plist plist))) | |
| 594 | |
| 428 | 595 (defun get-other-frame () |
| 1942 | 596 "Return some frame other than the current frame. |
| 597 Create one if necessary. Note that the minibuffer frame, if separate, | |
| 598 is not considered (see `next-frame')." | |
| 428 | 599 (let* ((this (selected-frame)) |
| 600 ;; search visible frames first | |
| 601 (next (next-frame this 'visible-nomini))) | |
| 602 ;; then search iconified frames | |
| 603 (if (eq this next) | |
| 604 (setq next (next-frame 'visible-iconic-nomini))) | |
| 605 (if (eq this next) | |
| 606 ;; otherwise, make a new frame | |
| 607 (make-frame) | |
| 608 next))) | |
| 609 | |
| 610 (defun next-multiframe-window () | |
| 611 "Select the next window, regardless of which frame it is on." | |
| 612 (interactive) | |
| 613 (select-window (next-window (selected-window) | |
| 614 (> (minibuffer-depth) 0) | |
| 1942 | 615 t)) |
| 616 ;; XEmacs change: select-window already selects the containing frame | |
| 617 ;(select-frame-set-input-focus (selected-frame)) | |
| 618 ) | |
| 428 | 619 |
| 620 (defun previous-multiframe-window () | |
| 621 "Select the previous window, regardless of which frame it is on." | |
| 622 (interactive) | |
| 623 (select-window (previous-window (selected-window) | |
| 624 (> (minibuffer-depth) 0) | |
| 1942 | 625 t)) |
| 626 ;; XEmacs change: select-window already selects the containing frame | |
| 627 ;(select-frame-set-input-focus (selected-frame)) | |
| 628 ) | |
| 428 | 629 |
| 1942 | 630 ;; XEmacs change: Emacs has make-frame-on-display |
| 428 | 631 (defun make-frame-on-device (type connection &optional props) |
| 632 "Create a frame of type TYPE on CONNECTION. | |
| 633 TYPE should be a symbol naming the device type, i.e. one of | |
| 634 | |
| 635 x An X display. CONNECTION should be a standard display string | |
| 636 such as \"unix:0\", or nil for the display specified on the | |
| 637 command line or in the DISPLAY environment variable. Only if | |
| 638 support for X was compiled into XEmacs. | |
| 639 tty A standard TTY connection or terminal. CONNECTION should be | |
| 640 a TTY device name such as \"/dev/ttyp2\" (as determined by | |
| 641 the Unix command `tty') or nil for XEmacs' standard input | |
| 642 and output (usually the TTY in which XEmacs started). Only | |
| 643 if support for TTY's was compiled into XEmacs. | |
| 462 | 644 gtk A GTK device. |
| 428 | 645 mswindows A connection to a machine running Microsoft Windows NT or |
| 646 Windows 95/97. | |
| 647 pc A direct-write MS-DOS frame. Not currently implemented. | |
| 648 | |
| 649 PROPS should be a plist of properties, as in the call to `make-frame'. | |
| 650 | |
| 651 If a connection to CONNECTION already exists, it is reused; otherwise, | |
| 652 a new connection is opened." | |
| 653 (make-frame props (make-device type connection props))) | |
| 654 | |
| 1942 | 655 ;; XEmacs omission: Emacs has make-frame-command here, but it reduces to |
| 656 ;; make-frame for us. | |
| 657 | |
| 658 ;; XEmacs omission: the following 2 variables are not yet implemented. | |
| 659 ;(defvar before-make-frame-hook nil | |
| 660 ; "Functions to run before a frame is created.") | |
| 661 ; | |
| 662 ;(defvar after-make-frame-functions nil | |
| 663 ; "Functions to run after a frame is created. | |
| 664 ;The functions are run with one arg, the newly created frame.") | |
| 665 ; | |
| 666 (defvar after-setting-font-hook nil | |
| 667 "Functions to run after a frame's font has been changed.") | |
| 668 | |
| 428 | 669 ;; Alias, kept temporarily. |
| 670 (defalias 'new-frame 'make-frame) | |
| 1942 | 671 (make-obsolete 'new-frame 'make-frame) |
| 428 | 672 |
| 1942 | 673 ;; XEmacs change: Emacs has make-frame here. We have it in C, so no need for |
| 674 ;; frame-creation-function. | |
| 428 | 675 |
| 1942 | 676 ;; XEmacs addition: support optional DEVICE argument. |
| 428 | 677 (defun filtered-frame-list (predicate &optional device) |
| 678 "Return a list of all live frames which satisfy PREDICATE. | |
| 679 If optional second arg DEVICE is non-nil, restrict the frames | |
| 680 returned to that device." | |
| 681 (let ((frames (if device (device-frame-list device) | |
| 682 (frame-list))) | |
| 683 good-frames) | |
| 684 (while (consp frames) | |
| 685 (if (funcall predicate (car frames)) | |
| 686 (setq good-frames (cons (car frames) good-frames))) | |
| 687 (setq frames (cdr frames))) | |
| 688 good-frames)) | |
| 689 | |
| 1942 | 690 ;; XEmacs addition: support optional DEVICE argument. |
| 428 | 691 (defun minibuffer-frame-list (&optional device) |
| 692 "Return a list of all frames with their own minibuffers. | |
| 693 If optional second arg DEVICE is non-nil, restrict the frames | |
| 694 returned to that device." | |
| 695 (filtered-frame-list | |
| 696 #'(lambda (frame) | |
| 697 (eq frame (window-frame (minibuffer-window frame)))) | |
| 698 device)) | |
| 699 | |
| 1942 | 700 ;; XEmacs omission: Emacs has frames-on-display-list here, but that is |
| 701 ;; essentially equivalent to supplying the optional DEVICE argument to | |
| 702 ;; filtered-frame-list. | |
| 703 | |
| 704 ;; XEmacs addition: the following two functions make life a lot simpler below. | |
| 705 (defsubst display-frame (display) | |
| 706 "Return the active frame for DISPLAY. | |
| 707 DISPLAY may be a frame, a device, or a console. If it is omitted or nil, | |
| 708 it defaults to the selected frame." | |
| 709 (cond | |
| 710 ((null display) (selected-frame)) | |
| 711 ((framep display) display) | |
| 712 ((devicep display) (selected-frame display)) | |
| 713 ((consolep display) (selected-frame (car (console-device-list display)))) | |
| 714 (t (error 'wrong-type-argument "Not a frame, device, or console" display)))) | |
| 715 | |
| 716 (defsubst display-device (display) | |
| 717 "Return the device for DISPLAY. | |
| 718 DISPLAY may be a frame, a device, or a console. If it is omitted or nil, | |
| 719 it defaults to the selected frame." | |
| 720 (cond | |
| 721 ((null display) (selected-device)) | |
| 722 ((framep display) (frame-device display)) | |
| 723 ((devicep display) display) | |
| 724 ((consolep display) (car (console-device-list display))) | |
| 725 (t (error 'wrong-type-argument "Not a frame, device, or console" display)))) | |
| 726 | |
| 727 ;; Emacs compatibility function. We do not allow display names of the type | |
| 728 ;; HOST:SERVER.SCREEN as Emacs does, but we do handle devices and consoles. | |
| 729 (defun framep-on-display (&optional display) | |
| 730 "Return the type of frames on DISPLAY. | |
| 731 DISPLAY may be a frame, a device, or a console. If it is a frame, its type | |
| 732 is returned. If DISPLAY is omitted or nil, it defaults to the selected | |
| 733 frame. All frames on a given device or console are of the same type." | |
| 734 (cond | |
| 735 ((null display) (frame-type (selected-frame))) | |
| 736 ((framep display) (frame-type display)) | |
| 737 ((devicep display) (device-type display)) | |
| 738 ((consolep display) (console-type display)) | |
| 739 (t (error 'wrong-type-argument "Not a frame, device, or console" display)))) | |
| 740 | |
| 741 ;; XEmacs addition: Emacs does not have this function. | |
| 428 | 742 (defun frame-minibuffer-only-p (frame) |
| 743 "Return non-nil if FRAME is a minibuffer-only frame." | |
| 744 (eq (frame-root-window frame) (minibuffer-window frame))) | |
| 745 | |
| 746 (defun frame-remove-geometry-props (plist) | |
| 747 "Return the property list PLIST, but with geometry specs removed. | |
| 748 This deletes all bindings in PLIST for `top', `left', `width', | |
| 749 `height', `user-size' and `user-position' properties. | |
| 750 Emacs uses this to avoid overriding explicit moves and resizings from | |
| 751 the user during startup." | |
| 752 (setq plist (canonicalize-lax-plist (copy-sequence plist))) | |
|
4783
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4759
diff
changeset
|
753 (mapc #'(lambda (property) |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4759
diff
changeset
|
754 (if (lax-plist-member plist property) |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4759
diff
changeset
|
755 (progn |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4759
diff
changeset
|
756 (setq frame-initial-geometry-arguments |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4759
diff
changeset
|
757 (cons property |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4759
diff
changeset
|
758 (cons (lax-plist-get plist property) |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4759
diff
changeset
|
759 frame-initial-geometry-arguments))) |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4759
diff
changeset
|
760 (setq plist (lax-plist-remprop plist property))))) |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4759
diff
changeset
|
761 '(height width top left user-size user-position)) |
| 428 | 762 plist) |
| 763 | |
| 1942 | 764 ;; XEmacs change: Emacs has focus-follows-mouse here, which lets them |
| 765 ;; Customize it. XEmacs has it builtin. Should that change? | |
| 766 | |
| 767 ;; XEmacs change: we have focus-frame instead of multiple foo-focus-frame | |
| 768 ;; functions. | |
| 769 (defun select-frame-set-input-focus (frame) | |
| 770 "Select FRAME, raise it, and set input focus, if possible." | |
| 771 (raise-frame frame) | |
| 772 (focus-frame frame) ;; This also selects FRAME | |
| 773 ;; XEmacs change: This is a bad idea; you should in general never warp the | |
| 774 ;; pointer unless the user asks for it. | |
| 775 ;;(if focus-follows-mouse | |
| 776 ;; (set-mouse-position (selected-window) (1- (frame-width frame)) 0))) | |
| 777 ) | |
| 778 | |
| 428 | 779 (defun other-frame (arg) |
| 780 "Select the ARG'th different visible frame, and raise it. | |
| 781 All frames are arranged in a cyclic order. | |
| 782 This command selects the frame ARG steps away in that order. | |
| 783 A negative ARG moves in the opposite order. | |
| 784 | |
| 1942 | 785 To make this command work properly, you must tell Emacs |
| 786 how the system (or the window manager) generally handles | |
| 787 focus-switching between windows. If moving the mouse onto a window | |
| 788 selects it (gives it focus), set `focus-follows-mouse' to t. | |
| 789 Otherwise, that variable should be nil." | |
| 428 | 790 (interactive "p") |
| 791 (let ((frame (selected-frame))) | |
| 792 (while (> arg 0) | |
| 793 (setq frame (next-frame frame 'visible-nomini)) | |
| 794 (setq arg (1- arg))) | |
| 795 (while (< arg 0) | |
| 796 (setq frame (previous-frame frame 'visible-nomini)) | |
| 797 (setq arg (1+ arg))) | |
| 1942 | 798 (select-frame-set-input-focus frame))) |
| 799 | |
| 800 (defun iconify-or-deiconify-frame () | |
| 801 "Iconify the selected frame, or deiconify if it's currently an icon." | |
| 802 (interactive) | |
| 803 (if (lax-plist-get (frame-properties) 'visibility) | |
| 804 (iconify-frame) | |
| 805 (make-frame-visible))) | |
| 806 | |
| 807 (defun make-frame-names-alist () | |
| 808 (let* ((current-frame (selected-frame)) | |
| 809 (falist | |
| 810 (cons | |
| 811 (cons (frame-property current-frame 'name) current-frame) nil)) | |
| 812 (frame (next-frame current-frame t))) | |
| 813 (while (not (eq frame current-frame)) | |
| 814 (progn | |
| 815 (setq falist (cons (cons (frame-property frame 'name) frame) falist)) | |
| 816 (setq frame (next-frame frame t)))) | |
| 817 falist)) | |
| 818 | |
| 819 (defvar frame-name-history nil) | |
| 820 (defun select-frame-by-name (name) | |
| 821 "Select the frame on the current terminal whose name is NAME and raise it. | |
| 822 If there is no frame by that name, signal an error." | |
| 823 (interactive | |
| 824 (let* ((frame-names-alist (make-frame-names-alist)) | |
| 825 (default (car (car frame-names-alist))) | |
| 826 (input (completing-read | |
| 827 (format "Select Frame (default %s): " default) | |
| 828 frame-names-alist nil t nil 'frame-name-history default))) | |
| 829 ;; XEmacs change: use the last param of completing-read to simplify. | |
| 830 (list input))) | |
| 831 (let* ((frame-names-alist (make-frame-names-alist)) | |
| 832 (frame (cdr (assoc name frame-names-alist)))) | |
| 833 (or frame | |
| 834 (error "There is no frame named `%s'" name)) | |
| 835 (make-frame-visible frame) | |
| 836 ;; XEmacs change: make-frame-visible implies (raise-frame) | |
| 837 ;; (raise-frame frame) | |
| 838 ;; XEmacs change: we defined this function, might as well use it. | |
| 839 (select-frame-set-input-focus frame))) | |
| 428 | 840 |
| 841 ;; XEmacs-added utility functions | |
| 842 | |
| 843 (defmacro save-selected-frame (&rest body) | |
| 844 "Execute forms in BODY, then restore the selected frame. | |
| 845 The value returned is the value of the last form in BODY." | |
| 846 (let ((old-frame (gensym "ssf"))) | |
| 847 `(let ((,old-frame (selected-frame))) | |
| 848 (unwind-protect | |
| 849 (progn ,@body) | |
| 850 (select-frame ,old-frame))))) | |
| 851 | |
| 852 (defmacro with-selected-frame (frame &rest body) | |
| 853 "Execute forms in BODY with FRAME as the selected frame. | |
| 854 The value returned is the value of the last form in BODY." | |
| 855 `(save-selected-frame | |
| 856 (select-frame ,frame) | |
| 857 ,@body)) | |
| 858 | |
| 1942 | 859 ; This is in C in Emacs |
| 428 | 860 (defun frame-list () |
| 861 "Return a list of all frames on all devices/consoles." | |
| 862 ;; Lists are copies, so nconc is safe here. | |
| 863 (apply 'nconc (mapcar 'device-frame-list (device-list)))) | |
| 864 | |
| 865 (defun frame-type (&optional frame) | |
| 866 "Return the type of the specified frame (e.g. `x' or `tty'). | |
| 867 This is equivalent to the type of the frame's device. | |
| 868 Value is `tty' for a tty frame (a character-only terminal), | |
| 869 `x' for a frame that is an X window, | |
| 440 | 870 `mswindows' for a frame that is a MS Windows desktop window, |
| 871 `msprinter' for a frame that is a MS Windows print job, | |
| 428 | 872 `stream' for a stream frame (which acts like a stdio stream), and |
| 873 `dead' for a deleted frame." | |
| 874 (or frame (setq frame (selected-frame))) | |
| 875 (if (not (frame-live-p frame)) 'dead | |
| 876 (device-type (frame-device frame)))) | |
| 877 | |
| 878 (defun device-or-frame-p (object) | |
| 879 "Return non-nil if OBJECT is a device or frame." | |
| 880 (or (devicep object) | |
| 881 (framep object))) | |
| 882 | |
| 883 (defun device-or-frame-type (device-or-frame) | |
| 884 "Return the type (e.g. `x' or `tty') of DEVICE-OR-FRAME. | |
| 885 DEVICE-OR-FRAME should be a device or a frame object. See `device-type' | |
| 886 for a description of the possible types." | |
| 887 (if (devicep device-or-frame) | |
| 888 (device-type device-or-frame) | |
| 889 (frame-type device-or-frame))) | |
| 890 | |
| 891 (defun fw-frame (obj) | |
| 892 "Given a frame or window, return the associated frame. | |
| 893 Return nil otherwise." | |
| 894 (cond ((windowp obj) (window-frame obj)) | |
| 895 ((framep obj) obj) | |
| 896 (t nil))) | |
| 897 | |
| 898 | |
| 899 ;;;; Frame configurations | |
| 900 | |
| 901 (defun current-frame-configuration () | |
| 902 "Return a list describing the positions and states of all frames. | |
| 903 Its car is `frame-configuration'. | |
| 904 Each element of the cdr is a list of the form (FRAME PLIST WINDOW-CONFIG), | |
| 905 where | |
| 906 FRAME is a frame object, | |
| 907 PLIST is a property list specifying some of FRAME's properties, and | |
| 908 WINDOW-CONFIG is a window configuration object for FRAME." | |
| 909 (cons 'frame-configuration | |
| 910 (mapcar (function | |
| 911 (lambda (frame) | |
| 912 (list frame | |
| 913 (frame-properties frame) | |
| 914 (current-window-configuration frame)))) | |
| 915 (frame-list)))) | |
| 916 | |
| 917 (defun set-frame-configuration (configuration &optional nodelete) | |
| 918 "Restore the frames to the state described by CONFIGURATION. | |
| 919 Each frame listed in CONFIGURATION has its position, size, window | |
| 920 configuration, and other properties set as specified in CONFIGURATION. | |
| 921 Ordinarily, this function deletes all existing frames not | |
| 922 listed in CONFIGURATION. But if optional second argument NODELETE | |
| 923 is given and non-nil, the unwanted frames are iconified instead." | |
| 924 (or (frame-configuration-p configuration) | |
| 925 (signal 'wrong-type-argument | |
| 926 (list 'frame-configuration-p configuration))) | |
| 1942 | 927 (let ((config-alist (cdr configuration)) |
| 428 | 928 frames-to-delete) |
| 1942 | 929 (mapc #'(lambda (frame) |
| 930 (let ((properties (assq frame config-alist))) | |
| 931 (if properties | |
| 932 (progn | |
| 933 (set-frame-properties | |
| 934 frame | |
| 935 ;; Since we can't set a frame's minibuffer status, | |
| 936 ;; we might as well omit the parameter altogether. | |
| 937 (lax-plist-remprop (nth 1 properties) 'minibuffer)) | |
| 938 (set-window-configuration (nth 2 properties))) | |
| 939 (setq frames-to-delete (cons frame frames-to-delete))))) | |
| 428 | 940 (frame-list)) |
| 941 (if nodelete | |
| 942 ;; Note: making frames invisible here was tried | |
| 943 ;; but led to some strange behavior--each time the frame | |
| 944 ;; was made visible again, the window manager asked afresh | |
| 945 ;; for where to put it. | |
| 1942 | 946 (mapc #'iconify-frame frames-to-delete) |
| 947 (mapc #'delete-frame frames-to-delete)))) | |
| 428 | 948 |
| 1942 | 949 ; XEmacs change: this function is in subr.el in Emacs. |
| 950 ; That's because they don't always include frame.el, while we do. | |
| 428 | 951 |
| 952 (defun frame-configuration-p (object) | |
| 953 "Return non-nil if OBJECT seems to be a frame configuration. | |
| 954 Any list whose car is `frame-configuration' is assumed to be a frame | |
| 955 configuration." | |
| 956 (and (consp object) | |
| 957 (eq (car object) 'frame-configuration))) | |
| 958 | |
| 959 | |
| 1942 | 960 ;;;; Convenience functions for accessing and interactively changing |
| 961 ;;;; frame parameters. | |
| 962 | |
| 963 (defun frame-height (&optional frame) | |
| 964 "Return number of lines available for display on FRAME. | |
| 965 If FRAME is omitted, describe the currently selected frame." | |
| 966 (frame-property frame 'height)) | |
| 967 | |
| 968 (defun frame-width (&optional frame) | |
| 969 "Return number of columns available for display on FRAME. | |
| 970 If FRAME is omitted, describe the currently selected frame." | |
| 971 (frame-property frame 'width)) | |
| 972 | |
| 973 (defalias 'set-default-font 'set-frame-font) | |
| 974 | |
| 975 ;; XEmacs change: this function differs significantly from Emacs. | |
| 976 (defun set-frame-font (font-name &optional keep-size) | |
| 977 "Set the font of the selected frame to FONT-NAME. | |
| 978 When called interactively, prompt for the name of the font to use. | |
| 979 To get the frame's current default font, use `(face-font-name 'default)'. | |
| 980 | |
| 981 The default behavior is to keep the numbers of lines and columns in | |
| 982 the frame, thus may change its pixel size. If optional KEEP-SIZE is | |
| 983 non-nil (interactively, prefix argument) the current frame size (in | |
| 984 pixels) is kept by adjusting the numbers of the lines and columns." | |
| 985 (interactive | |
| 986 (let* ((frame (selected-frame)) | |
| 987 (completion-ignore-case t) | |
| 988 (font (completing-read "Font name: " | |
| 989 (mapcar #'list | |
| 2527 | 990 (font-list "*" frame)) |
| 1942 | 991 nil nil nil nil |
| 992 (face-font-name 'default frame)))) | |
| 993 (list font current-prefix-arg))) | |
| 994 (let* ((frame (selected-frame)) | |
| 995 (fht (frame-pixel-height frame)) | |
| 996 (fwd (frame-pixel-width frame)) | |
| 997 (face-list-to-change (face-list))) | |
| 998 (when (eq (device-type) 'mswindows) | |
| 999 (setq face-list-to-change | |
| 1000 (delq 'border-glyph face-list-to-change))) | |
| 1001 ;; FIXME: Is it sufficient to just change the default face, due to | |
| 1002 ;; face inheritance? | |
| 1003 (dolist (face face-list-to-change) | |
| 1004 (when (face-font-instance face) | |
| 1005 (condition-case c | |
| 1006 (set-face-font face font-name frame) | |
| 1007 (error | |
| 1008 (display-error c nil) | |
| 1009 (sit-for 1))))) | |
| 1010 (if keep-size | |
| 1011 (set-frame-pixel-size frame fwd fht))) | |
| 1012 (run-hooks 'after-setting-font-hook)) | |
| 1013 | |
| 1014 (defun set-frame-property (frame prop val) | |
| 1015 "Set property PROP of FRAME to VAL. See `set-frame-properties'." | |
| 1016 (set-frame-properties frame (list prop val))) | |
| 1017 | |
| 1018 ;; XEmacs change: this function differs significantly from Emacs. | |
| 1019 (defun set-background-color (color-name) | |
| 1020 "Set the background color of the selected frame to COLOR-NAME. | |
| 1021 When called interactively, prompt for the name of the color to use. | |
| 1022 To get the frame's current background color, use | |
| 1023 `(face-background-name 'default)'." | |
| 1024 (interactive (list (read-color "Color: "))) | |
| 1025 ;; (set-face-foreground 'text-cursor color-name (selected-frame)) | |
| 1026 (set-face-background 'default color-name (selected-frame))) | |
| 1027 | |
| 1028 ;; XEmacs change: this function differs significantly from Emacs. | |
| 1029 (defun set-foreground-color (color-name) | |
| 1030 "Set the foreground color of the selected frame to COLOR-NAME. | |
| 1031 When called interactively, prompt for the name of the color to use. | |
| 1032 To get the frame's current foreground color, use | |
| 1033 `(face-foreground-name 'default)'." | |
| 1034 (interactive (list (read-color "Color: "))) | |
| 1035 (set-face-foreground 'default color-name (selected-frame))) | |
| 1036 | |
| 1037 ;; XEmacs change: this function differs significantly from Emacs. | |
| 1038 (defun set-cursor-color (color-name) | |
| 1039 "Set the text cursor color of the selected frame to COLOR-NAME. | |
| 1040 When called interactively, prompt for the name of the color to use. | |
| 1041 To get the frame's current cursor color, use | |
| 1042 '(face-background-name 'text-cursor)'." | |
| 1043 (interactive (list (read-color "Color: "))) | |
| 1044 (set-face-background 'text-cursor color-name (selected-frame))) | |
| 1045 | |
| 1046 ;; XEmacs change: this function differs significantly from Emacs. | |
| 1047 (defun set-mouse-color (color-name) | |
| 1048 "Set the color of the mouse pointer of the selected frame to COLOR-NAME. | |
| 1049 When called interactively, prompt for the name of the color to use. | |
| 1050 To get the frame's current mouse color, use | |
| 1051 `(face-foreground-name 'pointer)'." | |
| 1052 (interactive (list (read-color "Color: "))) | |
| 1053 (set-face-foreground 'pointer color-name (selected-frame))) | |
| 1054 | |
| 1055 ;; XEmacs change: this function differs significantly from Emacs. | |
| 1056 (defun set-border-color (color-name) | |
| 1057 "Set the color of the border of the selected frame to COLOR-NAME. | |
| 1058 When called interactively, prompt for the name of the color to use. | |
| 1059 To get the frame's current border color, use | |
| 1060 `(face-foreground-name 'border-glyph)'." | |
| 1061 (interactive (list (read-color "Color: "))) | |
| 1062 (set-face-foreground 'border-glyph color-name (selected-frame))) | |
| 1063 | |
| 1064 ;;; BEGIN XEmacs addition | |
| 1065 ;;; This is the traditional XEmacs auto-raise and auto-lower, which applies | |
| 1066 ;;; to all frames. | |
| 1067 | |
| 1068 (defcustom auto-raise-frame nil | |
| 1069 "*If true, frames will be raised to the top when selected. | |
| 1070 Under X, most ICCCM-compliant window managers will have an option to do this | |
| 1071 for you, but this variable is provided in case you're using a broken WM." | |
| 1072 :type 'boolean | |
| 1073 :group 'frames) | |
| 1074 | |
| 1075 (defcustom auto-lower-frame nil | |
| 1076 "*If true, frames will be lowered to the bottom when no longer selected. | |
| 1077 Under X, most ICCCM-compliant window managers will have an option to do this | |
| 1078 for you, but this variable is provided in case you're using a broken WM." | |
| 1079 :type 'boolean | |
| 1080 :group 'frames) | |
| 1081 | |
| 1082 (defun default-select-frame-hook () | |
| 1083 "Implement the `auto-raise-frame' variable. | |
| 1084 For use as the value of `select-frame-hook'." | |
| 1085 (if auto-raise-frame (raise-frame (selected-frame)))) | |
| 428 | 1086 |
| 1942 | 1087 (defun default-deselect-frame-hook () |
| 1088 "Implement the `auto-lower-frame' variable. | |
| 1089 For use as the value of `deselect-frame-hook'." | |
| 1090 (if auto-lower-frame (lower-frame (selected-frame))) | |
| 1091 (highlight-extent nil nil)) | |
| 1092 | |
| 1093 (or select-frame-hook | |
| 1094 (add-hook 'select-frame-hook 'default-select-frame-hook)) | |
| 1095 | |
| 1096 (or deselect-frame-hook | |
| 1097 (add-hook 'deselect-frame-hook 'default-deselect-frame-hook)) | |
| 1098 | |
| 1099 ;;; END XEmacs addition | |
| 1100 ;;; Following is the Emacs auto-raise/auto-lower interface, which lets the | |
| 1101 ;;; user select individual frames to auto-raise and auto-lower | |
| 1102 | |
| 1103 ;; XEmacs addition: the next two variables do not appear in Emacs | |
| 1104 (defvar auto-raise-specifier (make-boolean-specifier auto-raise-frame) | |
| 1105 "Specifier that determines which frames should auto-raise. | |
| 1106 A value of `t' means that a frame auto-raises; `nil' means it does not.") | |
| 1107 | |
| 1108 (defvar auto-lower-specifier (make-boolean-specifier auto-lower-frame) | |
| 1109 "Specifier that determines which frames should auto-lower. | |
| 1110 A value of `t' means that a frame auto-lowers; `nil' means it does not.") | |
| 1111 | |
| 1112 ;; XEmacs change: use specifiers instead of frame-parameters | |
| 1113 (defun auto-raise-mode (arg) | |
| 1114 "Toggle whether or not the selected frame should auto-raise. | |
| 1115 With arg, turn auto-raise mode on if and only if arg is positive. | |
| 1116 Note that this controls Emacs's own auto-raise feature. | |
| 1117 Some window managers allow you to enable auto-raise for certain windows. | |
| 1118 You can use that for Emacs windows if you wish, but if you do, | |
| 1119 that is beyond the control of Emacs and this command has no effect on it." | |
| 1120 (interactive "P") | |
| 1121 (if (null arg) | |
| 1122 (setq arg | |
| 1123 (if (specifier-instance auto-raise-specifier (selected-frame)) | |
| 1124 -1 1))) | |
| 1125 (if (> arg 0) | |
| 1126 (progn | |
| 1127 (raise-frame (selected-frame)) | |
| 1128 (add-hook 'select-frame-hook 'default-select-frame-hook)) | |
| 1129 (set-specifier auto-raise-specifier (> arg 0) (selected-frame)))) | |
| 1130 | |
| 1131 ;; XEmacs change: use specifiers instead of frame-parameters | |
| 1132 (defun auto-lower-mode (arg) | |
| 1133 "Toggle whether or not the selected frame should auto-lower. | |
| 1134 With arg, turn auto-lower mode on if and only if arg is positive. | |
| 1135 Note that this controls Emacs's own auto-lower feature. | |
| 1136 Some window managers allow you to enable auto-lower for certain windows. | |
| 1137 You can use that for Emacs windows if you wish, but if you do, | |
| 1138 that is beyond the control of Emacs and this command has no effect on it." | |
| 1139 (interactive "P") | |
| 1140 (if (null arg) | |
| 1141 (setq arg | |
| 1142 (if (specifier-instance auto-lower-specifier (selected-frame)) | |
| 1143 -1 1))) | |
| 1144 (if (> arg 0) | |
| 1145 (progn | |
| 1146 (lower-frame (selected-frame)) | |
| 1147 (add-hook 'deselect-frame-hook 'default-deselect-frame-hook)) | |
| 1148 (set-specifier auto-lower-specifier (> arg 0) (selected-frame)))) | |
| 428 | 1149 |
| 1942 | 1150 ;; XEmacs omission: XEmacs does not support changing the frame name |
| 1151 ;(defun set-frame-name (name) | |
| 1152 ; "Set the name of the selected frame to NAME. | |
| 1153 ;When called interactively, prompt for the name of the frame. | |
| 1154 ;The frame name is displayed on the modeline if the terminal displays only | |
| 1155 ;one frame, otherwise the name is displayed on the frame's caption bar." | |
| 1156 ; (interactive "sFrame name: ") | |
| 1157 ; (modify-frame-parameters (selected-frame) | |
| 1158 ; (list (cons 'name name)))) | |
| 1159 | |
| 1160 ;; XEmacs omission: XEmacs attaches scrollbars to windows, not frames. | |
| 1161 ;; See window-hscroll and ... what? window-start? | |
| 1162 ;(defun frame-current-scroll-bars (&optional frame) | |
| 1163 ; "Return the current scroll-bar settings in frame FRAME. | |
| 1164 ;Value is a cons (VERTICAL . HORISONTAL) where VERTICAL specifies the | |
| 1165 ;current location of the vertical scroll-bars (left, right, or nil), | |
| 1166 ;and HORISONTAL specifies the current location of the horisontal scroll | |
| 1167 ;bars (top, bottom, or nil)." | |
| 1168 ; (let ((vert (frame-parameter frame 'vertical-scroll-bars)) | |
| 1169 ; (hor nil)) | |
| 1170 ; (unless (memq vert '(left right nil)) | |
| 1171 ; (setq vert default-frame-scroll-bars)) | |
| 1172 ; (cons vert hor))) | |
| 1173 | |
| 1174 ;;;; Frame/display capabilities. | |
| 1175 (defun display-mouse-p (&optional display) | |
| 1176 "Return non-nil if DISPLAY has a mouse available. | |
| 1177 DISPLAY can be a frame, a device, a console, or nil (meaning the | |
| 1178 selected frame)." | |
|
4546
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1179 (let (type) |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1180 (setq display (display-device display) |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1181 type (device-type display)) |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1182 (cond |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1183 ((eq 'mswindows type) |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1184 (> (declare-boundp mswindows-num-mouse-buttons) 0)) |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1185 ((device-on-window-system-p display) |
|
4759
aa5ed11f473b
Remove support for obsolete systems. See xemacs-patches message with ID
Jerry James <james@xemacs.org>
parents:
4689
diff
changeset
|
1186 ;; We assume X, GTK and the rest always have a pointing device. |
|
4546
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1187 t) |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1188 ((eq 'tty type) |
| 2367 | 1189 (and-fboundp 'gpm-is-supported-p |
|
4546
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1190 (gpm-is-supported-p display))) |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1191 (t nil)))) |
| 1942 | 1192 |
| 1193 (defun display-popup-menus-p (&optional display) | |
| 1194 "Return non-nil if popup menus are supported on DISPLAY. | |
| 1195 DISPLAY can be a frame, a device, a console, or nil (meaning the selected | |
| 1196 frame). Support for popup menus requires that the mouse be available." | |
|
4546
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1197 (setq display (display-device display)) |
| 1942 | 1198 (and |
|
4546
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1199 (featurep 'menubar) |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1200 (device-on-window-system-p display) |
| 1942 | 1201 (display-mouse-p display))) |
| 1202 | |
| 1203 (defun display-graphic-p (&optional display) | |
| 1204 "Return non-nil if DISPLAY is a graphic display. | |
| 1205 Graphical displays are those which are capable of displaying several | |
| 1206 frames and several different fonts at once. This is true for displays | |
| 1207 that use a window system such as X, and false for text-only terminals. | |
| 1208 DISPLAY can be a frame, a device, a console, or nil (meaning the selected | |
| 1209 frame)." | |
|
4586
732e3243f2e4
Correct a bug in #'display-graphic-p.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4546
diff
changeset
|
1210 (device-on-window-system-p (display-device display))) |
| 1942 | 1211 |
| 1212 (defun display-images-p (&optional display) | |
| 1213 "Return non-nil if DISPLAY can display images. | |
| 1214 DISPLAY can be a frame, a device, a console, or nil (meaning the selected | |
| 1215 frame)." | |
|
4546
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1216 (and (memq (image-instance-type (specifier-instance |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1217 (glyph-image xemacs-logo) |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1218 display)) |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1219 '(color-pixmap mono-pixmap)) |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1220 t)) |
| 1942 | 1221 |
| 1222 (defalias 'display-multi-frame-p 'display-graphic-p) | |
| 1223 (defalias 'display-multi-font-p 'display-graphic-p) | |
| 428 | 1224 |
| 1942 | 1225 (defun display-selections-p (&optional display) |
| 1226 "Return non-nil if DISPLAY supports selections. | |
| 1227 A selection is a way to transfer text or other data between programs | |
| 1228 via special system buffers called `selection' or `cut buffer' or | |
| 1229 `clipboard'. | |
| 1230 DISPLAY can be a frame, a device, a console, or nil (meaning the selected | |
| 1231 frame)." | |
|
4546
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1232 (or |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1233 (device-on-window-system-p display) |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1234 ;; GPM supports #'get-selection-foreign, but not #'own-selection. |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1235 (and-fboundp 'gpm-is-supported-p |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1236 (gpm-is-supported-p display)))) |
| 1942 | 1237 |
| 1238 (defun display-screens (&optional display) | |
| 1239 "Return the number of screens associated with DISPLAY." | |
| 1240 (device-num-screens (display-device display))) | |
| 1241 | |
| 1242 (defun display-pixel-height (&optional display) | |
| 1243 "Return the height of DISPLAY's screen in pixels. | |
| 1244 For character terminals, each character counts as a single pixel." | |
| 1245 (device-pixel-height (display-device display))) | |
| 1246 | |
| 1247 (defun display-pixel-width (&optional display) | |
| 1248 "Return the width of DISPLAY's screen in pixels. | |
| 1249 For character terminals, each character counts as a single pixel." | |
| 1250 (device-pixel-width (display-device display))) | |
| 1251 | |
| 1252 (defun display-mm-height (&optional display) | |
| 1253 "Return the height of DISPLAY's screen in millimeters. | |
| 1254 If the information is unavailable, value is nil." | |
| 1255 (device-mm-height (display-device display))) | |
| 1256 | |
| 1257 (defun display-mm-width (&optional display) | |
| 1258 "Return the width of DISPLAY's screen in millimeters. | |
| 1259 If the information is unavailable, value is nil." | |
| 1260 (device-mm-width (display-device display))) | |
| 1261 | |
| 1262 (defun display-backing-store (&optional display) | |
| 1263 "Return the backing store capability of DISPLAY's screen. | |
| 1264 The value may be `always', `when-mapped', `not-useful', or nil if | |
| 1265 the question is inapplicable to a certain kind of display." | |
| 1266 (device-backing-store (display-device display))) | |
| 1267 | |
| 1268 (defun display-save-under (&optional display) | |
| 1269 "Return non-nil if DISPLAY's screen supports the SaveUnder feature." | |
| 1270 (device-save-under (display-device display))) | |
| 1271 | |
| 1272 (defun display-planes (&optional display) | |
| 1273 "Return the number of planes supported by DISPLAY." | |
| 1274 (device-bitplanes (display-device display))) | |
| 1275 | |
| 1276 (defun display-color-cells (&optional display) | |
| 1277 "Return the number of color cells supported by DISPLAY." | |
| 1278 (device-color-cells (display-device display))) | |
| 1279 | |
| 1280 (defun display-visual-class (&optional display) | |
| 1281 "Returns the visual class of DISPLAY. | |
| 1282 The value is one of the symbols `static-gray', `gray-scale', | |
| 1283 `static-color', `pseudo-color', `true-color', or `direct-color'." | |
|
4546
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1284 (let (type planes) |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1285 (setq display (display-device display) |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1286 type (device-type display)) |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1287 (cond |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1288 ((eq 'x type) |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1289 (declare-fboundp (x-display-visual-class display))) |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1290 ((eq 'gtk type) |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1291 (declare-fboundp (gtk-display-visual-class display))) |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1292 ((device-on-window-system-p display) |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1293 (setq planes (display-planes display)) |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1294 (cond ((eq planes 1) 'static-gray) |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1295 ((eq planes 4) 'static-color) |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1296 ((> planes 8) 'true-color) |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1297 (t 'pseudo-color))) |
|
44129f301385
Make functions in frame.el more general.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4506
diff
changeset
|
1298 (t 'static-gray)))) |
| 1942 | 1299 |
| 1300 | |
| 1301 ;; XEmacs change: omit the Emacs 18 compatibility functions: | |
| 1302 ;; screen-height, screen-width, set-screen-height, and set-screen-width. | |
| 1303 | |
| 1304 (defun delete-other-frames (&optional frame) | |
| 1305 "Delete all frames except FRAME. | |
| 1306 If FRAME uses another frame's minibuffer, the minibuffer frame is | |
| 1307 left untouched. FRAME nil or omitted means use the selected frame." | |
| 1308 (interactive) | |
| 1309 (unless frame | |
| 1310 (setq frame (selected-frame))) | |
| 1311 (let* ((mini-frame (window-frame (minibuffer-window frame))) | |
| 1312 (frames (delq mini-frame (delq frame (frame-list))))) | |
| 1313 (mapc 'delete-frame frames))) | |
| 1314 | |
| 1315 ;; XEmacs change: we still use delete-frame-hook | |
| 1316 ;; miscellaneous obsolescence declarations | |
| 1317 ;(defvaralias 'delete-frame-hook 'delete-frame-functions) | |
| 1318 ;(make-obsolete-variable 'delete-frame-hook 'delete-frame-functions "21.4") | |
| 1319 | |
| 1320 | |
| 1321 ;; Highlighting trailing whitespace. | |
| 1322 ;; XEmacs omission: this functionality is provided by whitespace-mode in the | |
| 1323 ;; text-modes package. | |
| 1324 | |
| 1325 ;(make-variable-buffer-local 'show-trailing-whitespace) | |
| 1326 | |
| 1327 ;(defcustom show-trailing-whitespace nil | |
| 1328 ; "*Non-nil means highlight trailing whitespace in face `trailing-whitespace'. | |
| 1329 ; | |
| 1330 ;Setting this variable makes it local to the current buffer." | |
| 1331 ; :tag "Highlight trailing whitespace." | |
| 1332 ; :type 'boolean | |
| 1333 ; :group 'font-lock) | |
| 1334 | |
| 1335 | |
| 1336 ;; Scrolling | |
| 1337 ;; XEmacs omission: This functionality is always enabled on XEmacs. | |
| 1338 | |
| 1339 ;(defgroup scrolling nil | |
| 1340 ; "Scrolling windows." | |
| 1341 ; :version "21.1" | |
| 1342 ; :group 'frames) | |
| 1343 | |
| 1344 ;(defcustom auto-hscroll-mode t | |
| 1345 ; "*Allow or disallow automatic scrolling windows horizontally. | |
| 1346 ;If non-nil, windows are automatically scrolled horizontally to make | |
| 1347 ;point visible." | |
| 1348 ; :version "21.1" | |
| 1349 ; :type 'boolean | |
| 1350 ; :group 'scrolling) | |
| 1351 ;(defvaralias 'automatic-hscrolling 'auto-hscroll-mode) | |
| 1352 | |
| 1353 | |
| 1354 ;; Blinking cursor | |
| 1355 ;; XEmacs omission: this functionality is provided by blink-cursor in the | |
| 1356 ;; edit-utils package. | |
| 1357 | |
| 1358 ; (defgroup cursor nil | |
| 1359 ; "Displaying text cursors." | |
| 1360 ; :version "21.1" | |
| 1361 ; :group 'frames) | |
| 428 | 1362 |
| 1942 | 1363 ; (defcustom blink-cursor-delay 0.5 |
| 1364 ; "*Seconds of idle time after which cursor starts to blink." | |
| 1365 ; :tag "Delay in seconds." | |
| 1366 ; :type 'number | |
| 1367 ; :group 'cursor) | |
| 1368 | |
| 1369 ; (defcustom blink-cursor-interval 0.5 | |
| 1370 ; "*Length of cursor blink interval in seconds." | |
| 1371 ; :tag "Blink interval in seconds." | |
| 1372 ; :type 'number | |
| 1373 ; :group 'cursor) | |
| 1374 | |
| 1375 ; (defvar blink-cursor-idle-timer nil | |
| 1376 ; "Timer started after `blink-cursor-delay' seconds of Emacs idle time. | |
| 1377 ; The function `blink-cursor-start' is called when the timer fires.") | |
| 1378 | |
| 1379 ; (defvar blink-cursor-timer nil | |
| 1380 ; "Timer started from `blink-cursor-start'. | |
| 1381 ; This timer calls `blink-cursor' every `blink-cursor-interval' seconds.") | |
| 1382 | |
| 1383 ; (defvar blink-cursor-mode nil | |
| 1384 ; "Non-nil means blinking cursor is active.") | |
| 1385 | |
| 1386 ; (defun blink-cursor-mode (arg) | |
| 1387 ; "Toggle blinking cursor mode. | |
| 1388 ; With a numeric argument, turn blinking cursor mode on iff ARG is positive. | |
| 1389 ; When blinking cursor mode is enabled, the cursor of the selected | |
| 1390 ; window blinks. | |
| 1391 | |
| 1392 ; Note that this command is effective only when Emacs | |
| 1393 ; displays through a window system, because then Emacs does its own | |
| 1394 ; cursor display. On a text-only terminal, this is not implemented." | |
| 1395 ; (interactive "P") | |
| 1396 ; (let ((on-p (if (null arg) | |
| 1397 ; (not blink-cursor-mode) | |
| 1398 ; (> (prefix-numeric-value arg) 0)))) | |
| 1399 ; (if blink-cursor-idle-timer | |
| 1400 ; (cancel-timer blink-cursor-idle-timer)) | |
| 1401 ; (if blink-cursor-timer | |
| 1402 ; (cancel-timer blink-cursor-timer)) | |
| 1403 ; (setq blink-cursor-idle-timer nil | |
| 1404 ; blink-cursor-timer nil | |
| 1405 ; blink-cursor-mode nil) | |
| 1406 ; (if on-p | |
| 1407 ; (progn | |
| 1408 ; ;; Hide the cursor. | |
| 1409 ; ;(internal-show-cursor nil nil) | |
| 1410 ; (setq blink-cursor-idle-timer | |
| 1411 ; (run-with-idle-timer blink-cursor-delay | |
| 1412 ; blink-cursor-delay | |
| 1413 ; 'blink-cursor-start)) | |
| 1414 ; (setq blink-cursor-mode t)) | |
| 1415 ; (internal-show-cursor nil t)))) | |
| 1416 | |
| 1417 ; ;; Note that this is really initialized from startup.el before | |
| 1418 ; ;; the init-file is read. | |
| 1419 | |
| 1420 ; (defcustom blink-cursor nil | |
| 1421 ; "*Non-nil means blinking cursor mode is active." | |
| 1422 ; :group 'cursor | |
| 1423 ; :tag "Blinking cursor" | |
| 1424 ; :type 'boolean | |
| 1425 ; :set #'(lambda (symbol value) | |
| 1426 ; (set-default symbol value) | |
| 1427 ; (blink-cursor-mode (or value 0)))) | |
| 428 | 1428 |
| 1942 | 1429 ; (defun blink-cursor-start () |
| 1430 ; "Timer function called from the timer `blink-cursor-idle-timer'. | |
| 1431 ; This starts the timer `blink-cursor-timer', which makes the cursor blink | |
| 1432 ; if appropriate. It also arranges to cancel that timer when the next | |
| 1433 ; command starts, by installing a pre-command hook." | |
| 1434 ; (when (null blink-cursor-timer) | |
| 1435 ; (add-hook 'pre-command-hook 'blink-cursor-end) | |
| 1436 ; (setq blink-cursor-timer | |
| 1437 ; (run-with-timer blink-cursor-interval blink-cursor-interval | |
| 1438 ; 'blink-cursor-timer-function)))) | |
| 1439 | |
| 1440 ; (defun blink-cursor-timer-function () | |
| 1441 ; "Timer function of timer `blink-cursor-timer'." | |
| 1442 ; (internal-show-cursor nil (not (internal-show-cursor-p)))) | |
| 1443 | |
| 1444 ; (defun blink-cursor-end () | |
| 1445 ; "Stop cursor blinking. | |
| 1446 ; This is installed as a pre-command hook by `blink-cursor-start'. | |
| 1447 ; When run, it cancels the timer `blink-cursor-timer' and removes | |
| 1448 ; itself as a pre-command hook." | |
| 1449 ; (remove-hook 'pre-command-hook 'blink-cursor-end) | |
| 1450 ; (internal-show-cursor nil t) | |
| 1451 ; (cancel-timer blink-cursor-timer) | |
| 1452 ; (setq blink-cursor-timer nil)) | |
| 1453 | |
| 428 | 1454 |
| 1942 | 1455 ;; Hourglass pointer |
| 1456 ;; XEmacs omission: this functionality is provided elsewhere. | |
| 1457 | |
| 1458 ; (defcustom display-hourglass t | |
| 1459 ; "*Non-nil means show an hourglass pointer when running under a window system." | |
| 1460 ; :tag "Hourglass pointer" | |
| 1461 ; :type 'boolean | |
| 1462 ; :group 'cursor) | |
| 1463 | |
| 1464 ; (defcustom hourglass-delay 1 | |
| 1465 ; "*Seconds to wait before displaying an hourglass pointer." | |
| 1466 ; :tag "Hourglass delay" | |
| 1467 ; :type 'number | |
| 1468 ; :group 'cursor) | |
| 1469 | |
| 1470 ; | |
| 1471 ; (defcustom cursor-in-non-selected-windows t | |
| 1472 ; "*Non-nil means show a hollow box cursor in non-selected-windows. | |
| 1473 ; If nil, don't show a cursor except in the selected window. | |
| 1474 ; Use Custom to set this variable to get the display updated." | |
| 1475 ; :tag "Cursor in non-selected windows" | |
| 1476 ; :type 'boolean | |
| 1477 ; :group 'cursor | |
| 1478 ; :set #'(lambda (symbol value) | |
| 1479 ; (set-default symbol value) | |
| 1480 ; (force-mode-line-update t))) | |
| 1481 | |
| 1482 | |
| 1483 ;;;; Key bindings | |
| 1484 ;; XEmacs change: these keybindings are in keydef.el. | |
| 1485 | |
| 1486 ;(define-key ctl-x-5-map "2" 'make-frame-command) | |
| 1487 ;(define-key ctl-x-5-map "1" 'delete-other-frames) | |
| 1488 ;(define-key ctl-x-5-map "0" 'delete-frame) | |
| 1489 ;(define-key ctl-x-5-map "o" 'other-frame) | |
| 1490 | |
| 1491 | |
| 1492 ;;; XEmacs addition: nothing below this point appears in the Emacs version. | |
| 1493 | |
| 428 | 1494 ;;; Iconifying emacs. |
| 1495 ;;; | |
| 1496 ;;; The function iconify-emacs replaces every non-iconified emacs window | |
| 1497 ;;; with a *single* icon. Iconified emacs windows are left alone. When | |
| 1498 ;;; emacs is in this globally-iconified state, de-iconifying any emacs icon | |
| 1499 ;;; will uniconify all frames that were visible, and iconify all frames | |
| 1500 ;;; that were not. This is done by temporarily changing the value of | |
| 1501 ;;; `map-frame-hook' to `deiconify-emacs' (which should never be called | |
| 1502 ;;; except from the map-frame-hook while emacs is iconified). | |
| 1503 ;;; | |
| 1504 ;;; The title of the icon representing all emacs frames is controlled by | |
| 1505 ;;; the variable `icon-name'. This is done by temporarily changing the | |
| 1506 ;;; value of `frame-icon-title-format'. Unfortunately, this changes the | |
| 1507 ;;; titles of all emacs icons, not just the "big" icon. | |
| 1508 ;;; | |
| 1509 ;;; It would be nice if existing icons were removed and restored by | |
| 1510 ;;; iconifying the emacs process, but I couldn't make that work yet. | |
| 1511 | |
| 1512 (defvar icon-name nil) ; set this at run time, not load time. | |
| 1513 | |
| 1514 (defvar iconification-data nil) | |
| 1515 | |
| 1516 (defun iconify-emacs () | |
| 1517 "Replace every non-iconified FRAME with a *single* icon. | |
| 1518 Iconified frames are left alone. When XEmacs is in this | |
| 1519 globally-iconified state, de-iconifying any emacs icon will uniconify | |
| 1520 all frames that were visible, and iconify all frames that were not." | |
| 1521 (interactive) | |
| 1522 (if iconification-data (error "already iconified?")) | |
| 1523 (let* ((frames (frame-list)) | |
| 1524 (rest frames) | |
| 1525 (me (selected-frame)) | |
| 1526 frame) | |
| 1527 (while rest | |
| 1528 (setq frame (car rest)) | |
| 1529 (setcar rest (cons frame (frame-visible-p frame))) | |
| 1530 ; (if (memq (cdr (car rest)) '(icon nil)) | |
| 1531 ; (progn | |
| 1532 ; (make-frame-visible frame) ; deiconify, and process the X event | |
| 1533 ; (sleep-for 500 t) ; process X events; I really want to XSync() here | |
| 1534 ; )) | |
| 1535 (or (eq frame me) (make-frame-invisible frame)) | |
| 1536 (setq rest (cdr rest))) | |
| 1537 (or (boundp 'map-frame-hook) (setq map-frame-hook nil)) | |
| 1538 (or icon-name | |
| 1539 (setq icon-name (concat invocation-name " @ " (system-name)))) | |
| 1540 (setq iconification-data | |
| 1541 (list frame-icon-title-format map-frame-hook frames) | |
| 1542 frame-icon-title-format icon-name | |
| 1543 map-frame-hook 'deiconify-emacs) | |
| 1544 (iconify-frame me))) | |
| 1545 | |
| 1546 | |
| 1547 (defun deiconify-emacs (&optional ignore) | |
| 1548 (or iconification-data (error "not iconified?")) | |
| 1549 (setq frame-icon-title-format (car iconification-data) | |
| 1550 map-frame-hook (car (cdr iconification-data)) | |
| 1551 iconification-data (car (cdr (cdr iconification-data)))) | |
| 1552 (while iconification-data | |
| 1553 (let ((visibility (cdr (car iconification-data)))) | |
| 1554 (cond (visibility ;; JV (Note non-nil means visible in XEmacs) | |
| 1555 (make-frame-visible (car (car iconification-data)))) | |
| 1556 ; (t ;; (eq visibility 'icon) ;; JV Not in XEmacs!!! | |
| 1557 ; (make-frame-visible (car (car iconification-data))) | |
| 1558 ; (sleep-for 500 t) ; process X events; I really want to XSync() here | |
| 1559 ; (iconify-frame (car (car iconification-data)))) | |
| 1560 ;; (t nil) | |
| 1561 )) | |
| 1562 (setq iconification-data (cdr iconification-data)))) | |
| 1563 | |
| 1564 (defun suspend-or-iconify-emacs () | |
| 3547 | 1565 "Call iconify-emacs if using a window system, otherwise suspend. |
| 1566 | |
| 1567 `suspend' here can mean different things; if the current TTY console was | |
| 1568 created by gnuclient, that console is suspended, and the related devices and | |
| 1569 frames are removed from the display. Otherwise the Emacs process as a whole | |
| 1570 is suspended--that is, the traditional Unix suspend takes place. " | |
| 428 | 1571 (interactive) |
| 1572 (cond ((device-on-window-system-p) | |
| 1573 (iconify-emacs)) | |
| 1574 ((and (eq (device-type) 'tty) | |
| 502 | 1575 (declare-fboundp (console-tty-controlling-process |
| 1576 (selected-console)))) | |
| 428 | 1577 (suspend-console (selected-console))) |
| 1578 (t | |
| 1579 (suspend-emacs)))) | |
| 1580 | |
| 1581 ;; This is quite a mouthful, but it should be descriptive, as it's | |
| 1582 ;; bound to C-z. FSF takes the easy way out by binding C-z to | |
| 1583 ;; different things depending on window-system. We can't do the same, | |
| 1584 ;; because we allow simultaneous X and TTY consoles. | |
| 1585 (defun suspend-emacs-or-iconify-frame () | |
| 3547 | 1586 "Iconify the selected frame if using a window system, otherwise suspend. |
| 1587 | |
| 1588 `suspend' here can mean different things; if the current TTY console was | |
| 1589 created by gnuclient, the console is suspended, and the related devices and | |
| 1590 frames are removed from the display. Otherwise the Emacs process as a whole | |
| 1591 is suspended--that is, the traditional Unix suspend takes place. " | |
| 428 | 1592 (interactive) |
| 1593 (cond ((device-on-window-system-p) | |
| 1594 (iconify-frame)) | |
| 1595 ((and (eq (frame-type) 'tty) | |
| 502 | 1596 (declare-fboundp (console-tty-controlling-process |
| 1597 (selected-console)))) | |
| 428 | 1598 (suspend-console (selected-console))) |
| 1599 (t | |
| 1600 (suspend-emacs)))) | |
| 1601 | |
| 1602 | |
| 1603 ;;; Application-specific frame-management | |
| 1604 | |
| 1605 (defcustom get-frame-for-buffer-default-frame-name nil | |
| 1606 "*The default frame to select; see doc of `get-frame-for-buffer'." | |
| 1607 :type 'string | |
| 1608 :group 'frames) | |
| 1609 | |
| 1610 (defcustom get-frame-for-buffer-default-instance-limit nil | |
| 1611 "*The default instance limit for creating new frames; | |
| 1612 see doc of `get-frame-for-buffer'." | |
| 1613 :type 'integer | |
| 1614 :group 'frames) | |
| 1615 | |
| 1616 (defun get-frame-name-for-buffer (buffer) | |
| 1617 (let ((mode (and (get-buffer buffer) | |
| 1618 (save-excursion (set-buffer buffer) | |
| 1619 major-mode)))) | |
| 1620 (or (get mode 'frame-name) | |
| 1621 get-frame-for-buffer-default-frame-name))) | |
| 1622 | |
| 1623 (defun get-frame-for-buffer-make-new-frame (buffer &optional frame-name plist) | |
| 1624 (let* ((fr (make-frame plist)) | |
| 1625 (w (frame-root-window fr))) | |
| 1626 ;; | |
| 1627 ;; Make the one buffer being displayed in this newly created | |
| 1628 ;; frame be the buffer of interest, instead of something | |
| 1629 ;; random, so that it won't be shown in two-window mode. | |
| 1630 ;; Avoid calling switch-to-buffer here, since that's something | |
| 1631 ;; people might want to call this routine from. | |
| 1632 ;; | |
| 1633 ;; (If the root window doesn't have a buffer, then that means | |
| 1634 ;; there is more than one window on the frame, which can only | |
| 1635 ;; happen if the user has done something funny on the frame- | |
| 1636 ;; creation-hook. If that's the case, leave it alone.) | |
| 1637 ;; | |
| 1638 (if (window-buffer w) | |
| 1639 (set-window-buffer w buffer)) | |
| 1640 fr)) | |
| 1641 | |
| 1642 (defcustom get-frame-for-buffer-default-to-current nil | |
| 1643 "*When non-nil, `get-frame-for-buffer' will default to the selected frame." | |
| 1644 :type 'boolean | |
| 1645 :group 'frames) | |
| 1646 | |
| 1647 (defun get-frame-for-buffer-noselect (buffer | |
| 1648 &optional not-this-window-p on-frame) | |
| 1649 "Return a frame in which to display BUFFER. | |
| 1650 This is a subroutine of `get-frame-for-buffer' (which see)." | |
| 1651 (let (name limit) | |
| 1652 (cond | |
| 1653 ((or on-frame (eq (selected-window) (minibuffer-window))) | |
| 1654 ;; don't switch frames if a frame was specified, or to list | |
| 1655 ;; completions from the minibuffer, etc. | |
| 1656 nil) | |
| 1657 | |
| 1658 ((setq name (get-frame-name-for-buffer buffer)) | |
| 1659 ;; | |
| 1660 ;; This buffer's mode expressed a preference for a frame of a particular | |
| 1661 ;; name. That always takes priority. | |
| 1662 ;; | |
| 1663 (let ((limit (get name 'instance-limit)) | |
| 1664 (defaults (get name 'frame-defaults)) | |
| 1665 (matching-frames '()) | |
| 1666 frames frame already-visible) | |
| 1667 ;; Sort the list so that iconic frames will be found last. They | |
| 1668 ;; will be used too, but mapped frames take precedence. And | |
| 1669 ;; fully visible frames come before occluded frames. | |
| 1670 ;; Hidden frames come after really visible ones | |
| 1671 (setq frames | |
| 1672 (sort (frame-list) | |
| 1673 #'(lambda (s1 s2) | |
| 1674 (cond ((frame-totally-visible-p s2) | |
| 1675 nil) | |
| 1676 ((not (frame-visible-p s2)) | |
| 1677 (frame-visible-p s1)) | |
| 1678 ((eq (frame-visible-p s2) 'hidden) | |
| 1679 (eq (frame-visible-p s1) t )) | |
| 1680 ((not (frame-totally-visible-p s2)) | |
| 1681 (and (frame-visible-p s1) | |
| 1682 (frame-totally-visible-p s1))))))) | |
| 1683 ;; but the selected frame should come first, even if it's occluded, | |
| 1684 ;; to minimize thrashing. | |
| 1685 (setq frames (cons (selected-frame) | |
| 1686 (delq (selected-frame) frames))) | |
| 1687 | |
| 1688 (setq name (symbol-name name)) | |
| 1689 (while frames | |
| 1690 (setq frame (car frames)) | |
| 1691 (if (equal name (frame-name frame)) | |
| 1692 (if (get-buffer-window buffer frame) | |
| 1693 (setq already-visible frame | |
| 1694 frames nil) | |
| 1695 (setq matching-frames (cons frame matching-frames)))) | |
| 1696 (setq frames (cdr frames))) | |
| 1697 (cond (already-visible | |
| 1698 already-visible) | |
| 1699 ((or (null matching-frames) | |
| 1700 (eq limit 0) ; means create with reckless abandon | |
| 1701 (and limit (< (length matching-frames) limit))) | |
| 1702 (get-frame-for-buffer-make-new-frame | |
| 1703 buffer | |
| 1704 name | |
| 1705 (alist-to-plist (acons 'name name | |
| 1706 (plist-to-alist defaults))))) | |
| 1707 (t | |
| 1708 ;; do not switch any of the window/buffer associations in an | |
| 1709 ;; existing frame; this function only picks a frame; the | |
| 1710 ;; determination of which windows on it get reused is up to | |
| 1711 ;; display-buffer itself. | |
| 1712 ;; (or (window-dedicated-p (selected-window)) | |
| 1713 ;; (switch-to-buffer buffer)) | |
| 1714 (car matching-frames))))) | |
| 1715 | |
| 1716 ((setq limit get-frame-for-buffer-default-instance-limit) | |
| 1717 ;; | |
| 1718 ;; This buffer's mode did not express a preference for a frame of a | |
| 1719 ;; particular name, but the user wants a new frame rather than | |
| 1720 ;; reusing the existing one. | |
| 1721 (let* ((defname | |
| 1722 (or (plist-get default-frame-plist 'name) | |
| 1723 default-frame-name)) | |
| 1724 (frames | |
| 1725 (sort (filtered-frame-list #'(lambda (x) | |
| 1726 (or (frame-visible-p x) | |
| 1727 (frame-iconified-p x)))) | |
| 1728 #'(lambda (s1 s2) | |
| 1729 (cond ((and (frame-visible-p s1) | |
| 1730 (not (frame-visible-p s2)))) | |
| 1731 ((and (eq (frame-visible-p s1) t) | |
| 1732 (eq (frame-visible-p s2) 'hidden))) | |
| 1733 ((and (frame-visible-p s2) | |
| 1734 (not (frame-visible-p s1))) | |
| 1735 nil) | |
| 1736 ((and (equal (frame-name s1) defname) | |
| 1737 (not (equal (frame-name s2) defname)))) | |
| 1738 ((and (equal (frame-name s2) defname) | |
| 1739 (not (equal (frame-name s1) defname))) | |
| 1740 nil) | |
| 1741 ((frame-totally-visible-p s2) | |
| 1742 nil) | |
| 1743 (t)))))) | |
| 1744 ;; put the selected frame last. The user wants a new frame, | |
| 1745 ;; so don't reuse the existing one unless forced to. | |
| 1746 (setq frames (append (delq (selected-frame) frames) (list frames))) | |
| 1747 (if (or (eq limit 0) ; means create with reckless abandon | |
| 1748 (< (length frames) limit)) | |
| 1749 (get-frame-for-buffer-make-new-frame buffer) | |
| 1750 (car frames)))) | |
| 1751 | |
| 1752 (not-this-window-p | |
| 1753 (let ((w-list (windows-of-buffer buffer)) | |
| 1754 f w | |
| 1755 (first-choice nil) | |
| 1756 (second-choice (if get-frame-for-buffer-default-to-current | |
| 1757 (selected-frame) | |
| 1758 nil)) | |
| 1759 (last-resort nil)) | |
| 1760 (while (and w-list (null first-choice)) | |
| 1761 (setq w (car w-list) | |
| 1762 f (window-frame w)) | |
| 1763 (cond ((eq w (selected-window)) nil) | |
| 1764 ((not (frame-visible-p f)) | |
| 1765 (if (null last-resort) | |
| 1766 (setq last-resort f))) | |
| 1767 ((eq f (selected-frame)) | |
| 1768 (setq first-choice f)) | |
| 1769 ((null second-choice) | |
| 1770 (setq second-choice f))) | |
| 1771 (setq w-list (cdr w-list))) | |
| 1772 (or first-choice second-choice last-resort))) | |
| 1773 | |
| 1774 (get-frame-for-buffer-default-to-current (selected-frame)) | |
| 1775 | |
| 1776 (t | |
| 1777 ;; | |
| 1778 ;; This buffer's mode did not express a preference for a frame of a | |
| 1779 ;; particular name. So try to find a frame already displaying this | |
| 1780 ;; buffer. | |
| 1781 ;; | |
| 1782 (let ((w (or (get-buffer-window buffer nil) ; check current first | |
| 1783 (get-buffer-window buffer 'visible) ; then visible | |
| 1784 (get-buffer-window buffer 0)))) ; then iconic | |
| 1785 (cond ((null w) | |
| 1786 ;; It's not in any window - return nil, meaning no frame has | |
| 1787 ;; preference. | |
| 1788 nil) | |
| 1789 (t | |
| 1790 ;; Otherwise, return the frame of the buffer's window. | |
| 1791 (window-frame w)))))))) | |
| 1792 | |
| 1793 | |
| 1794 ;; The pre-display-buffer-function is called for effect, so this needs to | |
| 1795 ;; actually select the frame it wants. Fdisplay_buffer() takes notice of | |
| 1796 ;; changes to the selected frame. | |
| 903 | 1797 (defun get-frame-for-buffer (buffer &optional not-this-window-p on-frame |
| 1798 shrink-to-fit) | |
| 428 | 1799 "Select and return a frame in which to display BUFFER. |
| 1800 Normally, the buffer will simply be displayed in the selected frame. | |
| 3061 | 1801 But if the symbol naming the major-mode of the buffer has a `frame-name' |
| 428 | 1802 property (which should be a symbol), then the buffer will be displayed in |
| 1803 a frame of that name. If there is no frame of that name, then one is | |
| 1804 created. | |
| 1805 | |
| 3061 | 1806 If the major-mode doesn't have a `frame-name' property, then the frame |
| 428 | 1807 named by `get-frame-for-buffer-default-frame-name' will be used. If |
| 1808 that is nil (the default) then the currently selected frame will used. | |
| 1809 | |
| 3061 | 1810 If the frame-name symbol has an `instance-limit' property (an integer) |
| 428 | 1811 then each time a buffer of the mode in question is displayed, a new frame |
| 1812 with that name will be created, until there are `instance-limit' of them. | |
| 1813 If instance-limit is 0, then a new frame will be created each time. | |
| 1814 | |
| 1815 If a buffer is already displayed in a frame, then `instance-limit' is | |
| 1816 ignored, and that frame is used. | |
| 1817 | |
| 3061 | 1818 If the frame-name symbol has a `frame-defaults' property, then that is |
| 428 | 1819 prepended to the `default-frame-plist' when creating a frame for the |
| 1820 first time. | |
| 1821 | |
| 1822 This function may be used as the value of `pre-display-buffer-function', | |
| 444 | 1823 to cause the `display-buffer' function and its callers to exhibit the |
| 1824 above behavior." | |
| 428 | 1825 (let ((frame (get-frame-for-buffer-noselect |
| 1826 buffer not-this-window-p on-frame))) | |
| 1827 (if (not (eq frame (selected-frame))) | |
| 1828 frame | |
| 1829 (select-frame frame) | |
| 1830 (or (frame-visible-p frame) | |
| 1831 ;; If the frame was already visible, just focus on it. | |
| 1832 ;; If it wasn't visible (it was just created, or it used | |
| 1833 ;; to be iconified) then uniconify, raise, etc. | |
| 1834 (make-frame-visible frame)) | |
| 1835 frame))) | |
| 1836 | |
| 1837 (defun frames-of-buffer (&optional buffer visible-only) | |
| 1838 "Return list of frames that BUFFER is currently being displayed on. | |
| 1839 If the buffer is being displayed on the currently selected frame, that frame | |
| 1840 is first in the list. VISIBLE-ONLY will only list non-iconified frames." | |
| 1841 (let ((list (windows-of-buffer buffer)) | |
| 1842 (cur-frame (selected-frame)) | |
| 1843 next-frame frames save-frame) | |
| 1844 | |
| 1845 (while list | |
| 1846 (if (memq (setq next-frame (window-frame (car list))) | |
| 1847 frames) | |
| 1848 nil | |
| 1849 (if (eq cur-frame next-frame) | |
| 1850 (setq save-frame next-frame) | |
| 1851 (and | |
| 1852 (or (not visible-only) | |
| 1853 (frame-visible-p next-frame)) | |
| 1854 (setq frames (append frames (list next-frame)))))) | |
| 1855 (setq list (cdr list))) | |
| 1856 | |
| 1857 (if save-frame | |
| 1858 (append (list save-frame) frames) | |
| 1859 frames))) | |
| 1860 | |
| 1861 (defcustom temp-buffer-shrink-to-fit nil | |
| 1862 "*When non-nil resize temporary output buffers to minimize blank lines." | |
| 1863 :type 'boolean | |
| 1864 :group 'frames) | |
| 1865 | |
| 1866 (defcustom temp-buffer-max-height .5 | |
| 1867 "*Proportion of frame to use for temp windows." | |
| 1868 :type 'number | |
| 1869 :group 'frames) | |
| 1870 | |
|
4506
bd28481bb0e1
Port #'window-buffer-height, #'fit-window-to-buffer, & window, buf, functions.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4044
diff
changeset
|
1871 ;; See also #'temp-buffer-resize-mode in help.el. |
|
bd28481bb0e1
Port #'window-buffer-height, #'fit-window-to-buffer, & window, buf, functions.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4044
diff
changeset
|
1872 |
| 428 | 1873 (defun show-temp-buffer-in-current-frame (buffer) |
| 444 | 1874 "For use as the value of `temp-buffer-show-function': |
| 428 | 1875 always displays the buffer in the selected frame, regardless of the behavior |
| 1876 that would otherwise be introduced by the `pre-display-buffer-function', which | |
| 1877 is normally set to `get-frame-for-buffer' (which see)." | |
| 1878 (let ((pre-display-buffer-function nil)) ; turn it off, whatever it is | |
| 903 | 1879 (let ((window (display-buffer buffer nil nil temp-buffer-shrink-to-fit))) |
| 428 | 1880 (if (not (eq (last-nonminibuf-frame) (window-frame window))) |
| 1881 ;; only the pre-display-buffer-function should ever do this. | |
| 1882 (error "display-buffer switched frames on its own!!")) | |
| 1883 (setq minibuffer-scroll-window window) | |
| 1884 (set-window-start window 1) ; obeys narrowing | |
| 1885 (set-window-point window 1) | |
| 1886 nil))) | |
| 1887 | |
| 1888 (setq temp-buffer-show-function 'show-temp-buffer-in-current-frame) | |
| 1889 | |
| 1890 | |
| 1891 ;; from Bob Weiner <bweiner@pts.mot.com>, modified by Ben Wing | |
| 1892 | |
| 1893 ;; By adding primitives to directly access the window hierarchy, | |
| 1894 ;; we can move many functions into Lisp. We do it this way | |
| 1895 ;; because the implementations are simpler in Lisp, and because | |
| 1896 ;; new functions like this can be added without requiring C | |
| 1897 ;; additions. | |
| 1898 | |
| 1899 (defun frame-utmost-window-2 (window position left-right-p major-end-p | |
| 1900 minor-end-p) | |
| 1901 ;; LEFT-RIGHT-P means we're looking for the leftmost or rightmost | |
| 1902 ;; window, instead of the highest or lowest. In this case, we | |
| 1903 ;; say that the "major axis" goes left-to-right instead of top-to- | |
| 1904 ;; bottom. The "minor axis" always goes perpendicularly. | |
| 1905 ;; | |
| 1906 ;; If MAJOR-END-P is t, we're looking for a windows that abut the | |
| 1907 ;; end (i.e. right or bottom) of the major axis, instead of the | |
| 1908 ;; start. | |
| 1909 ;; | |
| 1910 ;; If MINOR-END-P is t, then we want to start counting from the | |
| 1911 ;; end of the minor axis instead of the beginning. | |
| 1912 ;; | |
| 1913 ;; Here's the general idea: Imagine we're trying to count the number | |
| 1914 ;; of windows that abut the top; call this function foo(). So, we | |
| 1915 ;; start with the root window. If this is a vertical combination | |
| 1916 ;; window, then foo() applied to the root window is the same as | |
| 1917 ;; foo() applied to the first child. If the root is a horizontal | |
| 1918 ;; combination window, then foo() applied to the root is the | |
| 1919 ;; same as the sum of foo() applied to each of the children. | |
| 1920 ;; Otherwise, the root window is a leaf window, and foo() is 1. | |
| 1921 ;; Now it's clear that, each time foo() encounters a leaf window, | |
| 1922 ;; it's encountering a different window that abuts the top. | |
| 1923 ;; With a little examining, you can see that foo encounters the | |
| 1924 ;; top-abutting windows in order from left to right. We can | |
| 1925 ;; modify foo() to return the nth top-abutting window by simply | |
| 1926 ;; keeping a global variable that is decremented each time | |
| 1927 ;; foo() encounters a leaf window and would return 1. If the | |
| 1928 ;; global counter gets to zero, we've encountered the window | |
| 1929 ;; we were looking for, so we exit right away using a `throw'. | |
| 1930 ;; Otherwise, we make sure that all normal paths return nil. | |
| 1931 | |
| 1932 (let (child) | |
| 1933 (cond ((setq child (if left-right-p | |
| 1934 (window-first-hchild window) | |
| 1935 (window-first-vchild window))) | |
| 1936 (if major-end-p | |
| 1937 (while (window-next-child child) | |
| 1938 (setq child (window-next-child child)))) | |
| 1939 (frame-utmost-window-2 child position left-right-p major-end-p | |
| 1940 minor-end-p)) | |
| 1941 ((setq child (if left-right-p | |
| 1942 (window-first-vchild window) | |
| 1943 (window-first-hchild window))) | |
| 1944 (if minor-end-p | |
| 1945 (while (window-next-child child) | |
| 1946 (setq child (window-next-child child)))) | |
| 1947 (while child | |
| 1948 (frame-utmost-window-2 child position left-right-p major-end-p | |
| 1949 minor-end-p) | |
| 1950 (setq child (if minor-end-p | |
| 1951 (window-previous-child child) | |
| 1952 (window-next-child child)))) | |
| 1953 nil) | |
| 1954 (t | |
| 1955 (setcar position (1- (car position))) | |
| 1956 (if (= (car position) 0) | |
| 1957 (throw 'fhw-exit window) | |
| 1958 nil))))) | |
| 1959 | |
| 1960 (defun frame-utmost-window-1 (frame position left-right-p major-end-p) | |
| 1961 (let (minor-end-p) | |
| 1962 (or frame (setq frame (selected-frame))) | |
| 1963 (or position (setq position 0)) | |
| 1964 (if (>= position 0) | |
| 1965 (setq position (1+ position)) | |
| 1966 (setq minor-end-p t) | |
| 1967 (setq position (- position))) | |
| 1968 (catch 'fhw-exit | |
| 1969 ;; we use a cons here as a simple form of call-by-reference. | |
| 1970 ;; scheme has "boxes" for the same purpose. | |
| 1971 (frame-utmost-window-2 (frame-root-window frame) (list position) | |
| 1972 left-right-p major-end-p minor-end-p)))) | |
| 1973 | |
| 1974 | |
| 1975 (defun frame-highest-window (&optional frame position) | |
| 1976 "Return the highest window on FRAME which is at POSITION. | |
| 1977 If omitted, FRAME defaults to the currently selected frame. | |
| 1978 POSITION is used to distinguish between multiple windows that abut | |
| 1979 the top of the frame: 0 means the leftmost window abutting the | |
| 1980 top of the frame, 1 the next-leftmost, etc. POSITION can also | |
| 1981 be less than zero: -1 means the rightmost window abutting the | |
| 1982 top of the frame, -2 the next-rightmost, etc. | |
| 1983 If omitted, POSITION defaults to 0, i.e. the leftmost highest window. | |
| 1984 If there is no window at the given POSITION, return nil." | |
| 1985 (frame-utmost-window-1 frame position nil nil)) | |
| 1986 | |
| 1987 (defun frame-lowest-window (&optional frame position) | |
| 1988 "Return the lowest window on FRAME which is at POSITION. | |
| 1989 If omitted, FRAME defaults to the currently selected frame. | |
| 1990 POSITION is used to distinguish between multiple windows that abut | |
| 1991 the bottom of the frame: 0 means the leftmost window abutting the | |
| 1992 bottom of the frame, 1 the next-leftmost, etc. POSITION can also | |
| 1993 be less than zero: -1 means the rightmost window abutting the | |
| 1994 bottom of the frame, -2 the next-rightmost, etc. | |
| 1995 If omitted, POSITION defaults to 0, i.e. the leftmost lowest window. | |
| 1996 If there is no window at the given POSITION, return nil." | |
| 1997 (frame-utmost-window-1 frame position nil t)) | |
| 1998 | |
| 1999 (defun frame-leftmost-window (&optional frame position) | |
| 2000 "Return the leftmost window on FRAME which is at POSITION. | |
| 2001 If omitted, FRAME defaults to the currently selected frame. | |
| 2002 POSITION is used to distinguish between multiple windows that abut | |
| 2003 the left edge of the frame: 0 means the highest window abutting the | |
| 2004 left edge of the frame, 1 the next-highest, etc. POSITION can also | |
| 2005 be less than zero: -1 means the lowest window abutting the | |
| 2006 left edge of the frame, -2 the next-lowest, etc. | |
| 2007 If omitted, POSITION defaults to 0, i.e. the highest leftmost window. | |
| 2008 If there is no window at the given POSITION, return nil." | |
| 2009 (frame-utmost-window-1 frame position t nil)) | |
| 2010 | |
| 2011 (defun frame-rightmost-window (&optional frame position) | |
| 2012 "Return the rightmost window on FRAME which is at POSITION. | |
| 2013 If omitted, FRAME defaults to the currently selected frame. | |
| 2014 POSITION is used to distinguish between multiple windows that abut | |
| 2015 the right edge of the frame: 0 means the highest window abutting the | |
| 2016 right edge of the frame, 1 the next-highest, etc. POSITION can also | |
| 2017 be less than zero: -1 means the lowest window abutting the | |
| 2018 right edge of the frame, -2 the next-lowest, etc. | |
| 2019 If omitted, POSITION defaults to 0, i.e. the highest rightmost window. | |
| 2020 If there is no window at the given POSITION, return nil." | |
| 2021 (frame-utmost-window-1 frame position t t)) | |
| 2022 | |
| 2023 | |
| 2024 | |
| 2025 ;; frame properties. | |
| 2026 | |
| 2027 (put 'cursor-color 'frame-property-alias [text-cursor background]) | |
| 2028 (put 'modeline 'frame-property-alias 'has-modeline-p) | |
| 2029 | |
| 2030 | |
| 2031 (provide 'frame) | |
| 2032 | |
| 2033 ;;; frame.el ends here |