Mercurial > hg > xemacs-beta
annotate src/marker.c @ 5157:1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
-------------------- ChangeLog entries follow: --------------------
lisp/ChangeLog addition:
2010-03-18 Ben Wing <ben@xemacs.org>
* diagnose.el (show-memory-usage):
Rewrite to take into account API changes in memory-usage functions.
src/ChangeLog addition:
2010-03-18 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (disksave_object_finalization_1):
* alloc.c (lisp_object_storage_size):
* alloc.c (listu):
* alloc.c (listn):
* alloc.c (Fobject_memory_usage_stats):
* alloc.c (compute_memusage_stats_length):
* alloc.c (Fobject_memory_usage):
* alloc.c (Ftotal_object_memory_usage):
* alloc.c (malloced_storage_size):
* alloc.c (common_init_alloc_early):
* alloc.c (reinit_alloc_objects_early):
* alloc.c (reinit_alloc_early):
* alloc.c (init_alloc_once_early):
* alloc.c (syms_of_alloc):
* alloc.c (reinit_vars_of_alloc):
* buffer.c:
* buffer.c (struct buffer_stats):
* buffer.c (compute_buffer_text_usage):
* buffer.c (compute_buffer_usage):
* buffer.c (buffer_memory_usage):
* buffer.c (buffer_objects_create):
* buffer.c (syms_of_buffer):
* buffer.c (vars_of_buffer):
* console-impl.h (struct console_methods):
* dynarr.c (Dynarr_memory_usage):
* emacs.c (main_1):
* events.c (clear_event_resource):
* extents.c:
* extents.c (compute_buffer_extent_usage):
* extents.c (extent_objects_create):
* extents.h:
* faces.c:
* faces.c (compute_face_cachel_usage):
* faces.c (face_objects_create):
* faces.h:
* general-slots.h:
* glyphs.c:
* glyphs.c (compute_glyph_cachel_usage):
* glyphs.c (glyph_objects_create):
* glyphs.h:
* lisp.h:
* lisp.h (struct usage_stats):
* lrecord.h:
* lrecord.h (enum lrecord_type):
* lrecord.h (struct lrecord_implementation):
* lrecord.h (MC_ALLOC_CALL_FINALIZER_FOR_DISKSAVE):
* lrecord.h (DEFINE_DUMPABLE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_FROB_BLOCK_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_SIZABLE_INTERNAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_FROB_BLOCK_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_FROB_BLOCK_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_INTERNAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_SIZABLE_INTERNAL_LISP_OBJECT):
* lrecord.h (MAKE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_MODULE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_MODULE_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_MODULE_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_MODULE_SIZABLE_LISP_OBJECT):
* lrecord.h (MAKE_MODULE_LISP_OBJECT):
* lrecord.h (INIT_LISP_OBJECT):
* lrecord.h (INIT_MODULE_LISP_OBJECT):
* lrecord.h (UNDEF_LISP_OBJECT):
* lrecord.h (UNDEF_MODULE_LISP_OBJECT):
* lrecord.h (DECLARE_LISP_OBJECT):
* lrecord.h (DECLARE_MODULE_API_LISP_OBJECT):
* lrecord.h (DECLARE_MODULE_LISP_OBJECT):
* lstream.c:
* lstream.c (syms_of_lstream):
* lstream.c (vars_of_lstream):
* marker.c:
* marker.c (compute_buffer_marker_usage):
* mc-alloc.c (mc_alloced_storage_size):
* mc-alloc.h:
* mule-charset.c:
* mule-charset.c (struct charset_stats):
* mule-charset.c (compute_charset_usage):
* mule-charset.c (charset_memory_usage):
* mule-charset.c (mule_charset_objects_create):
* mule-charset.c (syms_of_mule_charset):
* mule-charset.c (vars_of_mule_charset):
* redisplay.c:
* redisplay.c (compute_rune_dynarr_usage):
* redisplay.c (compute_display_block_dynarr_usage):
* redisplay.c (compute_glyph_block_dynarr_usage):
* redisplay.c (compute_display_line_dynarr_usage):
* redisplay.c (compute_line_start_cache_dynarr_usage):
* redisplay.h:
* scrollbar-gtk.c (gtk_compute_scrollbar_instance_usage):
* scrollbar-msw.c (mswindows_compute_scrollbar_instance_usage):
* scrollbar-x.c (x_compute_scrollbar_instance_usage):
* scrollbar.c (compute_scrollbar_instance_usage):
* scrollbar.h:
* symbols.c:
* symbols.c (reinit_symbol_objects_early):
* symbols.c (init_symbols_once_early):
* symbols.c (reinit_symbols_early):
* symbols.c (defsymbol_massage_name_1):
* symsinit.h:
* ui-gtk.c:
* ui-gtk.c (emacs_gtk_object_getprop):
* ui-gtk.c (emacs_gtk_object_putprop):
* ui-gtk.c (ui_gtk_objects_create):
* unicode.c (compute_from_unicode_table_size_1):
* unicode.c (compute_to_unicode_table_size_1):
* unicode.c (compute_from_unicode_table_size):
* unicode.c (compute_to_unicode_table_size):
* window.c:
* window.c (struct window_stats):
* window.c (compute_window_mirror_usage):
* window.c (compute_window_usage):
* window.c (window_memory_usage):
* window.c (window_objects_create):
* window.c (syms_of_window):
* window.c (vars_of_window):
* window.h:
Redo memory-usage mechanism, make it general; add way of dynamically
initializing Lisp object types -- OBJECT_HAS_METHOD(), similar to
CONSOLE_HAS_METHOD().
(1) Create OBJECT_HAS_METHOD(), OBJECT_HAS_PROPERTY() etc. for
specifying that a Lisp object type has a particular method or
property. Call such methods with OBJECT_METH, MAYBE_OBJECT_METH,
OBJECT_METH_OR_GIVEN; retrieve properties with OBJECT_PROPERTY.
Methods that formerly required a DEFINE_*GENERAL_LISP_OBJECT() to
specify them (getprop, putprop, remprop, plist, disksave) now
instead use the dynamic-method mechanism. The main benefit of
this is that new methods or properties can be added without
requiring that the declaration statements of all existing methods
be modified. We have to make the `struct lrecord_implementation'
non-const, but I don't think this should have any effect on speed --
the only possible method that's really speed-critical is the
mark method, and we already extract those out into a separate
(non-const) array for increased cache locality.
Object methods need to be reinitialized after pdump, so we put
them in separate functions such as face_objects_create(),
extent_objects_create() and call them appropriately from emacs.c
The only current object property (`memusage_stats_list') that
objects can specify is a Lisp object and gets staticpro()ed so it
only needs to be set during dump time, but because it references
symbols that might not exist in a syms_of_() function, we
initialize it in vars_of_(). There is also an object property
(`num_extra_memusage_stats') that is automatically initialized based
on `memusage_stats_list'; we do that in reinit_vars_of_alloc(),
which is called after all vars_of_() functions are called.
`disksaver' method was renamed `disksave' to correspond with the
name normally given to the function (e.g. disksave_lstream()).
(2) Generalize the memory-usage mechanism in `buffer-memory-usage',
`window-memory-usage', `charset-memory-usage' into an object-type-
specific mechanism called by a single function
`object-memory-usage'. (Former function `object-memory-usage'
renamed to `total-object-memory-usage'). Generalize the mechanism
of different "slices" so that we can have different "classes" of
memory described and different "slices" onto each class; `t'
separates classes, `nil' separates slices. Currently we have
three classes defined: the memory of an object itself,
non-Lisp-object memory associated with the object (e.g. arrays or
dynarrs stored as fields in the object), and Lisp-object memory
associated with the object (other internal Lisp objects stored in
the object). This isn't completely finished yet and we might need
to further separate the "other internal Lisp objects" class into
two classes.
The memory-usage mechanism uses a `struct usage_stats' (renamed
from `struct overhead_stats') to describe a malloc-view onto a set
of allocated memory (listing how much was requested and various
types of overhead) and a more general `struct generic_usage_stats'
(with a `struct usage_stats' in it) to hold all statistics about
object memory. `struct generic_usage_stats' contains an array of
32 Bytecounts, which are statistics of unspecified semantics. The
intention is that individual types declare a corresponding struct
(e.g. `struct window_stats') with the same structure but with
specific fields in place of the array, corresponding to specific
statistics. The number of such statistics is an object property
computed from the list of tags (Lisp symbols describing the
statistics) stored in `memusage_stats_list'. The idea here is to
allow particular object types to customize the number and
semantics of the statistics where completely avoiding consing.
This doesn't matter so much yet, but the intention is to have the
memory usage of all objects computed at the end of GC, at the same
time as other statistics are currently computed. The values for
all statistics for a single type would be added up to compute
aggregate values for all objects of a specific type. To make this
efficient, we can't allow any memory allocation at all.
(3) Create some additional functions for creating lists that
specify the elements directly as args rather than indirectly through
an array: listn() (number of args given), listu() (list terminated
by Qunbound).
(4) Delete a bit of remaining unused C window_config stuff, also
unused lrecord_type_popup_data.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Thu, 18 Mar 2010 10:50:06 -0500 |
| parents | 88bd4f3ef8e4 |
| children | ab9ee10a53e4 |
| rev | line source |
|---|---|
| 428 | 1 /* Markers: examining, setting and killing. |
| 2 Copyright (C) 1985, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
3 Copyright (C) 2002, 2010 Ben Wing. |
| 428 | 4 |
| 5 This file is part of XEmacs. | |
| 6 | |
| 7 XEmacs is free software; you can redistribute it and/or modify it | |
| 8 under the terms of the GNU General Public License as published by the | |
| 9 Free Software Foundation; either version 2, or (at your option) any | |
| 10 later version. | |
| 11 | |
| 12 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 15 for more details. | |
| 16 | |
| 17 You should have received a copy of the GNU General Public License | |
| 18 along with XEmacs; see the file COPYING. If not, write to | |
| 19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 20 Boston, MA 02111-1307, USA. */ | |
| 21 | |
| 22 /* Synched up with: FSF 19.30. */ | |
| 23 | |
| 24 /* This file has been Mule-ized. */ | |
| 25 | |
| 26 /* Note that markers are currently kept in an unordered list. | |
| 27 This means that marker operations may be inefficient if | |
| 28 there are a bunch of markers in the buffer. This probably | |
| 29 won't have a significant impact on redisplay (which uses | |
| 30 markers), but if it does, it wouldn't be too hard to change | |
| 31 to an ordered gap array. (Just copy the code from extents.c.) | |
| 32 */ | |
| 33 | |
| 34 #include <config.h> | |
| 35 #include "lisp.h" | |
| 36 | |
| 37 #include "buffer.h" | |
| 38 | |
| 39 static Lisp_Object | |
| 40 mark_marker (Lisp_Object obj) | |
| 41 { | |
| 440 | 42 Lisp_Marker *marker = XMARKER (obj); |
| 428 | 43 Lisp_Object buf; |
| 44 /* DO NOT mark through the marker's chain. | |
| 45 The buffer's markers chain does not preserve markers from gc; | |
| 46 Instead, markers are removed from the chain when they are freed | |
| 47 by gc. | |
| 48 */ | |
| 49 if (!marker->buffer) | |
| 50 return (Qnil); | |
| 51 | |
| 793 | 52 buf = wrap_buffer (marker->buffer); |
| 428 | 53 return (buf); |
| 54 } | |
| 55 | |
| 56 static void | |
| 2286 | 57 print_marker (Lisp_Object obj, Lisp_Object printcharfun, |
| 58 int UNUSED (escapeflag)) | |
| 428 | 59 { |
| 440 | 60 Lisp_Marker *marker = XMARKER (obj); |
| 428 | 61 |
| 62 if (print_readably) | |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
63 printing_unreadable_object_fmt ("#<marker 0x%x>", LISP_OBJECT_UID (obj)); |
| 428 | 64 |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
3263
diff
changeset
|
65 write_ascstring (printcharfun, GETTEXT ("#<marker ")); |
| 428 | 66 if (!marker->buffer) |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
3263
diff
changeset
|
67 write_ascstring (printcharfun, GETTEXT ("in no buffer")); |
| 428 | 68 else |
| 69 { | |
| 826 | 70 write_fmt_string (printcharfun, "at %ld in ", |
| 71 (long) marker_position (obj)); | |
| 428 | 72 print_internal (marker->buffer->name, printcharfun, 0); |
| 73 } | |
| 826 | 74 if (marker->insertion_type) |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
3263
diff
changeset
|
75 write_ascstring (printcharfun, " insertion-type=t"); |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
76 write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); |
| 428 | 77 } |
| 78 | |
| 79 static int | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
3263
diff
changeset
|
80 marker_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
3263
diff
changeset
|
81 int UNUSED (foldcase)) |
| 428 | 82 { |
| 440 | 83 Lisp_Marker *marker1 = XMARKER (obj1); |
| 84 Lisp_Marker *marker2 = XMARKER (obj2); | |
| 428 | 85 |
| 86 return ((marker1->buffer == marker2->buffer) && | |
| 665 | 87 (marker1->membpos == marker2->membpos || |
| 428 | 88 /* All markers pointing nowhere are equal */ |
| 89 !marker1->buffer)); | |
| 90 } | |
| 91 | |
| 2515 | 92 static Hashcode |
| 2286 | 93 marker_hash (Lisp_Object obj, int UNUSED (depth)) |
| 428 | 94 { |
| 2515 | 95 Hashcode hash = (Hashcode) XMARKER (obj)->buffer; |
| 428 | 96 if (hash) |
| 665 | 97 hash = HASH2 (hash, XMARKER (obj)->membpos); |
| 428 | 98 return hash; |
| 99 } | |
| 100 | |
| 1204 | 101 static const struct memory_description marker_description[] = { |
| 2551 | 102 { XD_LISP_OBJECT, offsetof (Lisp_Marker, next), 0, { 0 }, XD_FLAG_NO_KKCC }, |
| 103 { XD_LISP_OBJECT, offsetof (Lisp_Marker, prev), 0, { 0 }, XD_FLAG_NO_KKCC }, | |
| 440 | 104 { XD_LISP_OBJECT, offsetof (Lisp_Marker, buffer) }, |
| 428 | 105 { XD_END } |
| 106 }; | |
| 107 | |
| 3263 | 108 #ifdef NEW_GC |
| 2720 | 109 static void |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
110 finalize_marker (Lisp_Object obj) |
| 2720 | 111 { |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
112 unchain_marker (obj); |
| 2720 | 113 } |
| 114 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
115 DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("marker", marker, |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
116 mark_marker, print_marker, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
117 finalize_marker, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
118 marker_equal, marker_hash, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
119 marker_description, Lisp_Marker); |
| 3263 | 120 #else /* not NEW_GC */ |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
121 DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("marker", marker, |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
122 mark_marker, print_marker, 0, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
123 marker_equal, marker_hash, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
124 marker_description, Lisp_Marker); |
| 3263 | 125 #endif /* not NEW_GC */ |
| 428 | 126 |
| 127 /* Operations on markers. */ | |
| 128 | |
| 129 DEFUN ("marker-buffer", Fmarker_buffer, 1, 1, 0, /* | |
| 130 Return the buffer that MARKER points into, or nil if none. | |
| 131 Return nil if MARKER points into a dead buffer or doesn't point anywhere. | |
| 132 */ | |
| 133 (marker)) | |
| 134 { | |
| 135 struct buffer *buf; | |
| 136 CHECK_MARKER (marker); | |
| 137 /* Return marker's buffer only if it is not dead. */ | |
| 138 if ((buf = XMARKER (marker)->buffer) && BUFFER_LIVE_P (buf)) | |
| 139 { | |
| 793 | 140 return wrap_buffer (buf); |
| 428 | 141 } |
| 142 return Qnil; | |
| 143 } | |
| 144 | |
| 145 DEFUN ("marker-position", Fmarker_position, 1, 1, 0, /* | |
| 146 Return the position MARKER points at, as a character number. | |
| 147 Return `nil' if marker doesn't point anywhere. | |
| 148 */ | |
| 149 (marker)) | |
| 150 { | |
| 151 CHECK_MARKER (marker); | |
| 152 return XMARKER (marker)->buffer ? make_int (marker_position (marker)) : Qnil; | |
| 153 } | |
| 154 | |
| 155 #if 0 /* useful debugging function */ | |
| 156 | |
| 157 static void | |
| 158 check_marker_circularities (struct buffer *buf) | |
| 159 { | |
| 440 | 160 Lisp_Marker *tortoise, *hare; |
| 428 | 161 |
| 162 tortoise = BUF_MARKERS (buf); | |
| 163 hare = tortoise; | |
| 164 | |
| 165 if (!tortoise) | |
| 166 return; | |
| 167 | |
| 168 while (1) | |
| 169 { | |
| 170 assert (hare->buffer == buf); | |
| 171 hare = hare->next; | |
| 172 if (!hare) | |
| 173 return; | |
| 174 assert (hare->buffer == buf); | |
| 175 hare = hare->next; | |
| 176 if (!hare) | |
| 177 return; | |
| 178 tortoise = tortoise->next; | |
| 179 assert (tortoise != hare); | |
| 180 } | |
| 181 } | |
| 182 | |
| 183 #endif | |
| 184 | |
| 185 static Lisp_Object | |
| 444 | 186 set_marker_internal (Lisp_Object marker, Lisp_Object position, |
| 187 Lisp_Object buffer, int restricted_p) | |
| 428 | 188 { |
| 665 | 189 Charbpos charno; |
| 428 | 190 struct buffer *b; |
| 440 | 191 Lisp_Marker *m; |
| 428 | 192 int point_p; |
| 193 | |
| 194 CHECK_MARKER (marker); | |
| 195 | |
| 196 point_p = POINT_MARKER_P (marker); | |
| 197 | |
| 198 /* If position is nil or a marker that points nowhere, | |
| 199 make this marker point nowhere. */ | |
| 444 | 200 if (NILP (position) || |
| 201 (MARKERP (position) && !XMARKER (position)->buffer)) | |
| 428 | 202 { |
| 203 if (point_p) | |
| 563 | 204 invalid_operation ("Can't make point-marker point nowhere", |
| 205 marker); | |
| 428 | 206 if (XMARKER (marker)->buffer) |
| 207 unchain_marker (marker); | |
| 208 return marker; | |
| 209 } | |
| 210 | |
| 444 | 211 CHECK_INT_COERCE_MARKER (position); |
| 428 | 212 if (NILP (buffer)) |
| 213 b = current_buffer; | |
| 214 else | |
| 215 { | |
| 216 CHECK_BUFFER (buffer); | |
| 217 b = XBUFFER (buffer); | |
| 218 /* If buffer is dead, set marker to point nowhere. */ | |
| 219 if (!BUFFER_LIVE_P (XBUFFER (buffer))) | |
| 220 { | |
| 221 if (point_p) | |
| 563 | 222 invalid_operation |
| 428 | 223 ("Can't move point-marker in a killed buffer", marker); |
| 224 if (XMARKER (marker)->buffer) | |
| 225 unchain_marker (marker); | |
| 226 return marker; | |
| 227 } | |
| 228 } | |
| 229 | |
| 444 | 230 charno = XINT (position); |
| 428 | 231 m = XMARKER (marker); |
| 232 | |
| 233 if (restricted_p) | |
| 234 { | |
| 235 if (charno < BUF_BEGV (b)) charno = BUF_BEGV (b); | |
| 236 if (charno > BUF_ZV (b)) charno = BUF_ZV (b); | |
| 237 } | |
| 238 else | |
| 239 { | |
| 240 if (charno < BUF_BEG (b)) charno = BUF_BEG (b); | |
| 241 if (charno > BUF_Z (b)) charno = BUF_Z (b); | |
| 242 } | |
| 243 | |
| 244 if (point_p) | |
| 245 { | |
| 246 #ifndef moving_point_by_moving_its_marker_is_a_bug | |
| 247 BUF_SET_PT (b, charno); /* this will move the marker */ | |
| 248 #else /* It's not a feature, so it must be a bug */ | |
| 563 | 249 invalid_operation ("DEBUG: attempt to move point via point-marker", |
| 250 marker); | |
| 428 | 251 #endif |
| 252 } | |
| 253 else | |
| 254 { | |
| 665 | 255 m->membpos = charbpos_to_membpos (b, charno); |
| 428 | 256 } |
| 257 | |
| 258 if (m->buffer != b) | |
| 259 { | |
| 260 if (point_p) | |
| 563 | 261 invalid_operation ("Can't change buffer of point-marker", marker); |
| 428 | 262 if (m->buffer != 0) |
| 263 unchain_marker (marker); | |
| 264 m->buffer = b; | |
| 265 marker_next (m) = BUF_MARKERS (b); | |
| 266 marker_prev (m) = 0; | |
| 267 if (BUF_MARKERS (b)) | |
| 268 marker_prev (BUF_MARKERS (b)) = m; | |
| 269 BUF_MARKERS (b) = m; | |
| 270 } | |
| 271 | |
| 272 return marker; | |
| 273 } | |
| 274 | |
| 275 | |
| 276 DEFUN ("set-marker", Fset_marker, 2, 3, 0, /* | |
| 444 | 277 Move MARKER to position POSITION in BUFFER. |
| 278 POSITION can be a marker, an integer or nil. If POSITION is an | |
| 279 integer, make MARKER point before the POSITIONth character in BUFFER. | |
| 280 If POSITION is nil, makes MARKER point nowhere. Then it no longer | |
| 281 slows down editing in any buffer. If POSITION is less than 1, move | |
| 282 MARKER to the beginning of BUFFER. If POSITION is greater than the | |
| 283 size of BUFFER, move MARKER to the end of BUFFER. | |
| 428 | 284 BUFFER defaults to the current buffer. |
| 444 | 285 If this marker was returned by (point-marker t), then changing its |
| 286 position moves point. You cannot change its buffer or make it point | |
| 287 nowhere. | |
| 288 The return value is MARKER. | |
| 428 | 289 */ |
| 444 | 290 (marker, position, buffer)) |
| 428 | 291 { |
| 444 | 292 return set_marker_internal (marker, position, buffer, 0); |
| 428 | 293 } |
| 294 | |
| 295 | |
| 296 /* This version of Fset_marker won't let the position | |
| 297 be outside the visible part. */ | |
| 298 Lisp_Object | |
| 444 | 299 set_marker_restricted (Lisp_Object marker, Lisp_Object position, |
| 300 Lisp_Object buffer) | |
| 428 | 301 { |
| 444 | 302 return set_marker_internal (marker, position, buffer, 1); |
| 428 | 303 } |
| 304 | |
| 305 | |
| 306 /* This is called during garbage collection, | |
| 307 so we must be careful to ignore and preserve mark bits, | |
| 308 including those in chain fields of markers. */ | |
| 309 | |
| 310 void | |
| 311 unchain_marker (Lisp_Object m) | |
| 312 { | |
| 440 | 313 Lisp_Marker *marker = XMARKER (m); |
| 428 | 314 struct buffer *b = marker->buffer; |
| 315 | |
| 316 if (b == 0) | |
| 317 return; | |
| 318 | |
| 800 | 319 #ifdef ERROR_CHECK_STRUCTURES |
| 428 | 320 assert (BUFFER_LIVE_P (b)); |
| 321 #endif | |
| 322 | |
| 323 if (marker_next (marker)) | |
| 324 marker_prev (marker_next (marker)) = marker_prev (marker); | |
| 325 if (marker_prev (marker)) | |
| 326 marker_next (marker_prev (marker)) = marker_next (marker); | |
| 327 else | |
| 328 BUF_MARKERS (b) = marker_next (marker); | |
| 329 | |
| 800 | 330 #ifdef ERROR_CHECK_STRUCTURES |
| 428 | 331 assert (marker != XMARKER (b->point_marker)); |
| 332 #endif | |
| 333 | |
| 334 marker->buffer = 0; | |
| 335 } | |
| 336 | |
| 665 | 337 Bytebpos |
| 826 | 338 byte_marker_position (Lisp_Object marker) |
| 428 | 339 { |
| 440 | 340 Lisp_Marker *m = XMARKER (marker); |
| 428 | 341 struct buffer *buf = m->buffer; |
| 665 | 342 Bytebpos pos; |
| 428 | 343 |
| 344 if (!buf) | |
| 563 | 345 invalid_argument ("Marker does not point anywhere", Qunbound); |
| 428 | 346 |
| 347 /* FSF claims that marker indices could end up denormalized, i.e. | |
| 348 in the gap. This is way bogus if it ever happens, and means | |
| 349 something fucked up elsewhere. Since I've overhauled all this | |
| 350 shit, I don't think this can happen. In any case, the following | |
| 351 macro has an assert() in it that will catch these denormalized | |
| 352 positions. */ | |
| 665 | 353 pos = membpos_to_bytebpos (buf, m->membpos); |
| 428 | 354 |
| 355 return pos; | |
| 356 } | |
| 357 | |
| 665 | 358 Charbpos |
| 428 | 359 marker_position (Lisp_Object marker) |
| 360 { | |
| 361 struct buffer *buf = XMARKER (marker)->buffer; | |
| 362 | |
| 363 if (!buf) | |
| 563 | 364 invalid_argument ("Marker does not point anywhere", Qunbound); |
| 428 | 365 |
| 826 | 366 return bytebpos_to_charbpos (buf, byte_marker_position (marker)); |
| 428 | 367 } |
| 368 | |
| 369 void | |
| 826 | 370 set_byte_marker_position (Lisp_Object marker, Bytebpos pos) |
| 428 | 371 { |
| 440 | 372 Lisp_Marker *m = XMARKER (marker); |
| 428 | 373 struct buffer *buf = m->buffer; |
| 374 | |
| 375 if (!buf) | |
| 563 | 376 invalid_argument ("Marker does not point anywhere", Qunbound); |
| 428 | 377 |
| 665 | 378 m->membpos = bytebpos_to_membpos (buf, pos); |
| 428 | 379 } |
| 380 | |
| 381 void | |
| 665 | 382 set_marker_position (Lisp_Object marker, Charbpos pos) |
| 428 | 383 { |
| 384 struct buffer *buf = XMARKER (marker)->buffer; | |
| 385 | |
| 386 if (!buf) | |
| 563 | 387 invalid_argument ("Marker does not point anywhere", Qunbound); |
| 428 | 388 |
| 826 | 389 set_byte_marker_position (marker, charbpos_to_bytebpos (buf, pos)); |
| 428 | 390 } |
| 391 | |
| 392 static Lisp_Object | |
| 393 copy_marker_1 (Lisp_Object marker, Lisp_Object type, int noseeum) | |
| 394 { | |
| 3025 | 395 REGISTER Lisp_Object new_; |
| 428 | 396 |
| 397 while (1) | |
| 398 { | |
| 399 if (INTP (marker) || MARKERP (marker)) | |
| 400 { | |
| 401 if (noseeum) | |
| 3025 | 402 new_ = noseeum_make_marker (); |
| 428 | 403 else |
| 3025 | 404 new_ = Fmake_marker (); |
| 405 Fset_marker (new_, marker, | |
| 428 | 406 (MARKERP (marker) ? Fmarker_buffer (marker) : Qnil)); |
| 3025 | 407 XMARKER (new_)->insertion_type = !NILP (type); |
| 408 return new_; | |
| 428 | 409 } |
| 410 else | |
| 411 marker = wrong_type_argument (Qinteger_or_marker_p, marker); | |
| 412 } | |
| 413 | |
| 1204 | 414 RETURN_NOT_REACHED (Qnil); /* not reached */ |
| 428 | 415 } |
| 416 | |
| 417 DEFUN ("copy-marker", Fcopy_marker, 1, 2, 0, /* | |
| 444 | 418 Return a new marker pointing at the same place as MARKER-OR-INTEGER. |
| 419 If MARKER-OR-INTEGER is an integer, return a new marker pointing | |
| 428 | 420 at that position in the current buffer. |
| 444 | 421 Optional argument MARKER-TYPE specifies the insertion type of the new |
| 422 marker; see `marker-insertion-type'. | |
| 428 | 423 */ |
| 444 | 424 (marker_or_integer, marker_type)) |
| 428 | 425 { |
| 444 | 426 return copy_marker_1 (marker_or_integer, marker_type, 0); |
| 428 | 427 } |
| 428 | |
| 429 Lisp_Object | |
| 444 | 430 noseeum_copy_marker (Lisp_Object marker, Lisp_Object marker_type) |
| 428 | 431 { |
| 444 | 432 return copy_marker_1 (marker, marker_type, 1); |
| 428 | 433 } |
| 434 | |
| 435 DEFUN ("marker-insertion-type", Fmarker_insertion_type, 1, 1, 0, /* | |
| 436 Return insertion type of MARKER: t if it stays after inserted text. | |
| 437 nil means the marker stays before text inserted there. | |
| 438 */ | |
| 439 (marker)) | |
| 440 { | |
| 441 CHECK_MARKER (marker); | |
| 442 return XMARKER (marker)->insertion_type ? Qt : Qnil; | |
| 443 } | |
| 444 | |
| 445 DEFUN ("set-marker-insertion-type", Fset_marker_insertion_type, 2, 2, 0, /* | |
| 446 Set the insertion-type of MARKER to TYPE. | |
| 447 If TYPE is t, it means the marker advances when you insert text at it. | |
| 448 If TYPE is nil, it means the marker stays behind when you insert text at it. | |
| 449 */ | |
| 450 (marker, type)) | |
| 451 { | |
| 452 CHECK_MARKER (marker); | |
| 453 | |
| 454 XMARKER (marker)->insertion_type = ! NILP (type); | |
| 455 return type; | |
| 456 } | |
| 457 | |
| 458 /* #### What is the possible use of this? It looks quite useless to | |
| 459 me, because there is no way to find *which* markers are positioned | |
| 460 at POSITION. Additional bogosity bonus: (buffer-has-markers-at | |
| 461 (point)) will always return t because of the `point-marker'. The | |
| 462 same goes for the position of mark. Bletch! | |
| 463 | |
| 464 Someone should discuss this with Stallman, but I don't have the | |
| 465 stomach. In fact, this function sucks so badly that I'm disabling | |
| 466 it by default (although I've debugged it). If you want to use it, | |
| 467 use extents instead. --hniksic */ | |
| 468 #if 0 | |
| 826 | 469 DEFUN ("buffer-has-markers-at", Fbuffer_has_markers_at, 1, 1, 0, /* |
| 428 | 470 Return t if there are markers pointing at POSITION in the current buffer. |
| 471 */ | |
| 472 (position)) | |
| 473 { | |
| 440 | 474 Lisp_Marker *marker; |
| 665 | 475 Membpos pos; |
| 428 | 476 |
| 665 | 477 /* A small optimization trick: convert POS to membpos now, rather |
| 478 than converting every marker's memory index to charbpos. */ | |
| 479 pos = bytebpos_to_membpos (current_buffer, | |
| 428 | 480 get_buffer_pos_byte (current_buffer, position, |
| 481 GB_COERCE_RANGE)); | |
| 482 | |
| 483 for (marker = BUF_MARKERS (current_buffer); | |
| 484 marker; | |
| 485 marker = marker_next (marker)) | |
| 486 { | |
| 665 | 487 /* We use marker->membpos, so we don't have to go through the |
| 428 | 488 unwieldy operation of creating a Lisp_Object for |
| 489 marker_position() every time around. */ | |
| 665 | 490 if (marker->membpos == pos) |
| 428 | 491 return Qt; |
| 492 } | |
| 493 | |
| 494 return Qnil; | |
| 495 } | |
| 496 #endif /* 0 */ | |
| 497 | |
| 498 #ifdef MEMORY_USAGE_STATS | |
| 499 | |
| 500 int | |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
501 compute_buffer_marker_usage (struct buffer *b, struct usage_stats *ustats) |
| 428 | 502 { |
| 440 | 503 Lisp_Marker *m; |
| 428 | 504 int total = 0; |
| 505 int overhead; | |
| 506 | |
| 507 for (m = BUF_MARKERS (b); m; m = m->next) | |
| 440 | 508 total += sizeof (Lisp_Marker); |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
509 ustats->was_requested += total; |
| 3263 | 510 #ifdef NEW_GC |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
511 overhead = mc_alloced_storage_size (total, 0) - total; |
| 3263 | 512 #else /* not NEW_GC */ |
| 428 | 513 overhead = fixed_type_block_overhead (total); |
| 3263 | 514 #endif /* not NEW_GC */ |
| 428 | 515 /* #### claiming this is all malloc overhead is not really right, |
| 516 but it has to go somewhere. */ | |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
517 ustats->malloc_overhead += overhead; |
| 428 | 518 return total + overhead; |
| 519 } | |
| 520 | |
| 521 #endif /* MEMORY_USAGE_STATS */ | |
| 522 | |
| 523 | |
| 524 void | |
| 525 syms_of_marker (void) | |
| 526 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
527 INIT_LISP_OBJECT (marker); |
| 442 | 528 |
| 428 | 529 DEFSUBR (Fmarker_position); |
| 530 DEFSUBR (Fmarker_buffer); | |
| 531 DEFSUBR (Fset_marker); | |
| 532 DEFSUBR (Fcopy_marker); | |
| 533 DEFSUBR (Fmarker_insertion_type); | |
| 534 DEFSUBR (Fset_marker_insertion_type); | |
| 535 #if 0 /* FSFmacs crock */ | |
| 536 DEFSUBR (Fbuffer_has_markers_at); | |
| 537 #endif | |
| 538 } | |
| 539 | |
| 540 void | |
| 541 init_buffer_markers (struct buffer *b) | |
| 542 { | |
| 793 | 543 Lisp_Object buf = wrap_buffer (b); |
| 428 | 544 |
| 545 b->mark = Fmake_marker (); | |
| 546 BUF_MARKERS (b) = 0; | |
| 547 b->point_marker = Fmake_marker (); | |
| 548 Fset_marker (b->point_marker, | |
| 549 /* For indirect buffers, point is already set. */ | |
| 550 b->base_buffer ? make_int (BUF_PT (b)) : make_int (1), | |
| 551 buf); | |
| 552 } | |
| 553 | |
| 554 void | |
| 555 uninit_buffer_markers (struct buffer *b) | |
| 556 { | |
| 557 /* Unchain all markers of this buffer | |
| 558 and leave them pointing nowhere. */ | |
| 440 | 559 REGISTER Lisp_Marker *m, *next; |
| 428 | 560 for (m = BUF_MARKERS (b); m; m = next) |
| 561 { | |
| 562 m->buffer = 0; | |
| 563 next = marker_next (m); | |
| 564 marker_next (m) = 0; | |
| 565 marker_prev (m) = 0; | |
| 566 } | |
| 567 BUF_MARKERS (b) = 0; | |
| 568 } |