Mercurial > hg > xemacs-beta
annotate src/extents.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 | b0ab9aa48977 |
| children | cf900a2f1fa3 |
| rev | line source |
|---|---|
| 428 | 1 /* Copyright (c) 1994, 1995 Free Software Foundation, Inc. |
| 2 Copyright (c) 1995 Sun Microsystems, Inc. | |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
4976
diff
changeset
|
3 Copyright (c) 1995, 1996, 2000, 2002, 2003, 2004, 2005, 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: Not in FSF. */ | |
| 23 | |
| 24 /* This file has been Mule-ized. */ | |
| 25 | |
| 26 /* Written by Ben Wing <ben@xemacs.org>. | |
| 27 | |
| 28 [Originally written by some people at Lucid. | |
| 29 Hacked on by jwz. | |
| 30 Start/end-open stuff added by John Rose (john.rose@eng.sun.com). | |
| 31 Rewritten from scratch by Ben Wing, December 1994.] */ | |
| 32 | |
| 33 /* Commentary: | |
| 34 | |
| 35 Extents are regions over a buffer, with a start and an end position | |
| 36 denoting the region of the buffer included in the extent. In | |
| 37 addition, either end can be closed or open, meaning that the endpoint | |
| 38 is or is not logically included in the extent. Insertion of a character | |
| 39 at a closed endpoint causes the character to go inside the extent; | |
| 40 insertion at an open endpoint causes the character to go outside. | |
| 41 | |
| 42 Extent endpoints are stored using memory indices (see insdel.c), | |
| 43 to minimize the amount of adjusting that needs to be done when | |
| 44 characters are inserted or deleted. | |
| 45 | |
| 46 (Formerly, extent endpoints at the gap could be either before or | |
| 47 after the gap, depending on the open/closedness of the endpoint. | |
| 48 The intent of this was to make it so that insertions would | |
| 49 automatically go inside or out of extents as necessary with no | |
| 50 further work needing to be done. It didn't work out that way, | |
| 51 however, and just ended up complexifying and buggifying all the | |
| 52 rest of the code.) | |
| 53 | |
| 54 Extents are compared using memory indices. There are two orderings | |
| 55 for extents and both orders are kept current at all times. The normal | |
| 56 or "display" order is as follows: | |
| 57 | |
| 58 Extent A is "less than" extent B, that is, earlier in the display order, | |
| 59 if: A-start < B-start, | |
| 60 or if: A-start = B-start, and A-end > B-end | |
| 61 | |
| 62 So if two extents begin at the same position, the larger of them is the | |
| 63 earlier one in the display order (EXTENT_LESS is true). | |
| 64 | |
| 65 For the e-order, the same thing holds: Extent A is "less than" extent B | |
| 66 in e-order, that is, later in the buffer, | |
| 67 if: A-end < B-end, | |
| 68 or if: A-end = B-end, and A-start > B-start | |
| 69 | |
| 70 So if two extents end at the same position, the smaller of them is the | |
| 71 earlier one in the e-order (EXTENT_E_LESS is true). | |
| 72 | |
| 73 The display order and the e-order are complementary orders: any | |
| 74 theorem about the display order also applies to the e-order if you | |
| 75 swap all occurrences of "display order" and "e-order", "less than" | |
| 76 and "greater than", and "extent start" and "extent end". | |
| 77 | |
| 78 Extents can be zero-length, and will end up that way if their endpoints | |
| 79 are explicitly set that way or if their detachable property is nil | |
| 80 and all the text in the extent is deleted. (The exception is open-open | |
| 81 zero-length extents, which are barred from existing because there is | |
| 82 no sensible way to define their properties. Deletion of the text in | |
| 83 an open-open extent causes it to be converted into a closed-open | |
| 84 extent.) Zero-length extents are primarily used to represent | |
| 85 annotations, and behave as follows: | |
| 86 | |
| 87 1) Insertion at the position of a zero-length extent expands the extent | |
| 88 if both endpoints are closed; goes after the extent if it is closed-open; | |
| 89 and goes before the extent if it is open-closed. | |
| 90 | |
| 91 2) Deletion of a character on a side of a zero-length extent whose | |
| 92 corresponding endpoint is closed causes the extent to be detached if | |
| 93 it is detachable; if the extent is not detachable or the corresponding | |
| 94 endpoint is open, the extent remains in the buffer, moving as necessary. | |
| 95 | |
| 96 Note that closed-open, non-detachable zero-length extents behave exactly | |
| 97 like markers and that open-closed, non-detachable zero-length extents | |
| 98 behave like the "point-type" marker in Mule. | |
| 99 | |
| 100 | |
| 101 #### The following information is wrong in places. | |
| 102 | |
| 103 More about the different orders: | |
| 104 -------------------------------- | |
| 105 | |
| 106 The extents in a buffer are ordered by "display order" because that | |
| 107 is that order that the redisplay mechanism needs to process them in. | |
| 108 The e-order is an auxiliary ordering used to facilitate operations | |
| 109 over extents. The operations that can be performed on the ordered | |
| 110 list of extents in a buffer are | |
| 111 | |
| 112 1) Locate where an extent would go if inserted into the list. | |
| 113 2) Insert an extent into the list. | |
| 114 3) Remove an extent from the list. | |
| 115 4) Map over all the extents that overlap a range. | |
| 116 | |
| 117 (4) requires being able to determine the first and last extents | |
| 118 that overlap a range. | |
| 119 | |
| 120 NOTE: "overlap" is used as follows: | |
| 121 | |
| 122 -- two ranges overlap if they have at least one point in common. | |
| 123 Whether the endpoints are open or closed makes a difference here. | |
| 124 -- a point overlaps a range if the point is contained within the | |
| 125 range; this is equivalent to treating a point P as the range | |
| 126 [P, P]. | |
| 127 -- In the case of an *extent* overlapping a point or range, the | |
| 128 extent is normally treated as having closed endpoints. This | |
| 129 applies consistently in the discussion of stacks of extents | |
| 130 and such below. Note that this definition of overlap is not | |
| 131 necessarily consistent with the extents that `map-extents' | |
| 132 maps over, since `map-extents' sometimes pays attention to | |
| 133 whether the endpoints of an extents are open or closed. | |
| 134 But for our purposes, it greatly simplifies things to treat | |
| 135 all extents as having closed endpoints. | |
| 136 | |
| 137 First, define >, <, <=, etc. as applied to extents to mean | |
| 138 comparison according to the display order. Comparison between an | |
| 139 extent E and an index I means comparison between E and the range | |
| 140 [I, I]. | |
| 141 Also define e>, e<, e<=, etc. to mean comparison according to the | |
| 142 e-order. | |
| 143 For any range R, define R(0) to be the starting index of the range | |
| 144 and R(1) to be the ending index of the range. | |
| 145 For any extent E, define E(next) to be the extent directly following | |
| 146 E, and E(prev) to be the extent directly preceding E. Assume | |
| 147 E(next) and E(prev) can be determined from E in constant time. | |
| 148 (This is because we store the extent list as a doubly linked | |
| 149 list.) | |
| 150 Similarly, define E(e-next) and E(e-prev) to be the extents | |
| 151 directly following and preceding E in the e-order. | |
| 152 | |
| 153 Now: | |
| 154 | |
| 155 Let R be a range. | |
| 156 Let F be the first extent overlapping R. | |
| 157 Let L be the last extent overlapping R. | |
| 158 | |
| 159 Theorem 1: R(1) lies between L and L(next), i.e. L <= R(1) < L(next). | |
| 160 | |
| 161 This follows easily from the definition of display order. The | |
| 162 basic reason that this theorem applies is that the display order | |
| 163 sorts by increasing starting index. | |
| 164 | |
| 165 Therefore, we can determine L just by looking at where we would | |
| 166 insert R(1) into the list, and if we know F and are moving forward | |
| 167 over extents, we can easily determine when we've hit L by comparing | |
| 168 the extent we're at to R(1). | |
| 169 | |
| 170 Theorem 2: F(e-prev) e< [1, R(0)] e<= F. | |
| 171 | |
| 172 This is the analog of Theorem 1, and applies because the e-order | |
| 173 sorts by increasing ending index. | |
| 174 | |
| 175 Therefore, F can be found in the same amount of time as operation (1), | |
| 176 i.e. the time that it takes to locate where an extent would go if | |
| 177 inserted into the e-order list. | |
| 178 | |
| 179 If the lists were stored as balanced binary trees, then operation (1) | |
| 180 would take logarithmic time, which is usually quite fast. However, | |
| 181 currently they're stored as simple doubly-linked lists, and instead | |
| 182 we do some caching to try to speed things up. | |
| 183 | |
| 184 Define a "stack of extents" (or "SOE") as the set of extents | |
| 185 (ordered in the display order) that overlap an index I, together with | |
| 186 the SOE's "previous" extent, which is an extent that precedes I in | |
| 187 the e-order. (Hopefully there will not be very many extents between | |
| 188 I and the previous extent.) | |
| 189 | |
| 190 Now: | |
| 191 | |
| 192 Let I be an index, let S be the stack of extents on I, let F be | |
| 193 the first extent in S, and let P be S's previous extent. | |
| 194 | |
| 195 Theorem 3: The first extent in S is the first extent that overlaps | |
| 196 any range [I, J]. | |
| 197 | |
| 198 Proof: Any extent that overlaps [I, J] but does not include I must | |
| 199 have a start index > I, and thus be greater than any extent in S. | |
| 200 | |
| 201 Therefore, finding the first extent that overlaps a range R is the | |
| 202 same as finding the first extent that overlaps R(0). | |
| 203 | |
| 204 Theorem 4: Let I2 be an index such that I2 > I, and let F2 be the | |
| 205 first extent that overlaps I2. Then, either F2 is in S or F2 is | |
| 206 greater than any extent in S. | |
| 207 | |
| 208 Proof: If F2 does not include I then its start index is greater | |
| 209 than I and thus it is greater than any extent in S, including F. | |
| 210 Otherwise, F2 includes I and thus is in S, and thus F2 >= F. | |
| 211 | |
| 212 */ | |
| 213 | |
| 214 #include <config.h> | |
| 215 #include "lisp.h" | |
| 216 | |
| 217 #include "buffer.h" | |
| 218 #include "debug.h" | |
| 219 #include "device.h" | |
| 220 #include "elhash.h" | |
| 872 | 221 #include "extents-impl.h" |
| 428 | 222 #include "faces.h" |
| 223 #include "frame.h" | |
| 224 #include "glyphs.h" | |
| 225 #include "insdel.h" | |
| 226 #include "keymap.h" | |
| 227 #include "opaque.h" | |
| 228 #include "process.h" | |
| 1292 | 229 #include "profile.h" |
| 428 | 230 #include "redisplay.h" |
| 442 | 231 #include "gutter.h" |
| 428 | 232 |
| 233 /* ------------------------------- */ | |
| 234 /* gap array */ | |
| 235 /* ------------------------------- */ | |
| 236 | |
| 237 /* Note that this object is not extent-specific and should perhaps be | |
| 238 moved into another file. */ | |
| 239 | |
| 240 /* Holds a marker that moves as elements in the array are inserted and | |
| 241 deleted, similar to standard markers. */ | |
| 242 | |
| 243 typedef struct gap_array_marker | |
| 244 { | |
| 3092 | 245 #ifdef NEW_GC |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
246 NORMAL_LISP_OBJECT_HEADER header; |
| 3092 | 247 #endif /* NEW_GC */ |
| 428 | 248 int pos; |
| 249 struct gap_array_marker *next; | |
| 250 } Gap_Array_Marker; | |
| 251 | |
| 1204 | 252 |
| 428 | 253 /* Holds a "gap array", which is an array of elements with a gap located |
| 254 in it. Insertions and deletions with a high degree of locality | |
| 255 are very fast, essentially in constant time. Array positions as | |
| 256 used and returned in the gap array functions are independent of | |
| 257 the gap. */ | |
| 258 | |
| 1204 | 259 /* Layout of gap array: |
| 260 | |
| 261 <------ gap ------><---- gapsize ----><----- numels - gap ----> | |
| 262 <---------------------- numels + gapsize ---------------------> | |
| 263 | |
| 264 For marking purposes, we use two extra variables computed from | |
| 265 the others -- the offset to the data past the gap, plus the number | |
| 266 of elements in that data: | |
| 267 | |
| 268 offset_past_gap = elsize * (gap + gapsize) | |
| 269 els_past_gap = numels - gap | |
| 270 */ | |
| 271 | |
| 272 | |
| 428 | 273 typedef struct gap_array |
| 274 { | |
| 3092 | 275 #ifdef NEW_GC |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
276 NORMAL_LISP_OBJECT_HEADER header; |
| 3092 | 277 #endif /* NEW_GC */ |
| 1204 | 278 Elemcount gap; |
| 279 Elemcount gapsize; | |
| 280 Elemcount numels; | |
| 281 Bytecount elsize; | |
| 282 /* Redundant numbers computed from the others, for marking purposes */ | |
| 283 Bytecount offset_past_gap; | |
| 284 Elemcount els_past_gap; | |
| 428 | 285 Gap_Array_Marker *markers; |
| 1204 | 286 /* this is a stretchy array */ |
| 287 char array[1]; | |
| 428 | 288 } Gap_Array; |
| 289 | |
| 3092 | 290 #ifndef NEW_GC |
| 428 | 291 static Gap_Array_Marker *gap_array_marker_freelist; |
| 3092 | 292 #endif /* not NEW_GC */ |
| 428 | 293 |
| 294 /* Convert a "memory position" (i.e. taking the gap into account) into | |
| 295 the address of the element at (i.e. after) that position. "Memory | |
| 826 | 296 positions" are only used internally and are of type Memxpos. |
| 428 | 297 "Array positions" are used externally and are of type int. */ |
| 298 #define GAP_ARRAY_MEMEL_ADDR(ga, memel) ((ga)->array + (ga)->elsize*(memel)) | |
| 299 | |
| 300 /* Number of elements currently in a gap array */ | |
| 301 #define GAP_ARRAY_NUM_ELS(ga) ((ga)->numels) | |
| 302 | |
| 303 #define GAP_ARRAY_ARRAY_TO_MEMORY_POS(ga, pos) \ | |
| 304 ((pos) <= (ga)->gap ? (pos) : (pos) + (ga)->gapsize) | |
| 305 | |
| 306 #define GAP_ARRAY_MEMORY_TO_ARRAY_POS(ga, pos) \ | |
| 307 ((pos) <= (ga)->gap ? (pos) : (pos) - (ga)->gapsize) | |
| 308 | |
| 309 /* Convert an array position into the address of the element at | |
| 310 (i.e. after) that position. */ | |
| 311 #define GAP_ARRAY_EL_ADDR(ga, pos) ((pos) < (ga)->gap ? \ | |
| 312 GAP_ARRAY_MEMEL_ADDR(ga, pos) : \ | |
| 313 GAP_ARRAY_MEMEL_ADDR(ga, (pos) + (ga)->gapsize)) | |
| 314 | |
| 315 /* ------------------------------- */ | |
| 316 /* extent list */ | |
| 317 /* ------------------------------- */ | |
| 318 | |
| 319 typedef struct extent_list_marker | |
| 320 { | |
| 3092 | 321 #ifdef NEW_GC |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
322 NORMAL_LISP_OBJECT_HEADER header; |
| 3092 | 323 #endif /* NEW_GC */ |
| 428 | 324 Gap_Array_Marker *m; |
| 325 int endp; | |
| 326 struct extent_list_marker *next; | |
| 327 } Extent_List_Marker; | |
| 328 | |
| 329 typedef struct extent_list | |
| 330 { | |
| 3092 | 331 #ifdef NEW_GC |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
332 NORMAL_LISP_OBJECT_HEADER header; |
| 3092 | 333 #endif /* NEW_GC */ |
| 428 | 334 Gap_Array *start; |
| 335 Gap_Array *end; | |
| 336 Extent_List_Marker *markers; | |
| 337 } Extent_List; | |
| 338 | |
| 3092 | 339 #ifndef NEW_GC |
| 428 | 340 static Extent_List_Marker *extent_list_marker_freelist; |
| 3092 | 341 #endif /* not NEW_GC */ |
| 428 | 342 |
| 343 #define EXTENT_LESS_VALS(e,st,nd) ((extent_start (e) < (st)) || \ | |
| 344 ((extent_start (e) == (st)) && \ | |
| 345 (extent_end (e) > (nd)))) | |
| 346 | |
| 347 #define EXTENT_EQUAL_VALS(e,st,nd) ((extent_start (e) == (st)) && \ | |
| 348 (extent_end (e) == (nd))) | |
| 349 | |
| 350 #define EXTENT_LESS_EQUAL_VALS(e,st,nd) ((extent_start (e) < (st)) || \ | |
| 351 ((extent_start (e) == (st)) && \ | |
| 352 (extent_end (e) >= (nd)))) | |
| 353 | |
| 354 /* Is extent E1 less than extent E2 in the display order? */ | |
| 355 #define EXTENT_LESS(e1,e2) \ | |
| 356 EXTENT_LESS_VALS (e1, extent_start (e2), extent_end (e2)) | |
| 357 | |
| 358 /* Is extent E1 equal to extent E2? */ | |
| 359 #define EXTENT_EQUAL(e1,e2) \ | |
| 360 EXTENT_EQUAL_VALS (e1, extent_start (e2), extent_end (e2)) | |
| 361 | |
| 362 /* Is extent E1 less than or equal to extent E2 in the display order? */ | |
| 363 #define EXTENT_LESS_EQUAL(e1,e2) \ | |
| 364 EXTENT_LESS_EQUAL_VALS (e1, extent_start (e2), extent_end (e2)) | |
| 365 | |
| 366 #define EXTENT_E_LESS_VALS(e,st,nd) ((extent_end (e) < (nd)) || \ | |
| 367 ((extent_end (e) == (nd)) && \ | |
| 368 (extent_start (e) > (st)))) | |
| 369 | |
| 370 #define EXTENT_E_LESS_EQUAL_VALS(e,st,nd) ((extent_end (e) < (nd)) || \ | |
| 371 ((extent_end (e) == (nd)) && \ | |
| 372 (extent_start (e) >= (st)))) | |
| 373 | |
| 374 /* Is extent E1 less than extent E2 in the e-order? */ | |
| 375 #define EXTENT_E_LESS(e1,e2) \ | |
| 376 EXTENT_E_LESS_VALS(e1, extent_start (e2), extent_end (e2)) | |
| 377 | |
| 378 /* Is extent E1 less than or equal to extent E2 in the e-order? */ | |
| 379 #define EXTENT_E_LESS_EQUAL(e1,e2) \ | |
| 380 EXTENT_E_LESS_EQUAL_VALS (e1, extent_start (e2), extent_end (e2)) | |
| 381 | |
| 382 #define EXTENT_GAP_ARRAY_AT(ga, pos) (* (EXTENT *) GAP_ARRAY_EL_ADDR(ga, pos)) | |
| 383 | |
| 384 /* ------------------------------- */ | |
| 385 /* buffer-extent primitives */ | |
| 386 /* ------------------------------- */ | |
| 387 | |
| 388 typedef struct stack_of_extents | |
| 389 { | |
| 3092 | 390 #ifdef NEW_GC |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
391 NORMAL_LISP_OBJECT_HEADER header; |
| 3092 | 392 #endif /* NEW_GC */ |
| 428 | 393 Extent_List *extents; |
| 826 | 394 Memxpos pos; /* Position of stack of extents. EXTENTS is the list of |
| 428 | 395 all extents that overlap this position. This position |
| 396 can be -1 if the stack of extents is invalid (this | |
| 397 happens when a buffer is first created or a string's | |
| 398 stack of extents is created [a string's stack of extents | |
| 399 is nuked when a GC occurs, to conserve memory]). */ | |
| 400 } Stack_Of_Extents; | |
| 401 | |
| 402 /* ------------------------------- */ | |
| 403 /* map-extents */ | |
| 404 /* ------------------------------- */ | |
| 405 | |
| 826 | 406 typedef int (*map_extents_fun) (EXTENT extent, void *arg); |
| 407 | |
| 428 | 408 typedef int Endpoint_Index; |
| 409 | |
| 826 | 410 #define memxpos_to_startind(x, start_open) \ |
| 428 | 411 ((Endpoint_Index) (((x) << 1) + !!(start_open))) |
| 826 | 412 #define memxpos_to_endind(x, end_open) \ |
| 428 | 413 ((Endpoint_Index) (((x) << 1) - !!(end_open))) |
| 414 | |
| 415 /* ------------------------------- */ | |
| 416 /* buffer-or-string primitives */ | |
| 417 /* ------------------------------- */ | |
| 418 | |
| 826 | 419 /* Similar for Bytebpos's and start/end indices. */ |
| 420 | |
| 421 #define buffer_or_string_bytexpos_to_startind(obj, ind, start_open) \ | |
| 422 memxpos_to_startind (buffer_or_string_bytexpos_to_memxpos (obj, ind), \ | |
| 428 | 423 start_open) |
| 424 | |
| 826 | 425 #define buffer_or_string_bytexpos_to_endind(obj, ind, end_open) \ |
| 426 memxpos_to_endind (buffer_or_string_bytexpos_to_memxpos (obj, ind), \ | |
| 428 | 427 end_open) |
| 428 | |
| 429 /* ------------------------------- */ | |
| 430 /* Lisp-level functions */ | |
| 431 /* ------------------------------- */ | |
| 432 | |
| 433 /* flags for decode_extent() */ | |
| 434 #define DE_MUST_HAVE_BUFFER 1 | |
| 435 #define DE_MUST_BE_ATTACHED 2 | |
| 436 | |
| 437 Lisp_Object Vlast_highlighted_extent; | |
| 1292 | 438 |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
439 Lisp_Object Vextent_auxiliary_defaults; |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
440 |
| 1292 | 441 Lisp_Object QSin_map_extents_internal; |
| 442 | |
| 458 | 443 Fixnum mouse_highlight_priority; |
| 428 | 444 |
| 445 Lisp_Object Qextentp; | |
| 446 Lisp_Object Qextent_live_p; | |
| 447 | |
| 448 Lisp_Object Qall_extents_closed; | |
| 449 Lisp_Object Qall_extents_open; | |
| 450 Lisp_Object Qall_extents_closed_open; | |
| 451 Lisp_Object Qall_extents_open_closed; | |
| 452 Lisp_Object Qstart_in_region; | |
| 453 Lisp_Object Qend_in_region; | |
| 454 Lisp_Object Qstart_and_end_in_region; | |
| 455 Lisp_Object Qstart_or_end_in_region; | |
| 456 Lisp_Object Qnegate_in_region; | |
| 457 | |
| 458 Lisp_Object Qdetached; | |
| 459 Lisp_Object Qdestroyed; | |
| 460 Lisp_Object Qbegin_glyph; | |
| 461 Lisp_Object Qend_glyph; | |
| 462 Lisp_Object Qstart_open; | |
| 463 Lisp_Object Qend_open; | |
| 464 Lisp_Object Qstart_closed; | |
| 465 Lisp_Object Qend_closed; | |
| 466 Lisp_Object Qread_only; | |
| 467 /* Qhighlight defined in general.c */ | |
| 468 Lisp_Object Qunique; | |
| 469 Lisp_Object Qduplicable; | |
| 470 Lisp_Object Qdetachable; | |
| 471 Lisp_Object Qpriority; | |
| 472 Lisp_Object Qmouse_face; | |
| 473 Lisp_Object Qinitial_redisplay_function; | |
| 474 | |
| 475 Lisp_Object Qglyph_layout; /* This exists only for backwards compatibility. */ | |
| 476 Lisp_Object Qbegin_glyph_layout, Qend_glyph_layout; | |
| 477 Lisp_Object Qoutside_margin; | |
| 478 Lisp_Object Qinside_margin; | |
| 479 Lisp_Object Qwhitespace; | |
| 480 /* Qtext defined in general.c */ | |
| 481 | |
| 482 Lisp_Object Qcopy_function; | |
| 483 Lisp_Object Qpaste_function; | |
| 484 | |
| 485 static Lisp_Object canonicalize_extent_property (Lisp_Object prop, | |
| 486 Lisp_Object value); | |
| 826 | 487 |
| 488 typedef struct | |
| 489 { | |
| 490 Lisp_Object key, value; | |
| 491 } Lisp_Object_pair; | |
| 492 typedef struct | |
| 493 { | |
| 494 Dynarr_declare (Lisp_Object_pair); | |
| 495 } Lisp_Object_pair_dynarr; | |
| 496 | |
| 497 static void extent_properties (EXTENT e, Lisp_Object_pair_dynarr *props); | |
| 498 | |
| 428 | 499 Lisp_Object Vextent_face_memoize_hash_table; |
| 500 Lisp_Object Vextent_face_reverse_memoize_hash_table; | |
| 501 Lisp_Object Vextent_face_reusable_list; | |
| 502 /* FSFmacs bogosity */ | |
| 503 Lisp_Object Vdefault_text_properties; | |
| 504 | |
| 442 | 505 /* if true, we don't want to set any redisplay flags on modeline extent |
| 506 changes */ | |
| 507 int in_modeline_generation; | |
| 508 | |
|
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
|
509 int debug_soe; |
|
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
|
510 |
| 428 | 511 |
| 512 /************************************************************************/ | |
| 513 /* Generalized gap array */ | |
| 514 /************************************************************************/ | |
| 515 | |
| 516 /* This generalizes the "array with a gap" model used to store buffer | |
| 517 characters. This is based on the stuff in insdel.c and should | |
| 518 probably be merged with it. This is not extent-specific and should | |
| 519 perhaps be moved into a separate file. */ | |
| 520 | |
| 521 /* ------------------------------- */ | |
| 522 /* internal functions */ | |
| 523 /* ------------------------------- */ | |
| 524 | |
| 525 /* Adjust the gap array markers in the range (FROM, TO]. Parallel to | |
| 526 adjust_markers() in insdel.c. */ | |
| 527 | |
| 528 static void | |
| 826 | 529 gap_array_adjust_markers (Gap_Array *ga, Memxpos from, |
| 1204 | 530 Memxpos to, Elemcount amount) |
| 428 | 531 { |
| 532 Gap_Array_Marker *m; | |
| 533 | |
| 534 for (m = ga->markers; m; m = m->next) | |
| 535 m->pos = do_marker_adjustment (m->pos, from, to, amount); | |
| 536 } | |
| 537 | |
| 1204 | 538 static void |
| 539 gap_array_recompute_derived_values (Gap_Array *ga) | |
| 540 { | |
| 541 ga->offset_past_gap = ga->elsize * (ga->gap + ga->gapsize); | |
| 542 ga->els_past_gap = ga->numels - ga->gap; | |
| 543 } | |
| 544 | |
| 428 | 545 /* Move the gap to array position POS. Parallel to move_gap() in |
| 546 insdel.c but somewhat simplified. */ | |
| 547 | |
| 548 static void | |
| 1204 | 549 gap_array_move_gap (Gap_Array *ga, Elemcount pos) |
| 550 { | |
| 551 Elemcount gap = ga->gap; | |
| 552 Elemcount gapsize = ga->gapsize; | |
| 553 | |
| 428 | 554 if (pos < gap) |
| 555 { | |
| 556 memmove (GAP_ARRAY_MEMEL_ADDR (ga, pos + gapsize), | |
| 557 GAP_ARRAY_MEMEL_ADDR (ga, pos), | |
| 558 (gap - pos)*ga->elsize); | |
| 826 | 559 gap_array_adjust_markers (ga, (Memxpos) pos, (Memxpos) gap, |
| 428 | 560 gapsize); |
| 561 } | |
| 562 else if (pos > gap) | |
| 563 { | |
| 564 memmove (GAP_ARRAY_MEMEL_ADDR (ga, gap), | |
| 565 GAP_ARRAY_MEMEL_ADDR (ga, gap + gapsize), | |
| 566 (pos - gap)*ga->elsize); | |
| 826 | 567 gap_array_adjust_markers (ga, (Memxpos) (gap + gapsize), |
| 568 (Memxpos) (pos + gapsize), - gapsize); | |
| 428 | 569 } |
| 570 ga->gap = pos; | |
| 1204 | 571 |
| 572 gap_array_recompute_derived_values (ga); | |
| 428 | 573 } |
| 574 | |
| 575 /* Make the gap INCREMENT characters longer. Parallel to make_gap() in | |
| 1204 | 576 insdel.c. The gap array may be moved, so assign the return value back |
| 577 to the array pointer. */ | |
| 578 | |
| 579 static Gap_Array * | |
| 580 gap_array_make_gap (Gap_Array *ga, Elemcount increment) | |
| 581 { | |
| 582 Elemcount real_gap_loc; | |
| 583 Elemcount old_gap_size; | |
| 428 | 584 |
| 585 /* If we have to get more space, get enough to last a while. We use | |
| 586 a geometric progression that saves on realloc space. */ | |
| 587 increment += 100 + ga->numels / 8; | |
| 588 | |
| 3092 | 589 #ifdef NEW_GC |
| 590 ga = (Gap_Array *) mc_realloc (ga, | |
| 591 offsetof (Gap_Array, array) + | |
| 592 (ga->numels + ga->gapsize + increment) * | |
| 593 ga->elsize); | |
| 594 #else /* not NEW_GC */ | |
| 1204 | 595 ga = (Gap_Array *) xrealloc (ga, |
| 596 offsetof (Gap_Array, array) + | |
| 597 (ga->numels + ga->gapsize + increment) * | |
| 598 ga->elsize); | |
| 3092 | 599 #endif /* not NEW_GC */ |
| 1204 | 600 if (ga == 0) |
| 428 | 601 memory_full (); |
| 602 | |
| 603 real_gap_loc = ga->gap; | |
| 604 old_gap_size = ga->gapsize; | |
| 605 | |
| 606 /* Call the newly allocated space a gap at the end of the whole space. */ | |
| 607 ga->gap = ga->numels + ga->gapsize; | |
| 608 ga->gapsize = increment; | |
| 609 | |
| 610 /* Move the new gap down to be consecutive with the end of the old one. | |
| 611 This adjusts the markers properly too. */ | |
| 612 gap_array_move_gap (ga, real_gap_loc + old_gap_size); | |
| 613 | |
| 614 /* Now combine the two into one large gap. */ | |
| 615 ga->gapsize += old_gap_size; | |
| 616 ga->gap = real_gap_loc; | |
| 1204 | 617 |
| 618 gap_array_recompute_derived_values (ga); | |
| 619 | |
| 620 return ga; | |
| 428 | 621 } |
| 622 | |
| 623 /* ------------------------------- */ | |
| 624 /* external functions */ | |
| 625 /* ------------------------------- */ | |
| 626 | |
| 627 /* Insert NUMELS elements (pointed to by ELPTR) into the specified | |
| 1204 | 628 gap array at POS. The gap array may be moved, so assign the |
| 629 return value back to the array pointer. */ | |
| 630 | |
| 631 static Gap_Array * | |
| 632 gap_array_insert_els (Gap_Array *ga, Elemcount pos, void *elptr, | |
| 633 Elemcount numels) | |
| 428 | 634 { |
| 635 assert (pos >= 0 && pos <= ga->numels); | |
| 636 if (ga->gapsize < numels) | |
| 1204 | 637 ga = gap_array_make_gap (ga, numels - ga->gapsize); |
| 428 | 638 if (pos != ga->gap) |
| 639 gap_array_move_gap (ga, pos); | |
| 640 | |
| 641 memcpy (GAP_ARRAY_MEMEL_ADDR (ga, ga->gap), (char *) elptr, | |
| 642 numels*ga->elsize); | |
| 643 ga->gapsize -= numels; | |
| 644 ga->gap += numels; | |
| 645 ga->numels += numels; | |
| 1204 | 646 gap_array_recompute_derived_values (ga); |
| 428 | 647 /* This is the equivalent of insert-before-markers. |
| 648 | |
| 649 #### Should only happen if marker is "moves forward at insert" type. | |
| 650 */ | |
| 651 | |
| 652 gap_array_adjust_markers (ga, pos - 1, pos, numels); | |
| 1204 | 653 return ga; |
| 428 | 654 } |
| 655 | |
| 656 /* Delete NUMELS elements from the specified gap array, starting at FROM. */ | |
| 657 | |
| 658 static void | |
| 1204 | 659 gap_array_delete_els (Gap_Array *ga, Elemcount from, Elemcount numdel) |
| 660 { | |
| 661 Elemcount to = from + numdel; | |
| 662 Elemcount gapsize = ga->gapsize; | |
| 428 | 663 |
| 664 assert (from >= 0); | |
| 665 assert (numdel >= 0); | |
| 666 assert (to <= ga->numels); | |
| 667 | |
| 668 /* Make sure the gap is somewhere in or next to what we are deleting. */ | |
| 669 if (to < ga->gap) | |
| 670 gap_array_move_gap (ga, to); | |
| 671 if (from > ga->gap) | |
| 672 gap_array_move_gap (ga, from); | |
| 673 | |
| 674 /* Relocate all markers pointing into the new, larger gap | |
| 675 to point at the end of the text before the gap. */ | |
| 676 gap_array_adjust_markers (ga, to + gapsize, to + gapsize, | |
| 677 - numdel - gapsize); | |
| 678 | |
| 679 ga->gapsize += numdel; | |
| 680 ga->numels -= numdel; | |
| 681 ga->gap = from; | |
| 1204 | 682 gap_array_recompute_derived_values (ga); |
| 428 | 683 } |
| 684 | |
| 685 static Gap_Array_Marker * | |
| 1204 | 686 gap_array_make_marker (Gap_Array *ga, Elemcount pos) |
| 428 | 687 { |
| 688 Gap_Array_Marker *m; | |
| 689 | |
| 690 assert (pos >= 0 && pos <= ga->numels); | |
| 3092 | 691 #ifdef NEW_GC |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
692 m = XGAP_ARRAY_MARKER (ALLOC_NORMAL_LISP_OBJECT (gap_array_marker)); |
| 3092 | 693 #else /* not NEW_GC */ |
| 428 | 694 if (gap_array_marker_freelist) |
| 695 { | |
| 696 m = gap_array_marker_freelist; | |
| 697 gap_array_marker_freelist = gap_array_marker_freelist->next; | |
| 698 } | |
| 699 else | |
| 700 m = xnew (Gap_Array_Marker); | |
| 3092 | 701 #endif /* not NEW_GC */ |
| 428 | 702 |
| 703 m->pos = GAP_ARRAY_ARRAY_TO_MEMORY_POS (ga, pos); | |
| 704 m->next = ga->markers; | |
| 705 ga->markers = m; | |
| 706 return m; | |
| 707 } | |
| 708 | |
| 709 static void | |
| 710 gap_array_delete_marker (Gap_Array *ga, Gap_Array_Marker *m) | |
| 711 { | |
| 712 Gap_Array_Marker *p, *prev; | |
| 713 | |
| 714 for (prev = 0, p = ga->markers; p && p != m; prev = p, p = p->next) | |
| 715 ; | |
| 716 assert (p); | |
| 717 if (prev) | |
| 718 prev->next = p->next; | |
| 719 else | |
| 720 ga->markers = p->next; | |
| 4117 | 721 #ifndef NEW_GC |
| 428 | 722 m->next = gap_array_marker_freelist; |
| 1204 | 723 m->pos = 0xDEADBEEF; /* -559038737 base 10 */ |
| 428 | 724 gap_array_marker_freelist = m; |
| 3092 | 725 #endif /* not NEW_GC */ |
| 726 } | |
| 727 | |
| 728 #ifndef NEW_GC | |
| 428 | 729 static void |
| 730 gap_array_delete_all_markers (Gap_Array *ga) | |
| 731 { | |
| 732 Gap_Array_Marker *p, *next; | |
| 733 | |
| 734 for (p = ga->markers; p; p = next) | |
| 735 { | |
| 736 next = p->next; | |
| 737 p->next = gap_array_marker_freelist; | |
| 738 p->pos = 0xDEADBEEF; /* -559038737 as an int */ | |
| 739 gap_array_marker_freelist = p; | |
| 740 } | |
| 741 } | |
| 3092 | 742 #endif /* not NEW_GC */ |
| 428 | 743 |
| 744 static void | |
| 1204 | 745 gap_array_move_marker (Gap_Array *ga, Gap_Array_Marker *m, Elemcount pos) |
| 428 | 746 { |
| 747 assert (pos >= 0 && pos <= ga->numels); | |
| 748 m->pos = GAP_ARRAY_ARRAY_TO_MEMORY_POS (ga, pos); | |
| 749 } | |
| 750 | |
| 751 #define gap_array_marker_pos(ga, m) \ | |
| 752 GAP_ARRAY_MEMORY_TO_ARRAY_POS (ga, (m)->pos) | |
| 753 | |
| 754 static Gap_Array * | |
| 1204 | 755 make_gap_array (Elemcount elsize) |
| 428 | 756 { |
| 3092 | 757 #ifdef NEW_GC |
|
5120
d1247f3cc363
latest work on lisp-object workspace;
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
758 Gap_Array *ga = XGAP_ARRAY (ALLOC_SIZED_LISP_OBJECT (sizeof (Gap_Array), |
|
d1247f3cc363
latest work on lisp-object workspace;
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
759 gap_array)); |
| 3092 | 760 #else /* not NEW_GC */ |
| 428 | 761 Gap_Array *ga = xnew_and_zero (Gap_Array); |
| 3092 | 762 #endif /* not NEW_GC */ |
| 428 | 763 ga->elsize = elsize; |
| 764 return ga; | |
| 765 } | |
| 766 | |
| 3092 | 767 #ifndef NEW_GC |
| 428 | 768 static void |
| 769 free_gap_array (Gap_Array *ga) | |
| 770 { | |
| 771 gap_array_delete_all_markers (ga); | |
|
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4967
diff
changeset
|
772 xfree (ga); |
| 428 | 773 } |
| 3092 | 774 #endif /* not NEW_GC */ |
| 428 | 775 |
| 776 | |
| 777 /************************************************************************/ | |
| 778 /* Extent list primitives */ | |
| 779 /************************************************************************/ | |
| 780 | |
| 781 /* A list of extents is maintained as a double gap array: one gap array | |
| 782 is ordered by start index (the "display order") and the other is | |
| 783 ordered by end index (the "e-order"). Note that positions in an | |
| 784 extent list should logically be conceived of as referring *to* | |
| 785 a particular extent (as is the norm in programs) rather than | |
| 786 sitting between two extents. Note also that callers of these | |
| 787 functions should not be aware of the fact that the extent list is | |
| 788 implemented as an array, except for the fact that positions are | |
| 789 integers (this should be generalized to handle integers and linked | |
| 790 list equally well). | |
| 791 */ | |
| 792 | |
| 793 /* Number of elements in an extent list */ | |
| 1204 | 794 #define extent_list_num_els(el) GAP_ARRAY_NUM_ELS (el->start) |
| 428 | 795 |
| 796 /* Return the position at which EXTENT is located in the specified extent | |
| 797 list (in the display order if ENDP is 0, in the e-order otherwise). | |
| 798 If the extent is not found, the position where the extent would | |
| 799 be inserted is returned. If ENDP is 0, the insertion would go after | |
| 800 all other equal extents. If ENDP is not 0, the insertion would go | |
| 801 before all other equal extents. If FOUNDP is not 0, then whether | |
| 802 the extent was found will get written into it. */ | |
| 803 | |
| 804 static int | |
| 805 extent_list_locate (Extent_List *el, EXTENT extent, int endp, int *foundp) | |
| 806 { | |
| 807 Gap_Array *ga = endp ? el->end : el->start; | |
| 808 int left = 0, right = GAP_ARRAY_NUM_ELS (ga); | |
| 809 int oldfoundpos, foundpos; | |
| 810 int found; | |
| 811 | |
| 812 while (left != right) | |
| 813 { | |
| 814 /* RIGHT might not point to a valid extent (i.e. it's at the end | |
| 815 of the list), so NEWPOS must round down. */ | |
| 647 | 816 int newpos = (left + right) >> 1; |
| 428 | 817 EXTENT e = EXTENT_GAP_ARRAY_AT (ga, (int) newpos); |
| 818 | |
| 819 if (endp ? EXTENT_E_LESS (e, extent) : EXTENT_LESS (e, extent)) | |
| 647 | 820 left = newpos + 1; |
| 428 | 821 else |
| 822 right = newpos; | |
| 823 } | |
| 824 | |
| 825 /* Now we're at the beginning of all equal extents. */ | |
| 826 found = 0; | |
| 827 oldfoundpos = foundpos = left; | |
| 828 while (foundpos < GAP_ARRAY_NUM_ELS (ga)) | |
| 829 { | |
| 830 EXTENT e = EXTENT_GAP_ARRAY_AT (ga, foundpos); | |
| 831 if (e == extent) | |
| 832 { | |
| 833 found = 1; | |
| 834 break; | |
| 835 } | |
| 836 if (!EXTENT_EQUAL (e, extent)) | |
| 837 break; | |
| 838 foundpos++; | |
| 839 } | |
| 840 if (foundp) | |
| 841 *foundp = found; | |
| 842 if (found || !endp) | |
| 843 return foundpos; | |
| 844 else | |
| 845 return oldfoundpos; | |
| 846 } | |
| 847 | |
| 848 /* Return the position of the first extent that begins at or after POS | |
| 849 (or ends at or after POS, if ENDP is not 0). | |
| 850 | |
| 851 An out-of-range value for POS is allowed, and guarantees that the | |
| 852 position at the beginning or end of the extent list is returned. */ | |
| 853 | |
| 854 static int | |
| 826 | 855 extent_list_locate_from_pos (Extent_List *el, Memxpos pos, int endp) |
| 428 | 856 { |
| 857 struct extent fake_extent; | |
| 858 /* | |
| 859 | |
| 860 Note that if we search for [POS, POS], then we get the following: | |
| 861 | |
| 862 -- if ENDP is 0, then all extents whose start position is <= POS | |
| 863 lie before the returned position, and all extents whose start | |
| 864 position is > POS lie at or after the returned position. | |
| 865 | |
| 866 -- if ENDP is not 0, then all extents whose end position is < POS | |
| 867 lie before the returned position, and all extents whose end | |
| 868 position is >= POS lie at or after the returned position. | |
| 869 | |
| 870 */ | |
| 871 set_extent_start (&fake_extent, endp ? pos : pos-1); | |
| 872 set_extent_end (&fake_extent, endp ? pos : pos-1); | |
| 873 return extent_list_locate (el, &fake_extent, endp, 0); | |
| 874 } | |
| 875 | |
| 876 /* Return the extent at POS. */ | |
| 877 | |
| 878 static EXTENT | |
| 826 | 879 extent_list_at (Extent_List *el, Memxpos pos, int endp) |
| 428 | 880 { |
| 881 Gap_Array *ga = endp ? el->end : el->start; | |
| 882 | |
| 883 assert (pos >= 0 && pos < GAP_ARRAY_NUM_ELS (ga)); | |
| 884 return EXTENT_GAP_ARRAY_AT (ga, pos); | |
| 885 } | |
| 886 | |
| 887 /* Insert an extent into an extent list. */ | |
| 888 | |
| 889 static void | |
| 890 extent_list_insert (Extent_List *el, EXTENT extent) | |
| 891 { | |
| 892 int pos, foundp; | |
| 893 | |
| 894 pos = extent_list_locate (el, extent, 0, &foundp); | |
| 895 assert (!foundp); | |
| 1204 | 896 el->start = gap_array_insert_els (el->start, pos, &extent, 1); |
| 428 | 897 pos = extent_list_locate (el, extent, 1, &foundp); |
| 898 assert (!foundp); | |
| 1204 | 899 el->end = gap_array_insert_els (el->end, pos, &extent, 1); |
| 428 | 900 } |
| 901 | |
| 902 /* Delete an extent from an extent list. */ | |
| 903 | |
| 904 static void | |
| 905 extent_list_delete (Extent_List *el, EXTENT extent) | |
| 906 { | |
| 907 int pos, foundp; | |
| 908 | |
| 909 pos = extent_list_locate (el, extent, 0, &foundp); | |
| 910 assert (foundp); | |
| 911 gap_array_delete_els (el->start, pos, 1); | |
| 912 pos = extent_list_locate (el, extent, 1, &foundp); | |
| 913 assert (foundp); | |
| 914 gap_array_delete_els (el->end, pos, 1); | |
| 915 } | |
| 916 | |
| 917 static void | |
| 918 extent_list_delete_all (Extent_List *el) | |
| 919 { | |
| 920 gap_array_delete_els (el->start, 0, GAP_ARRAY_NUM_ELS (el->start)); | |
| 921 gap_array_delete_els (el->end, 0, GAP_ARRAY_NUM_ELS (el->end)); | |
| 922 } | |
| 923 | |
| 924 static Extent_List_Marker * | |
| 925 extent_list_make_marker (Extent_List *el, int pos, int endp) | |
| 926 { | |
| 927 Extent_List_Marker *m; | |
| 928 | |
| 3092 | 929 #ifdef NEW_GC |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
930 m = XEXTENT_LIST_MARKER (ALLOC_NORMAL_LISP_OBJECT (extent_list_marker)); |
| 3092 | 931 #else /* not NEW_GC */ |
| 428 | 932 if (extent_list_marker_freelist) |
| 933 { | |
| 934 m = extent_list_marker_freelist; | |
| 935 extent_list_marker_freelist = extent_list_marker_freelist->next; | |
| 936 } | |
| 937 else | |
| 938 m = xnew (Extent_List_Marker); | |
| 3092 | 939 #endif /* not NEW_GC */ |
| 428 | 940 |
| 941 m->m = gap_array_make_marker (endp ? el->end : el->start, pos); | |
| 942 m->endp = endp; | |
| 943 m->next = el->markers; | |
| 944 el->markers = m; | |
| 945 return m; | |
| 946 } | |
| 947 | |
| 948 #define extent_list_move_marker(el, mkr, pos) \ | |
| 949 gap_array_move_marker((mkr)->endp ? (el)->end : (el)->start, (mkr)->m, pos) | |
| 950 | |
| 951 static void | |
| 952 extent_list_delete_marker (Extent_List *el, Extent_List_Marker *m) | |
| 953 { | |
| 954 Extent_List_Marker *p, *prev; | |
| 955 | |
| 956 for (prev = 0, p = el->markers; p && p != m; prev = p, p = p->next) | |
| 957 ; | |
| 958 assert (p); | |
| 959 if (prev) | |
| 960 prev->next = p->next; | |
| 961 else | |
| 962 el->markers = p->next; | |
| 3092 | 963 #ifdef NEW_GC |
| 964 gap_array_delete_marker (m->endp ? el->end : el->start, m->m); | |
| 965 #else /* not NEW_GC */ | |
| 428 | 966 m->next = extent_list_marker_freelist; |
| 967 extent_list_marker_freelist = m; | |
| 968 gap_array_delete_marker (m->endp ? el->end : el->start, m->m); | |
| 3092 | 969 #endif /* not NEW_GC */ |
| 428 | 970 } |
| 971 | |
| 972 #define extent_list_marker_pos(el, mkr) \ | |
| 973 gap_array_marker_pos ((mkr)->endp ? (el)->end : (el)->start, (mkr)->m) | |
| 974 | |
| 975 static Extent_List * | |
| 976 allocate_extent_list (void) | |
| 977 { | |
| 3092 | 978 #ifdef NEW_GC |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
979 Extent_List *el = XEXTENT_LIST (ALLOC_NORMAL_LISP_OBJECT (extent_list)); |
| 3092 | 980 #else /* not NEW_GC */ |
| 428 | 981 Extent_List *el = xnew (Extent_List); |
| 3092 | 982 #endif /* not NEW_GC */ |
| 440 | 983 el->start = make_gap_array (sizeof (EXTENT)); |
| 984 el->end = make_gap_array (sizeof (EXTENT)); | |
| 428 | 985 el->markers = 0; |
| 986 return el; | |
| 987 } | |
| 988 | |
| 3092 | 989 #ifndef NEW_GC |
| 428 | 990 static void |
| 991 free_extent_list (Extent_List *el) | |
| 992 { | |
| 993 free_gap_array (el->start); | |
| 994 free_gap_array (el->end); | |
|
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4967
diff
changeset
|
995 xfree (el); |
| 428 | 996 } |
| 3092 | 997 #endif /* not NEW_GC */ |
| 428 | 998 |
| 999 | |
| 1000 /************************************************************************/ | |
| 1001 /* Auxiliary extent structure */ | |
| 1002 /************************************************************************/ | |
| 1003 | |
| 1204 | 1004 static const struct memory_description extent_auxiliary_description[] ={ |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1005 #define SLOT(x) \ |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1006 { XD_LISP_OBJECT, offsetof (struct extent_auxiliary, x) }, |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1007 EXTENT_AUXILIARY_SLOTS |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1008 #undef SLOT |
| 934 | 1009 { XD_END } |
| 1010 }; | |
| 428 | 1011 static Lisp_Object |
| 1012 mark_extent_auxiliary (Lisp_Object obj) | |
| 1013 { | |
| 1014 struct extent_auxiliary *data = XEXTENT_AUXILIARY (obj); | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1015 #define SLOT(x) mark_object (data->x); |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1016 EXTENT_AUXILIARY_SLOTS |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1017 #undef SLOT |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1018 |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1019 return Qnil; |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1020 } |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1021 |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1022 DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("extent-auxiliary", |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1023 extent_auxiliary, |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1024 mark_extent_auxiliary, |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1025 extent_auxiliary_description, |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1026 struct extent_auxiliary); |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1027 |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1028 |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1029 static Lisp_Object |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1030 allocate_extent_auxiliary (void) |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1031 { |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1032 Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (extent_auxiliary); |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1033 struct extent_auxiliary *data = XEXTENT_AUXILIARY (obj); |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1034 |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1035 #define SLOT(x) data->x = Qnil; |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1036 EXTENT_AUXILIARY_SLOTS |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1037 #undef SLOT |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1038 |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1039 return obj; |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1040 } |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1041 |
| 428 | 1042 void |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1043 attach_extent_auxiliary (EXTENT ext) |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1044 { |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1045 Lisp_Object obj = allocate_extent_auxiliary (); |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1046 |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
1047 ext->plist = Fcons (obj, ext->plist); |
| 428 | 1048 ext->flags.has_aux = 1; |
| 1049 } | |
| 1050 | |
| 1051 | |
| 1052 /************************************************************************/ | |
| 1053 /* Extent info structure */ | |
| 1054 /************************************************************************/ | |
| 1055 | |
| 1056 /* An extent-info structure consists of a list of the buffer or string's | |
| 1057 extents and a "stack of extents" that lists all of the extents over | |
| 1058 a particular position. The stack-of-extents info is used for | |
| 1059 optimization purposes -- it basically caches some info that might | |
| 1060 be expensive to compute. Certain otherwise hard computations are easy | |
| 1061 given the stack of extents over a particular position, and if the | |
| 1062 stack of extents over a nearby position is known (because it was | |
| 1063 calculated at some prior point in time), it's easy to move the stack | |
| 1064 of extents to the proper position. | |
| 1065 | |
| 1066 Given that the stack of extents is an optimization, and given that | |
| 1067 it requires memory, a string's stack of extents is wiped out each | |
| 1068 time a garbage collection occurs. Therefore, any time you retrieve | |
| 1069 the stack of extents, it might not be there. If you need it to | |
| 1070 be there, use the _force version. | |
| 1071 | |
| 1072 Similarly, a string may or may not have an extent_info structure. | |
| 1073 (Generally it won't if there haven't been any extents added to the | |
| 1074 string.) So use the _force version if you need the extent_info | |
| 1075 structure to be there. */ | |
| 1076 | |
| 1077 static struct stack_of_extents *allocate_soe (void); | |
| 3092 | 1078 #ifndef NEW_GC |
| 428 | 1079 static void free_soe (struct stack_of_extents *soe); |
| 3092 | 1080 #endif /* not NEW_GC */ |
| 428 | 1081 static void soe_invalidate (Lisp_Object obj); |
| 1082 | |
| 1204 | 1083 extern const struct sized_memory_description gap_array_marker_description; |
| 1084 | |
| 1085 static const struct memory_description gap_array_marker_description_1[] = { | |
| 3092 | 1086 #ifdef NEW_GC |
| 1087 { XD_LISP_OBJECT, offsetof (Gap_Array_Marker, next) }, | |
| 1088 #else /* not NEW_GC */ | |
| 2367 | 1089 { XD_BLOCK_PTR, offsetof (Gap_Array_Marker, next), 1, |
| 2551 | 1090 { &gap_array_marker_description } }, |
| 3092 | 1091 #endif /* not NEW_GC */ |
| 1204 | 1092 { XD_END } |
| 1093 }; | |
| 1094 | |
| 3092 | 1095 #ifdef NEW_GC |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1096 DEFINE_NODUMP_INTERNAL_LISP_OBJECT ("gap-array-marker", gap_array_marker, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1097 0, gap_array_marker_description_1, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1098 struct gap_array_marker); |
| 3092 | 1099 #else /* not NEW_GC */ |
| 1204 | 1100 const struct sized_memory_description gap_array_marker_description = { |
| 1101 sizeof (Gap_Array_Marker), | |
| 1102 gap_array_marker_description_1 | |
| 934 | 1103 }; |
| 3092 | 1104 #endif /* not NEW_GC */ |
| 934 | 1105 |
| 1204 | 1106 static const struct memory_description lispobj_gap_array_description_1[] = { |
| 2881 | 1107 { XD_ELEMCOUNT, offsetof (Gap_Array, gap) }, |
| 1108 { XD_BYTECOUNT, offsetof (Gap_Array, offset_past_gap) }, | |
| 1109 { XD_ELEMCOUNT, offsetof (Gap_Array, els_past_gap) }, | |
| 3092 | 1110 #ifdef NEW_GC |
| 1111 { XD_LISP_OBJECT, offsetof (Gap_Array, markers) }, | |
| 1112 #else /* not NEW_GC */ | |
| 2367 | 1113 { XD_BLOCK_PTR, offsetof (Gap_Array, markers), 1, |
| 2551 | 1114 { &gap_array_marker_description }, XD_FLAG_NO_KKCC }, |
| 3092 | 1115 #endif /* not NEW_GC */ |
| 2367 | 1116 { XD_BLOCK_ARRAY, offsetof (Gap_Array, array), XD_INDIRECT (0, 0), |
| 2551 | 1117 { &lisp_object_description } }, |
| 2367 | 1118 { XD_BLOCK_ARRAY, XD_INDIRECT (1, offsetof (Gap_Array, array)), |
| 2551 | 1119 XD_INDIRECT (2, 0), { &lisp_object_description } }, |
| 934 | 1120 { XD_END } |
| 1121 }; | |
| 1204 | 1122 |
| 3092 | 1123 #ifdef NEW_GC |
| 1124 | |
| 1125 static Bytecount | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1126 size_gap_array (Lisp_Object obj) |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1127 { |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1128 Gap_Array *ga = XGAP_ARRAY (obj); |
| 3092 | 1129 return offsetof (Gap_Array, array) + (ga->numels + ga->gapsize) * ga->elsize; |
| 1130 } | |
| 1131 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1132 DEFINE_NODUMP_SIZABLE_INTERNAL_LISP_OBJECT ("gap-array", gap_array, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1133 0, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1134 lispobj_gap_array_description_1, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1135 size_gap_array, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1136 struct gap_array); |
| 3092 | 1137 #else /* not NEW_GC */ |
| 1204 | 1138 static const struct sized_memory_description lispobj_gap_array_description = { |
| 1139 sizeof (Gap_Array), | |
| 1140 lispobj_gap_array_description_1 | |
| 1141 }; | |
| 1142 | |
| 1143 extern const struct sized_memory_description extent_list_marker_description; | |
| 3092 | 1144 #endif /* not NEW_GC */ |
| 1204 | 1145 |
| 1146 static const struct memory_description extent_list_marker_description_1[] = { | |
| 3092 | 1147 #ifdef NEW_GC |
| 1148 { XD_LISP_OBJECT, offsetof (Extent_List_Marker, m) }, | |
| 1149 { XD_LISP_OBJECT, offsetof (Extent_List_Marker, next) }, | |
| 1150 #else /* not NEW_GC */ | |
| 2367 | 1151 { XD_BLOCK_PTR, offsetof (Extent_List_Marker, m), 1, |
| 2551 | 1152 { &gap_array_marker_description } }, |
| 2367 | 1153 { XD_BLOCK_PTR, offsetof (Extent_List_Marker, next), 1, |
| 2551 | 1154 { &extent_list_marker_description } }, |
| 3092 | 1155 #endif /* not NEW_GC */ |
| 1204 | 1156 { XD_END } |
| 1157 }; | |
| 1158 | |
| 3092 | 1159 #ifdef NEW_GC |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1160 DEFINE_NODUMP_INTERNAL_LISP_OBJECT ("extent-list-marker", |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1161 extent_list_marker, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1162 0, extent_list_marker_description_1, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1163 struct extent_list_marker); |
| 3092 | 1164 #else /* not NEW_GC */ |
| 1204 | 1165 const struct sized_memory_description extent_list_marker_description = { |
| 1166 sizeof (Extent_List_Marker), | |
| 1167 extent_list_marker_description_1 | |
| 1168 }; | |
| 3092 | 1169 #endif /* not NEW_GC */ |
| 1204 | 1170 |
| 1171 static const struct memory_description extent_list_description_1[] = { | |
| 3092 | 1172 #ifdef NEW_GC |
| 1173 { XD_LISP_OBJECT, offsetof (Extent_List, start) }, | |
| 1174 { XD_LISP_OBJECT, offsetof (Extent_List, end) }, | |
| 1175 { XD_LISP_OBJECT, offsetof (Extent_List, markers) }, | |
| 1176 #else /* not NEW_GC */ | |
| 2551 | 1177 { XD_BLOCK_PTR, offsetof (Extent_List, start), 1, |
| 1178 { &lispobj_gap_array_description } }, | |
| 1179 { XD_BLOCK_PTR, offsetof (Extent_List, end), 1, | |
| 1180 { &lispobj_gap_array_description }, XD_FLAG_NO_KKCC }, | |
| 1181 { XD_BLOCK_PTR, offsetof (Extent_List, markers), 1, | |
| 1182 { &extent_list_marker_description }, XD_FLAG_NO_KKCC }, | |
| 3092 | 1183 #endif /* not NEW_GC */ |
| 1204 | 1184 { XD_END } |
| 1185 }; | |
| 1186 | |
| 3092 | 1187 #ifdef NEW_GC |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1188 DEFINE_NODUMP_INTERNAL_LISP_OBJECT ("extent-list", extent_list, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1189 0, extent_list_description_1, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1190 struct extent_list); |
| 3092 | 1191 #else /* not NEW_GC */ |
| 1204 | 1192 static const struct sized_memory_description extent_list_description = { |
| 1193 sizeof (Extent_List), | |
| 1194 extent_list_description_1 | |
| 1195 }; | |
| 3092 | 1196 #endif /* not NEW_GC */ |
| 1204 | 1197 |
| 1198 static const struct memory_description stack_of_extents_description_1[] = { | |
| 3092 | 1199 #ifdef NEW_GC |
| 1200 { XD_LISP_OBJECT, offsetof (Stack_Of_Extents, extents) }, | |
| 1201 #else /* not NEW_GC */ | |
| 2551 | 1202 { XD_BLOCK_PTR, offsetof (Stack_Of_Extents, extents), 1, |
| 1203 { &extent_list_description } }, | |
| 3092 | 1204 #endif /* not NEW_GC */ |
| 1204 | 1205 { XD_END } |
| 1206 }; | |
| 1207 | |
| 3092 | 1208 #ifdef NEW_GC |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1209 DEFINE_NODUMP_INTERNAL_LISP_OBJECT ("stack-of-extents", stack_of_extents, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1210 0, stack_of_extents_description_1, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1211 struct stack_of_extents); |
| 3092 | 1212 #else /* not NEW_GC */ |
| 1204 | 1213 static const struct sized_memory_description stack_of_extents_description = { |
| 1214 sizeof (Stack_Of_Extents), | |
| 1215 stack_of_extents_description_1 | |
| 1216 }; | |
| 3092 | 1217 #endif /* not NEW_GC */ |
| 1204 | 1218 |
| 1219 static const struct memory_description extent_info_description [] = { | |
| 3092 | 1220 #ifdef NEW_GC |
| 1221 { XD_LISP_OBJECT, offsetof (struct extent_info, extents) }, | |
| 1222 { XD_LISP_OBJECT, offsetof (struct extent_info, soe) }, | |
| 1223 #else /* not NEW_GC */ | |
| 2367 | 1224 { XD_BLOCK_PTR, offsetof (struct extent_info, extents), 1, |
| 2551 | 1225 { &extent_list_description } }, |
| 2367 | 1226 { XD_BLOCK_PTR, offsetof (struct extent_info, soe), 1, |
| 2551 | 1227 { &stack_of_extents_description }, XD_FLAG_NO_KKCC }, |
| 3092 | 1228 #endif /* not NEW_GC */ |
| 1204 | 1229 { XD_END } |
| 1230 }; | |
| 934 | 1231 |
| 428 | 1232 static Lisp_Object |
| 1233 mark_extent_info (Lisp_Object obj) | |
| 1234 { | |
| 1235 struct extent_info *data = (struct extent_info *) XEXTENT_INFO (obj); | |
| 1236 int i; | |
| 1237 Extent_List *list = data->extents; | |
| 1238 | |
| 1239 /* Vbuffer_defaults and Vbuffer_local_symbols are buffer-like | |
| 1240 objects that are created specially and never have their extent | |
| 1241 list initialized (or rather, it is set to zero in | |
| 1242 nuke_all_buffer_slots()). However, these objects get | |
| 1243 garbage-collected so we have to deal. | |
| 1244 | |
| 1245 (Also the list can be zero when we're dealing with a destroyed | |
| 1246 buffer.) */ | |
| 1247 | |
| 1248 if (list) | |
| 1249 { | |
| 1250 for (i = 0; i < extent_list_num_els (list); i++) | |
| 1251 { | |
| 1252 struct extent *extent = extent_list_at (list, i, 0); | |
| 793 | 1253 Lisp_Object exobj = wrap_extent (extent); |
| 1254 | |
| 428 | 1255 mark_object (exobj); |
| 1256 } | |
| 1257 } | |
| 1258 | |
| 1259 return Qnil; | |
| 1260 } | |
| 1261 | |
| 3263 | 1262 #ifdef NEW_GC |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1263 DEFINE_NODUMP_INTERNAL_LISP_OBJECT ("extent-info", extent_info, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1264 mark_extent_info, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1265 extent_info_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1266 struct extent_info); |
| 3263 | 1267 #else /* not NEW_GC */ |
| 428 | 1268 static void |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1269 finalize_extent_info (Lisp_Object obj) |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1270 { |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1271 struct extent_info *data = XEXTENT_INFO (obj); |
| 428 | 1272 |
| 3092 | 1273 data->soe = 0; |
| 1274 data->extents = 0; | |
| 428 | 1275 if (data->soe) |
| 1276 { | |
| 1277 free_soe (data->soe); | |
| 1278 data->soe = 0; | |
| 1279 } | |
| 1280 if (data->extents) | |
| 1281 { | |
| 1282 free_extent_list (data->extents); | |
| 1283 data->extents = 0; | |
| 1284 } | |
| 1285 } | |
| 1286 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1287 DEFINE_NODUMP_LISP_OBJECT ("extent-info", extent_info, |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
1288 mark_extent_info, internal_object_printer, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
1289 finalize_extent_info, 0, 0, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
1290 extent_info_description, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
1291 struct extent_info); |
| 3263 | 1292 #endif /* not NEW_GC */ |
| 428 | 1293 |
| 1294 static Lisp_Object | |
| 1295 allocate_extent_info (void) | |
| 1296 { | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1297 Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (extent_info); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
1298 struct extent_info *data = XEXTENT_INFO (obj); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
1299 |
| 428 | 1300 data->extents = allocate_extent_list (); |
| 1301 data->soe = 0; | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
1302 return obj; |
| 428 | 1303 } |
| 1304 | |
| 1305 void | |
| 1306 flush_cached_extent_info (Lisp_Object extent_info) | |
| 1307 { | |
| 1308 struct extent_info *data = XEXTENT_INFO (extent_info); | |
| 1309 | |
| 1310 if (data->soe) | |
| 1311 { | |
| 3092 | 1312 #ifndef NEW_GC |
| 428 | 1313 free_soe (data->soe); |
| 3092 | 1314 #endif /* not NEW_GC */ |
| 428 | 1315 data->soe = 0; |
| 1316 } | |
| 1317 } | |
| 1318 | |
| 1319 | |
| 1320 /************************************************************************/ | |
| 1321 /* Buffer/string extent primitives */ | |
| 1322 /************************************************************************/ | |
| 1323 | |
| 1324 /* The functions in this section are the ONLY ones that should know | |
| 1325 about the internal implementation of the extent lists. Other functions | |
| 1326 should only know that there are two orderings on extents, the "display" | |
| 1327 order (sorted by start position, basically) and the e-order (sorted | |
| 1328 by end position, basically), and that certain operations are provided | |
| 1329 to manipulate the list. */ | |
| 1330 | |
| 1331 /* ------------------------------- */ | |
| 1332 /* basic primitives */ | |
| 1333 /* ------------------------------- */ | |
| 1334 | |
| 1335 static Lisp_Object | |
| 1336 decode_buffer_or_string (Lisp_Object object) | |
| 1337 { | |
| 1338 if (NILP (object)) | |
| 793 | 1339 object = wrap_buffer (current_buffer); |
| 428 | 1340 else if (BUFFERP (object)) |
| 1341 CHECK_LIVE_BUFFER (object); | |
| 1342 else if (STRINGP (object)) | |
| 1343 ; | |
| 1344 else | |
| 1345 dead_wrong_type_argument (Qbuffer_or_string_p, object); | |
| 1346 | |
| 1347 return object; | |
| 1348 } | |
| 1349 | |
| 1350 EXTENT | |
| 1351 extent_ancestor_1 (EXTENT e) | |
| 1352 { | |
| 1353 while (e->flags.has_parent) | |
| 1354 { | |
| 1355 /* There should be no circularities except in case of a logic | |
| 1356 error somewhere in the extent code */ | |
| 1357 e = XEXTENT (XEXTENT_AUXILIARY (XCAR (e->plist))->parent); | |
| 1358 } | |
| 1359 return e; | |
| 1360 } | |
| 1361 | |
| 1362 /* Given an extent object (string or buffer or nil), return its extent info. | |
| 1363 This may be 0 for a string. */ | |
| 1364 | |
| 1365 static struct extent_info * | |
| 1366 buffer_or_string_extent_info (Lisp_Object object) | |
| 1367 { | |
| 1368 if (STRINGP (object)) | |
| 1369 { | |
| 793 | 1370 Lisp_Object plist = XSTRING_PLIST (object); |
| 428 | 1371 if (!CONSP (plist) || !EXTENT_INFOP (XCAR (plist))) |
| 1372 return 0; | |
| 1373 return XEXTENT_INFO (XCAR (plist)); | |
| 1374 } | |
| 1375 else if (NILP (object)) | |
| 1376 return 0; | |
| 1377 else | |
| 1378 return XEXTENT_INFO (XBUFFER (object)->extent_info); | |
| 1379 } | |
| 1380 | |
| 1381 /* Given a string or buffer, return its extent list. This may be | |
| 1382 0 for a string. */ | |
| 1383 | |
| 1384 static Extent_List * | |
| 1385 buffer_or_string_extent_list (Lisp_Object object) | |
| 1386 { | |
| 1387 struct extent_info *info = buffer_or_string_extent_info (object); | |
| 1388 | |
| 1389 if (!info) | |
| 1390 return 0; | |
| 1391 return info->extents; | |
| 1392 } | |
| 1393 | |
| 1394 /* Given a string or buffer, return its extent info. If it's not there, | |
| 1395 create it. */ | |
| 1396 | |
| 1397 static struct extent_info * | |
| 1398 buffer_or_string_extent_info_force (Lisp_Object object) | |
| 1399 { | |
| 1400 struct extent_info *info = buffer_or_string_extent_info (object); | |
| 1401 | |
| 1402 if (!info) | |
| 1403 { | |
| 1404 Lisp_Object extent_info; | |
| 1405 | |
| 1406 assert (STRINGP (object)); /* should never happen for buffers -- | |
| 1407 the only buffers without an extent | |
| 1408 info are those after finalization, | |
| 1409 destroyed buffers, or special | |
| 1410 Lisp-inaccessible buffer objects. */ | |
| 1411 extent_info = allocate_extent_info (); | |
| 793 | 1412 XSTRING_PLIST (object) = Fcons (extent_info, XSTRING_PLIST (object)); |
| 428 | 1413 return XEXTENT_INFO (extent_info); |
| 1414 } | |
| 1415 | |
| 1416 return info; | |
| 1417 } | |
| 1418 | |
| 1419 /* Detach all the extents in OBJECT. Called from redisplay. */ | |
| 1420 | |
| 1421 void | |
| 1422 detach_all_extents (Lisp_Object object) | |
| 1423 { | |
| 1424 struct extent_info *data = buffer_or_string_extent_info (object); | |
| 1425 | |
| 1426 if (data) | |
| 1427 { | |
| 1428 if (data->extents) | |
| 1429 { | |
| 1430 int i; | |
| 1431 | |
| 1432 for (i = 0; i < extent_list_num_els (data->extents); i++) | |
| 1433 { | |
| 1434 EXTENT e = extent_list_at (data->extents, i, 0); | |
| 1435 /* No need to do detach_extent(). Just nuke the damn things, | |
| 1436 which results in the equivalent but faster. */ | |
| 1437 set_extent_start (e, -1); | |
| 1438 set_extent_end (e, -1); | |
| 1439 } | |
| 3466 | 1440 |
| 1441 /* But we need to clear all the lists containing extents or | |
| 1442 havoc will result. */ | |
| 1443 extent_list_delete_all (data->extents); | |
| 428 | 1444 } |
| 1445 soe_invalidate (object); | |
| 1446 } | |
| 1447 } | |
| 1448 | |
| 1449 | |
| 1450 void | |
| 1451 init_buffer_extents (struct buffer *b) | |
| 1452 { | |
| 1453 b->extent_info = allocate_extent_info (); | |
| 1454 } | |
| 1455 | |
| 1456 void | |
| 1457 uninit_buffer_extents (struct buffer *b) | |
| 1458 { | |
| 1459 /* Don't destroy the extents here -- there may still be children | |
| 1460 extents pointing to the extents. */ | |
| 771 | 1461 detach_all_extents (wrap_buffer (b)); |
| 3092 | 1462 #ifndef NEW_GC |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1463 finalize_extent_info (b->extent_info); |
| 3092 | 1464 #endif /* not NEW_GC */ |
| 428 | 1465 } |
| 1466 | |
| 1467 /* Retrieve the extent list that an extent is a member of; the | |
| 1468 return value will never be 0 except in destroyed buffers (in which | |
| 1469 case the only extents that can refer to this buffer are detached | |
| 1470 ones). */ | |
| 1471 | |
| 1472 #define extent_extent_list(e) buffer_or_string_extent_list (extent_object (e)) | |
| 1473 | |
| 1474 /* ------------------------------- */ | |
| 1475 /* stack of extents */ | |
| 1476 /* ------------------------------- */ | |
| 1477 | |
| 1478 #ifdef ERROR_CHECK_EXTENTS | |
| 1479 | |
| 771 | 1480 /* See unicode.c for more about sledgehammer checks */ |
| 1481 | |
| 428 | 1482 void |
| 1483 sledgehammer_extent_check (Lisp_Object object) | |
| 1484 { | |
| 1485 int i; | |
| 1486 int endp; | |
| 1487 Extent_List *el = buffer_or_string_extent_list (object); | |
| 1488 struct buffer *buf = 0; | |
| 1489 | |
| 1490 if (!el) | |
| 1491 return; | |
| 1492 | |
| 1493 if (BUFFERP (object)) | |
| 1494 buf = XBUFFER (object); | |
| 1495 | |
| 1496 for (endp = 0; endp < 2; endp++) | |
| 1497 for (i = 1; i < extent_list_num_els (el); i++) | |
| 1498 { | |
| 1499 EXTENT e1 = extent_list_at (el, i-1, endp); | |
| 1500 EXTENT e2 = extent_list_at (el, i, endp); | |
| 1501 if (buf) | |
| 1502 { | |
| 1503 assert (extent_start (e1) <= buf->text->gpt || | |
| 1504 extent_start (e1) > buf->text->gpt + buf->text->gap_size); | |
| 1505 assert (extent_end (e1) <= buf->text->gpt || | |
| 1506 extent_end (e1) > buf->text->gpt + buf->text->gap_size); | |
| 1507 } | |
| 1508 assert (extent_start (e1) <= extent_end (e1)); | |
| 1509 assert (endp ? (EXTENT_E_LESS_EQUAL (e1, e2)) : | |
| 1510 (EXTENT_LESS_EQUAL (e1, e2))); | |
| 1511 } | |
| 1512 } | |
| 1513 | |
| 1514 #endif | |
| 1515 | |
| 1516 static Stack_Of_Extents * | |
| 1517 buffer_or_string_stack_of_extents (Lisp_Object object) | |
| 1518 { | |
| 1519 struct extent_info *info = buffer_or_string_extent_info (object); | |
| 1520 if (!info) | |
| 1521 return 0; | |
| 1522 return info->soe; | |
| 1523 } | |
| 1524 | |
| 1525 static Stack_Of_Extents * | |
| 1526 buffer_or_string_stack_of_extents_force (Lisp_Object object) | |
| 1527 { | |
| 1528 struct extent_info *info = buffer_or_string_extent_info_force (object); | |
| 1529 if (!info->soe) | |
| 1530 info->soe = allocate_soe (); | |
| 1531 return info->soe; | |
| 1532 } | |
| 1533 | |
|
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
|
1534 #ifdef DEBUG_XEMACS |
| 428 | 1535 |
| 1536 static void | |
| 1537 soe_dump (Lisp_Object obj) | |
| 1538 { | |
| 1539 int i; | |
| 1540 Stack_Of_Extents *soe = buffer_or_string_stack_of_extents (obj); | |
| 1541 Extent_List *sel; | |
| 1542 int endp; | |
| 1543 | |
| 1544 if (!soe) | |
| 1545 { | |
|
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
|
1546 stderr_out ("No SOE"); |
| 428 | 1547 return; |
| 1548 } | |
| 1549 sel = soe->extents; | |
|
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
|
1550 stderr_out ("SOE pos is %ld (memxpos %ld)\n", |
|
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
|
1551 soe->pos < 0 ? soe->pos : |
|
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
|
1552 buffer_or_string_memxpos_to_bytexpos (obj, soe->pos), |
|
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
|
1553 soe->pos); |
| 428 | 1554 for (endp = 0; endp < 2; endp++) |
| 1555 { | |
|
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
|
1556 stderr_out (endp ? "SOE end:" : "SOE start:"); |
| 428 | 1557 for (i = 0; i < extent_list_num_els (sel); i++) |
| 1558 { | |
| 1559 EXTENT e = extent_list_at (sel, i, endp); | |
|
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
|
1560 stderr_out ("\t"); |
|
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
|
1561 debug_print (wrap_extent (e)); |
| 428 | 1562 } |
|
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
|
1563 stderr_out ("\n"); |
|
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
|
1564 } |
|
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
|
1565 stderr_out ("\n"); |
|
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
|
1566 } |
|
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
|
1567 |
|
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
|
1568 #endif /* DEBUG_XEMACS */ |
| 428 | 1569 |
| 1570 /* Insert EXTENT into OBJ's stack of extents, if necessary. */ | |
| 1571 | |
| 1572 static void | |
| 1573 soe_insert (Lisp_Object obj, EXTENT extent) | |
| 1574 { | |
| 1575 Stack_Of_Extents *soe = buffer_or_string_stack_of_extents (obj); | |
| 1576 | |
|
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
|
1577 #ifdef DEBUG_XEMACS |
|
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
|
1578 if (debug_soe) |
|
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
|
1579 { |
|
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
|
1580 stderr_out ("Inserting into SOE: "); |
|
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
|
1581 debug_print (wrap_extent (extent)); |
|
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
|
1582 stderr_out ("\n"); |
|
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
|
1583 } |
| 428 | 1584 #endif |
| 1585 if (!soe || soe->pos < extent_start (extent) || | |
| 1586 soe->pos > extent_end (extent)) | |
| 1587 { | |
|
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
|
1588 #ifdef DEBUG_XEMACS |
|
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
|
1589 if (debug_soe) |
|
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
|
1590 stderr_out ("(not needed)\n\n"); |
| 428 | 1591 #endif |
| 1592 return; | |
| 1593 } | |
| 1594 extent_list_insert (soe->extents, extent); | |
|
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
|
1595 #ifdef DEBUG_XEMACS |
|
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
|
1596 if (debug_soe) |
|
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
|
1597 { |
|
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
|
1598 stderr_out ("SOE afterwards is:\n"); |
|
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
|
1599 soe_dump (obj); |
|
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
|
1600 } |
| 428 | 1601 #endif |
| 1602 } | |
| 1603 | |
| 1604 /* Delete EXTENT from OBJ's stack of extents, if necessary. */ | |
| 1605 | |
| 1606 static void | |
| 1607 soe_delete (Lisp_Object obj, EXTENT extent) | |
| 1608 { | |
| 1609 Stack_Of_Extents *soe = buffer_or_string_stack_of_extents (obj); | |
| 1610 | |
|
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
|
1611 #ifdef DEBUG_XEMACS |
|
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
|
1612 if (debug_soe) |
|
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
|
1613 { |
|
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
|
1614 stderr_out ("Deleting from SOE: "); |
|
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
|
1615 debug_print (wrap_extent (extent)); |
|
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
|
1616 stderr_out ("\n"); |
|
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
|
1617 } |
| 428 | 1618 #endif |
| 1619 if (!soe || soe->pos < extent_start (extent) || | |
| 1620 soe->pos > extent_end (extent)) | |
| 1621 { | |
|
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
|
1622 #ifdef DEBUG_XEMACS |
|
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
|
1623 if (debug_soe) |
|
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
|
1624 stderr_out ("(not needed)\n\n"); |
| 428 | 1625 #endif |
| 1626 return; | |
| 1627 } | |
| 1628 extent_list_delete (soe->extents, extent); | |
|
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
|
1629 #ifdef DEBUG_XEMACS |
|
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
|
1630 if (debug_soe) |
|
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
|
1631 { |
|
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
|
1632 stderr_out ("SOE afterwards is:\n"); |
|
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
|
1633 soe_dump (obj); |
|
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
|
1634 } |
| 428 | 1635 #endif |
| 1636 } | |
| 1637 | |
| 1638 /* Move OBJ's stack of extents to lie over the specified position. */ | |
| 1639 | |
| 1640 static void | |
| 826 | 1641 soe_move (Lisp_Object obj, Memxpos pos) |
| 428 | 1642 { |
| 1643 Stack_Of_Extents *soe = buffer_or_string_stack_of_extents_force (obj); | |
| 1644 Extent_List *sel = soe->extents; | |
| 1645 int numsoe = extent_list_num_els (sel); | |
| 1646 Extent_List *bel = buffer_or_string_extent_list (obj); | |
| 1647 int direction; | |
| 1648 int endp; | |
| 1649 | |
| 1650 #ifdef ERROR_CHECK_EXTENTS | |
| 1651 assert (bel); | |
| 1652 #endif | |
| 1653 | |
|
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
|
1654 #ifdef DEBUG_XEMACS |
|
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
|
1655 if (debug_soe) |
|
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
|
1656 stderr_out ("Moving SOE from %ld (memxpos %ld) to %ld (memxpos %ld)\n", |
|
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
|
1657 soe->pos < 0 ? soe->pos : |
|
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
|
1658 buffer_or_string_memxpos_to_bytexpos (obj, soe->pos), soe->pos, |
|
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
|
1659 buffer_or_string_memxpos_to_bytexpos (obj, pos), pos); |
| 428 | 1660 #endif |
| 1661 if (soe->pos < pos) | |
| 1662 { | |
| 1663 direction = 1; | |
| 1664 endp = 0; | |
| 1665 } | |
| 1666 else if (soe->pos > pos) | |
| 1667 { | |
| 1668 direction = -1; | |
| 1669 endp = 1; | |
| 1670 } | |
| 1671 else | |
| 1672 { | |
|
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
|
1673 #ifdef DEBUG_XEMACS |
|
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
|
1674 if (debug_soe) |
|
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
|
1675 stderr_out ("(not needed)\n\n"); |
| 428 | 1676 #endif |
| 1677 return; | |
| 1678 } | |
| 1679 | |
| 1680 /* For DIRECTION = 1: Any extent that overlaps POS is either in the | |
| 1681 SOE (if the extent starts at or before SOE->POS) or is greater | |
| 1682 (in the display order) than any extent in the SOE (if it starts | |
| 1683 after SOE->POS). | |
| 1684 | |
| 1685 For DIRECTION = -1: Any extent that overlaps POS is either in the | |
| 1686 SOE (if the extent ends at or after SOE->POS) or is less (in the | |
| 1687 e-order) than any extent in the SOE (if it ends before SOE->POS). | |
| 1688 | |
| 1689 We proceed in two stages: | |
| 1690 | |
| 1691 1) delete all extents in the SOE that don't overlap POS. | |
| 1692 2) insert all extents into the SOE that start (or end, when | |
| 1693 DIRECTION = -1) in (SOE->POS, POS] and that overlap | |
| 1694 POS. (Don't include SOE->POS in the range because those | |
| 1695 extents would already be in the SOE.) | |
| 1696 */ | |
| 1697 | |
| 1698 /* STAGE 1. */ | |
| 1699 | |
| 1700 if (numsoe > 0) | |
| 1701 { | |
| 1702 /* Delete all extents in the SOE that don't overlap POS. | |
| 1703 This is all extents that end before (or start after, | |
| 1704 if DIRECTION = -1) POS. | |
| 1705 */ | |
| 1706 | |
| 1707 /* Deleting extents from the SOE is tricky because it changes | |
| 1708 the positions of extents. If we are deleting in the forward | |
| 1709 direction we have to call extent_list_at() on the same position | |
| 1710 over and over again because positions after the deleted element | |
| 1711 get shifted back by 1. To make life simplest, we delete forward | |
| 1712 irrespective of DIRECTION. | |
| 1713 */ | |
| 1714 int start, end; | |
| 1715 int i; | |
| 1716 | |
| 1717 if (direction > 0) | |
| 1718 { | |
| 1719 start = 0; | |
| 1720 end = extent_list_locate_from_pos (sel, pos, 1); | |
| 1721 } | |
| 1722 else | |
| 1723 { | |
| 1724 start = extent_list_locate_from_pos (sel, pos+1, 0); | |
| 1725 end = numsoe; | |
| 1726 } | |
| 1727 | |
| 1728 for (i = start; i < end; i++) | |
| 1729 extent_list_delete (sel, extent_list_at (sel, start /* see above */, | |
| 1730 !endp)); | |
| 1731 } | |
| 1732 | |
| 1733 /* STAGE 2. */ | |
| 1734 | |
| 1735 { | |
| 1736 int start_pos; | |
| 1737 | |
| 1738 if (direction < 0) | |
| 1739 start_pos = extent_list_locate_from_pos (bel, soe->pos, endp) - 1; | |
| 1740 else | |
| 1741 start_pos = extent_list_locate_from_pos (bel, soe->pos + 1, endp); | |
| 1742 | |
| 1743 for (; start_pos >= 0 && start_pos < extent_list_num_els (bel); | |
| 1744 start_pos += direction) | |
| 1745 { | |
| 1746 EXTENT e = extent_list_at (bel, start_pos, endp); | |
| 1747 if ((direction > 0) ? | |
| 1748 (extent_start (e) > pos) : | |
| 1749 (extent_end (e) < pos)) | |
| 1750 break; /* All further extents lie on the far side of POS | |
| 1751 and thus can't overlap. */ | |
| 1752 if ((direction > 0) ? | |
| 1753 (extent_end (e) >= pos) : | |
| 1754 (extent_start (e) <= pos)) | |
| 1755 extent_list_insert (sel, e); | |
| 1756 } | |
| 1757 } | |
| 1758 | |
| 1759 soe->pos = pos; | |
|
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
|
1760 #ifdef DEBUG_XEMACS |
|
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
|
1761 if (debug_soe) |
|
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
|
1762 { |
|
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
|
1763 stderr_out ("SOE afterwards is:\n"); |
|
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
|
1764 soe_dump (obj); |
|
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
|
1765 } |
| 428 | 1766 #endif |
| 1767 } | |
| 1768 | |
| 1769 static void | |
| 1770 soe_invalidate (Lisp_Object obj) | |
| 1771 { | |
| 1772 Stack_Of_Extents *soe = buffer_or_string_stack_of_extents (obj); | |
| 1773 | |
| 1774 if (soe) | |
| 1775 { | |
| 1776 extent_list_delete_all (soe->extents); | |
| 1777 soe->pos = -1; | |
| 1778 } | |
| 1779 } | |
| 1780 | |
| 1781 static struct stack_of_extents * | |
| 1782 allocate_soe (void) | |
| 1783 { | |
| 3092 | 1784 #ifdef NEW_GC |
|
5120
d1247f3cc363
latest work on lisp-object workspace;
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
1785 struct stack_of_extents *soe = |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1786 XSTACK_OF_EXTENTS (ALLOC_NORMAL_LISP_OBJECT (stack_of_extents)); |
| 3092 | 1787 #else /* not NEW_GC */ |
| 428 | 1788 struct stack_of_extents *soe = xnew_and_zero (struct stack_of_extents); |
| 3092 | 1789 #endif /* not NEW_GC */ |
| 428 | 1790 soe->extents = allocate_extent_list (); |
| 1791 soe->pos = -1; | |
| 1792 return soe; | |
| 1793 } | |
| 1794 | |
| 3092 | 1795 #ifndef NEW_GC |
| 428 | 1796 static void |
| 1797 free_soe (struct stack_of_extents *soe) | |
| 1798 { | |
| 1799 free_extent_list (soe->extents); | |
|
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4967
diff
changeset
|
1800 xfree (soe); |
| 428 | 1801 } |
| 3092 | 1802 #endif /* not NEW_GC */ |
| 428 | 1803 |
| 1804 /* ------------------------------- */ | |
| 1805 /* other primitives */ | |
| 1806 /* ------------------------------- */ | |
| 1807 | |
| 1808 /* Return the start (endp == 0) or end (endp == 1) of an extent as | |
| 1809 a byte index. If you want the value as a memory index, use | |
| 1810 extent_endpoint(). If you want the value as a buffer position, | |
| 826 | 1811 use extent_endpoint_char(). */ |
| 1812 | |
| 1813 Bytexpos | |
| 1814 extent_endpoint_byte (EXTENT extent, int endp) | |
| 1815 { | |
| 1816 assert (EXTENT_LIVE_P (extent)); | |
| 1817 assert (!extent_detached_p (extent)); | |
| 1818 { | |
| 1819 Memxpos i = endp ? extent_end (extent) : extent_start (extent); | |
| 1820 Lisp_Object obj = extent_object (extent); | |
| 1821 return buffer_or_string_memxpos_to_bytexpos (obj, i); | |
| 1822 } | |
| 1823 } | |
| 1824 | |
| 1825 Charxpos | |
| 1826 extent_endpoint_char (EXTENT extent, int endp) | |
| 428 | 1827 { |
| 1828 assert (EXTENT_LIVE_P (extent)); | |
| 1829 assert (!extent_detached_p (extent)); | |
| 1830 { | |
| 826 | 1831 Memxpos i = endp ? extent_end (extent) : extent_start (extent); |
| 428 | 1832 Lisp_Object obj = extent_object (extent); |
| 826 | 1833 return buffer_or_string_memxpos_to_charxpos (obj, i); |
| 428 | 1834 } |
| 1835 } | |
| 1836 | |
| 1837 static void | |
| 826 | 1838 signal_single_extent_changed (EXTENT extent, Lisp_Object property, |
| 2286 | 1839 Bytexpos UNUSED (old_start), |
| 1840 Bytexpos UNUSED (old_end)) | |
| 826 | 1841 { |
| 1842 EXTENT anc = extent_ancestor (extent); | |
| 1843 /* Redisplay checks */ | |
| 1844 if (NILP (property) ? | |
| 1845 (!NILP (extent_face (anc)) || | |
| 1846 !NILP (extent_begin_glyph (anc)) || | |
| 1847 !NILP (extent_end_glyph (anc)) || | |
| 1848 !NILP (extent_mouse_face (anc)) || | |
| 1849 !NILP (extent_invisible (anc)) || | |
| 1850 !NILP (extent_initial_redisplay_function (anc))) : | |
| 1851 EQ (property, Qface) || | |
| 1852 EQ (property, Qmouse_face) || | |
| 1853 EQ (property, Qbegin_glyph) || | |
| 1854 EQ (property, Qend_glyph) || | |
| 1855 EQ (property, Qbegin_glyph_layout) || | |
| 1856 EQ (property, Qend_glyph_layout) || | |
| 1857 EQ (property, Qinvisible) || | |
| 1858 EQ (property, Qinitial_redisplay_function) || | |
| 1859 EQ (property, Qpriority)) | |
| 1860 { | |
| 1861 Lisp_Object object = extent_object (extent); | |
| 1862 | |
| 1863 if (extent_detached_p (extent)) | |
| 1864 return; | |
| 1865 | |
| 1866 else if (STRINGP (object)) | |
| 1867 { | |
| 1868 /* #### Changes to string extents can affect redisplay if they are | |
| 1869 in the modeline or in the gutters. | |
| 1870 | |
| 1871 If the extent is in some generated-modeline-string: when we | |
| 1872 change an extent in generated-modeline-string, this changes its | |
| 1873 parent, which is in `modeline-format', so we should force the | |
| 1874 modeline to be updated. But how to determine whether a string | |
| 1875 is a `generated-modeline-string'? Looping through all buffers | |
| 1876 is not very efficient. Should we add all | |
| 1877 `generated-modeline-string' strings to a hash table? Maybe | |
| 1878 efficiency is not the greatest concern here and there's no big | |
| 1879 loss in looping over the buffers. | |
| 1880 | |
| 1881 If the extent is in a gutter we mark the gutter as | |
| 1882 changed. This means (a) we can update extents in the gutters | |
| 1883 when we need it. (b) we don't have to update the gutters when | |
| 1884 only extents attached to buffers have changed. */ | |
| 1885 | |
| 1886 if (!in_modeline_generation) | |
| 1887 MARK_EXTENTS_CHANGED; | |
| 1888 gutter_extent_signal_changed_region_maybe | |
| 1889 (object, extent_endpoint_char (extent, 0), | |
| 1890 extent_endpoint_char (extent, 1)); | |
| 1891 } | |
| 1892 else if (BUFFERP (object)) | |
| 1893 { | |
| 1894 struct buffer *b; | |
| 1895 b = XBUFFER (object); | |
| 1896 BUF_FACECHANGE (b)++; | |
| 1897 MARK_EXTENTS_CHANGED; | |
| 1898 if (NILP (property) ? !NILP (extent_invisible (anc)) : | |
| 1899 EQ (property, Qinvisible)) | |
| 1900 MARK_CLIP_CHANGED; | |
| 1901 buffer_extent_signal_changed_region | |
| 1902 (b, extent_endpoint_char (extent, 0), | |
| 1903 extent_endpoint_char (extent, 1)); | |
| 1904 } | |
| 1905 } | |
| 1906 | |
| 1907 /* Check for syntax table property change */ | |
| 1908 if (NILP (property) ? !NILP (Fextent_property (wrap_extent (extent), | |
| 1909 Qsyntax_table, Qnil)) : | |
| 1910 EQ (property, Qsyntax_table)) | |
| 3250 | 1911 signal_syntax_cache_extent_changed (extent); |
| 826 | 1912 } |
| 1913 | |
| 1914 /* Make note that a change has happened in EXTENT. The change was either | |
| 1915 to a property or to the endpoints (but not both at once). If PROPERTY | |
| 1916 is non-nil, the change happened to that property; otherwise, the change | |
| 1917 happened to the endpoints, and the old ones are given. Currently, all | |
| 1918 endpoints changes are in the form of two signals, a detach followed by | |
| 1919 an attach, and when detaching, we are signalled before the extent is | |
| 1920 detached. (You can distinguish a detach from an attach because the | |
| 1921 latter has old_start == -1 and old_end == -1.) (#### We don't currently | |
| 1922 give the old property. If someone needs that, this will have to | |
| 1923 change.) KLUDGE: If PROPERTY is Qt, all properties may have changed | |
| 1924 because the parent was changed. #### We need to handle this properly, by | |
| 1925 mapping over properties. */ | |
| 1926 | |
| 1927 static void | |
| 1928 signal_extent_changed (EXTENT extent, Lisp_Object property, | |
| 1929 Bytexpos old_start, Bytexpos old_end, | |
| 1930 int descendants_too) | |
| 1931 { | |
| 428 | 1932 /* we could easily encounter a detached extent while traversing the |
| 1933 children, but we should never be able to encounter a dead extent. */ | |
| 1934 assert (EXTENT_LIVE_P (extent)); | |
| 1935 | |
| 1936 if (descendants_too) | |
| 1937 { | |
| 1938 Lisp_Object children = extent_children (extent); | |
| 1939 | |
| 1940 if (!NILP (children)) | |
| 1941 { | |
| 826 | 1942 /* first process all of the extent's children. We will lose |
| 1943 big-time if there are any circularities here, so we sure as | |
| 1944 hell better ensure that there aren't. */ | |
| 831 | 1945 LIST_LOOP_2 (child, XWEAK_LIST_LIST (children)) |
| 1946 signal_extent_changed (XEXTENT (child), property, old_start, | |
| 840 | 1947 old_end, descendants_too); |
| 428 | 1948 } |
| 1949 } | |
| 1950 | |
| 826 | 1951 /* now process the extent itself. */ |
| 1952 signal_single_extent_changed (extent, property, old_start, old_end); | |
| 1953 } | |
| 428 | 1954 |
| 1955 static void | |
| 826 | 1956 signal_extent_property_changed (EXTENT extent, Lisp_Object property, |
| 1957 int descendants_too) | |
| 1958 { | |
| 1959 signal_extent_changed (extent, property, 0, 0, descendants_too); | |
| 428 | 1960 } |
| 1961 | |
| 1962 static EXTENT | |
| 1963 make_extent_detached (Lisp_Object object) | |
| 1964 { | |
| 1965 EXTENT extent = allocate_extent (); | |
| 1966 | |
| 1967 assert (NILP (object) || STRINGP (object) || | |
| 1968 (BUFFERP (object) && BUFFER_LIVE_P (XBUFFER (object)))); | |
| 1969 extent_object (extent) = object; | |
| 1970 /* Now make sure the extent info exists. */ | |
| 1971 if (!NILP (object)) | |
| 1972 buffer_or_string_extent_info_force (object); | |
| 1973 return extent; | |
| 1974 } | |
| 1975 | |
| 1976 /* A "real" extent is any extent other than the internal (not-user-visible) | |
| 1977 extents used by `map-extents'. */ | |
| 1978 | |
| 1979 static EXTENT | |
| 1980 real_extent_at_forward (Extent_List *el, int pos, int endp) | |
| 1981 { | |
| 1982 for (; pos < extent_list_num_els (el); pos++) | |
| 1983 { | |
| 1984 EXTENT e = extent_list_at (el, pos, endp); | |
| 1985 if (!extent_internal_p (e)) | |
| 1986 return e; | |
| 1987 } | |
| 1988 return 0; | |
| 1989 } | |
| 1990 | |
| 1991 static EXTENT | |
| 1992 real_extent_at_backward (Extent_List *el, int pos, int endp) | |
| 1993 { | |
| 1994 for (; pos >= 0; pos--) | |
| 1995 { | |
| 1996 EXTENT e = extent_list_at (el, pos, endp); | |
| 1997 if (!extent_internal_p (e)) | |
| 1998 return e; | |
| 1999 } | |
| 2000 return 0; | |
| 2001 } | |
| 2002 | |
| 2003 static EXTENT | |
| 2004 extent_first (Lisp_Object obj) | |
| 2005 { | |
| 2006 Extent_List *el = buffer_or_string_extent_list (obj); | |
| 2007 | |
| 2008 if (!el) | |
| 2009 return 0; | |
| 2010 return real_extent_at_forward (el, 0, 0); | |
| 2011 } | |
| 2012 | |
| 2013 #ifdef DEBUG_XEMACS | |
| 2014 static EXTENT | |
| 2015 extent_e_first (Lisp_Object obj) | |
| 2016 { | |
| 2017 Extent_List *el = buffer_or_string_extent_list (obj); | |
| 2018 | |
| 2019 if (!el) | |
| 2020 return 0; | |
| 2021 return real_extent_at_forward (el, 0, 1); | |
| 2022 } | |
| 2023 #endif | |
| 2024 | |
| 2025 static EXTENT | |
| 2026 extent_next (EXTENT e) | |
| 2027 { | |
| 2028 Extent_List *el = extent_extent_list (e); | |
| 2029 int foundp; | |
| 2030 int pos = extent_list_locate (el, e, 0, &foundp); | |
| 2031 assert (foundp); | |
| 2032 return real_extent_at_forward (el, pos+1, 0); | |
| 2033 } | |
| 2034 | |
| 2035 #ifdef DEBUG_XEMACS | |
| 2036 static EXTENT | |
| 2037 extent_e_next (EXTENT e) | |
| 2038 { | |
| 2039 Extent_List *el = extent_extent_list (e); | |
| 2040 int foundp; | |
| 2041 int pos = extent_list_locate (el, e, 1, &foundp); | |
| 2042 assert (foundp); | |
| 2043 return real_extent_at_forward (el, pos+1, 1); | |
| 2044 } | |
| 2045 #endif | |
| 2046 | |
| 2047 static EXTENT | |
| 2048 extent_last (Lisp_Object obj) | |
| 2049 { | |
| 2050 Extent_List *el = buffer_or_string_extent_list (obj); | |
| 2051 | |
| 2052 if (!el) | |
| 2053 return 0; | |
| 2054 return real_extent_at_backward (el, extent_list_num_els (el) - 1, 0); | |
| 2055 } | |
| 2056 | |
| 2057 #ifdef DEBUG_XEMACS | |
| 2058 static EXTENT | |
| 2059 extent_e_last (Lisp_Object obj) | |
| 2060 { | |
| 2061 Extent_List *el = buffer_or_string_extent_list (obj); | |
| 2062 | |
| 2063 if (!el) | |
| 2064 return 0; | |
| 2065 return real_extent_at_backward (el, extent_list_num_els (el) - 1, 1); | |
| 2066 } | |
| 2067 #endif | |
| 2068 | |
| 2069 static EXTENT | |
| 2070 extent_previous (EXTENT e) | |
| 2071 { | |
| 2072 Extent_List *el = extent_extent_list (e); | |
| 2073 int foundp; | |
| 2074 int pos = extent_list_locate (el, e, 0, &foundp); | |
| 2075 assert (foundp); | |
| 2076 return real_extent_at_backward (el, pos-1, 0); | |
| 2077 } | |
| 2078 | |
| 2079 #ifdef DEBUG_XEMACS | |
| 2080 static EXTENT | |
| 2081 extent_e_previous (EXTENT e) | |
| 2082 { | |
| 2083 Extent_List *el = extent_extent_list (e); | |
| 2084 int foundp; | |
| 2085 int pos = extent_list_locate (el, e, 1, &foundp); | |
| 2086 assert (foundp); | |
| 2087 return real_extent_at_backward (el, pos-1, 1); | |
| 2088 } | |
| 2089 #endif | |
| 2090 | |
| 2091 static void | |
| 2092 extent_attach (EXTENT extent) | |
| 2093 { | |
| 2094 Extent_List *el = extent_extent_list (extent); | |
| 2095 | |
| 2096 extent_list_insert (el, extent); | |
| 2097 soe_insert (extent_object (extent), extent); | |
| 2098 /* only this extent changed */ | |
| 826 | 2099 signal_extent_changed (extent, Qnil, -1, -1, 0); |
| 428 | 2100 } |
| 2101 | |
| 2102 static void | |
| 2103 extent_detach (EXTENT extent) | |
| 2104 { | |
| 2105 Extent_List *el; | |
| 2106 | |
| 2107 if (extent_detached_p (extent)) | |
| 2108 return; | |
| 2109 el = extent_extent_list (extent); | |
| 2110 | |
| 2111 /* call this before messing with the extent. */ | |
| 826 | 2112 signal_extent_changed (extent, Qnil, |
| 2113 extent_endpoint_byte (extent, 0), | |
| 2114 extent_endpoint_char (extent, 0), | |
| 2115 0); | |
| 428 | 2116 extent_list_delete (el, extent); |
| 2117 soe_delete (extent_object (extent), extent); | |
| 2118 set_extent_start (extent, -1); | |
| 2119 set_extent_end (extent, -1); | |
| 2120 } | |
| 2121 | |
| 2122 /* ------------------------------- */ | |
| 2123 /* map-extents et al. */ | |
| 2124 /* ------------------------------- */ | |
| 2125 | |
| 2126 /* Returns true iff map_extents() would visit the given extent. | |
| 2127 See the comments at map_extents() for info on the overlap rule. | |
| 2128 Assumes that all validation on the extent and buffer positions has | |
| 2129 already been performed (see Fextent_in_region_p ()). | |
| 2130 */ | |
| 2131 static int | |
| 826 | 2132 extent_in_region_p (EXTENT extent, Bytexpos from, Bytexpos to, |
| 428 | 2133 unsigned int flags) |
| 2134 { | |
| 2135 Lisp_Object obj = extent_object (extent); | |
| 2136 Endpoint_Index start, end, exs, exe; | |
| 2137 int start_open, end_open; | |
| 2138 unsigned int all_extents_flags = flags & ME_ALL_EXTENTS_MASK; | |
| 2139 unsigned int in_region_flags = flags & ME_IN_REGION_MASK; | |
| 2140 int retval; | |
| 2141 | |
| 2142 /* A zero-length region is treated as closed-closed. */ | |
| 2143 if (from == to) | |
| 2144 { | |
| 2145 flags |= ME_END_CLOSED; | |
| 2146 flags &= ~ME_START_OPEN; | |
| 2147 } | |
| 2148 | |
| 2149 /* So is a zero-length extent. */ | |
| 2150 if (extent_start (extent) == extent_end (extent)) | |
| 2151 start_open = 0, end_open = 0; | |
| 2152 /* `all_extents_flags' will almost always be zero. */ | |
| 2153 else if (all_extents_flags == 0) | |
| 2154 { | |
| 2155 start_open = extent_start_open_p (extent); | |
| 2156 end_open = extent_end_open_p (extent); | |
| 2157 } | |
| 2158 else | |
| 2159 switch (all_extents_flags) | |
| 2160 { | |
| 2161 case ME_ALL_EXTENTS_CLOSED: start_open = 0, end_open = 0; break; | |
| 2162 case ME_ALL_EXTENTS_OPEN: start_open = 1, end_open = 1; break; | |
| 2163 case ME_ALL_EXTENTS_CLOSED_OPEN: start_open = 0, end_open = 1; break; | |
| 2164 case ME_ALL_EXTENTS_OPEN_CLOSED: start_open = 1, end_open = 0; break; | |
| 2500 | 2165 default: ABORT(); return 0; |
| 428 | 2166 } |
| 2167 | |
| 826 | 2168 start = buffer_or_string_bytexpos_to_startind (obj, from, |
| 428 | 2169 flags & ME_START_OPEN); |
| 826 | 2170 end = buffer_or_string_bytexpos_to_endind (obj, to, |
| 2171 ! (flags & ME_END_CLOSED)); | |
| 2172 exs = memxpos_to_startind (extent_start (extent), start_open); | |
| 2173 exe = memxpos_to_endind (extent_end (extent), end_open); | |
| 428 | 2174 |
| 2175 /* It's easy to determine whether an extent lies *outside* the | |
| 2176 region -- just determine whether it's completely before | |
| 2177 or completely after the region. Reject all such extents, so | |
| 2178 we're now left with only the extents that overlap the region. | |
| 2179 */ | |
| 2180 | |
| 2181 if (exs > end || exe < start) | |
| 2182 return 0; | |
| 2183 | |
| 2184 /* See if any further restrictions are called for. */ | |
| 2185 /* in_region_flags will almost always be zero. */ | |
| 2186 if (in_region_flags == 0) | |
| 2187 retval = 1; | |
| 2188 else | |
| 2189 switch (in_region_flags) | |
| 2190 { | |
| 2191 case ME_START_IN_REGION: | |
| 2192 retval = start <= exs && exs <= end; break; | |
| 2193 case ME_END_IN_REGION: | |
| 2194 retval = start <= exe && exe <= end; break; | |
| 2195 case ME_START_AND_END_IN_REGION: | |
| 2196 retval = start <= exs && exe <= end; break; | |
| 2197 case ME_START_OR_END_IN_REGION: | |
| 2198 retval = (start <= exs && exs <= end) || (start <= exe && exe <= end); | |
| 2199 break; | |
| 2200 default: | |
| 2500 | 2201 ABORT(); return 0; |
| 428 | 2202 } |
| 2203 return flags & ME_NEGATE_IN_REGION ? !retval : retval; | |
| 2204 } | |
| 2205 | |
| 2206 struct map_extents_struct | |
| 2207 { | |
| 2208 Extent_List *el; | |
| 2209 Extent_List_Marker *mkr; | |
| 2210 EXTENT range; | |
| 2211 }; | |
| 2212 | |
| 2213 static Lisp_Object | |
| 2214 map_extents_unwind (Lisp_Object obj) | |
| 2215 { | |
| 2216 struct map_extents_struct *closure = | |
| 2217 (struct map_extents_struct *) get_opaque_ptr (obj); | |
| 2218 free_opaque_ptr (obj); | |
| 2219 if (closure->range) | |
| 2220 extent_detach (closure->range); | |
| 2221 if (closure->mkr) | |
| 2222 extent_list_delete_marker (closure->el, closure->mkr); | |
| 2223 return Qnil; | |
| 2224 } | |
| 2225 | |
| 2226 /* This is the guts of `map-extents' and the other functions that | |
| 2227 map over extents. In theory the operation of this function is | |
| 2228 simple: just figure out what extents we're mapping over, and | |
| 2229 call the function on each one of them in the range. Unfortunately | |
| 2230 there are a wide variety of things that the mapping function | |
| 2231 might do, and we have to be very tricky to avoid getting messed | |
| 2232 up. Furthermore, this function needs to be very fast (it is | |
| 2233 called multiple times every time text is inserted or deleted | |
| 2234 from a buffer), and so we can't always afford the overhead of | |
| 2235 dealing with all the possible things that the mapping function | |
| 2236 might do; thus, there are many flags that can be specified | |
| 2237 indicating what the mapping function might or might not do. | |
| 2238 | |
| 2239 The result of all this is that this is the most complicated | |
| 2240 function in this file. Change it at your own risk! | |
| 2241 | |
| 2242 A potential simplification to the logic below is to determine | |
| 2243 all the extents that the mapping function should be called on | |
| 2244 before any calls are actually made and save them in an array. | |
| 2245 That introduces its own complications, however (the array | |
| 2246 needs to be marked for garbage-collection, and a static array | |
| 2247 cannot be used because map_extents() needs to be reentrant). | |
| 2248 Furthermore, the results might be a little less sensible than | |
| 2249 the logic below. */ | |
| 2250 | |
| 2251 | |
| 2252 static void | |
| 826 | 2253 map_extents (Bytexpos from, Bytexpos to, map_extents_fun fn, |
| 2254 void *arg, Lisp_Object obj, EXTENT after, | |
| 2255 unsigned int flags) | |
| 2256 { | |
| 2257 Memxpos st, en; /* range we're mapping over */ | |
| 428 | 2258 EXTENT range = 0; /* extent for this, if ME_MIGHT_MODIFY_TEXT */ |
| 2259 Extent_List *el = 0; /* extent list we're iterating over */ | |
| 2260 Extent_List_Marker *posm = 0; /* marker for extent list, | |
| 2261 if ME_MIGHT_MODIFY_EXTENTS */ | |
| 2262 /* count and struct for unwind-protect, if ME_MIGHT_THROW */ | |
| 1292 | 2263 int count = specpdl_depth (); |
| 428 | 2264 struct map_extents_struct closure; |
| 1292 | 2265 PROFILE_DECLARE (); |
| 428 | 2266 |
| 2267 #ifdef ERROR_CHECK_EXTENTS | |
| 2268 assert (from <= to); | |
| 2269 assert (from >= buffer_or_string_absolute_begin_byte (obj) && | |
| 2270 from <= buffer_or_string_absolute_end_byte (obj) && | |
| 2271 to >= buffer_or_string_absolute_begin_byte (obj) && | |
| 2272 to <= buffer_or_string_absolute_end_byte (obj)); | |
| 2273 #endif | |
| 2274 | |
| 2275 if (after) | |
| 2276 { | |
| 2277 assert (EQ (obj, extent_object (after))); | |
| 2278 assert (!extent_detached_p (after)); | |
| 2279 } | |
| 2280 | |
| 2281 el = buffer_or_string_extent_list (obj); | |
| 1292 | 2282 if (!el || !extent_list_num_els (el)) |
| 428 | 2283 return; |
| 2284 el = 0; | |
| 2285 | |
| 1292 | 2286 PROFILE_RECORD_ENTERING_SECTION (QSin_map_extents_internal); |
| 2287 | |
| 826 | 2288 st = buffer_or_string_bytexpos_to_memxpos (obj, from); |
| 2289 en = buffer_or_string_bytexpos_to_memxpos (obj, to); | |
| 428 | 2290 |
| 2291 if (flags & ME_MIGHT_MODIFY_TEXT) | |
| 2292 { | |
| 2293 /* The mapping function might change the text in the buffer, | |
| 2294 so make an internal extent to hold the range we're mapping | |
| 2295 over. */ | |
| 2296 range = make_extent_detached (obj); | |
| 2297 set_extent_start (range, st); | |
| 2298 set_extent_end (range, en); | |
| 2299 range->flags.start_open = flags & ME_START_OPEN; | |
| 2300 range->flags.end_open = !(flags & ME_END_CLOSED); | |
| 2301 range->flags.internal = 1; | |
| 2302 range->flags.detachable = 0; | |
| 2303 extent_attach (range); | |
| 2304 } | |
| 2305 | |
| 2306 if (flags & ME_MIGHT_THROW) | |
| 2307 { | |
| 2308 /* The mapping function might throw past us so we need to use an | |
| 2309 unwind_protect() to eliminate the internal extent and range | |
| 2310 that we use. */ | |
| 2311 closure.range = range; | |
| 2312 closure.mkr = 0; | |
| 2313 record_unwind_protect (map_extents_unwind, | |
| 2314 make_opaque_ptr (&closure)); | |
| 2315 } | |
| 2316 | |
| 2317 /* ---------- Figure out where we start and what direction | |
| 2318 we move in. This is the trickiest part of this | |
| 2319 function. ---------- */ | |
| 2320 | |
| 2321 /* If ME_START_IN_REGION, ME_END_IN_REGION or ME_START_AND_END_IN_REGION | |
| 2322 was specified and ME_NEGATE_IN_REGION was not specified, our job | |
| 2323 is simple because of the presence of the display order and e-order. | |
| 2324 (Note that theoretically do something similar for | |
| 2325 ME_START_OR_END_IN_REGION, but that would require more trickiness | |
| 2326 than it's worth to avoid hitting the same extent twice.) | |
| 2327 | |
| 2328 In the general case, all the extents that overlap a range can be | |
| 2329 divided into two classes: those whose start position lies within | |
| 2330 the range (including the range's end but not including the | |
| 2331 range's start), and those that overlap the start position, | |
| 2332 i.e. those in the SOE for the start position. Or equivalently, | |
| 2333 the extents can be divided into those whose end position lies | |
| 2334 within the range and those in the SOE for the end position. Note | |
| 2335 that for this purpose we treat both the range and all extents in | |
| 2336 the buffer as closed on both ends. If this is not what the ME_ | |
| 2337 flags specified, then we've mapped over a few too many extents, | |
| 2338 but no big deal because extent_in_region_p() will filter them | |
| 2339 out. Ideally, we could move the SOE to the closer of the range's | |
| 2340 two ends and work forwards or backwards from there. However, in | |
| 2341 order to make the semantics of the AFTER argument work out, we | |
| 2342 have to always go in the same direction; so we choose to always | |
| 2343 move the SOE to the start position. | |
| 2344 | |
| 2345 When it comes time to do the SOE stage, we first call soe_move() | |
| 2346 so that the SOE gets set up. Note that the SOE might get | |
| 2347 changed while we are mapping over its contents. If we can | |
| 2348 guarantee that the SOE won't get moved to a new position, we | |
| 2349 simply need to put a marker in the SOE and we will track deletions | |
| 2350 and insertions of extents in the SOE. If the SOE might get moved, | |
| 2351 however (this would happen as a result of a recursive invocation | |
| 2352 of map-extents or a call to a redisplay-type function), then | |
| 2353 trying to track its changes is hopeless, so we just keep a | |
| 2354 marker to the first (or last) extent in the SOE and use that as | |
| 2355 our bound. | |
| 2356 | |
| 2357 Finally, if DONT_USE_SOE is defined, we don't use the SOE at all | |
| 2358 and instead just map from the beginning of the buffer. This is | |
| 2359 used for testing purposes and allows the SOE to be calculated | |
| 2360 using map_extents() instead of the other way around. */ | |
| 2361 | |
| 2362 { | |
| 2363 int range_flag; /* ME_*_IN_REGION subset of flags */ | |
| 2364 int do_soe_stage = 0; /* Are we mapping over the SOE? */ | |
| 2365 /* Does the range stage map over start or end positions? */ | |
| 2366 int range_endp; | |
| 2367 /* If type == 0, we include the start position in the range stage mapping. | |
| 2368 If type == 1, we exclude the start position in the range stage mapping. | |
| 2369 If type == 2, we begin at range_start_pos, an extent-list position. | |
| 2370 */ | |
| 2371 int range_start_type = 0; | |
| 2372 int range_start_pos = 0; | |
| 2373 int stage; | |
| 2374 | |
| 2375 range_flag = flags & ME_IN_REGION_MASK; | |
| 2376 if ((range_flag == ME_START_IN_REGION || | |
| 2377 range_flag == ME_START_AND_END_IN_REGION) && | |
| 2378 !(flags & ME_NEGATE_IN_REGION)) | |
| 2379 { | |
| 2380 /* map over start position in [range-start, range-end]. No SOE | |
| 2381 stage. */ | |
| 2382 range_endp = 0; | |
| 2383 } | |
| 2384 else if (range_flag == ME_END_IN_REGION && !(flags & ME_NEGATE_IN_REGION)) | |
| 2385 { | |
| 2386 /* map over end position in [range-start, range-end]. No SOE | |
| 2387 stage. */ | |
| 2388 range_endp = 1; | |
| 2389 } | |
| 2390 else | |
| 2391 { | |
| 2392 /* Need to include the SOE extents. */ | |
| 2393 #ifdef DONT_USE_SOE | |
| 2394 /* Just brute-force it: start from the beginning. */ | |
| 2395 range_endp = 0; | |
| 2396 range_start_type = 2; | |
| 2397 range_start_pos = 0; | |
| 2398 #else | |
| 2399 Stack_Of_Extents *soe = buffer_or_string_stack_of_extents_force (obj); | |
| 2400 int numsoe; | |
| 2401 | |
| 2402 /* Move the SOE to the closer end of the range. This dictates | |
| 2403 whether we map over start positions or end positions. */ | |
| 2404 range_endp = 0; | |
| 2405 soe_move (obj, st); | |
| 2406 numsoe = extent_list_num_els (soe->extents); | |
| 2407 if (numsoe) | |
| 2408 { | |
| 2409 if (flags & ME_MIGHT_MOVE_SOE) | |
| 2410 { | |
| 2411 int foundp; | |
| 2412 /* Can't map over SOE, so just extend range to cover the | |
| 2413 SOE. */ | |
| 2414 EXTENT e = extent_list_at (soe->extents, 0, 0); | |
| 2415 range_start_pos = | |
| 2416 extent_list_locate (buffer_or_string_extent_list (obj), e, 0, | |
| 2417 &foundp); | |
| 2418 assert (foundp); | |
| 2419 range_start_type = 2; | |
| 2420 } | |
| 2421 else | |
| 2422 { | |
| 2423 /* We can map over the SOE. */ | |
| 2424 do_soe_stage = 1; | |
| 2425 range_start_type = 1; | |
| 2426 } | |
| 2427 } | |
| 2428 else | |
| 2429 { | |
| 2430 /* No extents in the SOE to map over, so we act just as if | |
| 2431 ME_START_IN_REGION or ME_END_IN_REGION was specified. | |
| 2432 RANGE_ENDP already specified so no need to do anything else. */ | |
| 2433 } | |
| 2434 } | |
| 2435 #endif | |
| 2436 | |
| 2437 /* ---------- Now loop over the extents. ---------- */ | |
| 2438 | |
| 2439 /* We combine the code for the two stages because much of it | |
| 2440 overlaps. */ | |
| 2441 for (stage = 0; stage < 2; stage++) | |
| 2442 { | |
| 2443 int pos = 0; /* Position in extent list */ | |
| 2444 | |
| 2445 /* First set up start conditions */ | |
| 2446 if (stage == 0) | |
| 2447 { /* The SOE stage */ | |
| 2448 if (!do_soe_stage) | |
| 2449 continue; | |
| 2450 el = buffer_or_string_stack_of_extents_force (obj)->extents; | |
| 2451 /* We will always be looping over start extents here. */ | |
| 2452 assert (!range_endp); | |
| 2453 pos = 0; | |
| 2454 } | |
| 2455 else | |
| 2456 { /* The range stage */ | |
| 2457 el = buffer_or_string_extent_list (obj); | |
| 2458 switch (range_start_type) | |
| 2459 { | |
| 2460 case 0: | |
| 2461 pos = extent_list_locate_from_pos (el, st, range_endp); | |
| 2462 break; | |
| 2463 case 1: | |
| 2464 pos = extent_list_locate_from_pos (el, st + 1, range_endp); | |
| 2465 break; | |
| 2466 case 2: | |
| 2467 pos = range_start_pos; | |
| 2468 break; | |
| 2469 } | |
| 2470 } | |
| 2471 | |
| 2472 if (flags & ME_MIGHT_MODIFY_EXTENTS) | |
| 2473 { | |
| 2474 /* Create a marker to track changes to the extent list */ | |
| 2475 if (posm) | |
| 2476 /* Delete the marker used in the SOE stage. */ | |
| 2477 extent_list_delete_marker | |
| 2478 (buffer_or_string_stack_of_extents_force (obj)->extents, posm); | |
| 2479 posm = extent_list_make_marker (el, pos, range_endp); | |
| 2480 /* tell the unwind function about the marker. */ | |
| 2481 closure.el = el; | |
| 2482 closure.mkr = posm; | |
| 2483 } | |
| 2484 | |
| 2485 /* Now loop! */ | |
| 2486 for (;;) | |
| 2487 { | |
| 2488 EXTENT e; | |
| 2489 Lisp_Object obj2; | |
| 2490 | |
| 2491 /* ----- update position in extent list | |
| 2492 and fetch next extent ----- */ | |
| 2493 | |
| 2494 if (posm) | |
| 2495 /* fetch POS again to track extent insertions or deletions */ | |
| 2496 pos = extent_list_marker_pos (el, posm); | |
| 2497 if (pos >= extent_list_num_els (el)) | |
| 2498 break; | |
| 2499 e = extent_list_at (el, pos, range_endp); | |
| 2500 pos++; | |
| 2501 if (posm) | |
| 2502 /* now point the marker to the next one we're going to process. | |
| 2503 This ensures graceful behavior if this extent is deleted. */ | |
| 2504 extent_list_move_marker (el, posm, pos); | |
| 2505 | |
| 2506 /* ----- deal with internal extents ----- */ | |
| 2507 | |
| 2508 if (extent_internal_p (e)) | |
| 2509 { | |
| 2510 if (!(flags & ME_INCLUDE_INTERNAL)) | |
| 2511 continue; | |
| 2512 else if (e == range) | |
| 2513 { | |
| 2514 /* We're processing internal extents and we've | |
| 2515 come across our own special range extent. | |
| 2516 (This happens only in adjust_extents*() and | |
| 2517 process_extents*(), which handle text | |
| 2518 insertion and deletion.) We need to omit | |
| 2519 processing of this extent; otherwise | |
| 2520 we will probably end up prematurely | |
| 2521 terminating this loop. */ | |
| 2522 continue; | |
| 2523 } | |
| 2524 } | |
| 2525 | |
| 2526 /* ----- deal with AFTER condition ----- */ | |
| 2527 | |
| 2528 if (after) | |
| 2529 { | |
| 2530 /* if e > after, then we can stop skipping extents. */ | |
| 2531 if (EXTENT_LESS (after, e)) | |
| 2532 after = 0; | |
| 2533 else /* otherwise, skip this extent. */ | |
| 2534 continue; | |
| 2535 } | |
| 2536 | |
| 2537 /* ----- stop if we're completely outside the range ----- */ | |
| 2538 | |
| 2539 /* fetch ST and EN again to track text insertions or deletions */ | |
| 2540 if (range) | |
| 2541 { | |
| 2542 st = extent_start (range); | |
| 2543 en = extent_end (range); | |
| 2544 } | |
| 2545 if (extent_endpoint (e, range_endp) > en) | |
| 2546 { | |
| 2547 /* Can't be mapping over SOE because all extents in | |
| 2548 there should overlap ST */ | |
| 2549 assert (stage == 1); | |
| 2550 break; | |
| 2551 } | |
| 2552 | |
| 2553 /* ----- Now actually call the function ----- */ | |
| 2554 | |
| 2555 obj2 = extent_object (e); | |
| 2556 if (extent_in_region_p (e, | |
| 826 | 2557 buffer_or_string_memxpos_to_bytexpos (obj2, |
| 2558 st), | |
| 2559 buffer_or_string_memxpos_to_bytexpos (obj2, | |
| 2560 en), | |
| 428 | 2561 flags)) |
| 2562 { | |
| 2563 if ((*fn)(e, arg)) | |
| 2564 { | |
| 2565 /* Function wants us to stop mapping. */ | |
| 2566 stage = 1; /* so outer for loop will terminate */ | |
| 2567 break; | |
| 2568 } | |
| 2569 } | |
| 2570 } | |
| 2571 } | |
| 2572 /* ---------- Finished looping. ---------- */ | |
| 2573 } | |
| 2574 | |
| 1292 | 2575 if (!(flags & ME_MIGHT_THROW)) |
| 428 | 2576 { |
| 2577 /* Delete them ourselves */ | |
| 2578 if (range) | |
| 2579 extent_detach (range); | |
| 2580 if (posm) | |
| 2581 extent_list_delete_marker (el, posm); | |
| 2582 } | |
| 1292 | 2583 |
| 2584 /* This deletes the range extent and frees the marker, if ME_MIGHT_THROW. */ | |
| 2585 unbind_to (count); | |
| 2586 | |
| 2587 PROFILE_RECORD_EXITING_SECTION (QSin_map_extents_internal); | |
| 428 | 2588 } |
| 2589 | |
| 2590 /* ------------------------------- */ | |
| 2591 /* adjust_extents() */ | |
| 2592 /* ------------------------------- */ | |
| 2593 | |
| 2594 /* Add AMOUNT to all extent endpoints in the range (FROM, TO]. This | |
| 2595 happens whenever the gap is moved or (under Mule) a character in a | |
| 2596 string is substituted for a different-length one. The reason for | |
| 2597 this is that extent endpoints behave just like markers (all memory | |
| 2598 indices do) and this adjustment correct for markers -- see | |
| 2599 adjust_markers(). Note that it is important that we visit all | |
| 2600 extent endpoints in the range, irrespective of whether the | |
| 2601 endpoints are open or closed. | |
| 2602 | |
| 2603 We could use map_extents() for this (and in fact the function | |
| 2604 was originally written that way), but the gap is in an incoherent | |
| 2605 state when this function is called and this function plays | |
| 2606 around with extent endpoints without detaching and reattaching | |
| 2607 the extents (this is provably correct and saves lots of time), | |
| 2608 so for safety we make it just look at the extent lists directly. */ | |
| 2609 | |
| 2610 void | |
| 826 | 2611 adjust_extents (Lisp_Object obj, Memxpos from, Memxpos to, int amount) |
| 428 | 2612 { |
| 2613 int endp; | |
| 2614 int pos; | |
| 2615 int startpos[2]; | |
| 2616 Extent_List *el; | |
| 2617 Stack_Of_Extents *soe; | |
| 2618 | |
| 2619 #ifdef ERROR_CHECK_EXTENTS | |
| 2620 sledgehammer_extent_check (obj); | |
| 2621 #endif | |
| 2622 el = buffer_or_string_extent_list (obj); | |
| 2623 | |
| 2624 if (!el || !extent_list_num_els(el)) | |
| 2625 return; | |
| 2626 | |
| 2627 /* IMPORTANT! Compute the starting positions of the extents to | |
| 2628 modify BEFORE doing any modification! Otherwise the starting | |
| 2629 position for the second time through the loop might get | |
| 2630 incorrectly calculated (I got bit by this bug real bad). */ | |
| 2631 startpos[0] = extent_list_locate_from_pos (el, from+1, 0); | |
| 2632 startpos[1] = extent_list_locate_from_pos (el, from+1, 1); | |
| 2633 for (endp = 0; endp < 2; endp++) | |
| 2634 { | |
| 2635 for (pos = startpos[endp]; pos < extent_list_num_els (el); | |
| 2636 pos++) | |
| 2637 { | |
| 2638 EXTENT e = extent_list_at (el, pos, endp); | |
| 2639 if (extent_endpoint (e, endp) > to) | |
| 2640 break; | |
| 2641 set_extent_endpoint (e, | |
| 2642 do_marker_adjustment (extent_endpoint (e, endp), | |
| 2643 from, to, amount), | |
| 2644 endp); | |
| 2645 } | |
| 2646 } | |
| 2647 | |
| 2648 /* The index for the buffer's SOE is a memory index and thus | |
| 2649 needs to be adjusted like a marker. */ | |
| 2650 soe = buffer_or_string_stack_of_extents (obj); | |
| 2651 if (soe && soe->pos >= 0) | |
| 2652 soe->pos = do_marker_adjustment (soe->pos, from, to, amount); | |
| 2653 } | |
| 2654 | |
| 2655 /* ------------------------------- */ | |
| 2656 /* adjust_extents_for_deletion() */ | |
| 2657 /* ------------------------------- */ | |
| 2658 | |
| 2659 struct adjust_extents_for_deletion_arg | |
| 2660 { | |
| 2661 EXTENT_dynarr *list; | |
| 2662 }; | |
| 2663 | |
| 2664 static int | |
| 2665 adjust_extents_for_deletion_mapper (EXTENT extent, void *arg) | |
| 2666 { | |
| 2667 struct adjust_extents_for_deletion_arg *closure = | |
| 2668 (struct adjust_extents_for_deletion_arg *) arg; | |
| 2669 | |
| 2670 Dynarr_add (closure->list, extent); | |
| 2671 return 0; /* continue mapping */ | |
| 2672 } | |
| 2673 | |
| 2674 /* For all extent endpoints in the range (FROM, TO], move them to the beginning | |
| 2675 of the new gap. Note that it is important that we visit all extent | |
| 2676 endpoints in the range, irrespective of whether the endpoints are open or | |
| 2677 closed. | |
| 2678 | |
| 2679 This function deals with weird stuff such as the fact that extents | |
| 2680 may get reordered. | |
| 2681 | |
| 2682 There is no string correspondent for this because you can't | |
| 2683 delete characters from a string. | |
| 2684 */ | |
| 2685 | |
| 2686 void | |
| 826 | 2687 adjust_extents_for_deletion (Lisp_Object object, Bytexpos from, |
| 2688 Bytexpos to, int gapsize, int numdel, | |
| 428 | 2689 int movegapsize) |
| 2690 { | |
| 2691 struct adjust_extents_for_deletion_arg closure; | |
| 2692 int i; | |
| 826 | 2693 Memxpos adjust_to = (Memxpos) (to + gapsize); |
| 428 | 2694 Bytecount amount = - numdel - movegapsize; |
| 826 | 2695 Memxpos oldsoe = 0, newsoe = 0; |
| 428 | 2696 Stack_Of_Extents *soe = buffer_or_string_stack_of_extents (object); |
| 2697 | |
| 2698 #ifdef ERROR_CHECK_EXTENTS | |
| 2699 sledgehammer_extent_check (object); | |
| 2700 #endif | |
| 2701 closure.list = Dynarr_new (EXTENT); | |
| 2702 | |
| 2703 /* We're going to be playing weird games below with extents and the SOE | |
| 2704 and such, so compute the list now of all the extents that we're going | |
| 2705 to muck with. If we do the mapping and adjusting together, things can | |
| 2706 get all screwed up. */ | |
| 2707 | |
| 826 | 2708 map_extents (from, to, adjust_extents_for_deletion_mapper, |
| 2709 (void *) &closure, object, 0, | |
| 2710 /* extent endpoints move like markers regardless | |
| 2711 of their open/closeness. */ | |
| 2712 ME_ALL_EXTENTS_CLOSED | ME_END_CLOSED | | |
| 2713 ME_START_OR_END_IN_REGION | ME_INCLUDE_INTERNAL); | |
| 428 | 2714 |
| 2715 /* | |
| 2716 Old and new values for the SOE's position. (It gets adjusted | |
| 2717 like a marker, just like extent endpoints.) | |
| 2718 */ | |
| 2719 | |
| 2720 if (soe) | |
| 2721 { | |
| 2722 oldsoe = soe->pos; | |
| 2723 if (soe->pos >= 0) | |
| 2724 newsoe = do_marker_adjustment (soe->pos, | |
| 2725 adjust_to, adjust_to, | |
| 2726 amount); | |
| 2727 else | |
| 2728 newsoe = soe->pos; | |
| 2729 } | |
| 2730 | |
| 2731 for (i = 0; i < Dynarr_length (closure.list); i++) | |
| 2732 { | |
| 2733 EXTENT extent = Dynarr_at (closure.list, i); | |
| 826 | 2734 Memxpos new_start = extent_start (extent); |
| 2735 Memxpos new_end = extent_end (extent); | |
| 428 | 2736 |
| 2737 /* do_marker_adjustment() will not adjust values that should not be | |
| 2738 adjusted. We're passing the same funky arguments to | |
| 2739 do_marker_adjustment() as buffer_delete_range() does. */ | |
| 2740 new_start = | |
| 2741 do_marker_adjustment (new_start, | |
| 2742 adjust_to, adjust_to, | |
| 2743 amount); | |
| 2744 new_end = | |
| 2745 do_marker_adjustment (new_end, | |
| 2746 adjust_to, adjust_to, | |
| 2747 amount); | |
| 2748 | |
| 2749 /* We need to be very careful here so that the SOE doesn't get | |
| 2750 corrupted. We are shrinking extents out of the deleted region | |
| 2751 and simultaneously moving the SOE's pos out of the deleted | |
| 2752 region, so the SOE should contain the same extents at the end | |
| 2753 as at the beginning. However, extents may get reordered | |
| 2754 by this process, so we have to operate by pulling the extents | |
| 2755 out of the buffer and SOE, changing their bounds, and then | |
| 2756 reinserting them. In order for the SOE not to get screwed up, | |
| 2757 we have to make sure that the SOE's pos points to its old | |
| 2758 location whenever we pull an extent out, and points to its | |
| 2759 new location whenever we put the extent back in. | |
| 2760 */ | |
| 2761 | |
| 2762 if (new_start != extent_start (extent) || | |
| 2763 new_end != extent_end (extent)) | |
| 2764 { | |
| 2765 extent_detach (extent); | |
| 2766 set_extent_start (extent, new_start); | |
| 2767 set_extent_end (extent, new_end); | |
| 2768 if (soe) | |
| 2769 soe->pos = newsoe; | |
| 2770 extent_attach (extent); | |
| 2771 if (soe) | |
| 2772 soe->pos = oldsoe; | |
| 2773 } | |
| 2774 } | |
| 2775 | |
| 2776 if (soe) | |
| 2777 soe->pos = newsoe; | |
| 2778 | |
| 2779 #ifdef ERROR_CHECK_EXTENTS | |
| 2780 sledgehammer_extent_check (object); | |
| 2781 #endif | |
| 2782 Dynarr_free (closure.list); | |
| 2783 } | |
| 2784 | |
| 2785 /* ------------------------------- */ | |
| 2786 /* extent fragments */ | |
| 2787 /* ------------------------------- */ | |
| 2788 | |
| 2789 /* Imagine that the buffer is divided up into contiguous, | |
| 2790 nonoverlapping "runs" of text such that no extent | |
| 2791 starts or ends within a run (extents that abut the | |
| 2792 run don't count). | |
| 2793 | |
| 2794 An extent fragment is a structure that holds data about | |
| 2795 the run that contains a particular buffer position (if | |
| 2796 the buffer position is at the junction of two runs, the | |
| 2797 run after the position is used) -- the beginning and | |
| 2798 end of the run, a list of all of the extents in that | |
| 2799 run, the "merged face" that results from merging all of | |
| 2800 the faces corresponding to those extents, the begin and | |
| 2801 end glyphs at the beginning of the run, etc. This is | |
| 2802 the information that redisplay needs in order to | |
| 2803 display this run. | |
| 2804 | |
| 2805 Extent fragments have to be very quick to update to | |
| 2806 a new buffer position when moving linearly through | |
| 2807 the buffer. They rely on the stack-of-extents code, | |
| 2808 which does the heavy-duty algorithmic work of determining | |
| 2809 which extents overly a particular position. */ | |
| 2810 | |
| 2811 /* This function returns the position of the beginning of | |
| 2812 the first run that begins after POS, or returns POS if | |
| 2813 there are no such runs. */ | |
| 2814 | |
| 826 | 2815 static Bytexpos |
| 2816 extent_find_end_of_run (Lisp_Object obj, Bytexpos pos, int outside_accessible) | |
| 428 | 2817 { |
| 2818 Extent_List *sel; | |
| 2819 Extent_List *bel = buffer_or_string_extent_list (obj); | |
| 826 | 2820 Bytexpos pos1, pos2; |
| 428 | 2821 int elind1, elind2; |
| 826 | 2822 Memxpos mempos = buffer_or_string_bytexpos_to_memxpos (obj, pos); |
| 2823 Bytexpos limit = outside_accessible ? | |
| 428 | 2824 buffer_or_string_absolute_end_byte (obj) : |
| 826 | 2825 buffer_or_string_accessible_end_byte (obj); |
| 2826 | |
| 2827 if (!bel || !extent_list_num_els (bel)) | |
| 428 | 2828 return limit; |
| 2829 | |
| 2830 sel = buffer_or_string_stack_of_extents_force (obj)->extents; | |
| 2831 soe_move (obj, mempos); | |
| 2832 | |
| 2833 /* Find the first start position after POS. */ | |
| 2834 elind1 = extent_list_locate_from_pos (bel, mempos+1, 0); | |
| 2835 if (elind1 < extent_list_num_els (bel)) | |
| 826 | 2836 pos1 = buffer_or_string_memxpos_to_bytexpos |
| 428 | 2837 (obj, extent_start (extent_list_at (bel, elind1, 0))); |
| 2838 else | |
| 2839 pos1 = limit; | |
| 2840 | |
| 2841 /* Find the first end position after POS. The extent corresponding | |
| 2842 to this position is either in the SOE or is greater than or | |
| 2843 equal to POS1, so we just have to look in the SOE. */ | |
| 2844 elind2 = extent_list_locate_from_pos (sel, mempos+1, 1); | |
| 2845 if (elind2 < extent_list_num_els (sel)) | |
| 826 | 2846 pos2 = buffer_or_string_memxpos_to_bytexpos |
| 428 | 2847 (obj, extent_end (extent_list_at (sel, elind2, 1))); |
| 2848 else | |
| 2849 pos2 = limit; | |
| 2850 | |
| 2851 return min (min (pos1, pos2), limit); | |
| 2852 } | |
| 2853 | |
| 826 | 2854 static Bytexpos |
| 2855 extent_find_beginning_of_run (Lisp_Object obj, Bytexpos pos, | |
| 428 | 2856 int outside_accessible) |
| 2857 { | |
| 2858 Extent_List *sel; | |
| 2859 Extent_List *bel = buffer_or_string_extent_list (obj); | |
| 826 | 2860 Bytexpos pos1, pos2; |
| 428 | 2861 int elind1, elind2; |
| 826 | 2862 Memxpos mempos = buffer_or_string_bytexpos_to_memxpos (obj, pos); |
| 2863 Bytexpos limit = outside_accessible ? | |
| 428 | 2864 buffer_or_string_absolute_begin_byte (obj) : |
| 826 | 2865 buffer_or_string_accessible_begin_byte (obj); |
| 428 | 2866 |
| 2867 if (!bel || !extent_list_num_els(bel)) | |
| 2868 return limit; | |
| 2869 | |
| 2870 sel = buffer_or_string_stack_of_extents_force (obj)->extents; | |
| 2871 soe_move (obj, mempos); | |
| 2872 | |
| 2873 /* Find the first end position before POS. */ | |
| 2874 elind1 = extent_list_locate_from_pos (bel, mempos, 1); | |
| 2875 if (elind1 > 0) | |
| 826 | 2876 pos1 = buffer_or_string_memxpos_to_bytexpos |
| 428 | 2877 (obj, extent_end (extent_list_at (bel, elind1 - 1, 1))); |
| 2878 else | |
| 2879 pos1 = limit; | |
| 2880 | |
| 2881 /* Find the first start position before POS. The extent corresponding | |
| 2882 to this position is either in the SOE or is less than or | |
| 2883 equal to POS1, so we just have to look in the SOE. */ | |
| 2884 elind2 = extent_list_locate_from_pos (sel, mempos, 0); | |
| 2885 if (elind2 > 0) | |
| 826 | 2886 pos2 = buffer_or_string_memxpos_to_bytexpos |
| 428 | 2887 (obj, extent_start (extent_list_at (sel, elind2 - 1, 0))); |
| 2888 else | |
| 2889 pos2 = limit; | |
| 2890 | |
| 2891 return max (max (pos1, pos2), limit); | |
| 2892 } | |
| 2893 | |
| 2894 struct extent_fragment * | |
| 2895 extent_fragment_new (Lisp_Object buffer_or_string, struct frame *frm) | |
| 2896 { | |
| 2897 struct extent_fragment *ef = xnew_and_zero (struct extent_fragment); | |
| 2898 | |
| 2899 ef->object = buffer_or_string; | |
| 2900 ef->frm = frm; | |
| 2901 ef->extents = Dynarr_new (EXTENT); | |
| 2902 ef->begin_glyphs = Dynarr_new (glyph_block); | |
| 2903 ef->end_glyphs = Dynarr_new (glyph_block); | |
| 2904 | |
| 2905 return ef; | |
| 2906 } | |
| 2907 | |
| 2908 void | |
| 2909 extent_fragment_delete (struct extent_fragment *ef) | |
| 2910 { | |
| 2911 Dynarr_free (ef->extents); | |
| 2912 Dynarr_free (ef->begin_glyphs); | |
| 2913 Dynarr_free (ef->end_glyphs); | |
|
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4967
diff
changeset
|
2914 xfree (ef); |
| 428 | 2915 } |
| 2916 | |
| 2917 static int | |
| 2918 extent_priority_sort_function (const void *humpty, const void *dumpty) | |
| 2919 { | |
| 442 | 2920 const EXTENT foo = * (const EXTENT *) humpty; |
| 2921 const EXTENT bar = * (const EXTENT *) dumpty; | |
| 428 | 2922 if (extent_priority (foo) < extent_priority (bar)) |
| 2923 return -1; | |
| 2924 return extent_priority (foo) > extent_priority (bar); | |
| 2925 } | |
| 2926 | |
| 2927 static void | |
| 2928 extent_fragment_sort_by_priority (EXTENT_dynarr *extarr) | |
| 2929 { | |
| 2930 int i; | |
| 2931 | |
| 2932 /* Sort our copy of the stack by extent_priority. We use a bubble | |
| 2933 sort here because it's going to be faster than qsort() for small | |
| 2934 numbers of extents (less than 10 or so), and 99.999% of the time | |
| 2935 there won't ever be more extents than this in the stack. */ | |
| 2936 if (Dynarr_length (extarr) < 10) | |
| 2937 { | |
| 2938 for (i = 1; i < Dynarr_length (extarr); i++) | |
| 2939 { | |
| 2940 int j = i - 1; | |
| 2941 while (j >= 0 && | |
| 2942 (extent_priority (Dynarr_at (extarr, j)) > | |
| 2943 extent_priority (Dynarr_at (extarr, j+1)))) | |
| 2944 { | |
| 2945 EXTENT tmp = Dynarr_at (extarr, j); | |
| 2946 Dynarr_at (extarr, j) = Dynarr_at (extarr, j+1); | |
| 2947 Dynarr_at (extarr, j+1) = tmp; | |
| 2948 j--; | |
| 2949 } | |
| 2950 } | |
| 2951 } | |
| 2952 else | |
| 2953 /* But some loser programs mess up and may create a large number | |
| 2954 of extents overlapping the same spot. This will result in | |
| 2955 catastrophic behavior if we use the bubble sort above. */ | |
| 4967 | 2956 qsort (Dynarr_begin (extarr), Dynarr_length (extarr), |
| 428 | 2957 sizeof (EXTENT), extent_priority_sort_function); |
| 2958 } | |
| 2959 | |
| 2960 /* If PROP is the `invisible' property of an extent, | |
| 2961 this is 1 if the extent should be treated as invisible. */ | |
| 2962 | |
| 2963 #define EXTENT_PROP_MEANS_INVISIBLE(buf, prop) \ | |
| 2964 (EQ (buf->invisibility_spec, Qt) \ | |
| 2965 ? ! NILP (prop) \ | |
| 2966 : invisible_p (prop, buf->invisibility_spec)) | |
| 2967 | |
| 2968 /* If PROP is the `invisible' property of a extent, | |
| 2969 this is 1 if the extent should be treated as invisible | |
| 2970 and should have an ellipsis. */ | |
| 2971 | |
| 2972 #define EXTENT_PROP_MEANS_INVISIBLE_WITH_ELLIPSIS(buf, prop) \ | |
| 2973 (EQ (buf->invisibility_spec, Qt) \ | |
| 2974 ? 0 \ | |
| 2975 : invisible_ellipsis_p (prop, buf->invisibility_spec)) | |
| 2976 | |
| 2977 /* This is like a combination of memq and assq. | |
| 2978 Return 1 if PROPVAL appears as an element of LIST | |
| 2979 or as the car of an element of LIST. | |
| 2980 If PROPVAL is a list, compare each element against LIST | |
| 2981 in that way, and return 1 if any element of PROPVAL is found in LIST. | |
| 2982 Otherwise return 0. | |
| 2983 This function cannot quit. */ | |
| 2984 | |
| 2985 static int | |
| 2986 invisible_p (REGISTER Lisp_Object propval, Lisp_Object list) | |
| 2987 { | |
| 2988 REGISTER Lisp_Object tail, proptail; | |
| 2989 for (tail = list; CONSP (tail); tail = XCDR (tail)) | |
| 2990 { | |
| 2991 REGISTER Lisp_Object tem; | |
| 2992 tem = XCAR (tail); | |
| 2993 if (EQ (propval, tem)) | |
| 2994 return 1; | |
| 2995 if (CONSP (tem) && EQ (propval, XCAR (tem))) | |
| 2996 return 1; | |
| 2997 } | |
| 2998 if (CONSP (propval)) | |
| 2999 for (proptail = propval; CONSP (proptail); | |
| 3000 proptail = XCDR (proptail)) | |
| 3001 { | |
| 3002 Lisp_Object propelt; | |
| 3003 propelt = XCAR (proptail); | |
| 3004 for (tail = list; CONSP (tail); tail = XCDR (tail)) | |
| 3005 { | |
| 3006 REGISTER Lisp_Object tem; | |
| 3007 tem = XCAR (tail); | |
| 3008 if (EQ (propelt, tem)) | |
| 3009 return 1; | |
| 3010 if (CONSP (tem) && EQ (propelt, XCAR (tem))) | |
| 3011 return 1; | |
| 3012 } | |
| 3013 } | |
| 3014 return 0; | |
| 3015 } | |
| 3016 | |
| 3017 /* Return 1 if PROPVAL appears as the car of an element of LIST | |
| 3018 and the cdr of that element is non-nil. | |
| 3019 If PROPVAL is a list, check each element of PROPVAL in that way, | |
| 3020 and the first time some element is found, | |
| 3021 return 1 if the cdr of that element is non-nil. | |
| 3022 Otherwise return 0. | |
| 3023 This function cannot quit. */ | |
| 3024 | |
| 3025 static int | |
| 3026 invisible_ellipsis_p (REGISTER Lisp_Object propval, Lisp_Object list) | |
| 3027 { | |
| 3028 REGISTER Lisp_Object tail, proptail; | |
| 3029 for (tail = list; CONSP (tail); tail = XCDR (tail)) | |
| 3030 { | |
| 3031 REGISTER Lisp_Object tem; | |
| 3032 tem = XCAR (tail); | |
| 3033 if (CONSP (tem) && EQ (propval, XCAR (tem))) | |
| 3034 return ! NILP (XCDR (tem)); | |
| 3035 } | |
| 3036 if (CONSP (propval)) | |
| 3037 for (proptail = propval; CONSP (proptail); | |
| 3038 proptail = XCDR (proptail)) | |
| 3039 { | |
| 3040 Lisp_Object propelt; | |
| 3041 propelt = XCAR (proptail); | |
| 3042 for (tail = list; CONSP (tail); tail = XCDR (tail)) | |
| 3043 { | |
| 3044 REGISTER Lisp_Object tem; | |
| 3045 tem = XCAR (tail); | |
| 3046 if (CONSP (tem) && EQ (propelt, XCAR (tem))) | |
| 3047 return ! NILP (XCDR (tem)); | |
| 3048 } | |
| 3049 } | |
| 3050 return 0; | |
| 3051 } | |
| 3052 | |
| 3053 face_index | |
| 3054 extent_fragment_update (struct window *w, struct extent_fragment *ef, | |
| 826 | 3055 Bytexpos pos, Lisp_Object last_glyph) |
| 428 | 3056 { |
| 3057 int i; | |
| 819 | 3058 int seen_glyph = NILP (last_glyph) ? 1 : 0; |
| 428 | 3059 Extent_List *sel = |
| 3060 buffer_or_string_stack_of_extents_force (ef->object)->extents; | |
| 3061 EXTENT lhe = 0; | |
| 3062 struct extent dummy_lhe_extent; | |
| 826 | 3063 Memxpos mempos = buffer_or_string_bytexpos_to_memxpos (ef->object, pos); |
| 428 | 3064 |
| 3065 #ifdef ERROR_CHECK_EXTENTS | |
| 3066 assert (pos >= buffer_or_string_accessible_begin_byte (ef->object) | |
| 3067 && pos <= buffer_or_string_accessible_end_byte (ef->object)); | |
| 3068 #endif | |
| 3069 | |
| 3070 Dynarr_reset (ef->extents); | |
| 3071 Dynarr_reset (ef->begin_glyphs); | |
| 3072 Dynarr_reset (ef->end_glyphs); | |
| 3073 | |
| 3074 ef->previously_invisible = ef->invisible; | |
| 3075 if (ef->invisible) | |
| 3076 { | |
| 3077 if (ef->invisible_ellipses) | |
| 3078 ef->invisible_ellipses_already_displayed = 1; | |
| 3079 } | |
| 3080 else | |
| 3081 ef->invisible_ellipses_already_displayed = 0; | |
| 3082 ef->invisible = 0; | |
| 3083 ef->invisible_ellipses = 0; | |
| 3084 | |
| 3085 /* Set up the begin and end positions. */ | |
| 3086 ef->pos = pos; | |
| 3087 ef->end = extent_find_end_of_run (ef->object, pos, 0); | |
| 3088 | |
| 3089 /* Note that extent_find_end_of_run() already moved the SOE for us. */ | |
| 3090 /* soe_move (ef->object, mempos); */ | |
| 3091 | |
| 3092 /* Determine the begin glyphs at POS. */ | |
| 3093 for (i = 0; i < extent_list_num_els (sel); i++) | |
| 3094 { | |
| 3095 EXTENT e = extent_list_at (sel, i, 0); | |
| 3096 if (extent_start (e) == mempos && !NILP (extent_begin_glyph (e))) | |
| 3097 { | |
| 3098 Lisp_Object glyph = extent_begin_glyph (e); | |
| 4932 | 3099 if (seen_glyph) |
| 3100 { | |
| 3101 struct glyph_block gb; | |
| 3102 | |
| 3103 xzero (gb); | |
| 3104 gb.glyph = glyph; | |
| 3105 gb.extent = wrap_extent (e); | |
| 3106 Dynarr_add (ef->begin_glyphs, gb); | |
| 3107 } | |
| 819 | 3108 else if (EQ (glyph, last_glyph)) |
| 3109 seen_glyph = 1; | |
| 428 | 3110 } |
| 3111 } | |
| 3112 | |
| 3113 /* Determine the end glyphs at POS. */ | |
| 3114 for (i = 0; i < extent_list_num_els (sel); i++) | |
| 3115 { | |
| 3116 EXTENT e = extent_list_at (sel, i, 1); | |
| 3117 if (extent_end (e) == mempos && !NILP (extent_end_glyph (e))) | |
| 3118 { | |
| 3119 Lisp_Object glyph = extent_end_glyph (e); | |
| 4932 | 3120 if (seen_glyph) |
| 3121 { | |
| 3122 struct glyph_block gb; | |
| 3123 | |
| 3124 xzero (gb); | |
| 3125 gb.glyph = glyph; | |
| 3126 gb.extent = wrap_extent (e); | |
| 3127 Dynarr_add (ef->end_glyphs, gb); | |
| 3128 } | |
| 819 | 3129 else if (EQ (glyph, last_glyph)) |
| 3130 seen_glyph = 1; | |
| 428 | 3131 } |
| 3132 } | |
| 3133 | |
| 3134 /* We tried determining all the charsets used in the run here, | |
| 3135 but that fails even if we only do the current line -- display | |
| 3136 tables or non-printable characters might cause other charsets | |
| 3137 to be used. */ | |
| 3138 | |
| 3139 /* Determine whether the last-highlighted-extent is present. */ | |
| 3140 if (EXTENTP (Vlast_highlighted_extent)) | |
| 3141 lhe = XEXTENT (Vlast_highlighted_extent); | |
| 3142 | |
| 3143 /* Now add all extents that overlap the character after POS and | |
| 3144 have a non-nil face. Also check if the character is invisible. */ | |
| 3145 for (i = 0; i < extent_list_num_els (sel); i++) | |
| 3146 { | |
| 3147 EXTENT e = extent_list_at (sel, i, 0); | |
| 3148 if (extent_end (e) > mempos) | |
| 3149 { | |
| 3150 Lisp_Object invis_prop = extent_invisible (e); | |
| 3151 | |
| 3152 if (!NILP (invis_prop)) | |
| 3153 { | |
| 3154 if (!BUFFERP (ef->object)) | |
| 3155 /* #### no `string-invisibility-spec' */ | |
| 3156 ef->invisible = 1; | |
| 3157 else | |
| 3158 { | |
| 3159 if (!ef->invisible_ellipses_already_displayed && | |
| 3160 EXTENT_PROP_MEANS_INVISIBLE_WITH_ELLIPSIS | |
| 3161 (XBUFFER (ef->object), invis_prop)) | |
| 3162 { | |
| 3163 ef->invisible = 1; | |
| 3164 ef->invisible_ellipses = 1; | |
| 3165 } | |
| 3166 else if (EXTENT_PROP_MEANS_INVISIBLE | |
| 3167 (XBUFFER (ef->object), invis_prop)) | |
| 3168 ef->invisible = 1; | |
| 3169 } | |
| 3170 } | |
| 3171 | |
| 3172 /* Remember that one of the extents in the list might be our | |
| 3173 dummy extent representing the highlighting that is | |
| 3174 attached to some other extent that is currently | |
| 3175 mouse-highlighted. When an extent is mouse-highlighted, | |
| 3176 it is as if there are two extents there, of potentially | |
| 3177 different priorities: the extent being highlighted, with | |
| 3178 whatever face and priority it has; and an ephemeral | |
| 3179 extent in the `mouse-face' face with | |
| 3180 `mouse-highlight-priority'. | |
| 3181 */ | |
| 3182 | |
| 3183 if (!NILP (extent_face (e))) | |
| 3184 Dynarr_add (ef->extents, e); | |
| 3185 if (e == lhe) | |
| 3186 { | |
| 3187 Lisp_Object f; | |
| 3188 /* zeroing isn't really necessary; we only deref `priority' | |
| 3189 and `face' */ | |
| 3190 xzero (dummy_lhe_extent); | |
| 3191 set_extent_priority (&dummy_lhe_extent, | |
| 3192 mouse_highlight_priority); | |
| 3193 /* Need to break up the following expression, due to an */ | |
| 3194 /* error in the Digital UNIX 3.2g C compiler (Digital */ | |
| 3195 /* UNIX Compiler Driver 3.11). */ | |
| 3196 f = extent_mouse_face (lhe); | |
| 3197 extent_face (&dummy_lhe_extent) = f; | |
| 3198 Dynarr_add (ef->extents, &dummy_lhe_extent); | |
| 3199 } | |
| 3200 /* since we are looping anyway, we might as well do this here */ | |
| 3201 if ((!NILP(extent_initial_redisplay_function (e))) && | |
| 3202 !extent_in_red_event_p(e)) | |
| 3203 { | |
| 3204 Lisp_Object function = extent_initial_redisplay_function (e); | |
| 3205 Lisp_Object obj; | |
| 3206 | |
|
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
|
3207 /* stderr_out ("initial redisplay function called!\n "); */ |
|
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
|
3208 |
|
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
|
3209 /* debug_print (wrap_extent (e)); |
|
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
|
3210 stderr_out ("\n"); */ |
| 428 | 3211 |
| 3212 /* FIXME: One should probably inhibit the displaying of | |
| 3213 this extent to reduce flicker */ | |
| 793 | 3214 extent_in_red_event_p (e) = 1; |
| 428 | 3215 |
| 3216 /* call the function */ | |
| 793 | 3217 obj = wrap_extent (e); |
| 3218 if (!NILP (function)) | |
| 3219 Fenqueue_eval_event (function, obj); | |
| 428 | 3220 } |
| 3221 } | |
| 3222 } | |
| 3223 | |
| 3224 extent_fragment_sort_by_priority (ef->extents); | |
| 3225 | |
| 3226 /* Now merge the faces together into a single face. The code to | |
| 3227 do this is in faces.c because it involves manipulating faces. */ | |
| 3228 return get_extent_fragment_face_cache_index (w, ef); | |
| 3229 } | |
| 3230 | |
| 3231 | |
| 3232 /************************************************************************/ | |
| 3233 /* extent-object methods */ | |
| 3234 /************************************************************************/ | |
| 3235 | |
| 3236 /* These are the basic helper functions for handling the allocation of | |
| 3237 extent objects. They are similar to the functions for other | |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
3238 frob-block objects. allocate_extent() is in alloc.c, not here. */ |
| 428 | 3239 |
| 3240 static Lisp_Object | |
| 3241 mark_extent (Lisp_Object obj) | |
| 3242 { | |
| 3243 struct extent *extent = XEXTENT (obj); | |
| 3244 | |
| 3245 mark_object (extent_object (extent)); | |
| 3246 mark_object (extent_no_chase_normal_field (extent, face)); | |
| 3247 return extent->plist; | |
| 3248 } | |
| 3249 | |
| 3250 static void | |
| 2286 | 3251 print_extent_1 (Lisp_Object obj, Lisp_Object printcharfun, |
| 3252 int UNUSED (escapeflag)) | |
| 428 | 3253 { |
| 3254 EXTENT ext = XEXTENT (obj); | |
| 3255 EXTENT anc = extent_ancestor (ext); | |
| 3256 Lisp_Object tail; | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
3257 Ascbyte buf[64], *bp = buf; |
| 428 | 3258 |
| 3259 /* Retrieve the ancestor and use it, for faster retrieval of properties */ | |
| 3260 | |
| 3261 if (!NILP (extent_begin_glyph (anc))) *bp++ = '*'; | |
| 3262 *bp++ = (extent_start_open_p (anc) ? '(': '['); | |
| 3263 if (extent_detached_p (ext)) | |
| 3264 strcpy (bp, "detached"); | |
| 3265 else | |
| 826 | 3266 sprintf (bp, "%ld, %ld", |
| 819 | 3267 XINT (Fextent_start_position (obj)), |
| 3268 XINT (Fextent_end_position (obj))); | |
| 428 | 3269 bp += strlen (bp); |
| 3270 *bp++ = (extent_end_open_p (anc) ? ')': ']'); | |
| 3271 if (!NILP (extent_end_glyph (anc))) *bp++ = '*'; | |
| 3272 *bp++ = ' '; | |
| 3273 | |
| 3274 if (!NILP (extent_read_only (anc))) *bp++ = '%'; | |
| 3275 if (!NILP (extent_mouse_face (anc))) *bp++ = 'H'; | |
| 3276 if (extent_unique_p (anc)) *bp++ = 'U'; | |
| 3277 else if (extent_duplicable_p (anc)) *bp++ = 'D'; | |
| 3278 if (!NILP (extent_invisible (anc))) *bp++ = 'I'; | |
| 3279 | |
| 3280 if (!NILP (extent_read_only (anc)) || !NILP (extent_mouse_face (anc)) || | |
| 3281 extent_unique_p (anc) || | |
| 3282 extent_duplicable_p (anc) || !NILP (extent_invisible (anc))) | |
| 3283 *bp++ = ' '; | |
| 3284 *bp = '\0'; | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
3285 write_ascstring (printcharfun, buf); |
| 428 | 3286 |
| 3287 tail = extent_plist_slot (anc); | |
| 3288 | |
| 3289 for (; !NILP (tail); tail = Fcdr (Fcdr (tail))) | |
| 3290 { | |
| 3291 Lisp_Object v = XCAR (XCDR (tail)); | |
| 3292 if (NILP (v)) continue; | |
| 800 | 3293 write_fmt_string_lisp (printcharfun, "%S ", 1, XCAR (tail)); |
| 428 | 3294 } |
| 3295 } | |
| 3296 | |
| 3297 static void | |
| 3298 print_extent (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) | |
| 3299 { | |
| 3300 if (escapeflag) | |
| 3301 { | |
| 442 | 3302 const char *title = ""; |
| 3303 const char *name = ""; | |
| 3304 const char *posttitle = ""; | |
| 428 | 3305 Lisp_Object obj2 = Qnil; |
| 3306 | |
| 3307 /* Destroyed extents have 't' in the object field, causing | |
| 2500 | 3308 extent_object() to ABORT (maybe). */ |
| 428 | 3309 if (EXTENT_LIVE_P (XEXTENT (obj))) |
| 3310 obj2 = extent_object (XEXTENT (obj)); | |
| 3311 | |
| 3312 if (NILP (obj2)) | |
| 3313 title = "no buffer"; | |
| 3314 else if (BUFFERP (obj2)) | |
| 3315 { | |
| 3316 if (BUFFER_LIVE_P (XBUFFER (obj2))) | |
| 3317 { | |
| 3318 title = "buffer "; | |
| 3319 name = (char *) XSTRING_DATA (XBUFFER (obj2)->name); | |
| 3320 } | |
| 3321 else | |
| 3322 { | |
| 3323 title = "Killed Buffer"; | |
| 3324 name = ""; | |
| 3325 } | |
| 3326 } | |
| 3327 else | |
| 3328 { | |
| 3329 assert (STRINGP (obj2)); | |
| 3330 title = "string \""; | |
| 3331 posttitle = "\""; | |
| 3332 name = (char *) XSTRING_DATA (obj2); | |
| 3333 } | |
| 3334 | |
| 3335 if (print_readably) | |
| 3336 { | |
| 3337 if (!EXTENT_LIVE_P (XEXTENT (obj))) | |
|
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
|
3338 printing_unreadable_object_fmt ("#<destroyed extent 0x%x>", |
|
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
|
3339 LISP_OBJECT_UID (obj)); |
| 428 | 3340 else |
|
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
|
3341 printing_unreadable_object_fmt ("#<extent 0x%x>", |
|
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
|
3342 LISP_OBJECT_UID (obj)); |
| 428 | 3343 } |
| 3344 | |
| 3345 if (!EXTENT_LIVE_P (XEXTENT (obj))) | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
3346 write_ascstring (printcharfun, "#<destroyed extent"); |
| 428 | 3347 else |
| 3348 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
3349 write_ascstring (printcharfun, "#<extent "); |
| 428 | 3350 print_extent_1 (obj, printcharfun, escapeflag); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
3351 write_ascstring (printcharfun, extent_detached_p (XEXTENT (obj)) |
|
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
|
3352 ? "from " : "in "); |
| 800 | 3353 write_fmt_string (printcharfun, "%s%s%s", title, name, posttitle); |
| 428 | 3354 } |
| 3355 } | |
| 3356 else | |
| 3357 { | |
| 3358 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
|
3359 printing_unreadable_object_fmt ("#<extent 0x%x>", |
|
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
|
3360 LISP_OBJECT_UID (obj)); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
3361 write_ascstring (printcharfun, "#<extent"); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
3362 } |
|
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
|
3363 |
|
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
|
3364 write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); |
| 428 | 3365 } |
| 3366 | |
| 3367 static int | |
| 3368 properties_equal (EXTENT e1, EXTENT e2, int depth) | |
| 3369 { | |
| 3370 /* When this function is called, all indirections have been followed. | |
| 3371 Thus, the indirection checks in the various macros below will not | |
| 3372 amount to anything, and could be removed. However, the time | |
| 3373 savings would probably not be significant. */ | |
| 3374 if (!(EQ (extent_face (e1), extent_face (e2)) && | |
| 3375 extent_priority (e1) == extent_priority (e2) && | |
| 3376 internal_equal (extent_begin_glyph (e1), extent_begin_glyph (e2), | |
| 3377 depth + 1) && | |
| 3378 internal_equal (extent_end_glyph (e1), extent_end_glyph (e2), | |
| 3379 depth + 1))) | |
| 3380 return 0; | |
| 3381 | |
| 3382 /* compare the bit flags. */ | |
| 3383 { | |
| 3384 /* The has_aux field should not be relevant. */ | |
| 3385 int e1_has_aux = e1->flags.has_aux; | |
| 3386 int e2_has_aux = e2->flags.has_aux; | |
| 3387 int value; | |
| 3388 | |
| 3389 e1->flags.has_aux = e2->flags.has_aux = 0; | |
| 3390 value = memcmp (&e1->flags, &e2->flags, sizeof (e1->flags)); | |
| 3391 e1->flags.has_aux = e1_has_aux; | |
| 3392 e2->flags.has_aux = e2_has_aux; | |
| 3393 if (value) | |
| 3394 return 0; | |
| 3395 } | |
| 3396 | |
| 3397 /* compare the random elements of the plists. */ | |
| 3398 return !plists_differ (extent_no_chase_plist (e1), | |
| 3399 extent_no_chase_plist (e2), | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4117
diff
changeset
|
3400 0, 0, depth + 1, 0); |
| 428 | 3401 } |
| 3402 | |
| 3403 static int | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4117
diff
changeset
|
3404 extent_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4117
diff
changeset
|
3405 int UNUSED (foldcase)) |
| 428 | 3406 { |
| 3407 struct extent *e1 = XEXTENT (obj1); | |
| 3408 struct extent *e2 = XEXTENT (obj2); | |
| 3409 return | |
| 3410 (extent_start (e1) == extent_start (e2) && | |
| 3411 extent_end (e1) == extent_end (e2) && | |
| 3412 internal_equal (extent_object (e1), extent_object (e2), depth + 1) && | |
| 3413 properties_equal (extent_ancestor (e1), extent_ancestor (e2), | |
| 3414 depth)); | |
| 3415 } | |
| 3416 | |
| 665 | 3417 static Hashcode |
| 428 | 3418 extent_hash (Lisp_Object obj, int depth) |
| 3419 { | |
| 3420 struct extent *e = XEXTENT (obj); | |
| 3421 /* No need to hash all of the elements; that would take too long. | |
| 3422 Just hash the most common ones. */ | |
| 3423 return HASH3 (extent_start (e), extent_end (e), | |
| 3424 internal_hash (extent_object (e), depth + 1)); | |
| 3425 } | |
| 3426 | |
| 1204 | 3427 static const struct memory_description extent_description[] = { |
| 442 | 3428 { XD_LISP_OBJECT, offsetof (struct extent, object) }, |
| 3429 { XD_LISP_OBJECT, offsetof (struct extent, flags.face) }, | |
| 3430 { XD_LISP_OBJECT, offsetof (struct extent, plist) }, | |
| 3431 { XD_END } | |
| 3432 }; | |
| 3433 | |
| 428 | 3434 static Lisp_Object |
| 3435 extent_getprop (Lisp_Object obj, Lisp_Object prop) | |
| 3436 { | |
| 3437 return Fextent_property (obj, prop, Qunbound); | |
| 3438 } | |
| 3439 | |
| 3440 static int | |
| 3441 extent_putprop (Lisp_Object obj, Lisp_Object prop, Lisp_Object value) | |
| 3442 { | |
| 3443 Fset_extent_property (obj, prop, value); | |
| 3444 return 1; | |
| 3445 } | |
| 3446 | |
| 3447 static int | |
| 3448 extent_remprop (Lisp_Object obj, Lisp_Object prop) | |
| 3449 { | |
| 826 | 3450 Lisp_Object retval = Fset_extent_property (obj, prop, Qunbound); |
| 3451 if (UNBOUNDP (retval)) | |
| 3452 return -1; | |
| 3453 else if (!NILP (retval)) | |
| 3454 return 1; | |
| 3455 else | |
| 3456 return 0; | |
| 428 | 3457 } |
| 3458 | |
| 3459 static Lisp_Object | |
| 3460 extent_plist (Lisp_Object obj) | |
| 3461 { | |
| 3462 return Fextent_properties (obj); | |
| 3463 } | |
| 3464 | |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5147
diff
changeset
|
3465 DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("extent", extent, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5147
diff
changeset
|
3466 mark_extent, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5147
diff
changeset
|
3467 print_extent, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5147
diff
changeset
|
3468 /* NOTE: If you declare a |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5147
diff
changeset
|
3469 finalization method here, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5147
diff
changeset
|
3470 it will NOT be called. |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5147
diff
changeset
|
3471 Shaft city. */ |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5147
diff
changeset
|
3472 0, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5147
diff
changeset
|
3473 extent_equal, extent_hash, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5147
diff
changeset
|
3474 extent_description, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5147
diff
changeset
|
3475 struct extent); |
| 428 | 3476 |
| 3477 /************************************************************************/ | |
| 3478 /* basic extent accessors */ | |
| 3479 /************************************************************************/ | |
| 3480 | |
| 3481 /* These functions are for checking externally-passed extent objects | |
| 3482 and returning an extent's basic properties, which include the | |
| 3483 buffer the extent is associated with, the endpoints of the extent's | |
| 3484 range, the open/closed-ness of those endpoints, and whether the | |
| 3485 extent is detached. Manipulating these properties requires | |
| 3486 manipulating the ordered lists that hold extents; thus, functions | |
| 3487 to do that are in a later section. */ | |
| 3488 | |
| 3489 /* Given a Lisp_Object that is supposed to be an extent, make sure it | |
| 3490 is OK and return an extent pointer. Extents can be in one of four | |
| 3491 states: | |
| 3492 | |
| 3493 1) destroyed | |
| 3494 2) detached and not associated with a buffer | |
| 3495 3) detached and associated with a buffer | |
| 3496 4) attached to a buffer | |
| 3497 | |
| 3498 If FLAGS is 0, types 2-4 are allowed. If FLAGS is DE_MUST_HAVE_BUFFER, | |
| 3499 types 3-4 are allowed. If FLAGS is DE_MUST_BE_ATTACHED, only type 4 | |
| 3500 is allowed. | |
| 3501 */ | |
| 3502 | |
| 3503 static EXTENT | |
| 3504 decode_extent (Lisp_Object extent_obj, unsigned int flags) | |
| 3505 { | |
| 3506 EXTENT extent; | |
| 3507 Lisp_Object obj; | |
| 3508 | |
| 3509 CHECK_LIVE_EXTENT (extent_obj); | |
| 3510 extent = XEXTENT (extent_obj); | |
| 3511 obj = extent_object (extent); | |
| 3512 | |
| 3513 /* the following condition will fail if we're dealing with a freed extent */ | |
| 3514 assert (NILP (obj) || BUFFERP (obj) || STRINGP (obj)); | |
| 3515 | |
| 3516 if (flags & DE_MUST_BE_ATTACHED) | |
| 3517 flags |= DE_MUST_HAVE_BUFFER; | |
| 3518 | |
| 3519 /* if buffer is dead, then convert extent to have no buffer. */ | |
| 3520 if (BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) | |
| 3521 obj = extent_object (extent) = Qnil; | |
| 3522 | |
| 3523 assert (!NILP (obj) || extent_detached_p (extent)); | |
| 3524 | |
| 3525 if ((NILP (obj) && (flags & DE_MUST_HAVE_BUFFER)) | |
| 3526 || (extent_detached_p (extent) && (flags & DE_MUST_BE_ATTACHED))) | |
| 3527 { | |
| 442 | 3528 invalid_argument ("extent doesn't belong to a buffer or string", |
| 3529 extent_obj); | |
| 428 | 3530 } |
| 3531 | |
| 3532 return extent; | |
| 3533 } | |
| 3534 | |
| 826 | 3535 /* Note that the returned value is a char position, not a byte position. */ |
| 428 | 3536 |
| 3537 static Lisp_Object | |
| 3538 extent_endpoint_external (Lisp_Object extent_obj, int endp) | |
| 3539 { | |
| 3540 EXTENT extent = decode_extent (extent_obj, 0); | |
| 3541 | |
| 3542 if (extent_detached_p (extent)) | |
| 3543 return Qnil; | |
| 3544 else | |
| 826 | 3545 return make_int (extent_endpoint_char (extent, endp)); |
| 428 | 3546 } |
| 3547 | |
| 3548 DEFUN ("extentp", Fextentp, 1, 1, 0, /* | |
| 3549 Return t if OBJECT is an extent. | |
| 3550 */ | |
| 3551 (object)) | |
| 3552 { | |
| 3553 return EXTENTP (object) ? Qt : Qnil; | |
| 3554 } | |
| 3555 | |
| 3556 DEFUN ("extent-live-p", Fextent_live_p, 1, 1, 0, /* | |
| 3557 Return t if OBJECT is an extent that has not been destroyed. | |
| 3558 */ | |
| 3559 (object)) | |
| 3560 { | |
| 3561 return EXTENTP (object) && EXTENT_LIVE_P (XEXTENT (object)) ? Qt : Qnil; | |
| 3562 } | |
| 3563 | |
| 3564 DEFUN ("extent-detached-p", Fextent_detached_p, 1, 1, 0, /* | |
| 3565 Return t if EXTENT is detached. | |
| 3566 */ | |
| 3567 (extent)) | |
| 3568 { | |
| 3569 return extent_detached_p (decode_extent (extent, 0)) ? Qt : Qnil; | |
| 3570 } | |
| 3571 | |
| 3572 DEFUN ("extent-object", Fextent_object, 1, 1, 0, /* | |
| 3573 Return object (buffer or string) that EXTENT refers to. | |
| 3574 */ | |
| 3575 (extent)) | |
| 3576 { | |
| 3577 return extent_object (decode_extent (extent, 0)); | |
| 3578 } | |
| 3579 | |
| 3580 DEFUN ("extent-start-position", Fextent_start_position, 1, 1, 0, /* | |
| 3581 Return start position of EXTENT, or nil if EXTENT is detached. | |
| 3582 */ | |
| 3583 (extent)) | |
| 3584 { | |
| 3585 return extent_endpoint_external (extent, 0); | |
| 3586 } | |
| 3587 | |
| 3588 DEFUN ("extent-end-position", Fextent_end_position, 1, 1, 0, /* | |
| 3589 Return end position of EXTENT, or nil if EXTENT is detached. | |
| 3590 */ | |
| 3591 (extent)) | |
| 3592 { | |
| 3593 return extent_endpoint_external (extent, 1); | |
| 3594 } | |
| 3595 | |
| 3596 DEFUN ("extent-length", Fextent_length, 1, 1, 0, /* | |
| 3597 Return length of EXTENT in characters. | |
| 3598 */ | |
| 3599 (extent)) | |
| 3600 { | |
| 3601 EXTENT e = decode_extent (extent, DE_MUST_BE_ATTACHED); | |
| 826 | 3602 return make_int (extent_endpoint_char (e, 1) |
| 3603 - extent_endpoint_char (e, 0)); | |
| 428 | 3604 } |
| 3605 | |
| 3606 DEFUN ("next-extent", Fnext_extent, 1, 1, 0, /* | |
| 3607 Find next extent after EXTENT. | |
| 3608 If EXTENT is a buffer return the first extent in the buffer; likewise | |
| 3609 for strings. | |
| 3610 Extents in a buffer are ordered in what is called the "display" | |
| 3611 order, which sorts by increasing start positions and then by *decreasing* | |
| 3612 end positions. | |
| 3613 If you want to perform an operation on a series of extents, use | |
| 3614 `map-extents' instead of this function; it is much more efficient. | |
| 3615 The primary use of this function should be to enumerate all the | |
| 3616 extents in a buffer. | |
| 3617 Note: The display order is not necessarily the order that `map-extents' | |
| 3618 processes extents in! | |
| 3619 */ | |
| 3620 (extent)) | |
| 3621 { | |
| 3622 EXTENT next; | |
| 3623 | |
| 3624 if (EXTENTP (extent)) | |
| 3625 next = extent_next (decode_extent (extent, DE_MUST_BE_ATTACHED)); | |
| 3626 else | |
| 3627 next = extent_first (decode_buffer_or_string (extent)); | |
| 3628 | |
| 3629 if (!next) | |
| 3630 return Qnil; | |
| 793 | 3631 return wrap_extent (next); |
| 428 | 3632 } |
| 3633 | |
| 3634 DEFUN ("previous-extent", Fprevious_extent, 1, 1, 0, /* | |
| 3635 Find last extent before EXTENT. | |
| 3636 If EXTENT is a buffer return the last extent in the buffer; likewise | |
| 3637 for strings. | |
| 3638 This function is analogous to `next-extent'. | |
| 3639 */ | |
| 3640 (extent)) | |
| 3641 { | |
| 3642 EXTENT prev; | |
| 3643 | |
| 3644 if (EXTENTP (extent)) | |
| 3645 prev = extent_previous (decode_extent (extent, DE_MUST_BE_ATTACHED)); | |
| 3646 else | |
| 3647 prev = extent_last (decode_buffer_or_string (extent)); | |
| 3648 | |
| 3649 if (!prev) | |
| 3650 return Qnil; | |
| 793 | 3651 return wrap_extent (prev); |
| 428 | 3652 } |
| 3653 | |
| 3654 #ifdef DEBUG_XEMACS | |
| 3655 | |
| 3656 DEFUN ("next-e-extent", Fnext_e_extent, 1, 1, 0, /* | |
| 3657 Find next extent after EXTENT using the "e" order. | |
| 3658 If EXTENT is a buffer return the first extent in the buffer; likewise | |
| 3659 for strings. | |
| 3660 */ | |
| 3661 (extent)) | |
| 3662 { | |
| 3663 EXTENT next; | |
| 3664 | |
| 3665 if (EXTENTP (extent)) | |
| 3666 next = extent_e_next (decode_extent (extent, DE_MUST_BE_ATTACHED)); | |
| 3667 else | |
| 3668 next = extent_e_first (decode_buffer_or_string (extent)); | |
| 3669 | |
| 3670 if (!next) | |
| 3671 return Qnil; | |
| 793 | 3672 return wrap_extent (next); |
| 428 | 3673 } |
| 3674 | |
| 3675 DEFUN ("previous-e-extent", Fprevious_e_extent, 1, 1, 0, /* | |
| 3676 Find last extent before EXTENT using the "e" order. | |
| 3677 If EXTENT is a buffer return the last extent in the buffer; likewise | |
| 3678 for strings. | |
| 3679 This function is analogous to `next-e-extent'. | |
| 3680 */ | |
| 3681 (extent)) | |
| 3682 { | |
| 3683 EXTENT prev; | |
| 3684 | |
| 3685 if (EXTENTP (extent)) | |
| 3686 prev = extent_e_previous (decode_extent (extent, DE_MUST_BE_ATTACHED)); | |
| 3687 else | |
| 3688 prev = extent_e_last (decode_buffer_or_string (extent)); | |
| 3689 | |
| 3690 if (!prev) | |
| 3691 return Qnil; | |
| 793 | 3692 return wrap_extent (prev); |
| 428 | 3693 } |
| 3694 | |
| 3695 #endif | |
| 3696 | |
| 3697 DEFUN ("next-extent-change", Fnext_extent_change, 1, 2, 0, /* | |
| 3698 Return the next position after POS where an extent begins or ends. | |
| 3699 If POS is at the end of the buffer or string, POS will be returned; | |
| 3700 otherwise a position greater than POS will always be returned. | |
| 444 | 3701 If OBJECT is nil, the current buffer is assumed. |
| 428 | 3702 */ |
| 3703 (pos, object)) | |
| 3704 { | |
| 3705 Lisp_Object obj = decode_buffer_or_string (object); | |
| 826 | 3706 Bytexpos xpos; |
| 3707 | |
| 3708 xpos = get_buffer_or_string_pos_byte (obj, pos, GB_ALLOW_PAST_ACCESSIBLE); | |
| 3709 xpos = extent_find_end_of_run (obj, xpos, 1); | |
| 3710 return make_int (buffer_or_string_bytexpos_to_charxpos (obj, xpos)); | |
| 428 | 3711 } |
| 3712 | |
| 3713 DEFUN ("previous-extent-change", Fprevious_extent_change, 1, 2, 0, /* | |
| 3714 Return the last position before POS where an extent begins or ends. | |
| 3715 If POS is at the beginning of the buffer or string, POS will be returned; | |
| 3716 otherwise a position less than POS will always be returned. | |
| 3717 If OBJECT is nil, the current buffer is assumed. | |
| 3718 */ | |
| 3719 (pos, object)) | |
| 3720 { | |
| 3721 Lisp_Object obj = decode_buffer_or_string (object); | |
| 826 | 3722 Bytexpos xpos; |
| 3723 | |
| 3724 xpos = get_buffer_or_string_pos_byte (obj, pos, GB_ALLOW_PAST_ACCESSIBLE); | |
| 3725 xpos = extent_find_beginning_of_run (obj, xpos, 1); | |
| 3726 return make_int (buffer_or_string_bytexpos_to_charxpos (obj, xpos)); | |
| 428 | 3727 } |
| 3728 | |
| 3729 | |
| 3730 /************************************************************************/ | |
| 3731 /* parent and children stuff */ | |
| 3732 /************************************************************************/ | |
| 3733 | |
| 3734 DEFUN ("extent-parent", Fextent_parent, 1, 1, 0, /* | |
| 3735 Return the parent (if any) of EXTENT. | |
| 3736 If an extent has a parent, it derives all its properties from that extent | |
| 3737 and has no properties of its own. (The only "properties" that the | |
| 3738 extent keeps are the buffer/string it refers to and the start and end | |
| 3739 points.) It is possible for an extent's parent to itself have a parent. | |
| 3740 */ | |
| 3741 (extent)) | |
| 3742 /* do I win the prize for the strangest split infinitive? */ | |
| 3743 { | |
| 3744 EXTENT e = decode_extent (extent, 0); | |
| 3745 return extent_parent (e); | |
| 3746 } | |
| 3747 | |
| 3748 DEFUN ("extent-children", Fextent_children, 1, 1, 0, /* | |
| 3749 Return a list of the children (if any) of EXTENT. | |
| 3750 The children of an extent are all those extents whose parent is that extent. | |
| 3751 This function does not recursively trace children of children. | |
| 3752 \(To do that, use `extent-descendants'.) | |
| 3753 */ | |
| 3754 (extent)) | |
| 3755 { | |
| 3756 EXTENT e = decode_extent (extent, 0); | |
| 3757 Lisp_Object children = extent_children (e); | |
| 3758 | |
| 3759 if (!NILP (children)) | |
| 3760 return Fcopy_sequence (XWEAK_LIST_LIST (children)); | |
| 3761 else | |
| 3762 return Qnil; | |
| 3763 } | |
| 3764 | |
| 3765 static void | |
| 3766 remove_extent_from_children_list (EXTENT e, Lisp_Object child) | |
| 3767 { | |
| 3768 Lisp_Object children = extent_children (e); | |
| 3769 | |
| 3770 #ifdef ERROR_CHECK_EXTENTS | |
| 3771 assert (!NILP (memq_no_quit (child, XWEAK_LIST_LIST (children)))); | |
| 3772 #endif | |
| 3773 XWEAK_LIST_LIST (children) = | |
| 3774 delq_no_quit (child, XWEAK_LIST_LIST (children)); | |
| 3775 } | |
| 3776 | |
| 3777 static void | |
| 3778 add_extent_to_children_list (EXTENT e, Lisp_Object child) | |
| 3779 { | |
| 3780 Lisp_Object children = extent_children (e); | |
| 3781 | |
| 3782 if (NILP (children)) | |
| 3783 { | |
| 3784 children = make_weak_list (WEAK_LIST_SIMPLE); | |
| 3785 set_extent_no_chase_aux_field (e, children, children); | |
| 3786 } | |
| 3787 | |
| 3788 #ifdef ERROR_CHECK_EXTENTS | |
| 3789 assert (NILP (memq_no_quit (child, XWEAK_LIST_LIST (children)))); | |
| 3790 #endif | |
| 3791 XWEAK_LIST_LIST (children) = Fcons (child, XWEAK_LIST_LIST (children)); | |
| 3792 } | |
| 3793 | |
| 826 | 3794 |
| 3795 static int | |
| 3796 compare_key_value_pairs (const void *humpty, const void *dumpty) | |
| 3797 { | |
| 3798 Lisp_Object_pair *foo = (Lisp_Object_pair *) humpty; | |
| 3799 Lisp_Object_pair *bar = (Lisp_Object_pair *) dumpty; | |
| 3800 if (EQ (foo->key, bar->key)) | |
| 3801 return 0; | |
| 3802 return !NILP (Fstring_lessp (foo->key, bar->key)) ? -1 : 1; | |
| 3803 } | |
| 3804 | |
| 428 | 3805 DEFUN ("set-extent-parent", Fset_extent_parent, 2, 2, 0, /* |
| 3806 Set the parent of EXTENT to PARENT (may be nil). | |
| 3807 See `extent-parent'. | |
| 3808 */ | |
| 3809 (extent, parent)) | |
| 3810 { | |
| 3811 EXTENT e = decode_extent (extent, 0); | |
| 3812 Lisp_Object cur_parent = extent_parent (e); | |
| 3813 Lisp_Object rest; | |
| 3814 | |
| 793 | 3815 extent = wrap_extent (e); |
| 428 | 3816 if (!NILP (parent)) |
| 3817 CHECK_LIVE_EXTENT (parent); | |
| 3818 if (EQ (parent, cur_parent)) | |
| 3819 return Qnil; | |
| 3820 for (rest = parent; !NILP (rest); rest = extent_parent (XEXTENT (rest))) | |
| 3821 if (EQ (rest, extent)) | |
| 563 | 3822 signal_error (Qinvalid_change, |
| 442 | 3823 "Circular parent chain would result", |
| 3824 extent); | |
| 428 | 3825 if (NILP (parent)) |
| 3826 { | |
| 3827 remove_extent_from_children_list (XEXTENT (cur_parent), extent); | |
| 3828 set_extent_no_chase_aux_field (e, parent, Qnil); | |
| 3829 e->flags.has_parent = 0; | |
| 3830 } | |
| 3831 else | |
| 3832 { | |
| 3833 add_extent_to_children_list (XEXTENT (parent), extent); | |
| 3834 set_extent_no_chase_aux_field (e, parent, parent); | |
| 3835 e->flags.has_parent = 1; | |
| 3836 } | |
| 3837 /* changing the parent also changes the properties of all children. */ | |
| 3838 { | |
| 826 | 3839 Lisp_Object_pair_dynarr *oldprops, *newprops; |
| 3840 int i, orignewlength; | |
| 3841 | |
| 3842 /* perhaps there's a smarter way, but the following will work, | |
| 3843 and it's O(N*log N): | |
| 3844 | |
| 3845 (1) get the old props. | |
| 3846 (2) get the new props. | |
| 3847 (3) sort both. | |
| 3848 (4) loop through old props; if key not in new, add it, with value | |
| 3849 Qunbound. | |
| 3850 (5) vice-versa for new props. | |
| 3851 (6) sort both again. | |
| 3852 (7) now we have identical lists of keys; we run through and compare | |
| 3853 the values. | |
| 3854 | |
| 3855 Of course in reality the number of properties will be low, so | |
| 3856 an N^2 algorithm wouldn't be a problem, but the stuff below is just | |
| 3857 as easy to write given the existence of qsort and bsearch. | |
| 3858 */ | |
| 3859 | |
| 3860 oldprops = Dynarr_new (Lisp_Object_pair); | |
| 3861 newprops = Dynarr_new (Lisp_Object_pair); | |
| 3862 if (!NILP (cur_parent)) | |
| 3863 extent_properties (XEXTENT (cur_parent), oldprops); | |
| 3864 if (!NILP (parent)) | |
| 3865 extent_properties (XEXTENT (parent), newprops); | |
| 3866 | |
| 4967 | 3867 qsort (Dynarr_begin (oldprops), Dynarr_length (oldprops), |
| 826 | 3868 sizeof (Lisp_Object_pair), compare_key_value_pairs); |
| 4967 | 3869 qsort (Dynarr_begin (newprops), Dynarr_length (newprops), |
| 826 | 3870 sizeof (Lisp_Object_pair), compare_key_value_pairs); |
| 3871 orignewlength = Dynarr_length (newprops); | |
| 3872 for (i = 0; i < Dynarr_length (oldprops); i++) | |
| 3873 { | |
| 4967 | 3874 if (!bsearch (Dynarr_atp (oldprops, i), Dynarr_begin (newprops), |
| 826 | 3875 Dynarr_length (newprops), sizeof (Lisp_Object_pair), |
| 3876 compare_key_value_pairs)) | |
| 3877 { | |
| 3025 | 3878 Lisp_Object_pair new_; |
| 3879 new_.key = Dynarr_at (oldprops, i).key; | |
| 3880 new_.value = Qunbound; | |
| 3881 Dynarr_add (newprops, new_); | |
| 826 | 3882 } |
| 3883 } | |
| 3884 for (i = 0; i < orignewlength; i++) | |
| 3885 { | |
| 859 | 3886 if (!Dynarr_length (oldprops) || !bsearch (Dynarr_atp (newprops, i), |
| 4967 | 3887 Dynarr_begin (oldprops), |
| 859 | 3888 Dynarr_length (oldprops), |
| 3889 sizeof (Lisp_Object_pair), | |
| 3890 compare_key_value_pairs)) | |
| 826 | 3891 { |
| 3025 | 3892 Lisp_Object_pair new_; |
| 3893 new_.key = Dynarr_at (newprops, i).key; | |
| 3894 new_.value = Qunbound; | |
| 3895 Dynarr_add (oldprops, new_); | |
| 826 | 3896 } |
| 3897 } | |
| 4967 | 3898 qsort (Dynarr_begin (oldprops), Dynarr_length (oldprops), |
| 826 | 3899 sizeof (Lisp_Object_pair), compare_key_value_pairs); |
| 4967 | 3900 qsort (Dynarr_begin (newprops), Dynarr_length (newprops), |
| 826 | 3901 sizeof (Lisp_Object_pair), compare_key_value_pairs); |
| 3902 for (i = 0; i < Dynarr_length (oldprops); i++) | |
| 3903 { | |
| 3904 assert (EQ (Dynarr_at (oldprops, i).key, Dynarr_at (newprops, i).key)); | |
| 3905 if (!EQ (Dynarr_at (oldprops, i).value, Dynarr_at (newprops, i).value)) | |
| 3906 signal_extent_property_changed (e, Dynarr_at (oldprops, i).key, 1); | |
| 3907 } | |
| 3908 | |
| 3909 Dynarr_free (oldprops); | |
| 3910 Dynarr_free (newprops); | |
| 3911 #if 0 | |
| 3912 { | |
| 428 | 3913 int old_invis = (!NILP (cur_parent) && |
| 3914 !NILP (extent_invisible (XEXTENT (cur_parent)))); | |
| 3915 int new_invis = (!NILP (parent) && | |
| 3916 !NILP (extent_invisible (XEXTENT (parent)))); | |
| 3917 | |
| 3918 extent_maybe_changed_for_redisplay (e, 1, new_invis != old_invis); | |
| 3919 } | |
| 826 | 3920 #endif /* 0 */ |
| 3921 } | |
| 428 | 3922 return Qnil; |
| 3923 } | |
| 3924 | |
| 3925 | |
| 3926 /************************************************************************/ | |
| 3927 /* basic extent mutators */ | |
| 3928 /************************************************************************/ | |
| 3929 | |
| 3930 /* Note: If you track non-duplicable extents by undo, you'll get bogus | |
| 3931 undo records for transient extents via update-extent. | |
| 3932 For example, query-replace will do this. | |
| 3933 */ | |
| 3934 | |
| 3935 static void | |
| 826 | 3936 set_extent_endpoints_1 (EXTENT extent, Memxpos start, Memxpos end) |
| 428 | 3937 { |
| 3938 #ifdef ERROR_CHECK_EXTENTS | |
| 3939 Lisp_Object obj = extent_object (extent); | |
| 3940 | |
| 3941 assert (start <= end); | |
| 3942 if (BUFFERP (obj)) | |
| 3943 { | |
| 665 | 3944 assert (valid_membpos_p (XBUFFER (obj), start)); |
| 3945 assert (valid_membpos_p (XBUFFER (obj), end)); | |
| 428 | 3946 } |
| 3947 #endif | |
| 3948 | |
| 3949 /* Optimization: if the extent is already where we want it to be, | |
| 3950 do nothing. */ | |
| 3951 if (!extent_detached_p (extent) && extent_start (extent) == start && | |
| 3952 extent_end (extent) == end) | |
| 3953 return; | |
| 3954 | |
| 3955 if (extent_detached_p (extent)) | |
| 3956 { | |
| 3957 if (extent_duplicable_p (extent)) | |
| 3958 { | |
| 793 | 3959 Lisp_Object extent_obj = wrap_extent (extent); |
| 3960 | |
| 428 | 3961 record_extent (extent_obj, 1); |
| 3962 } | |
| 3963 } | |
| 3964 else | |
| 3965 extent_detach (extent); | |
| 3966 | |
| 3967 set_extent_start (extent, start); | |
| 3968 set_extent_end (extent, end); | |
| 3969 extent_attach (extent); | |
| 3970 } | |
| 3971 | |
| 3972 /* Set extent's endpoints to S and E, and put extent in buffer or string | |
| 3973 OBJECT. (If OBJECT is nil, do not change the extent's object.) */ | |
| 3974 | |
| 3975 void | |
| 826 | 3976 set_extent_endpoints (EXTENT extent, Bytexpos s, Bytexpos e, |
| 3977 Lisp_Object object) | |
| 3978 { | |
| 3979 Memxpos start, end; | |
| 428 | 3980 |
| 3981 if (NILP (object)) | |
| 3982 { | |
| 3983 object = extent_object (extent); | |
| 3984 assert (!NILP (object)); | |
| 3985 } | |
| 3986 else if (!EQ (object, extent_object (extent))) | |
| 3987 { | |
| 3988 extent_detach (extent); | |
| 3989 extent_object (extent) = object; | |
| 3990 } | |
| 3991 | |
| 3992 start = s < 0 ? extent_start (extent) : | |
| 826 | 3993 buffer_or_string_bytexpos_to_memxpos (object, s); |
| 428 | 3994 end = e < 0 ? extent_end (extent) : |
| 826 | 3995 buffer_or_string_bytexpos_to_memxpos (object, e); |
| 428 | 3996 set_extent_endpoints_1 (extent, start, end); |
| 3997 } | |
| 3998 | |
| 3999 static void | |
| 4000 set_extent_openness (EXTENT extent, int start_open, int end_open) | |
| 4001 { | |
| 4002 if (start_open != -1) | |
| 826 | 4003 { |
| 4004 extent_start_open_p (extent) = start_open; | |
| 4005 signal_extent_property_changed (extent, Qstart_open, 1); | |
| 4006 } | |
| 428 | 4007 if (end_open != -1) |
| 826 | 4008 { |
| 4009 extent_end_open_p (extent) = end_open; | |
| 4010 signal_extent_property_changed (extent, Qend_open, 1); | |
| 4011 } | |
| 428 | 4012 } |
| 4013 | |
| 4014 static EXTENT | |
| 826 | 4015 make_extent (Lisp_Object object, Bytexpos from, Bytexpos to) |
| 428 | 4016 { |
| 4017 EXTENT extent; | |
| 4018 | |
| 4019 extent = make_extent_detached (object); | |
| 4020 set_extent_endpoints (extent, from, to, Qnil); | |
| 4021 return extent; | |
| 4022 } | |
| 4023 | |
| 826 | 4024 /* Copy ORIGINAL, changing it to span FROM,TO in OBJECT. */ |
| 4025 | |
| 428 | 4026 static EXTENT |
| 826 | 4027 copy_extent (EXTENT original, Bytexpos from, Bytexpos to, Lisp_Object object) |
| 428 | 4028 { |
| 4029 EXTENT e; | |
| 4030 | |
| 4031 e = make_extent_detached (object); | |
| 4032 if (from >= 0) | |
| 4033 set_extent_endpoints (e, from, to, Qnil); | |
| 4034 | |
| 4035 e->plist = Fcopy_sequence (original->plist); | |
| 4036 memcpy (&e->flags, &original->flags, sizeof (e->flags)); | |
| 4037 if (e->flags.has_aux) | |
| 4038 { | |
| 4039 /* also need to copy the aux struct. It won't work for | |
| 4040 this extent to share the same aux struct as the original | |
| 4041 one. */ | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
4042 Lisp_Object ea = ALLOC_NORMAL_LISP_OBJECT (extent_auxiliary); |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
4043 |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
4044 copy_lisp_object (ea, XCAR (original->plist)); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
4045 XCAR (e->plist) = ea; |
| 428 | 4046 } |
| 4047 | |
| 4048 { | |
| 4049 /* we may have just added another child to the parent extent. */ | |
| 4050 Lisp_Object parent = extent_parent (e); | |
| 4051 if (!NILP (parent)) | |
| 4052 { | |
| 793 | 4053 Lisp_Object extent = wrap_extent (e); |
| 4054 | |
| 428 | 4055 add_extent_to_children_list (XEXTENT (parent), extent); |
| 4056 } | |
| 4057 } | |
| 4058 | |
| 4059 return e; | |
| 4060 } | |
| 4061 | |
| 4062 static void | |
| 4063 destroy_extent (EXTENT extent) | |
| 4064 { | |
| 4065 Lisp_Object rest, nextrest, children; | |
| 4066 Lisp_Object extent_obj; | |
| 4067 | |
| 4068 if (!extent_detached_p (extent)) | |
| 4069 extent_detach (extent); | |
| 4070 /* disassociate the extent from its children and parent */ | |
| 4071 children = extent_children (extent); | |
| 4072 if (!NILP (children)) | |
| 4073 { | |
| 4074 LIST_LOOP_DELETING (rest, nextrest, XWEAK_LIST_LIST (children)) | |
| 4075 Fset_extent_parent (XCAR (rest), Qnil); | |
| 4076 } | |
| 793 | 4077 extent_obj = wrap_extent (extent); |
| 428 | 4078 Fset_extent_parent (extent_obj, Qnil); |
| 4079 /* mark the extent as destroyed */ | |
| 4080 extent_object (extent) = Qt; | |
| 4081 } | |
| 4082 | |
| 4083 DEFUN ("make-extent", Fmake_extent, 2, 3, 0, /* | |
| 4084 Make an extent for the range [FROM, TO) in BUFFER-OR-STRING. | |
| 4085 BUFFER-OR-STRING defaults to the current buffer. Insertions at point | |
| 4086 TO will be outside of the extent; insertions at FROM will be inside the | |
| 4087 extent, causing the extent to grow. (This is the same way that markers | |
| 4088 behave.) You can change the behavior of insertions at the endpoints | |
| 4089 using `set-extent-property'. The extent is initially detached if both | |
| 4090 FROM and TO are nil, and in this case BUFFER-OR-STRING defaults to nil, | |
| 4091 meaning the extent is in no buffer and no string. | |
| 4092 */ | |
| 4093 (from, to, buffer_or_string)) | |
| 4094 { | |
| 4095 Lisp_Object extent_obj; | |
| 4096 Lisp_Object obj; | |
| 4097 | |
| 4098 obj = decode_buffer_or_string (buffer_or_string); | |
| 4099 if (NILP (from) && NILP (to)) | |
| 4100 { | |
| 4101 if (NILP (buffer_or_string)) | |
| 4102 obj = Qnil; | |
| 793 | 4103 extent_obj = wrap_extent (make_extent_detached (obj)); |
| 428 | 4104 } |
| 4105 else | |
| 4106 { | |
| 826 | 4107 Bytexpos start, end; |
| 428 | 4108 |
| 4109 get_buffer_or_string_range_byte (obj, from, to, &start, &end, | |
| 4110 GB_ALLOW_PAST_ACCESSIBLE); | |
| 826 | 4111 extent_obj = wrap_extent (make_extent (obj, start, end)); |
| 428 | 4112 } |
| 4113 return extent_obj; | |
| 4114 } | |
| 4115 | |
| 4116 DEFUN ("copy-extent", Fcopy_extent, 1, 2, 0, /* | |
| 4117 Make a copy of EXTENT. It is initially detached. | |
| 4118 Optional argument BUFFER-OR-STRING defaults to EXTENT's buffer or string. | |
| 4119 */ | |
| 4120 (extent, buffer_or_string)) | |
| 4121 { | |
| 4122 EXTENT ext = decode_extent (extent, 0); | |
| 4123 | |
| 4124 if (NILP (buffer_or_string)) | |
| 4125 buffer_or_string = extent_object (ext); | |
| 4126 else | |
| 4127 buffer_or_string = decode_buffer_or_string (buffer_or_string); | |
| 4128 | |
| 793 | 4129 return wrap_extent (copy_extent (ext, -1, -1, buffer_or_string)); |
| 428 | 4130 } |
| 4131 | |
| 4132 DEFUN ("delete-extent", Fdelete_extent, 1, 1, 0, /* | |
| 4133 Remove EXTENT from its buffer and destroy it. | |
| 4134 This does not modify the buffer's text, only its display properties. | |
| 4135 The extent cannot be used thereafter. | |
| 4136 */ | |
| 4137 (extent)) | |
| 4138 { | |
| 4139 EXTENT ext; | |
| 4140 | |
| 4141 /* We do not call decode_extent() here because already-destroyed | |
| 4142 extents are OK. */ | |
| 4143 CHECK_EXTENT (extent); | |
| 4144 ext = XEXTENT (extent); | |
| 4145 | |
| 4146 if (!EXTENT_LIVE_P (ext)) | |
| 4147 return Qnil; | |
| 4148 destroy_extent (ext); | |
| 4149 return Qnil; | |
| 4150 } | |
| 4151 | |
| 4152 DEFUN ("detach-extent", Fdetach_extent, 1, 1, 0, /* | |
| 4153 Remove EXTENT from its buffer in such a way that it can be re-inserted. | |
| 4154 An extent is also detached when all of its characters are all killed by a | |
| 4155 deletion, unless its `detachable' property has been unset. | |
| 4156 | |
| 4157 Extents which have the `duplicable' attribute are tracked by the undo | |
| 4158 mechanism. Detachment via `detach-extent' and string deletion is recorded, | |
| 4159 as is attachment via `insert-extent' and string insertion. Extent motion, | |
| 4160 face changes, and attachment via `make-extent' and `set-extent-endpoints' | |
| 4161 are not recorded. This means that extent changes which are to be undo-able | |
| 4162 must be performed by character editing, or by insertion and detachment of | |
| 4163 duplicable extents. | |
| 4164 */ | |
| 4165 (extent)) | |
| 4166 { | |
| 4167 EXTENT ext = decode_extent (extent, 0); | |
| 4168 | |
| 4169 if (extent_detached_p (ext)) | |
| 4170 return extent; | |
| 4171 if (extent_duplicable_p (ext)) | |
| 4172 record_extent (extent, 0); | |
| 4173 extent_detach (ext); | |
| 4174 | |
| 4175 return extent; | |
| 4176 } | |
| 4177 | |
| 4178 DEFUN ("set-extent-endpoints", Fset_extent_endpoints, 3, 4, 0, /* | |
| 4179 Set the endpoints of EXTENT to START, END. | |
| 4180 If START and END are null, call detach-extent on EXTENT. | |
| 4181 BUFFER-OR-STRING specifies the new buffer or string that the extent should | |
| 4182 be in, and defaults to EXTENT's buffer or string. (If nil, and EXTENT | |
| 4183 is in no buffer and no string, it defaults to the current buffer.) | |
| 4184 See documentation on `detach-extent' for a discussion of undo recording. | |
| 4185 */ | |
| 4186 (extent, start, end, buffer_or_string)) | |
| 4187 { | |
| 4188 EXTENT ext; | |
| 826 | 4189 Bytexpos s, e; |
| 428 | 4190 |
| 4191 ext = decode_extent (extent, 0); | |
| 4192 | |
| 4193 if (NILP (buffer_or_string)) | |
| 4194 { | |
| 4195 buffer_or_string = extent_object (ext); | |
| 4196 if (NILP (buffer_or_string)) | |
| 4197 buffer_or_string = Fcurrent_buffer (); | |
| 4198 } | |
| 4199 else | |
| 4200 buffer_or_string = decode_buffer_or_string (buffer_or_string); | |
| 4201 | |
| 4202 if (NILP (start) && NILP (end)) | |
| 4203 return Fdetach_extent (extent); | |
| 4204 | |
| 4205 get_buffer_or_string_range_byte (buffer_or_string, start, end, &s, &e, | |
| 4206 GB_ALLOW_PAST_ACCESSIBLE); | |
| 4207 | |
| 468 | 4208 buffer_or_string_extent_info_force (buffer_or_string); |
| 428 | 4209 set_extent_endpoints (ext, s, e, buffer_or_string); |
| 4210 return extent; | |
| 4211 } | |
| 4212 | |
| 4213 | |
| 4214 /************************************************************************/ | |
| 4215 /* mapping over extents */ | |
| 4216 /************************************************************************/ | |
| 4217 | |
| 4218 static unsigned int | |
| 4219 decode_map_extents_flags (Lisp_Object flags) | |
| 4220 { | |
| 4221 unsigned int retval = 0; | |
| 4222 unsigned int all_extents_specified = 0; | |
| 4223 unsigned int in_region_specified = 0; | |
| 4224 | |
| 4225 if (EQ (flags, Qt)) /* obsoleteness compatibility */ | |
| 4226 return ME_END_CLOSED; | |
| 4227 if (NILP (flags)) | |
| 4228 return 0; | |
| 4229 if (SYMBOLP (flags)) | |
| 4230 flags = Fcons (flags, Qnil); | |
| 4231 while (!NILP (flags)) | |
| 4232 { | |
| 4233 Lisp_Object sym; | |
| 4234 CHECK_CONS (flags); | |
| 4235 sym = XCAR (flags); | |
| 4236 CHECK_SYMBOL (sym); | |
| 4237 if (EQ (sym, Qall_extents_closed) || EQ (sym, Qall_extents_open) || | |
| 4238 EQ (sym, Qall_extents_closed_open) || | |
| 4239 EQ (sym, Qall_extents_open_closed)) | |
| 4240 { | |
| 4241 if (all_extents_specified) | |
| 563 | 4242 invalid_argument ("Only one `all-extents-*' flag may be specified", Qunbound); |
| 428 | 4243 all_extents_specified = 1; |
| 4244 } | |
| 4245 if (EQ (sym, Qstart_in_region) || EQ (sym, Qend_in_region) || | |
| 4246 EQ (sym, Qstart_and_end_in_region) || | |
| 4247 EQ (sym, Qstart_or_end_in_region)) | |
| 4248 { | |
| 4249 if (in_region_specified) | |
| 563 | 4250 invalid_argument ("Only one `*-in-region' flag may be specified", Qunbound); |
| 428 | 4251 in_region_specified = 1; |
| 4252 } | |
| 4253 | |
| 4254 /* I do so love that conditional operator ... */ | |
| 4255 retval |= | |
| 4256 EQ (sym, Qend_closed) ? ME_END_CLOSED : | |
| 4257 EQ (sym, Qstart_open) ? ME_START_OPEN : | |
| 4258 EQ (sym, Qall_extents_closed) ? ME_ALL_EXTENTS_CLOSED : | |
| 4259 EQ (sym, Qall_extents_open) ? ME_ALL_EXTENTS_OPEN : | |
| 4260 EQ (sym, Qall_extents_closed_open) ? ME_ALL_EXTENTS_CLOSED_OPEN : | |
| 4261 EQ (sym, Qall_extents_open_closed) ? ME_ALL_EXTENTS_OPEN_CLOSED : | |
| 4262 EQ (sym, Qstart_in_region) ? ME_START_IN_REGION : | |
| 4263 EQ (sym, Qend_in_region) ? ME_END_IN_REGION : | |
| 4264 EQ (sym, Qstart_and_end_in_region) ? ME_START_AND_END_IN_REGION : | |
| 4265 EQ (sym, Qstart_or_end_in_region) ? ME_START_OR_END_IN_REGION : | |
| 4266 EQ (sym, Qnegate_in_region) ? ME_NEGATE_IN_REGION : | |
| 563 | 4267 (invalid_constant ("Invalid `map-extents' flag", sym), 0); |
| 428 | 4268 |
| 4269 flags = XCDR (flags); | |
| 4270 } | |
| 4271 return retval; | |
| 4272 } | |
| 4273 | |
| 4274 DEFUN ("extent-in-region-p", Fextent_in_region_p, 1, 4, 0, /* | |
| 4275 Return whether EXTENT overlaps a specified region. | |
| 4276 This is equivalent to whether `map-extents' would visit EXTENT when called | |
| 4277 with these args. | |
| 4278 */ | |
| 4279 (extent, from, to, flags)) | |
| 4280 { | |
| 826 | 4281 Bytexpos start, end; |
| 428 | 4282 EXTENT ext = decode_extent (extent, DE_MUST_BE_ATTACHED); |
| 4283 Lisp_Object obj = extent_object (ext); | |
| 4284 | |
| 4285 get_buffer_or_string_range_byte (obj, from, to, &start, &end, GB_ALLOW_NIL | | |
| 4286 GB_ALLOW_PAST_ACCESSIBLE); | |
| 4287 | |
| 4288 return extent_in_region_p (ext, start, end, decode_map_extents_flags (flags)) ? | |
| 4289 Qt : Qnil; | |
| 4290 } | |
| 4291 | |
| 4292 struct slow_map_extents_arg | |
| 4293 { | |
| 4294 Lisp_Object map_arg; | |
| 4295 Lisp_Object map_routine; | |
| 4296 Lisp_Object result; | |
| 4297 Lisp_Object property; | |
| 4298 Lisp_Object value; | |
| 4299 }; | |
| 4300 | |
| 4301 static int | |
| 4302 slow_map_extents_function (EXTENT extent, void *arg) | |
| 4303 { | |
| 4304 /* This function can GC */ | |
| 4305 struct slow_map_extents_arg *closure = (struct slow_map_extents_arg *) arg; | |
| 793 | 4306 Lisp_Object extent_obj = wrap_extent (extent); |
| 4307 | |
| 428 | 4308 |
| 4309 /* make sure this extent qualifies according to the PROPERTY | |
| 4310 and VALUE args */ | |
| 4311 | |
| 4312 if (!NILP (closure->property)) | |
| 4313 { | |
| 4314 Lisp_Object value = Fextent_property (extent_obj, closure->property, | |
| 4315 Qnil); | |
| 4316 if ((NILP (closure->value) && NILP (value)) || | |
| 4317 (!NILP (closure->value) && !EQ (value, closure->value))) | |
| 4318 return 0; | |
| 4319 } | |
| 4320 | |
| 4321 closure->result = call2 (closure->map_routine, extent_obj, | |
| 4322 closure->map_arg); | |
| 4323 return !NILP (closure->result); | |
| 4324 } | |
| 4325 | |
| 4326 DEFUN ("map-extents", Fmap_extents, 1, 8, 0, /* | |
| 4327 Map FUNCTION over the extents which overlap a region in OBJECT. | |
| 4328 OBJECT is normally a buffer or string but could be an extent (see below). | |
| 4329 The region is normally bounded by [FROM, TO) (i.e. the beginning of the | |
| 4330 region is closed and the end of the region is open), but this can be | |
| 4331 changed with the FLAGS argument (see below for a complete discussion). | |
| 4332 | |
| 4333 FUNCTION is called with the arguments (extent, MAPARG). The arguments | |
| 4334 OBJECT, FROM, TO, MAPARG, and FLAGS are all optional and default to | |
| 4335 the current buffer, the beginning of OBJECT, the end of OBJECT, nil, | |
| 4336 and nil, respectively. `map-extents' returns the first non-nil result | |
| 4337 produced by FUNCTION, and no more calls to FUNCTION are made after it | |
| 4338 returns non-nil. | |
| 4339 | |
| 4340 If OBJECT is an extent, FROM and TO default to the extent's endpoints, | |
| 4341 and the mapping omits that extent and its predecessors. This feature | |
| 4342 supports restarting a loop based on `map-extents'. Note: OBJECT must | |
| 4343 be attached to a buffer or string, and the mapping is done over that | |
| 4344 buffer or string. | |
| 4345 | |
| 4346 An extent overlaps the region if there is any point in the extent that is | |
| 4347 also in the region. (For the purpose of overlap, zero-length extents and | |
| 4348 regions are treated as closed on both ends regardless of their endpoints' | |
| 4349 specified open/closedness.) Note that the endpoints of an extent or region | |
| 4350 are considered to be in that extent or region if and only if the | |
| 4351 corresponding end is closed. For example, the extent [5,7] overlaps the | |
| 4352 region [2,5] because 5 is in both the extent and the region. However, (5,7] | |
| 4353 does not overlap [2,5] because 5 is not in the extent, and neither [5,7] nor | |
| 4354 \(5,7] overlaps the region [2,5) because 5 is not in the region. | |
| 4355 | |
| 4356 The optional FLAGS can be a symbol or a list of one or more symbols, | |
| 4357 modifying the behavior of `map-extents'. Allowed symbols are: | |
| 4358 | |
| 4359 end-closed The region's end is closed. | |
| 4360 | |
| 4361 start-open The region's start is open. | |
| 4362 | |
| 4363 all-extents-closed Treat all extents as closed on both ends for the | |
| 4364 purpose of determining whether they overlap the | |
| 4365 region, irrespective of their actual open- or | |
| 4366 closedness. | |
| 4367 all-extents-open Treat all extents as open on both ends. | |
| 4368 all-extents-closed-open Treat all extents as start-closed, end-open. | |
| 4369 all-extents-open-closed Treat all extents as start-open, end-closed. | |
| 4370 | |
| 4371 start-in-region In addition to the above conditions for extent | |
| 4372 overlap, the extent's start position must lie within | |
| 4373 the specified region. Note that, for this | |
| 4374 condition, open start positions are treated as if | |
| 4375 0.5 was added to the endpoint's value, and open | |
| 4376 end positions are treated as if 0.5 was subtracted | |
| 4377 from the endpoint's value. | |
| 4378 end-in-region The extent's end position must lie within the | |
| 4379 region. | |
| 4380 start-and-end-in-region Both the extent's start and end positions must lie | |
| 4381 within the region. | |
| 4382 start-or-end-in-region Either the extent's start or end position must lie | |
| 4383 within the region. | |
| 4384 | |
| 4385 negate-in-region The condition specified by a `*-in-region' flag | |
| 4386 must NOT hold for the extent to be considered. | |
| 4387 | |
| 4388 | |
| 4389 At most one of `all-extents-closed', `all-extents-open', | |
| 4390 `all-extents-closed-open', and `all-extents-open-closed' may be specified. | |
| 4391 | |
| 4392 At most one of `start-in-region', `end-in-region', | |
| 4393 `start-and-end-in-region', and `start-or-end-in-region' may be specified. | |
| 4394 | |
| 4395 If optional arg PROPERTY is non-nil, only extents with that property set | |
| 4396 on them will be visited. If optional arg VALUE is non-nil, only extents | |
| 4397 whose value for that property is `eq' to VALUE will be visited. | |
| 4398 */ | |
| 4399 (function, object, from, to, maparg, flags, property, value)) | |
| 4400 { | |
| 4401 /* This function can GC */ | |
| 4402 struct slow_map_extents_arg closure; | |
| 4403 unsigned int me_flags; | |
| 826 | 4404 Bytexpos start, end; |
| 428 | 4405 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; |
| 4406 EXTENT after = 0; | |
| 4407 | |
| 4408 if (EXTENTP (object)) | |
| 4409 { | |
| 4410 after = decode_extent (object, DE_MUST_BE_ATTACHED); | |
| 4411 if (NILP (from)) | |
| 4412 from = Fextent_start_position (object); | |
| 4413 if (NILP (to)) | |
| 4414 to = Fextent_end_position (object); | |
| 4415 object = extent_object (after); | |
| 4416 } | |
| 4417 else | |
| 4418 object = decode_buffer_or_string (object); | |
| 4419 | |
| 4420 get_buffer_or_string_range_byte (object, from, to, &start, &end, | |
| 4421 GB_ALLOW_NIL | GB_ALLOW_PAST_ACCESSIBLE); | |
| 4422 | |
| 4423 me_flags = decode_map_extents_flags (flags); | |
| 4424 | |
| 4425 if (!NILP (property)) | |
| 4426 { | |
| 4427 if (!NILP (value)) | |
| 4428 value = canonicalize_extent_property (property, value); | |
| 4429 } | |
| 4430 | |
| 4431 GCPRO5 (function, maparg, object, property, value); | |
| 4432 | |
| 4433 closure.map_arg = maparg; | |
| 4434 closure.map_routine = function; | |
| 4435 closure.result = Qnil; | |
| 4436 closure.property = property; | |
| 4437 closure.value = value; | |
| 4438 | |
| 826 | 4439 map_extents (start, end, slow_map_extents_function, |
| 4440 (void *) &closure, object, after, | |
| 4441 /* You never know what the user might do ... */ | |
| 4442 me_flags | ME_MIGHT_CALL_ELISP); | |
| 428 | 4443 |
| 4444 UNGCPRO; | |
| 4445 return closure.result; | |
| 4446 } | |
| 4447 | |
| 4448 | |
| 4449 /************************************************************************/ | |
| 4450 /* mapping over extents -- other functions */ | |
| 4451 /************************************************************************/ | |
| 4452 | |
| 4453 /* ------------------------------- */ | |
| 4454 /* map-extent-children */ | |
| 4455 /* ------------------------------- */ | |
| 4456 | |
| 4457 struct slow_map_extent_children_arg | |
| 4458 { | |
| 4459 Lisp_Object map_arg; | |
| 4460 Lisp_Object map_routine; | |
| 4461 Lisp_Object result; | |
| 4462 Lisp_Object property; | |
| 4463 Lisp_Object value; | |
| 826 | 4464 Bytexpos start_min; |
| 4465 Bytexpos prev_start; | |
| 4466 Bytexpos prev_end; | |
| 428 | 4467 }; |
| 4468 | |
| 4469 static int | |
| 4470 slow_map_extent_children_function (EXTENT extent, void *arg) | |
| 4471 { | |
| 4472 /* This function can GC */ | |
| 4473 struct slow_map_extent_children_arg *closure = | |
| 4474 (struct slow_map_extent_children_arg *) arg; | |
| 4475 Lisp_Object extent_obj; | |
| 826 | 4476 Bytexpos start = extent_endpoint_byte (extent, 0); |
| 4477 Bytexpos end = extent_endpoint_byte (extent, 1); | |
| 428 | 4478 /* Make sure the extent starts inside the region of interest, |
| 4479 rather than just overlaps it. | |
| 4480 */ | |
| 4481 if (start < closure->start_min) | |
| 4482 return 0; | |
| 4483 /* Make sure the extent is not a child of a previous visited one. | |
| 4484 We know already, because of extent ordering, | |
| 4485 that start >= prev_start, and that if | |
| 4486 start == prev_start, then end <= prev_end. | |
| 4487 */ | |
| 4488 if (start == closure->prev_start) | |
| 4489 { | |
| 4490 if (end < closure->prev_end) | |
| 4491 return 0; | |
| 4492 } | |
| 4493 else /* start > prev_start */ | |
| 4494 { | |
| 4495 if (start < closure->prev_end) | |
| 4496 return 0; | |
| 4497 /* corner case: prev_end can be -1 if there is no prev */ | |
| 4498 } | |
| 793 | 4499 extent_obj = wrap_extent (extent); |
| 428 | 4500 |
| 4501 /* make sure this extent qualifies according to the PROPERTY | |
| 4502 and VALUE args */ | |
| 4503 | |
| 4504 if (!NILP (closure->property)) | |
| 4505 { | |
| 4506 Lisp_Object value = Fextent_property (extent_obj, closure->property, | |
| 4507 Qnil); | |
| 4508 if ((NILP (closure->value) && NILP (value)) || | |
| 4509 (!NILP (closure->value) && !EQ (value, closure->value))) | |
| 4510 return 0; | |
| 4511 } | |
| 4512 | |
| 4513 closure->result = call2 (closure->map_routine, extent_obj, | |
| 4514 closure->map_arg); | |
| 4515 | |
| 4516 /* Since the callback may change the buffer, compute all stored | |
| 4517 buffer positions here. | |
| 4518 */ | |
| 4519 closure->start_min = -1; /* no need for this any more */ | |
| 826 | 4520 closure->prev_start = extent_endpoint_byte (extent, 0); |
| 4521 closure->prev_end = extent_endpoint_byte (extent, 1); | |
| 428 | 4522 |
| 4523 return !NILP (closure->result); | |
| 4524 } | |
| 4525 | |
| 4526 DEFUN ("map-extent-children", Fmap_extent_children, 1, 8, 0, /* | |
| 4527 Map FUNCTION over the extents in the region from FROM to TO. | |
| 4528 FUNCTION is called with arguments (extent, MAPARG). See `map-extents' | |
| 4529 for a full discussion of the arguments FROM, TO, and FLAGS. | |
| 4530 | |
| 4531 The arguments are the same as for `map-extents', but this function differs | |
| 4532 in that it only visits extents which start in the given region, and also | |
| 4533 in that, after visiting an extent E, it skips all other extents which start | |
| 4534 inside E but end before E's end. | |
| 4535 | |
| 4536 Thus, this function may be used to walk a tree of extents in a buffer: | |
| 4537 (defun walk-extents (buffer &optional ignore) | |
| 4538 (map-extent-children 'walk-extents buffer)) | |
| 4539 */ | |
| 4540 (function, object, from, to, maparg, flags, property, value)) | |
| 4541 { | |
| 4542 /* This function can GC */ | |
| 4543 struct slow_map_extent_children_arg closure; | |
| 4544 unsigned int me_flags; | |
| 826 | 4545 Bytexpos start, end; |
| 428 | 4546 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; |
| 4547 EXTENT after = 0; | |
| 4548 | |
| 4549 if (EXTENTP (object)) | |
| 4550 { | |
| 4551 after = decode_extent (object, DE_MUST_BE_ATTACHED); | |
| 4552 if (NILP (from)) | |
| 4553 from = Fextent_start_position (object); | |
| 4554 if (NILP (to)) | |
| 4555 to = Fextent_end_position (object); | |
| 4556 object = extent_object (after); | |
| 4557 } | |
| 4558 else | |
| 4559 object = decode_buffer_or_string (object); | |
| 4560 | |
| 4561 get_buffer_or_string_range_byte (object, from, to, &start, &end, | |
| 4562 GB_ALLOW_NIL | GB_ALLOW_PAST_ACCESSIBLE); | |
| 4563 | |
| 4564 me_flags = decode_map_extents_flags (flags); | |
| 4565 | |
| 4566 if (!NILP (property)) | |
| 4567 { | |
| 4568 if (!NILP (value)) | |
| 4569 value = canonicalize_extent_property (property, value); | |
| 4570 } | |
| 4571 | |
| 4572 GCPRO5 (function, maparg, object, property, value); | |
| 4573 | |
| 4574 closure.map_arg = maparg; | |
| 4575 closure.map_routine = function; | |
| 4576 closure.result = Qnil; | |
| 4577 closure.property = property; | |
| 4578 closure.value = value; | |
| 4579 closure.start_min = start; | |
| 4580 closure.prev_start = -1; | |
| 4581 closure.prev_end = -1; | |
| 826 | 4582 map_extents (start, end, slow_map_extent_children_function, |
| 4583 (void *) &closure, object, after, | |
| 4584 /* You never know what the user might do ... */ | |
| 4585 me_flags | ME_MIGHT_CALL_ELISP); | |
| 428 | 4586 |
| 4587 UNGCPRO; | |
| 4588 return closure.result; | |
| 4589 } | |
| 4590 | |
| 4591 /* ------------------------------- */ | |
| 4592 /* extent-at */ | |
| 4593 /* ------------------------------- */ | |
| 4594 | |
| 4595 /* find "smallest" matching extent containing pos -- (flag == 0) means | |
| 4596 all extents match, else (EXTENT_FLAGS (extent) & flag) must be true; | |
| 4597 for more than one matching extent with precisely the same endpoints, | |
| 4598 we choose the last extent in the extents_list. | |
| 4599 The search stops just before "before", if that is non-null. | |
| 4600 */ | |
| 4601 | |
| 4602 struct extent_at_arg | |
| 4603 { | |
| 442 | 4604 Lisp_Object best_match; /* or list of extents */ |
| 826 | 4605 Memxpos best_start; |
| 4606 Memxpos best_end; | |
| 428 | 4607 Lisp_Object prop; |
| 4608 EXTENT before; | |
| 442 | 4609 int all_extents; |
| 428 | 4610 }; |
| 4611 | |
| 4612 static enum extent_at_flag | |
| 4613 decode_extent_at_flag (Lisp_Object at_flag) | |
| 4614 { | |
| 4615 if (NILP (at_flag)) | |
| 4616 return EXTENT_AT_AFTER; | |
| 4617 | |
| 4618 CHECK_SYMBOL (at_flag); | |
| 4619 if (EQ (at_flag, Qafter)) return EXTENT_AT_AFTER; | |
| 4620 if (EQ (at_flag, Qbefore)) return EXTENT_AT_BEFORE; | |
| 4621 if (EQ (at_flag, Qat)) return EXTENT_AT_AT; | |
| 4622 | |
| 563 | 4623 invalid_constant ("Invalid AT-FLAG in `extent-at'", at_flag); |
| 1204 | 4624 RETURN_NOT_REACHED (EXTENT_AT_AFTER); |
| 428 | 4625 } |
| 4626 | |
| 4627 static int | |
| 4628 extent_at_mapper (EXTENT e, void *arg) | |
| 4629 { | |
| 4630 struct extent_at_arg *closure = (struct extent_at_arg *) arg; | |
| 4631 | |
| 4632 if (e == closure->before) | |
| 4633 return 1; | |
| 4634 | |
| 4635 /* If closure->prop is non-nil, then the extent is only acceptable | |
| 4636 if it has a non-nil value for that property. */ | |
| 4637 if (!NILP (closure->prop)) | |
| 4638 { | |
| 793 | 4639 Lisp_Object extent = wrap_extent (e); |
| 4640 | |
| 428 | 4641 if (NILP (Fextent_property (extent, closure->prop, Qnil))) |
| 4642 return 0; | |
| 4643 } | |
| 4644 | |
| 442 | 4645 if (!closure->all_extents) |
| 428 | 4646 { |
| 442 | 4647 EXTENT current; |
| 4648 | |
| 4649 if (NILP (closure->best_match)) | |
| 428 | 4650 goto accept; |
| 442 | 4651 current = XEXTENT (closure->best_match); |
| 428 | 4652 /* redundant but quick test */ |
| 442 | 4653 if (extent_start (current) > extent_start (e)) |
| 428 | 4654 return 0; |
| 4655 | |
| 4656 /* we return the "last" best fit, instead of the first -- | |
| 4657 this is because then the glyph closest to two equivalent | |
| 4658 extents corresponds to the "extent-at" the text just past | |
| 4659 that same glyph */ | |
| 4660 else if (!EXTENT_LESS_VALS (e, closure->best_start, | |
| 4661 closure->best_end)) | |
| 4662 goto accept; | |
| 4663 else | |
| 4664 return 0; | |
| 4665 accept: | |
| 793 | 4666 closure->best_match = wrap_extent (e); |
| 428 | 4667 closure->best_start = extent_start (e); |
| 4668 closure->best_end = extent_end (e); | |
| 4669 } | |
| 442 | 4670 else |
| 4671 { | |
| 793 | 4672 Lisp_Object extent = wrap_extent (e); |
| 4673 | |
| 442 | 4674 closure->best_match = Fcons (extent, closure->best_match); |
| 4675 } | |
| 428 | 4676 |
| 4677 return 0; | |
| 4678 } | |
| 4679 | |
| 826 | 4680 Lisp_Object |
| 4681 extent_at (Bytexpos position, Lisp_Object object, | |
| 4682 Lisp_Object property, EXTENT before, | |
| 4683 enum extent_at_flag at_flag, int all_extents) | |
| 428 | 4684 { |
| 4685 struct extent_at_arg closure; | |
| 442 | 4686 struct gcpro gcpro1; |
| 428 | 4687 |
| 4688 /* it might be argued that invalid positions should cause | |
| 4689 errors, but the principle of least surprise dictates that | |
| 4690 nil should be returned (extent-at is often used in | |
| 4691 response to a mouse event, and in many cases previous events | |
| 4692 have changed the buffer contents). | |
| 4693 | |
| 4694 Also, the openness stuff in the text-property code currently | |
| 4695 does not check its limits and might go off the end. */ | |
| 4696 if ((at_flag == EXTENT_AT_BEFORE | |
| 4697 ? position <= buffer_or_string_absolute_begin_byte (object) | |
| 4698 : position < buffer_or_string_absolute_begin_byte (object)) | |
| 4699 || (at_flag == EXTENT_AT_AFTER | |
| 4700 ? position >= buffer_or_string_absolute_end_byte (object) | |
| 4701 : position > buffer_or_string_absolute_end_byte (object))) | |
| 4702 return Qnil; | |
| 4703 | |
| 442 | 4704 closure.best_match = Qnil; |
| 428 | 4705 closure.prop = property; |
| 4706 closure.before = before; | |
| 442 | 4707 closure.all_extents = all_extents; |
| 4708 | |
| 4709 GCPRO1 (closure.best_match); | |
| 826 | 4710 map_extents (at_flag == EXTENT_AT_BEFORE ? prev_bytexpos (object, position) : |
| 4711 position, | |
| 4712 at_flag == EXTENT_AT_AFTER ? next_bytexpos (object, position) : | |
| 4713 position, | |
| 4714 extent_at_mapper, (void *) &closure, object, 0, | |
| 4715 ME_START_OPEN | ME_ALL_EXTENTS_CLOSED); | |
| 442 | 4716 if (all_extents) |
| 4717 closure.best_match = Fnreverse (closure.best_match); | |
| 4718 UNGCPRO; | |
| 4719 | |
| 4720 return closure.best_match; | |
| 428 | 4721 } |
| 4722 | |
| 4723 DEFUN ("extent-at", Fextent_at, 1, 5, 0, /* | |
| 4724 Find "smallest" extent at POS in OBJECT having PROPERTY set. | |
| 4725 Normally, an extent is "at" POS if it overlaps the region (POS, POS+1); | |
| 4726 i.e. if it covers the character after POS. (However, see the definition | |
| 4727 of AT-FLAG.) "Smallest" means the extent that comes last in the display | |
| 4728 order; this normally means the extent whose start position is closest to | |
| 4729 POS. See `next-extent' for more information. | |
| 4730 OBJECT specifies a buffer or string and defaults to the current buffer. | |
| 4731 PROPERTY defaults to nil, meaning that any extent will do. | |
| 4732 Properties are attached to extents with `set-extent-property', which see. | |
| 4733 Returns nil if POS is invalid or there is no matching extent at POS. | |
| 4734 If the fourth argument BEFORE is not nil, it must be an extent; any returned | |
| 4735 extent will precede that extent. This feature allows `extent-at' to be | |
| 4736 used by a loop over extents. | |
| 4737 AT-FLAG controls how end cases are handled, and should be one of: | |
| 4738 | |
| 4739 nil or `after' An extent is at POS if it covers the character | |
| 4740 after POS. This is consistent with the way | |
| 4741 that text properties work. | |
| 4742 `before' An extent is at POS if it covers the character | |
| 4743 before POS. | |
| 4744 `at' An extent is at POS if it overlaps or abuts POS. | |
| 4745 This includes all zero-length extents at POS. | |
| 4746 | |
| 4747 Note that in all cases, the start-openness and end-openness of the extents | |
| 4748 considered is ignored. If you want to pay attention to those properties, | |
| 4749 you should use `map-extents', which gives you more control. | |
| 4750 */ | |
| 4751 (pos, object, property, before, at_flag)) | |
| 4752 { | |
| 826 | 4753 Bytexpos position; |
| 428 | 4754 EXTENT before_extent; |
| 4755 enum extent_at_flag fl; | |
| 4756 | |
| 4757 object = decode_buffer_or_string (object); | |
| 4758 position = get_buffer_or_string_pos_byte (object, pos, GB_NO_ERROR_IF_BAD); | |
| 4759 if (NILP (before)) | |
| 4760 before_extent = 0; | |
| 4761 else | |
| 4762 before_extent = decode_extent (before, DE_MUST_BE_ATTACHED); | |
| 4763 if (before_extent && !EQ (object, extent_object (before_extent))) | |
| 442 | 4764 invalid_argument ("extent not in specified buffer or string", object); |
| 428 | 4765 fl = decode_extent_at_flag (at_flag); |
| 4766 | |
| 826 | 4767 return extent_at (position, object, property, before_extent, fl, 0); |
| 442 | 4768 } |
| 4769 | |
| 4770 DEFUN ("extents-at", Fextents_at, 1, 5, 0, /* | |
| 4771 Find all extents at POS in OBJECT having PROPERTY set. | |
| 4772 Normally, an extent is "at" POS if it overlaps the region (POS, POS+1); | |
| 4773 i.e. if it covers the character after POS. (However, see the definition | |
| 4774 of AT-FLAG.) | |
| 4775 This provides similar functionality to `extent-list', but does so in a way | |
| 4776 that is compatible with `extent-at'. (For example, errors due to POS out of | |
| 4777 range are ignored; this makes it safer to use this function in response to | |
| 4778 a mouse event, because in many cases previous events have changed the buffer | |
| 4779 contents.) | |
| 4780 OBJECT specifies a buffer or string and defaults to the current buffer. | |
| 4781 PROPERTY defaults to nil, meaning that any extent will do. | |
| 4782 Properties are attached to extents with `set-extent-property', which see. | |
| 4783 Returns nil if POS is invalid or there is no matching extent at POS. | |
| 4784 If the fourth argument BEFORE is not nil, it must be an extent; any returned | |
| 4785 extent will precede that extent. This feature allows `extents-at' to be | |
| 4786 used by a loop over extents. | |
| 4787 AT-FLAG controls how end cases are handled, and should be one of: | |
| 4788 | |
| 4789 nil or `after' An extent is at POS if it covers the character | |
| 4790 after POS. This is consistent with the way | |
| 4791 that text properties work. | |
| 4792 `before' An extent is at POS if it covers the character | |
| 4793 before POS. | |
| 4794 `at' An extent is at POS if it overlaps or abuts POS. | |
| 4795 This includes all zero-length extents at POS. | |
| 4796 | |
| 4797 Note that in all cases, the start-openness and end-openness of the extents | |
| 4798 considered is ignored. If you want to pay attention to those properties, | |
| 4799 you should use `map-extents', which gives you more control. | |
| 4800 */ | |
| 4801 (pos, object, property, before, at_flag)) | |
| 4802 { | |
| 826 | 4803 Bytexpos position; |
| 442 | 4804 EXTENT before_extent; |
| 4805 enum extent_at_flag fl; | |
| 4806 | |
| 4807 object = decode_buffer_or_string (object); | |
| 4808 position = get_buffer_or_string_pos_byte (object, pos, GB_NO_ERROR_IF_BAD); | |
| 4809 if (NILP (before)) | |
| 4810 before_extent = 0; | |
| 4811 else | |
| 4812 before_extent = decode_extent (before, DE_MUST_BE_ATTACHED); | |
| 4813 if (before_extent && !EQ (object, extent_object (before_extent))) | |
| 4814 invalid_argument ("extent not in specified buffer or string", object); | |
| 4815 fl = decode_extent_at_flag (at_flag); | |
| 4816 | |
| 826 | 4817 return extent_at (position, object, property, before_extent, fl, 1); |
| 428 | 4818 } |
| 4819 | |
| 4820 /* ------------------------------- */ | |
| 4821 /* verify_extent_modification() */ | |
| 4822 /* ------------------------------- */ | |
| 4823 | |
| 4824 /* verify_extent_modification() is called when a buffer or string is | |
| 4825 modified to check whether the modification is occuring inside a | |
| 4826 read-only extent. | |
| 4827 */ | |
| 4828 | |
| 4829 struct verify_extents_arg | |
| 4830 { | |
| 4831 Lisp_Object object; | |
| 826 | 4832 Memxpos start; |
| 4833 Memxpos end; | |
| 428 | 4834 Lisp_Object iro; /* value of inhibit-read-only */ |
| 4835 }; | |
| 4836 | |
| 4837 static int | |
| 4838 verify_extent_mapper (EXTENT extent, void *arg) | |
| 4839 { | |
| 4840 struct verify_extents_arg *closure = (struct verify_extents_arg *) arg; | |
| 4841 Lisp_Object prop = extent_read_only (extent); | |
| 4842 | |
| 4843 if (NILP (prop)) | |
| 4844 return 0; | |
| 4845 | |
| 4846 if (CONSP (closure->iro) && !NILP (Fmemq (prop, closure->iro))) | |
| 4847 return 0; | |
| 4848 | |
| 4849 #if 0 /* Nobody seems to care for this any more -sb */ | |
| 4850 /* Allow deletion if the extent is completely contained in | |
| 4851 the region being deleted. | |
| 4852 This is important for supporting tokens which are internally | |
| 4853 write-protected, but which can be killed and yanked as a whole. | |
| 4854 Ignore open/closed distinctions at this point. | |
| 4855 -- Rose | |
| 4856 */ | |
| 4857 if (closure->start != closure->end && | |
| 4858 extent_start (extent) >= closure->start && | |
| 4859 extent_end (extent) <= closure->end) | |
| 4860 return 0; | |
| 4861 #endif | |
| 4862 | |
| 4863 while (1) | |
| 4864 Fsignal (Qbuffer_read_only, (list1 (closure->object))); | |
| 4865 | |
| 1204 | 4866 RETURN_NOT_REACHED(0); |
| 428 | 4867 } |
| 4868 | |
| 4869 /* Value of Vinhibit_read_only is precomputed and passed in for | |
| 4870 efficiency */ | |
| 4871 | |
| 4872 void | |
| 826 | 4873 verify_extent_modification (Lisp_Object object, Bytexpos from, Bytexpos to, |
| 428 | 4874 Lisp_Object inhibit_read_only_value) |
| 4875 { | |
| 4876 int closed; | |
| 4877 struct verify_extents_arg closure; | |
| 4878 | |
| 4879 /* If insertion, visit closed-endpoint extents touching the insertion | |
| 4880 point because the text would go inside those extents. If deletion, | |
| 4881 treat the range as open on both ends so that touching extents are not | |
| 4882 visited. Note that we assume that an insertion is occurring if the | |
| 4883 changed range has zero length, and a deletion otherwise. This | |
| 4884 fails if a change (i.e. non-insertion, non-deletion) is happening. | |
| 4885 As far as I know, this doesn't currently occur in XEmacs. --ben */ | |
| 4886 closed = (from==to); | |
| 4887 closure.object = object; | |
| 826 | 4888 closure.start = buffer_or_string_bytexpos_to_memxpos (object, from); |
| 4889 closure.end = buffer_or_string_bytexpos_to_memxpos (object, to); | |
| 428 | 4890 closure.iro = inhibit_read_only_value; |
| 4891 | |
| 826 | 4892 map_extents (from, to, verify_extent_mapper, (void *) &closure, |
| 4893 object, 0, closed ? ME_END_CLOSED : ME_START_OPEN); | |
| 428 | 4894 } |
| 4895 | |
| 4896 /* ------------------------------------ */ | |
| 4897 /* process_extents_for_insertion() */ | |
| 4898 /* ------------------------------------ */ | |
| 4899 | |
| 4900 struct process_extents_for_insertion_arg | |
| 4901 { | |
| 826 | 4902 Bytexpos opoint; |
| 428 | 4903 int length; |
| 4904 Lisp_Object object; | |
| 4905 }; | |
| 4906 | |
| 4907 /* A region of length LENGTH was just inserted at OPOINT. Modify all | |
| 4908 of the extents as required for the insertion, based on their | |
| 4909 start-open/end-open properties. | |
| 4910 */ | |
| 4911 | |
| 4912 static int | |
| 4913 process_extents_for_insertion_mapper (EXTENT extent, void *arg) | |
| 4914 { | |
| 4915 struct process_extents_for_insertion_arg *closure = | |
| 4916 (struct process_extents_for_insertion_arg *) arg; | |
| 826 | 4917 Memxpos indice = buffer_or_string_bytexpos_to_memxpos (closure->object, |
| 4918 closure->opoint); | |
| 428 | 4919 |
| 4920 /* When this function is called, one end of the newly-inserted text should | |
| 4921 be adjacent to some endpoint of the extent, or disjoint from it. If | |
| 4922 the insertion overlaps any existing extent, something is wrong. | |
| 4923 */ | |
| 4924 #ifdef ERROR_CHECK_EXTENTS | |
|
5053
0e803dc6f096
fix to assert in extents.c, so `make check' works
Ben Wing <ben@xemacs.org>
parents:
5050
diff
changeset
|
4925 assert (extent_start (extent) <= indice || extent_start (extent) >= indice + closure->length); |
|
0e803dc6f096
fix to assert in extents.c, so `make check' works
Ben Wing <ben@xemacs.org>
parents:
5050
diff
changeset
|
4926 assert (extent_end (extent) <= indice || extent_end (extent) >= indice + closure->length); |
| 428 | 4927 #endif |
| 4928 | |
| 4929 /* The extent-adjustment code adjusted the extent's endpoints as if | |
| 468 | 4930 all extents were closed-open -- endpoints at the insertion point |
| 4931 remain unchanged. We need to fix the other kinds of extents: | |
| 4932 | |
| 4933 1. Start position of start-open extents needs to be moved. | |
| 4934 | |
| 4935 2. End position of end-closed extents needs to be moved. | |
| 4936 | |
| 4937 Note that both conditions hold for zero-length (] extents at the | |
| 4938 insertion point. But under these rules, zero-length () extents | |
| 4939 would get adjusted such that their start is greater than their | |
| 4940 end; instead of allowing that, we treat them as [) extents by | |
| 4941 modifying condition #1 to not fire nothing when dealing with a | |
| 4942 zero-length open-open extent. | |
| 4943 | |
| 4944 Existence of zero-length open-open extents is unfortunately an | |
| 4945 inelegant part of the extent model, but there is no way around | |
| 4946 it. */ | |
| 428 | 4947 |
| 4948 { | |
| 826 | 4949 Memxpos new_start = extent_start (extent); |
| 4950 Memxpos new_end = extent_end (extent); | |
| 468 | 4951 |
| 4952 if (indice == extent_start (extent) && extent_start_open_p (extent) | |
| 4953 /* zero-length () extents are exempt; see comment above. */ | |
| 4954 && !(new_start == new_end && extent_end_open_p (extent)) | |
| 4955 ) | |
| 428 | 4956 new_start += closure->length; |
| 4957 if (indice == extent_end (extent) && !extent_end_open_p (extent)) | |
| 4958 new_end += closure->length; | |
| 468 | 4959 |
| 428 | 4960 set_extent_endpoints_1 (extent, new_start, new_end); |
| 4961 } | |
| 4962 | |
| 4963 return 0; | |
| 4964 } | |
| 4965 | |
| 4966 void | |
| 826 | 4967 process_extents_for_insertion (Lisp_Object object, Bytexpos opoint, |
| 428 | 4968 Bytecount length) |
| 4969 { | |
| 4970 struct process_extents_for_insertion_arg closure; | |
| 4971 | |
| 4972 closure.opoint = opoint; | |
| 4973 closure.length = length; | |
| 4974 closure.object = object; | |
| 4975 | |
| 826 | 4976 map_extents (opoint, opoint + length, |
| 4977 process_extents_for_insertion_mapper, | |
| 4978 (void *) &closure, object, 0, | |
| 4979 ME_END_CLOSED | ME_MIGHT_MODIFY_EXTENTS | | |
| 4980 ME_INCLUDE_INTERNAL); | |
| 428 | 4981 } |
| 4982 | |
| 4983 /* ------------------------------------ */ | |
| 4984 /* process_extents_for_deletion() */ | |
| 4985 /* ------------------------------------ */ | |
| 4986 | |
| 4987 struct process_extents_for_deletion_arg | |
| 4988 { | |
| 826 | 4989 Memxpos start, end; |
| 428 | 4990 int destroy_included_extents; |
| 4991 }; | |
| 4992 | |
| 4993 /* This function is called when we're about to delete the range [from, to]. | |
| 4994 Detach all of the extents that are completely inside the range [from, to], | |
| 4995 if they're detachable or open-open. */ | |
| 4996 | |
| 4997 static int | |
| 4998 process_extents_for_deletion_mapper (EXTENT extent, void *arg) | |
| 4999 { | |
| 5000 struct process_extents_for_deletion_arg *closure = | |
| 5001 (struct process_extents_for_deletion_arg *) arg; | |
| 5002 | |
| 5003 /* If the extent lies completely within the range that | |
| 5004 is being deleted, then nuke the extent if it's detachable | |
| 5005 (otherwise, it will become a zero-length extent). */ | |
| 5006 | |
| 5007 if (closure->start <= extent_start (extent) && | |
| 5008 extent_end (extent) <= closure->end) | |
| 5009 { | |
| 5010 if (extent_detachable_p (extent)) | |
| 5011 { | |
| 5012 if (closure->destroy_included_extents) | |
| 5013 destroy_extent (extent); | |
| 5014 else | |
| 5015 extent_detach (extent); | |
| 5016 } | |
| 5017 } | |
| 5018 | |
| 5019 return 0; | |
| 5020 } | |
| 5021 | |
| 5022 /* DESTROY_THEM means destroy the extents instead of just deleting them. | |
| 5023 It is unused currently, but perhaps might be used (there used to | |
| 5024 be a function process_extents_for_destruction(), #if 0'd out, | |
| 5025 that did the equivalent). */ | |
| 5026 void | |
| 826 | 5027 process_extents_for_deletion (Lisp_Object object, Bytexpos from, |
| 5028 Bytexpos to, int destroy_them) | |
| 428 | 5029 { |
| 5030 struct process_extents_for_deletion_arg closure; | |
| 5031 | |
| 826 | 5032 closure.start = buffer_or_string_bytexpos_to_memxpos (object, from); |
| 5033 closure.end = buffer_or_string_bytexpos_to_memxpos (object, to); | |
| 428 | 5034 closure.destroy_included_extents = destroy_them; |
| 5035 | |
| 826 | 5036 map_extents (from, to, process_extents_for_deletion_mapper, |
| 5037 (void *) &closure, object, 0, | |
| 5038 ME_END_CLOSED | ME_MIGHT_MODIFY_EXTENTS); | |
| 428 | 5039 } |
| 5040 | |
| 5041 /* ------------------------------- */ | |
| 5042 /* report_extent_modification() */ | |
| 5043 /* ------------------------------- */ | |
| 826 | 5044 |
| 5045 struct report_extent_modification_closure | |
| 5046 { | |
| 428 | 5047 Lisp_Object buffer; |
| 826 | 5048 Charxpos start, end; |
| 428 | 5049 int afterp; |
| 5050 int speccount; | |
| 5051 }; | |
| 5052 | |
| 5053 static Lisp_Object | |
| 5054 report_extent_modification_restore (Lisp_Object buffer) | |
| 5055 { | |
| 5056 if (current_buffer != XBUFFER (buffer)) | |
| 5057 Fset_buffer (buffer); | |
| 5058 return Qnil; | |
| 5059 } | |
| 5060 | |
| 5061 static int | |
| 5062 report_extent_modification_mapper (EXTENT extent, void *arg) | |
| 5063 { | |
| 5064 struct report_extent_modification_closure *closure = | |
| 5065 (struct report_extent_modification_closure *)arg; | |
| 5066 Lisp_Object exobj, startobj, endobj; | |
| 5067 Lisp_Object hook = (closure->afterp | |
| 5068 ? extent_after_change_functions (extent) | |
| 5069 : extent_before_change_functions (extent)); | |
| 5070 if (NILP (hook)) | |
| 5071 return 0; | |
| 5072 | |
| 793 | 5073 exobj = wrap_extent (extent); |
| 5074 startobj = make_int (closure->start); | |
| 5075 endobj = make_int (closure->end); | |
| 428 | 5076 |
| 5077 /* Now that we are sure to call elisp, set up an unwind-protect so | |
| 5078 inside_change_hook gets restored in case we throw. Also record | |
| 5079 the current buffer, in case we change it. Do the recording only | |
| 438 | 5080 once. |
| 5081 | |
| 5082 One confusing thing here is that our caller never actually calls | |
| 771 | 5083 unbind_to (closure.speccount). This is because |
| 826 | 5084 map_extents() unbinds before, and with a smaller |
| 771 | 5085 speccount. The additional unbind_to_1() in |
| 438 | 5086 report_extent_modification() would cause XEmacs to abort. */ |
| 428 | 5087 if (closure->speccount == -1) |
| 5088 { | |
| 5089 closure->speccount = specpdl_depth (); | |
| 5090 record_unwind_protect (report_extent_modification_restore, | |
| 5091 Fcurrent_buffer ()); | |
| 5092 } | |
| 5093 | |
| 5094 /* The functions will expect closure->buffer to be the current | |
| 5095 buffer, so change it if it isn't. */ | |
| 5096 if (current_buffer != XBUFFER (closure->buffer)) | |
| 5097 Fset_buffer (closure->buffer); | |
| 5098 | |
| 5099 /* #### It's a shame that we can't use any of the existing run_hook* | |
| 5100 functions here. This is so because all of them work with | |
| 5101 symbols, to be able to retrieve default values of local hooks. | |
| 438 | 5102 <sigh> |
| 5103 | |
| 5104 #### Idea: we could set up a dummy symbol, and call the hook | |
| 5105 functions on *that*. */ | |
| 428 | 5106 |
| 5107 if (!CONSP (hook) || EQ (XCAR (hook), Qlambda)) | |
| 5108 call3 (hook, exobj, startobj, endobj); | |
| 5109 else | |
| 5110 { | |
| 2367 | 5111 EXTERNAL_LIST_LOOP_2 (elt, hook) |
| 438 | 5112 /* #### Shouldn't this perform the same Fset_buffer() check as |
| 5113 above? */ | |
| 2367 | 5114 call3 (elt, exobj, startobj, endobj); |
| 428 | 5115 } |
| 5116 return 0; | |
| 5117 } | |
| 5118 | |
| 5119 void | |
| 665 | 5120 report_extent_modification (Lisp_Object buffer, Charbpos start, Charbpos end, |
| 438 | 5121 int afterp) |
| 428 | 5122 { |
| 5123 struct report_extent_modification_closure closure; | |
| 5124 | |
| 5125 closure.buffer = buffer; | |
| 5126 closure.start = start; | |
| 5127 closure.end = end; | |
| 5128 closure.afterp = afterp; | |
| 5129 closure.speccount = -1; | |
| 5130 | |
| 826 | 5131 map_extents (charbpos_to_bytebpos (XBUFFER (buffer), start), |
| 5132 charbpos_to_bytebpos (XBUFFER (buffer), end), | |
| 5133 report_extent_modification_mapper, (void *)&closure, | |
| 428 | 5134 buffer, NULL, ME_MIGHT_CALL_ELISP); |
| 5135 } | |
| 5136 | |
| 5137 | |
| 5138 /************************************************************************/ | |
| 5139 /* extent properties */ | |
| 5140 /************************************************************************/ | |
| 5141 | |
| 5142 static void | |
| 5143 set_extent_invisible (EXTENT extent, Lisp_Object value) | |
| 5144 { | |
| 5145 if (!EQ (extent_invisible (extent), value)) | |
| 5146 { | |
| 5147 set_extent_invisible_1 (extent, value); | |
| 826 | 5148 signal_extent_property_changed (extent, Qinvisible, 1); |
| 428 | 5149 } |
| 5150 } | |
| 5151 | |
| 5152 /* This function does "memoization" -- similar to the interning | |
| 5153 that happens with symbols. Given a list of faces, an equivalent | |
| 5154 list is returned such that if this function is called twice with | |
| 5155 input that is `equal', the resulting outputs will be `eq'. | |
| 5156 | |
| 5157 Note that the inputs and outputs are in general *not* `equal' -- | |
| 5158 faces in symbol form become actual face objects in the output. | |
| 5159 This is necessary so that temporary faces stay around. */ | |
| 5160 | |
| 5161 static Lisp_Object | |
| 5162 memoize_extent_face_internal (Lisp_Object list) | |
| 5163 { | |
| 5164 int len; | |
| 5165 int thelen; | |
| 5166 Lisp_Object cons, thecons; | |
| 5167 Lisp_Object oldtail, tail; | |
| 5168 struct gcpro gcpro1; | |
| 5169 | |
| 5170 if (NILP (list)) | |
| 5171 return Qnil; | |
| 5172 if (!CONSP (list)) | |
| 5173 return Fget_face (list); | |
| 5174 | |
| 5175 /* To do the memoization, we use a hash table mapping from | |
| 5176 external lists to internal lists. We do `equal' comparisons | |
| 5177 on the keys so the memoization works correctly. | |
| 5178 | |
| 5179 Note that we canonicalize things so that the keys in the | |
| 5180 hash table (the external lists) always contain symbols and | |
| 5181 the values (the internal lists) always contain face objects. | |
| 5182 | |
| 5183 We also maintain a "reverse" table that maps from the internal | |
| 5184 lists to the external equivalents. The idea here is twofold: | |
| 5185 | |
| 5186 1) `extent-face' wants to return a list containing face symbols | |
| 5187 rather than face objects. | |
| 5188 2) We don't want things to get quite so messed up if the user | |
| 5189 maliciously side-effects the returned lists. | |
| 5190 */ | |
| 5191 | |
| 5192 len = XINT (Flength (list)); | |
| 5193 thelen = XINT (Flength (Vextent_face_reusable_list)); | |
| 5194 oldtail = Qnil; | |
| 5195 tail = Qnil; | |
| 5196 GCPRO1 (oldtail); | |
| 5197 | |
| 5198 /* We canonicalize the given list into another list. | |
| 5199 We try to avoid consing except when necessary, so we have | |
| 5200 a reusable list. | |
| 5201 */ | |
| 5202 | |
| 5203 if (thelen < len) | |
| 5204 { | |
| 5205 cons = Vextent_face_reusable_list; | |
| 5206 while (!NILP (XCDR (cons))) | |
| 5207 cons = XCDR (cons); | |
| 5208 XCDR (cons) = Fmake_list (make_int (len - thelen), Qnil); | |
| 5209 } | |
| 5210 else if (thelen > len) | |
| 5211 { | |
| 5212 int i; | |
| 5213 | |
| 5214 /* Truncate the list temporarily so it's the right length; | |
| 5215 remember the old tail. */ | |
| 5216 cons = Vextent_face_reusable_list; | |
| 5217 for (i = 0; i < len - 1; i++) | |
| 5218 cons = XCDR (cons); | |
| 5219 tail = cons; | |
| 5220 oldtail = XCDR (cons); | |
| 5221 XCDR (cons) = Qnil; | |
| 5222 } | |
| 5223 | |
| 5224 thecons = Vextent_face_reusable_list; | |
| 2367 | 5225 { |
| 5226 EXTERNAL_LIST_LOOP_2 (face, list) | |
| 5227 { | |
| 5228 face = Fget_face (face); | |
| 5229 | |
| 5230 XCAR (thecons) = Fface_name (face); | |
| 5231 thecons = XCDR (thecons); | |
| 5232 } | |
| 5233 } | |
| 428 | 5234 |
| 5235 list = Fgethash (Vextent_face_reusable_list, Vextent_face_memoize_hash_table, | |
| 5236 Qnil); | |
| 5237 if (NILP (list)) | |
| 5238 { | |
| 5239 Lisp_Object symlist = Fcopy_sequence (Vextent_face_reusable_list); | |
| 5240 Lisp_Object facelist = Fcopy_sequence (Vextent_face_reusable_list); | |
| 5241 | |
| 5242 LIST_LOOP (cons, facelist) | |
| 5243 { | |
| 5244 XCAR (cons) = Fget_face (XCAR (cons)); | |
| 5245 } | |
| 5246 Fputhash (symlist, facelist, Vextent_face_memoize_hash_table); | |
| 5247 Fputhash (facelist, symlist, Vextent_face_reverse_memoize_hash_table); | |
| 5248 list = facelist; | |
| 5249 } | |
| 5250 | |
| 5251 /* Now restore the truncated tail of the reusable list, if necessary. */ | |
| 5252 if (!NILP (tail)) | |
| 5253 XCDR (tail) = oldtail; | |
| 5254 | |
| 5255 UNGCPRO; | |
| 5256 return list; | |
| 5257 } | |
| 5258 | |
| 5259 static Lisp_Object | |
| 5260 external_of_internal_memoized_face (Lisp_Object face) | |
| 5261 { | |
| 5262 if (NILP (face)) | |
| 5263 return Qnil; | |
| 5264 else if (!CONSP (face)) | |
| 5265 return XFACE (face)->name; | |
| 5266 else | |
| 5267 { | |
| 5268 face = Fgethash (face, Vextent_face_reverse_memoize_hash_table, | |
| 5269 Qunbound); | |
| 5270 assert (!UNBOUNDP (face)); | |
| 5271 return face; | |
| 5272 } | |
| 5273 } | |
| 5274 | |
| 826 | 5275 /* The idea here is that if we're given a list of faces, we |
| 5276 need to "memoize" this so that two lists of faces that are `equal' | |
| 5277 turn into the same object. When `set-extent-face' is called, we | |
| 5278 "memoize" into a list of actual faces; when `extent-face' is called, | |
| 5279 we do a reverse lookup to get the list of symbols. */ | |
| 5280 | |
| 428 | 5281 static Lisp_Object |
| 5282 canonicalize_extent_property (Lisp_Object prop, Lisp_Object value) | |
| 5283 { | |
| 5284 if (EQ (prop, Qface) || EQ (prop, Qmouse_face)) | |
| 5285 value = (external_of_internal_memoized_face | |
| 5286 (memoize_extent_face_internal (value))); | |
| 5287 return value; | |
| 5288 } | |
| 5289 | |
| 5290 /* Do we need a lisp-level function ? */ | |
| 826 | 5291 DEFUN ("set-extent-initial-redisplay-function", |
| 5292 Fset_extent_initial_redisplay_function, | |
| 444 | 5293 2,2,0, /* |
| 428 | 5294 Note: This feature is experimental! |
| 5295 | |
| 5296 Set initial-redisplay-function of EXTENT to the function | |
| 5297 FUNCTION. | |
| 5298 | |
| 5299 The first time the EXTENT is (re)displayed, an eval event will be | |
| 5300 dispatched calling FUNCTION with EXTENT as its only argument. | |
| 5301 */ | |
| 5302 (extent, function)) | |
| 5303 { | |
| 826 | 5304 /* #### This is totally broken. */ |
| 5305 EXTENT e = decode_extent (extent, DE_MUST_BE_ATTACHED); | |
| 428 | 5306 |
| 5307 e = extent_ancestor (e); /* Is this needed? Macro also does chasing!*/ | |
| 826 | 5308 set_extent_initial_redisplay_function (e, function); |
| 5309 extent_in_red_event_p (e) = 0; /* If the function changed we can spawn | |
| 428 | 5310 new events */ |
| 826 | 5311 signal_extent_property_changed (e, Qinitial_redisplay_function, 1); |
| 428 | 5312 return function; |
| 5313 } | |
| 5314 | |
| 5315 DEFUN ("extent-face", Fextent_face, 1, 1, 0, /* | |
| 5316 Return the name of the face in which EXTENT is displayed, or nil | |
| 5317 if the extent's face is unspecified. This might also return a list | |
| 5318 of face names. | |
| 5319 */ | |
| 5320 (extent)) | |
| 5321 { | |
| 5322 Lisp_Object face; | |
| 5323 | |
| 5324 CHECK_EXTENT (extent); | |
| 5325 face = extent_face (XEXTENT (extent)); | |
| 5326 | |
| 5327 return external_of_internal_memoized_face (face); | |
| 5328 } | |
| 5329 | |
| 5330 DEFUN ("set-extent-face", Fset_extent_face, 2, 2, 0, /* | |
| 5331 Make the given EXTENT have the graphic attributes specified by FACE. | |
| 5332 FACE can also be a list of faces, and all faces listed will apply, | |
| 5333 with faces earlier in the list taking priority over those later in the | |
| 5334 list. | |
| 5335 */ | |
| 5336 (extent, face)) | |
| 5337 { | |
| 5338 EXTENT e = decode_extent(extent, 0); | |
| 5339 Lisp_Object orig_face = face; | |
| 5340 | |
| 5341 /* retrieve the ancestor for efficiency and proper redisplay noting. */ | |
| 5342 e = extent_ancestor (e); | |
| 5343 | |
| 5344 face = memoize_extent_face_internal (face); | |
| 5345 | |
| 5346 extent_face (e) = face; | |
| 826 | 5347 signal_extent_property_changed (e, Qface, 1); |
| 428 | 5348 |
| 5349 return orig_face; | |
| 5350 } | |
| 5351 | |
| 5352 | |
| 5353 DEFUN ("extent-mouse-face", Fextent_mouse_face, 1, 1, 0, /* | |
| 5354 Return the face used to highlight EXTENT when the mouse passes over it. | |
| 5355 The return value will be a face name, a list of face names, or nil | |
| 5356 if the extent's mouse face is unspecified. | |
| 5357 */ | |
| 5358 (extent)) | |
| 5359 { | |
| 5360 Lisp_Object face; | |
| 5361 | |
| 5362 CHECK_EXTENT (extent); | |
| 5363 face = extent_mouse_face (XEXTENT (extent)); | |
| 5364 | |
| 5365 return external_of_internal_memoized_face (face); | |
| 5366 } | |
| 5367 | |
| 5368 DEFUN ("set-extent-mouse-face", Fset_extent_mouse_face, 2, 2, 0, /* | |
| 5369 Set the face used to highlight EXTENT when the mouse passes over it. | |
| 5370 FACE can also be a list of faces, and all faces listed will apply, | |
| 5371 with faces earlier in the list taking priority over those later in the | |
| 5372 list. | |
| 5373 */ | |
| 5374 (extent, face)) | |
| 5375 { | |
| 5376 EXTENT e; | |
| 5377 Lisp_Object orig_face = face; | |
| 5378 | |
| 5379 CHECK_EXTENT (extent); | |
| 5380 e = XEXTENT (extent); | |
| 5381 /* retrieve the ancestor for efficiency and proper redisplay noting. */ | |
| 5382 e = extent_ancestor (e); | |
| 5383 | |
| 5384 face = memoize_extent_face_internal (face); | |
| 5385 | |
| 5386 set_extent_mouse_face (e, face); | |
| 826 | 5387 signal_extent_property_changed (e, Qmouse_face, 1); |
| 428 | 5388 |
| 5389 return orig_face; | |
| 5390 } | |
| 5391 | |
| 5392 void | |
| 5393 set_extent_glyph (EXTENT extent, Lisp_Object glyph, int endp, | |
| 5394 glyph_layout layout) | |
| 5395 { | |
| 5396 extent = extent_ancestor (extent); | |
| 5397 | |
| 5398 if (!endp) | |
| 5399 { | |
| 5400 set_extent_begin_glyph (extent, glyph); | |
| 647 | 5401 set_extent_begin_glyph_layout (extent, layout); |
| 826 | 5402 signal_extent_property_changed (extent, Qbegin_glyph, 1); |
| 5403 signal_extent_property_changed (extent, Qbegin_glyph_layout, 1); | |
| 428 | 5404 } |
| 5405 else | |
| 5406 { | |
| 5407 set_extent_end_glyph (extent, glyph); | |
| 647 | 5408 set_extent_end_glyph_layout (extent, layout); |
| 826 | 5409 signal_extent_property_changed (extent, Qend_glyph, 1); |
| 5410 signal_extent_property_changed (extent, Qend_glyph_layout, 1); | |
| 428 | 5411 } |
| 5412 } | |
| 5413 | |
| 5414 static Lisp_Object | |
| 5415 glyph_layout_to_symbol (glyph_layout layout) | |
| 5416 { | |
| 5417 switch (layout) | |
| 5418 { | |
| 5419 case GL_TEXT: return Qtext; | |
| 5420 case GL_OUTSIDE_MARGIN: return Qoutside_margin; | |
| 5421 case GL_INSIDE_MARGIN: return Qinside_margin; | |
| 5422 case GL_WHITESPACE: return Qwhitespace; | |
| 5423 default: | |
| 2500 | 5424 ABORT (); |
| 428 | 5425 return Qnil; /* unreached */ |
| 5426 } | |
| 5427 } | |
| 5428 | |
| 5429 static glyph_layout | |
| 5430 symbol_to_glyph_layout (Lisp_Object layout_obj) | |
| 5431 { | |
| 5432 if (NILP (layout_obj)) | |
| 5433 return GL_TEXT; | |
| 5434 | |
| 5435 CHECK_SYMBOL (layout_obj); | |
| 5436 if (EQ (layout_obj, Qoutside_margin)) return GL_OUTSIDE_MARGIN; | |
| 5437 if (EQ (layout_obj, Qinside_margin)) return GL_INSIDE_MARGIN; | |
| 5438 if (EQ (layout_obj, Qwhitespace)) return GL_WHITESPACE; | |
| 5439 if (EQ (layout_obj, Qtext)) return GL_TEXT; | |
| 5440 | |
| 563 | 5441 invalid_constant ("Unknown glyph layout type", layout_obj); |
| 1204 | 5442 RETURN_NOT_REACHED (GL_TEXT); |
| 428 | 5443 } |
| 5444 | |
| 5445 static Lisp_Object | |
| 5446 set_extent_glyph_1 (Lisp_Object extent_obj, Lisp_Object glyph, int endp, | |
| 5447 Lisp_Object layout_obj) | |
| 5448 { | |
| 442 | 5449 EXTENT extent = decode_extent (extent_obj, 0); |
| 428 | 5450 glyph_layout layout = symbol_to_glyph_layout (layout_obj); |
| 5451 | |
| 5452 /* Make sure we've actually been given a valid glyph or it's nil | |
| 5453 (meaning we're deleting a glyph from an extent). */ | |
| 5454 if (!NILP (glyph)) | |
| 5455 CHECK_BUFFER_GLYPH (glyph); | |
| 5456 | |
| 5457 set_extent_glyph (extent, glyph, endp, layout); | |
| 5458 return glyph; | |
| 5459 } | |
| 5460 | |
| 5461 DEFUN ("set-extent-begin-glyph", Fset_extent_begin_glyph, 2, 3, 0, /* | |
| 5462 Display a bitmap, subwindow or string at the beginning of EXTENT. | |
| 5463 BEGIN-GLYPH must be a glyph object. The layout policy defaults to `text'. | |
| 5464 */ | |
| 5465 (extent, begin_glyph, layout)) | |
| 5466 { | |
| 5467 return set_extent_glyph_1 (extent, begin_glyph, 0, layout); | |
| 5468 } | |
| 5469 | |
| 5470 DEFUN ("set-extent-end-glyph", Fset_extent_end_glyph, 2, 3, 0, /* | |
| 5471 Display a bitmap, subwindow or string at the end of EXTENT. | |
| 5472 END-GLYPH must be a glyph object. The layout policy defaults to `text'. | |
| 5473 */ | |
| 5474 (extent, end_glyph, layout)) | |
| 5475 { | |
| 5476 return set_extent_glyph_1 (extent, end_glyph, 1, layout); | |
| 5477 } | |
| 5478 | |
| 5479 DEFUN ("extent-begin-glyph", Fextent_begin_glyph, 1, 1, 0, /* | |
| 5480 Return the glyph object displayed at the beginning of EXTENT. | |
| 5481 If there is none, nil is returned. | |
| 5482 */ | |
| 5483 (extent)) | |
| 5484 { | |
| 5485 return extent_begin_glyph (decode_extent (extent, 0)); | |
| 5486 } | |
| 5487 | |
| 5488 DEFUN ("extent-end-glyph", Fextent_end_glyph, 1, 1, 0, /* | |
| 5489 Return the glyph object displayed at the end of EXTENT. | |
| 5490 If there is none, nil is returned. | |
| 5491 */ | |
| 5492 (extent)) | |
| 5493 { | |
| 5494 return extent_end_glyph (decode_extent (extent, 0)); | |
| 5495 } | |
| 5496 | |
| 5497 DEFUN ("set-extent-begin-glyph-layout", Fset_extent_begin_glyph_layout, 2, 2, 0, /* | |
| 5498 Set the layout policy of EXTENT's begin glyph. | |
| 5499 Access this using the `extent-begin-glyph-layout' function. | |
| 5500 */ | |
| 5501 (extent, layout)) | |
| 5502 { | |
| 5503 EXTENT e = decode_extent (extent, 0); | |
| 5504 e = extent_ancestor (e); | |
| 647 | 5505 set_extent_begin_glyph_layout (e, symbol_to_glyph_layout (layout)); |
| 826 | 5506 signal_extent_property_changed (e, Qbegin_glyph_layout, 1); |
| 428 | 5507 return layout; |
| 5508 } | |
| 5509 | |
| 5510 DEFUN ("set-extent-end-glyph-layout", Fset_extent_end_glyph_layout, 2, 2, 0, /* | |
| 5511 Set the layout policy of EXTENT's end glyph. | |
| 5512 Access this using the `extent-end-glyph-layout' function. | |
| 5513 */ | |
| 5514 (extent, layout)) | |
| 5515 { | |
| 5516 EXTENT e = decode_extent (extent, 0); | |
| 5517 e = extent_ancestor (e); | |
| 647 | 5518 set_extent_end_glyph_layout (e, symbol_to_glyph_layout (layout)); |
| 826 | 5519 signal_extent_property_changed (e, Qend_glyph_layout, 1); |
| 428 | 5520 return layout; |
| 5521 } | |
| 5522 | |
| 5523 DEFUN ("extent-begin-glyph-layout", Fextent_begin_glyph_layout, 1, 1, 0, /* | |
| 5524 Return the layout policy associated with EXTENT's begin glyph. | |
| 5525 Set this using the `set-extent-begin-glyph-layout' function. | |
| 5526 */ | |
| 5527 (extent)) | |
| 5528 { | |
| 5529 EXTENT e = decode_extent (extent, 0); | |
| 5530 return glyph_layout_to_symbol ((glyph_layout) extent_begin_glyph_layout (e)); | |
| 5531 } | |
| 5532 | |
| 5533 DEFUN ("extent-end-glyph-layout", Fextent_end_glyph_layout, 1, 1, 0, /* | |
| 5534 Return the layout policy associated with EXTENT's end glyph. | |
| 5535 Set this using the `set-extent-end-glyph-layout' function. | |
| 5536 */ | |
| 5537 (extent)) | |
| 5538 { | |
| 5539 EXTENT e = decode_extent (extent, 0); | |
| 5540 return glyph_layout_to_symbol ((glyph_layout) extent_end_glyph_layout (e)); | |
| 5541 } | |
| 5542 | |
| 5543 DEFUN ("set-extent-priority", Fset_extent_priority, 2, 2, 0, /* | |
| 5544 Set the display priority of EXTENT to PRIORITY (an integer). | |
| 5545 When the extent attributes are being merged for display, the priority | |
| 5546 is used to determine which extent takes precedence in the event of a | |
| 5547 conflict (two extents whose faces both specify font, for example: the | |
| 5548 font of the extent with the higher priority will be used). | |
| 5549 Extents are created with priority 0; priorities may be negative. | |
| 5550 */ | |
| 5551 (extent, priority)) | |
| 5552 { | |
| 5553 EXTENT e = decode_extent (extent, 0); | |
| 5554 | |
| 5555 CHECK_INT (priority); | |
| 5556 e = extent_ancestor (e); | |
| 5557 set_extent_priority (e, XINT (priority)); | |
| 826 | 5558 signal_extent_property_changed (e, Qpriority, 1); |
| 428 | 5559 return priority; |
| 5560 } | |
| 5561 | |
| 5562 DEFUN ("extent-priority", Fextent_priority, 1, 1, 0, /* | |
| 5563 Return the display priority of EXTENT; see `set-extent-priority'. | |
| 5564 */ | |
| 5565 (extent)) | |
| 5566 { | |
| 5567 EXTENT e = decode_extent (extent, 0); | |
| 5568 return make_int (extent_priority (e)); | |
| 5569 } | |
| 5570 | |
| 5571 DEFUN ("set-extent-property", Fset_extent_property, 3, 3, 0, /* | |
| 5572 Change a property of an extent. | |
| 5573 PROPERTY may be any symbol; the value stored may be accessed with | |
| 5574 the `extent-property' function. | |
| 2758 | 5575 |
| 428 | 5576 The following symbols have predefined meanings: |
| 5577 | |
| 5578 detached Removes the extent from its buffer; setting this is | |
| 5579 the same as calling `detach-extent'. | |
| 5580 | |
| 5581 destroyed Removes the extent from its buffer, and makes it | |
| 5582 unusable in the future; this is the same calling | |
| 5583 `delete-extent'. | |
| 5584 | |
| 5585 priority Change redisplay priority; same as `set-extent-priority'. | |
| 5586 | |
| 5587 start-open Whether the set of characters within the extent is | |
| 5588 treated being open on the left, that is, whether | |
| 5589 the start position is an exclusive, rather than | |
| 5590 inclusive, boundary. If true, then characters | |
| 5591 inserted exactly at the beginning of the extent | |
| 5592 will remain outside of the extent; otherwise they | |
| 5593 will go into the extent, extending it. | |
| 5594 | |
| 5595 end-open Whether the set of characters within the extent is | |
| 5596 treated being open on the right, that is, whether | |
| 5597 the end position is an exclusive, rather than | |
| 5598 inclusive, boundary. If true, then characters | |
| 5599 inserted exactly at the end of the extent will | |
| 5600 remain outside of the extent; otherwise they will | |
| 5601 go into the extent, extending it. | |
| 5602 | |
| 5603 By default, extents have the `end-open' but not the | |
| 5604 `start-open' property set. | |
| 5605 | |
| 5606 read-only Text within this extent will be unmodifiable. | |
| 5607 | |
| 5608 initial-redisplay-function (EXPERIMENTAL) | |
| 5609 function to be called the first time (part of) the extent | |
| 5610 is redisplayed. It will be called with the extent as its | |
| 5611 first argument. | |
| 1041 | 5612 Note: The function will not be called immediately |
| 5613 during redisplay, an eval event will be dispatched. | |
| 428 | 5614 |
| 5615 detachable Whether the extent gets detached (as with | |
| 5616 `detach-extent') when all the text within the | |
| 5617 extent is deleted. This is true by default. If | |
| 5618 this property is not set, the extent becomes a | |
| 5619 zero-length extent when its text is deleted. (In | |
| 5620 such a case, the `start-open' property is | |
| 5621 automatically removed if both the `start-open' and | |
| 5622 `end-open' properties are set, since zero-length | |
| 5623 extents open on both ends are not allowed.) | |
| 5624 | |
| 5625 face The face in which to display the text. Setting | |
| 5626 this is the same as calling `set-extent-face'. | |
| 5627 | |
| 1041 | 5628 mouse-face If non-nil, the extent will be highlighted in this |
| 5629 face when the mouse moves over it. | |
| 428 | 5630 |
| 5631 pointer If non-nil, and a valid pointer glyph, this specifies | |
| 5632 the shape of the mouse pointer while over the extent. | |
| 5633 | |
| 5634 highlight Obsolete: Setting this property is equivalent to | |
| 1041 | 5635 setting a `mouse-face' property of `highlight'. |
| 5636 Reading this property returns non-nil if | |
| 5637 the extent has a non-nil `mouse-face' property. | |
| 428 | 5638 |
| 5639 duplicable Whether this extent should be copied into strings, | |
| 5640 so that kill, yank, and undo commands will restore | |
| 5641 or copy it. `duplicable' extents are copied from | |
| 5642 an extent into a string when `buffer-substring' or | |
| 5643 a similar function creates a string. The extents | |
| 5644 in a string are copied into other strings created | |
| 5645 from the string using `concat' or `substring'. | |
| 5646 When `insert' or a similar function inserts the | |
| 5647 string into a buffer, the extents are copied back | |
| 5648 into the buffer. | |
| 5649 | |
| 5650 unique Meaningful only in conjunction with `duplicable'. | |
| 5651 When this is set, there may be only one instance | |
| 5652 of this extent attached at a time: if it is copied | |
| 5653 to the kill ring and then yanked, the extent is | |
| 5654 not copied. If, however, it is killed (removed | |
| 5655 from the buffer) and then yanked, it will be | |
| 5656 re-attached at the new position. | |
| 5657 | |
| 5658 invisible If the value is non-nil, text under this extent | |
| 5659 may be treated as not present for the purpose of | |
| 5660 redisplay, or may be displayed using an ellipsis | |
| 5661 or other marker; see `buffer-invisibility-spec' | |
| 5662 and `invisible-text-glyph'. In all cases, | |
| 5663 however, the text is still visible to other | |
| 5664 functions that examine a buffer's text. | |
| 5665 | |
| 5666 keymap This keymap is consulted for mouse clicks on this | |
| 5667 extent, or keypresses made while point is within the | |
| 5668 extent. | |
| 5669 | |
| 5670 copy-function This is a hook that is run when a duplicable extent | |
| 5671 is about to be copied from a buffer to a string (or | |
| 5672 the kill ring). It is called with three arguments, | |
| 5673 the extent, and the buffer-positions within it | |
| 5674 which are being copied. If this function returns | |
| 5675 nil, then the extent will not be copied; otherwise | |
| 5676 it will. | |
| 5677 | |
| 5678 paste-function This is a hook that is run when a duplicable extent is | |
| 5679 about to be copied from a string (or the kill ring) | |
| 5680 into a buffer. It is called with three arguments, | |
| 5681 the original extent, and the buffer positions which | |
| 5682 the copied extent will occupy. (This hook is run | |
| 5683 after the corresponding text has already been | |
| 5684 inserted into the buffer.) Note that the extent | |
| 5685 argument may be detached when this function is run. | |
| 5686 If this function returns nil, no extent will be | |
| 5687 inserted. Otherwise, there will be an extent | |
| 5688 covering the range in question. | |
| 5689 | |
| 5690 If the original extent is not attached to a buffer, | |
| 5691 then it will be re-attached at this range. | |
| 5692 Otherwise, a copy will be made, and that copy | |
| 5693 attached here. | |
| 5694 | |
| 5695 The copy-function and paste-function are meaningful | |
| 5696 only for extents with the `duplicable' flag set, | |
| 5697 and if they are not specified, behave as if `t' was | |
| 5698 the returned value. When these hooks are invoked, | |
| 5699 the current buffer is the buffer which the extent | |
| 5700 is being copied from/to, respectively. | |
| 5701 | |
| 5702 begin-glyph A glyph to be displayed at the beginning of the extent, | |
| 5703 or nil. | |
| 5704 | |
| 5705 end-glyph A glyph to be displayed at the end of the extent, | |
| 5706 or nil. | |
| 5707 | |
| 5708 begin-glyph-layout The layout policy (one of `text', `whitespace', | |
| 5709 `inside-margin', or `outside-margin') of the extent's | |
| 5710 begin glyph. | |
| 5711 | |
| 1041 | 5712 end-glyph-layout The layout policy of the extent's end glyph. |
| 5713 | |
| 5714 syntax-table A cons or a syntax table object. If a cons, the car must | |
| 2767 | 5715 be an integer (interpreted as a syntax code, applicable |
| 5716 to all characters in the extent). Otherwise, syntax of | |
| 5717 characters in the extent is looked up in the syntax | |
| 5718 table. You should use the text property API to | |
| 5719 manipulate this property. (This may be required in the | |
| 5720 future.) | |
| 5721 | |
| 5722 The following property is available if `atomic-extents.el'--part of the | |
| 5723 `edit-utils' package--has been loaded: | |
| 2758 | 5724 |
| 5725 atomic When set, point will never fall inside the extent. | |
| 5726 Not as useful as you might think, as | |
| 5727 `delete-backward-char' still removes characters one by | |
| 2767 | 5728 one. This property as currently implemented is a |
| 5729 kludge, and be prepared for it to go away if and when we | |
| 5730 implement something better. | |
| 2758 | 5731 |
| 428 | 5732 */ |
| 5733 (extent, property, value)) | |
| 5734 { | |
| 5735 /* This function can GC if property is `keymap' */ | |
| 5736 EXTENT e = decode_extent (extent, 0); | |
| 826 | 5737 int signal_change = 0; |
| 5738 | |
| 5739 /* If VALUE is unbound, the property is being removed through `remprop'. | |
| 5740 Return Qunbound if removal disallowed, Qt if anything removed, | |
| 5741 Qnil otherwise. */ | |
| 5742 | |
| 5743 /* Keep in synch with stuff below. */ | |
| 5744 if (UNBOUNDP (value)) | |
| 5745 { | |
| 5746 int retval; | |
| 5747 | |
| 5748 if (EQ (property, Qread_only) | |
| 5749 || EQ (property, Qunique) | |
| 5750 || EQ (property, Qduplicable) | |
| 5751 || EQ (property, Qinvisible) | |
| 5752 || EQ (property, Qdetachable) | |
| 5753 || EQ (property, Qdetached) | |
| 5754 || EQ (property, Qdestroyed) | |
| 5755 || EQ (property, Qpriority) | |
| 5756 || EQ (property, Qface) | |
| 5757 || EQ (property, Qinitial_redisplay_function) | |
| 5758 || EQ (property, Qafter_change_functions) | |
| 5759 || EQ (property, Qbefore_change_functions) | |
| 5760 || EQ (property, Qmouse_face) | |
| 5761 || EQ (property, Qhighlight) | |
| 5762 || EQ (property, Qbegin_glyph_layout) | |
| 5763 || EQ (property, Qend_glyph_layout) | |
| 5764 || EQ (property, Qglyph_layout) | |
| 5765 || EQ (property, Qbegin_glyph) | |
| 5766 || EQ (property, Qend_glyph) | |
| 5767 || EQ (property, Qstart_open) | |
| 5768 || EQ (property, Qend_open) | |
| 5769 || EQ (property, Qstart_closed) | |
| 5770 || EQ (property, Qend_closed) | |
| 5771 || EQ (property, Qkeymap)) | |
| 5772 return Qunbound; | |
| 5773 | |
| 5774 retval = external_remprop (extent_plist_addr (e), property, 0, | |
| 5775 ERROR_ME); | |
| 5776 if (retval) | |
| 5777 signal_extent_property_changed (e, property, 1); | |
| 5778 return retval ? Qt : Qnil; | |
| 5779 } | |
| 428 | 5780 |
| 5781 if (EQ (property, Qread_only)) | |
| 826 | 5782 { |
| 5783 set_extent_read_only (e, value); | |
| 5784 signal_change = 1; | |
| 5785 } | |
| 428 | 5786 else if (EQ (property, Qunique)) |
| 826 | 5787 { |
| 5788 extent_unique_p (e) = !NILP (value); | |
| 5789 signal_change = 1; | |
| 5790 } | |
| 428 | 5791 else if (EQ (property, Qduplicable)) |
| 826 | 5792 { |
| 5793 extent_duplicable_p (e) = !NILP (value); | |
| 5794 signal_change = 1; | |
| 5795 } | |
| 428 | 5796 else if (EQ (property, Qinvisible)) |
| 5797 set_extent_invisible (e, value); | |
| 5798 else if (EQ (property, Qdetachable)) | |
| 826 | 5799 { |
| 5800 extent_detachable_p (e) = !NILP (value); | |
| 5801 signal_change = 1; | |
| 5802 } | |
| 428 | 5803 else if (EQ (property, Qdetached)) |
| 5804 { | |
| 5805 if (NILP (value)) | |
| 826 | 5806 invalid_operation ("can only set `detached' to t", Qunbound); |
| 428 | 5807 Fdetach_extent (extent); |
| 5808 } | |
| 5809 else if (EQ (property, Qdestroyed)) | |
| 5810 { | |
| 5811 if (NILP (value)) | |
| 826 | 5812 invalid_operation ("can only set `destroyed' to t", Qunbound); |
| 428 | 5813 Fdelete_extent (extent); |
| 5814 } | |
| 5815 else if (EQ (property, Qpriority)) | |
| 5816 Fset_extent_priority (extent, value); | |
| 5817 else if (EQ (property, Qface)) | |
| 5818 Fset_extent_face (extent, value); | |
| 5819 else if (EQ (property, Qinitial_redisplay_function)) | |
| 5820 Fset_extent_initial_redisplay_function (extent, value); | |
| 5821 else if (EQ (property, Qbefore_change_functions)) | |
| 826 | 5822 { |
| 5823 set_extent_before_change_functions (e, value); | |
| 5824 signal_change = 1; | |
| 5825 } | |
| 428 | 5826 else if (EQ (property, Qafter_change_functions)) |
| 826 | 5827 { |
| 5828 set_extent_after_change_functions (e, value); | |
| 5829 signal_change = 1; | |
| 5830 } | |
| 428 | 5831 else if (EQ (property, Qmouse_face)) |
| 5832 Fset_extent_mouse_face (extent, value); | |
| 5833 /* Obsolete: */ | |
| 5834 else if (EQ (property, Qhighlight)) | |
| 5835 Fset_extent_mouse_face (extent, Qhighlight); | |
| 5836 else if (EQ (property, Qbegin_glyph_layout)) | |
| 5837 Fset_extent_begin_glyph_layout (extent, value); | |
| 5838 else if (EQ (property, Qend_glyph_layout)) | |
| 5839 Fset_extent_end_glyph_layout (extent, value); | |
| 5840 /* For backwards compatibility. We use begin glyph because it is by | |
| 5841 far the more used of the two. */ | |
| 5842 else if (EQ (property, Qglyph_layout)) | |
| 5843 Fset_extent_begin_glyph_layout (extent, value); | |
| 5844 else if (EQ (property, Qbegin_glyph)) | |
| 5845 Fset_extent_begin_glyph (extent, value, Qnil); | |
| 5846 else if (EQ (property, Qend_glyph)) | |
| 5847 Fset_extent_end_glyph (extent, value, Qnil); | |
| 5848 else if (EQ (property, Qstart_open)) | |
| 5849 set_extent_openness (e, !NILP (value), -1); | |
| 5850 else if (EQ (property, Qend_open)) | |
| 5851 set_extent_openness (e, -1, !NILP (value)); | |
| 5852 /* Support (but don't document...) the obvious *_closed antonyms. */ | |
| 5853 else if (EQ (property, Qstart_closed)) | |
| 5854 set_extent_openness (e, NILP (value), -1); | |
| 5855 else if (EQ (property, Qend_closed)) | |
| 5856 set_extent_openness (e, -1, NILP (value)); | |
| 5857 else | |
| 5858 { | |
| 5859 if (EQ (property, Qkeymap)) | |
| 5860 while (!NILP (value) && NILP (Fkeymapp (value))) | |
| 5861 value = wrong_type_argument (Qkeymapp, value); | |
| 5862 | |
| 5863 external_plist_put (extent_plist_addr (e), property, value, 0, ERROR_ME); | |
| 826 | 5864 signal_change = 1; |
| 428 | 5865 } |
| 5866 | |
| 826 | 5867 if (signal_change) |
| 5868 signal_extent_property_changed (e, property, 1); | |
| 428 | 5869 return value; |
| 5870 } | |
| 5871 | |
| 5872 DEFUN ("set-extent-properties", Fset_extent_properties, 2, 2, 0, /* | |
| 5873 Change some properties of EXTENT. | |
| 5874 PLIST is a property list. | |
| 5875 For a list of built-in properties, see `set-extent-property'. | |
| 5876 */ | |
| 5877 (extent, plist)) | |
| 5878 { | |
| 5879 /* This function can GC, if one of the properties is `keymap' */ | |
| 5880 Lisp_Object property, value; | |
| 5881 struct gcpro gcpro1; | |
| 5882 GCPRO1 (plist); | |
| 5883 | |
| 5884 plist = Fcopy_sequence (plist); | |
| 5885 Fcanonicalize_plist (plist, Qnil); | |
| 5886 | |
| 5887 while (!NILP (plist)) | |
| 5888 { | |
| 5889 property = Fcar (plist); plist = Fcdr (plist); | |
| 5890 value = Fcar (plist); plist = Fcdr (plist); | |
| 5891 Fset_extent_property (extent, property, value); | |
| 5892 } | |
| 5893 UNGCPRO; | |
| 5894 return Qnil; | |
| 5895 } | |
| 5896 | |
| 5897 DEFUN ("extent-property", Fextent_property, 2, 3, 0, /* | |
| 5898 Return EXTENT's value for property PROPERTY. | |
| 444 | 5899 If no such property exists, DEFAULT is returned. |
| 428 | 5900 See `set-extent-property' for the built-in property names. |
| 5901 */ | |
| 5902 (extent, property, default_)) | |
| 5903 { | |
| 5904 EXTENT e = decode_extent (extent, 0); | |
| 5905 | |
| 5906 if (EQ (property, Qdetached)) | |
| 5907 return extent_detached_p (e) ? Qt : Qnil; | |
| 5908 else if (EQ (property, Qdestroyed)) | |
| 5909 return !EXTENT_LIVE_P (e) ? Qt : Qnil; | |
| 5910 else if (EQ (property, Qstart_open)) | |
| 5911 return extent_normal_field (e, start_open) ? Qt : Qnil; | |
| 5912 else if (EQ (property, Qend_open)) | |
| 5913 return extent_normal_field (e, end_open) ? Qt : Qnil; | |
| 5914 else if (EQ (property, Qunique)) | |
| 5915 return extent_normal_field (e, unique) ? Qt : Qnil; | |
| 5916 else if (EQ (property, Qduplicable)) | |
| 5917 return extent_normal_field (e, duplicable) ? Qt : Qnil; | |
| 5918 else if (EQ (property, Qdetachable)) | |
| 5919 return extent_normal_field (e, detachable) ? Qt : Qnil; | |
| 5920 /* Support (but don't document...) the obvious *_closed antonyms. */ | |
| 5921 else if (EQ (property, Qstart_closed)) | |
| 5922 return extent_start_open_p (e) ? Qnil : Qt; | |
| 5923 else if (EQ (property, Qend_closed)) | |
| 5924 return extent_end_open_p (e) ? Qnil : Qt; | |
| 5925 else if (EQ (property, Qpriority)) | |
| 5926 return make_int (extent_priority (e)); | |
| 5927 else if (EQ (property, Qread_only)) | |
| 5928 return extent_read_only (e); | |
| 5929 else if (EQ (property, Qinvisible)) | |
| 5930 return extent_invisible (e); | |
| 5931 else if (EQ (property, Qface)) | |
| 5932 return Fextent_face (extent); | |
| 5933 else if (EQ (property, Qinitial_redisplay_function)) | |
| 5934 return extent_initial_redisplay_function (e); | |
| 5935 else if (EQ (property, Qbefore_change_functions)) | |
| 5936 return extent_before_change_functions (e); | |
| 5937 else if (EQ (property, Qafter_change_functions)) | |
| 5938 return extent_after_change_functions (e); | |
| 5939 else if (EQ (property, Qmouse_face)) | |
| 5940 return Fextent_mouse_face (extent); | |
| 5941 /* Obsolete: */ | |
| 5942 else if (EQ (property, Qhighlight)) | |
| 5943 return !NILP (Fextent_mouse_face (extent)) ? Qt : Qnil; | |
| 5944 else if (EQ (property, Qbegin_glyph_layout)) | |
| 5945 return Fextent_begin_glyph_layout (extent); | |
| 5946 else if (EQ (property, Qend_glyph_layout)) | |
| 5947 return Fextent_end_glyph_layout (extent); | |
| 5948 /* For backwards compatibility. We use begin glyph because it is by | |
| 5949 far the more used of the two. */ | |
| 5950 else if (EQ (property, Qglyph_layout)) | |
| 5951 return Fextent_begin_glyph_layout (extent); | |
| 5952 else if (EQ (property, Qbegin_glyph)) | |
| 5953 return extent_begin_glyph (e); | |
| 5954 else if (EQ (property, Qend_glyph)) | |
| 5955 return extent_end_glyph (e); | |
| 5956 else | |
| 5957 { | |
| 5958 Lisp_Object value = external_plist_get (extent_plist_addr (e), | |
| 5959 property, 0, ERROR_ME); | |
| 5960 return UNBOUNDP (value) ? default_ : value; | |
| 5961 } | |
| 5962 } | |
| 5963 | |
| 826 | 5964 static void |
| 5965 extent_properties (EXTENT e, Lisp_Object_pair_dynarr *props) | |
| 5966 { | |
| 5967 Lisp_Object face, anc_obj; | |
| 428 | 5968 glyph_layout layout; |
| 826 | 5969 EXTENT anc; |
| 5970 | |
| 5971 #define ADD_PROP(miftaaH, maal) \ | |
| 5972 do { \ | |
| 5973 Lisp_Object_pair p; \ | |
| 5974 p.key = miftaaH; \ | |
| 5975 p.value = maal; \ | |
| 5976 Dynarr_add (props, p); \ | |
| 5977 } while (0) | |
| 5978 | |
| 428 | 5979 if (!EXTENT_LIVE_P (e)) |
| 826 | 5980 { |
| 5981 ADD_PROP (Qdestroyed, Qt); | |
| 5982 return; | |
| 5983 } | |
| 428 | 5984 |
| 5985 anc = extent_ancestor (e); | |
| 793 | 5986 anc_obj = wrap_extent (anc); |
| 428 | 5987 |
| 5988 /* For efficiency, use the ancestor for all properties except detached */ | |
| 826 | 5989 { |
| 5990 EXTERNAL_PROPERTY_LIST_LOOP_3 (key, value, extent_plist_slot (anc)) | |
| 5991 ADD_PROP (key, value); | |
| 5992 } | |
| 428 | 5993 |
| 5994 if (!NILP (face = Fextent_face (anc_obj))) | |
| 826 | 5995 ADD_PROP (Qface, face); |
| 428 | 5996 |
| 5997 if (!NILP (face = Fextent_mouse_face (anc_obj))) | |
| 826 | 5998 ADD_PROP (Qmouse_face, face); |
| 428 | 5999 |
| 6000 if ((layout = (glyph_layout) extent_begin_glyph_layout (anc)) != GL_TEXT) | |
| 6001 { | |
| 6002 Lisp_Object sym = glyph_layout_to_symbol (layout); | |
| 826 | 6003 ADD_PROP (Qglyph_layout, sym); /* compatibility */ |
| 6004 ADD_PROP (Qbegin_glyph_layout, sym); | |
| 428 | 6005 } |
| 6006 | |
| 6007 if ((layout = (glyph_layout) extent_end_glyph_layout (anc)) != GL_TEXT) | |
| 826 | 6008 ADD_PROP (Qend_glyph_layout, glyph_layout_to_symbol (layout)); |
| 428 | 6009 |
| 6010 if (!NILP (extent_end_glyph (anc))) | |
| 826 | 6011 ADD_PROP (Qend_glyph, extent_end_glyph (anc)); |
| 428 | 6012 |
| 6013 if (!NILP (extent_begin_glyph (anc))) | |
| 826 | 6014 ADD_PROP (Qbegin_glyph, extent_begin_glyph (anc)); |
| 428 | 6015 |
| 6016 if (extent_priority (anc) != 0) | |
| 826 | 6017 ADD_PROP (Qpriority, make_int (extent_priority (anc))); |
| 428 | 6018 |
| 6019 if (!NILP (extent_initial_redisplay_function (anc))) | |
| 826 | 6020 ADD_PROP (Qinitial_redisplay_function, |
| 6021 extent_initial_redisplay_function (anc)); | |
| 428 | 6022 |
| 6023 if (!NILP (extent_before_change_functions (anc))) | |
| 826 | 6024 ADD_PROP (Qbefore_change_functions, extent_before_change_functions (anc)); |
| 428 | 6025 |
| 6026 if (!NILP (extent_after_change_functions (anc))) | |
| 826 | 6027 ADD_PROP (Qafter_change_functions, extent_after_change_functions (anc)); |
| 428 | 6028 |
| 6029 if (!NILP (extent_invisible (anc))) | |
| 826 | 6030 ADD_PROP (Qinvisible, extent_invisible (anc)); |
| 428 | 6031 |
| 6032 if (!NILP (extent_read_only (anc))) | |
| 826 | 6033 ADD_PROP (Qread_only, extent_read_only (anc)); |
| 428 | 6034 |
| 6035 if (extent_normal_field (anc, end_open)) | |
| 826 | 6036 ADD_PROP (Qend_open, Qt); |
| 428 | 6037 |
| 6038 if (extent_normal_field (anc, start_open)) | |
| 826 | 6039 ADD_PROP (Qstart_open, Qt); |
| 428 | 6040 |
| 6041 if (extent_normal_field (anc, detachable)) | |
| 826 | 6042 ADD_PROP (Qdetachable, Qt); |
| 428 | 6043 |
| 6044 if (extent_normal_field (anc, duplicable)) | |
| 826 | 6045 ADD_PROP (Qduplicable, Qt); |
| 428 | 6046 |
| 6047 if (extent_normal_field (anc, unique)) | |
| 826 | 6048 ADD_PROP (Qunique, Qt); |
| 428 | 6049 |
| 6050 /* detached is not an inherited property */ | |
| 6051 if (extent_detached_p (e)) | |
| 826 | 6052 ADD_PROP (Qdetached, Qt); |
| 6053 | |
| 6054 #undef ADD_PROP | |
| 6055 } | |
| 6056 | |
| 6057 DEFUN ("extent-properties", Fextent_properties, 1, 1, 0, /* | |
| 6058 Return a property list of the attributes of EXTENT. | |
| 6059 Do not modify this list; use `set-extent-property' instead. | |
| 6060 */ | |
| 6061 (extent)) | |
| 6062 { | |
| 6063 EXTENT e; | |
| 6064 Lisp_Object result = Qnil; | |
| 6065 Lisp_Object_pair_dynarr *props; | |
| 6066 int i; | |
| 6067 | |
| 6068 CHECK_EXTENT (extent); | |
| 6069 e = XEXTENT (extent); | |
| 6070 props = Dynarr_new (Lisp_Object_pair); | |
| 6071 extent_properties (e, props); | |
| 6072 | |
| 6073 for (i = 0; i < Dynarr_length (props); i++) | |
| 6074 result = cons3 (Dynarr_at (props, i).key, Dynarr_at (props, i).value, | |
| 6075 result); | |
| 6076 | |
| 6077 Dynarr_free (props); | |
| 428 | 6078 return result; |
| 6079 } | |
| 6080 | |
| 6081 | |
| 6082 /************************************************************************/ | |
| 6083 /* highlighting */ | |
| 6084 /************************************************************************/ | |
| 6085 | |
| 6086 /* The display code looks into the Vlast_highlighted_extent variable to | |
| 6087 correctly display highlighted extents. This updates that variable, | |
| 6088 and marks the appropriate buffers as needing some redisplay. | |
| 6089 */ | |
| 6090 static void | |
| 6091 do_highlight (Lisp_Object extent_obj, int highlight_p) | |
| 6092 { | |
| 6093 if (( highlight_p && (EQ (Vlast_highlighted_extent, extent_obj))) || | |
| 6094 (!highlight_p && (EQ (Vlast_highlighted_extent, Qnil)))) | |
| 6095 return; | |
| 6096 if (EXTENTP (Vlast_highlighted_extent) && | |
| 6097 EXTENT_LIVE_P (XEXTENT (Vlast_highlighted_extent))) | |
| 6098 { | |
| 6099 /* do not recurse on descendants. Only one extent is highlighted | |
| 6100 at a time. */ | |
| 826 | 6101 /* A bit of a lie. */ |
| 6102 signal_extent_property_changed (XEXTENT (Vlast_highlighted_extent), | |
| 6103 Qface, 0); | |
| 428 | 6104 } |
| 6105 Vlast_highlighted_extent = Qnil; | |
| 6106 if (!NILP (extent_obj) | |
| 6107 && BUFFERP (extent_object (XEXTENT (extent_obj))) | |
| 6108 && highlight_p) | |
| 6109 { | |
| 826 | 6110 signal_extent_property_changed (XEXTENT (extent_obj), Qface, 0); |
| 428 | 6111 Vlast_highlighted_extent = extent_obj; |
| 6112 } | |
| 6113 } | |
| 6114 | |
| 6115 DEFUN ("force-highlight-extent", Fforce_highlight_extent, 1, 2, 0, /* | |
| 6116 Highlight or unhighlight the given extent. | |
| 6117 If the second arg is non-nil, it will be highlighted, else dehighlighted. | |
| 6118 This is the same as `highlight-extent', except that it will work even | |
| 6119 on extents without the `mouse-face' property. | |
| 6120 */ | |
| 6121 (extent, highlight_p)) | |
| 6122 { | |
| 6123 if (NILP (extent)) | |
| 6124 highlight_p = Qnil; | |
| 6125 else | |
| 793 | 6126 extent = wrap_extent (decode_extent (extent, DE_MUST_BE_ATTACHED)); |
| 428 | 6127 do_highlight (extent, !NILP (highlight_p)); |
| 6128 return Qnil; | |
| 6129 } | |
| 6130 | |
| 6131 DEFUN ("highlight-extent", Fhighlight_extent, 1, 2, 0, /* | |
| 6132 Highlight EXTENT, if it is highlightable. | |
| 6133 \(that is, if it has the `mouse-face' property). | |
| 6134 If the second arg is non-nil, it will be highlighted, else dehighlighted. | |
| 6135 Highlighted extents are displayed as if they were merged with the face | |
| 6136 or faces specified by the `mouse-face' property. | |
| 6137 */ | |
| 6138 (extent, highlight_p)) | |
| 6139 { | |
| 6140 if (EXTENTP (extent) && NILP (extent_mouse_face (XEXTENT (extent)))) | |
| 6141 return Qnil; | |
| 6142 else | |
| 6143 return Fforce_highlight_extent (extent, highlight_p); | |
| 6144 } | |
| 6145 | |
| 6146 | |
| 6147 /************************************************************************/ | |
| 6148 /* strings and extents */ | |
| 6149 /************************************************************************/ | |
| 6150 | |
| 6151 /* copy/paste hooks */ | |
| 6152 | |
| 6153 static int | |
| 826 | 6154 run_extent_copy_paste_internal (EXTENT e, Charxpos from, Charxpos to, |
| 428 | 6155 Lisp_Object object, |
| 6156 Lisp_Object prop) | |
| 6157 { | |
| 6158 /* This function can GC */ | |
| 6159 Lisp_Object extent; | |
| 6160 Lisp_Object copy_fn; | |
| 793 | 6161 extent = wrap_extent (e); |
| 428 | 6162 copy_fn = Fextent_property (extent, prop, Qnil); |
| 6163 if (!NILP (copy_fn)) | |
| 6164 { | |
| 6165 Lisp_Object flag; | |
| 6166 struct gcpro gcpro1, gcpro2, gcpro3; | |
| 6167 GCPRO3 (extent, copy_fn, object); | |
| 6168 if (BUFFERP (object)) | |
| 6169 flag = call3_in_buffer (XBUFFER (object), copy_fn, extent, | |
| 6170 make_int (from), make_int (to)); | |
| 6171 else | |
| 6172 flag = call3 (copy_fn, extent, make_int (from), make_int (to)); | |
| 6173 UNGCPRO; | |
| 6174 if (NILP (flag) || !EXTENT_LIVE_P (XEXTENT (extent))) | |
| 6175 return 0; | |
| 6176 } | |
| 6177 return 1; | |
| 6178 } | |
| 6179 | |
| 6180 static int | |
| 826 | 6181 run_extent_copy_function (EXTENT e, Bytexpos from, Bytexpos to) |
| 428 | 6182 { |
| 6183 Lisp_Object object = extent_object (e); | |
| 6184 /* This function can GC */ | |
| 6185 return run_extent_copy_paste_internal | |
| 826 | 6186 (e, buffer_or_string_bytexpos_to_charxpos (object, from), |
| 6187 buffer_or_string_bytexpos_to_charxpos (object, to), object, | |
| 428 | 6188 Qcopy_function); |
| 6189 } | |
| 6190 | |
| 6191 static int | |
| 826 | 6192 run_extent_paste_function (EXTENT e, Bytexpos from, Bytexpos to, |
| 428 | 6193 Lisp_Object object) |
| 6194 { | |
| 6195 /* This function can GC */ | |
| 6196 return run_extent_copy_paste_internal | |
| 826 | 6197 (e, buffer_or_string_bytexpos_to_charxpos (object, from), |
| 6198 buffer_or_string_bytexpos_to_charxpos (object, to), object, | |
| 428 | 6199 Qpaste_function); |
| 6200 } | |
| 6201 | |
| 826 | 6202 static int |
| 6203 run_extent_paste_function_char (EXTENT e, Charxpos from, Charxpos to, | |
| 6204 Lisp_Object object) | |
| 6205 { | |
| 6206 /* This function can GC */ | |
| 6207 return run_extent_copy_paste_internal (e, from, to, object, Qpaste_function); | |
| 6208 } | |
| 6209 | |
| 428 | 6210 static Lisp_Object |
| 826 | 6211 insert_extent (EXTENT extent, Bytexpos new_start, Bytexpos new_end, |
| 428 | 6212 Lisp_Object object, int run_hooks) |
| 6213 { | |
| 6214 /* This function can GC */ | |
| 6215 if (!EQ (extent_object (extent), object)) | |
| 6216 goto copy_it; | |
| 6217 | |
| 6218 if (extent_detached_p (extent)) | |
| 6219 { | |
| 6220 if (run_hooks && | |
| 6221 !run_extent_paste_function (extent, new_start, new_end, object)) | |
| 6222 /* The paste-function said don't re-attach this extent here. */ | |
| 6223 return Qnil; | |
| 6224 else | |
| 826 | 6225 set_extent_endpoints (extent, new_start, new_end, Qnil); |
| 428 | 6226 } |
| 6227 else | |
| 6228 { | |
| 826 | 6229 Bytexpos exstart = extent_endpoint_byte (extent, 0); |
| 6230 Bytexpos exend = extent_endpoint_byte (extent, 1); | |
| 428 | 6231 |
| 6232 if (exend < new_start || exstart > new_end) | |
| 6233 goto copy_it; | |
| 6234 else | |
| 6235 { | |
| 6236 new_start = min (exstart, new_start); | |
| 6237 new_end = max (exend, new_end); | |
| 6238 if (exstart != new_start || exend != new_end) | |
| 826 | 6239 set_extent_endpoints (extent, new_start, new_end, Qnil); |
| 428 | 6240 } |
| 6241 } | |
| 6242 | |
| 793 | 6243 return wrap_extent (extent); |
| 428 | 6244 |
| 6245 copy_it: | |
| 6246 if (run_hooks && | |
| 6247 !run_extent_paste_function (extent, new_start, new_end, object)) | |
| 6248 /* The paste-function said don't attach a copy of the extent here. */ | |
| 6249 return Qnil; | |
| 6250 else | |
| 793 | 6251 return wrap_extent (copy_extent (extent, new_start, new_end, object)); |
| 428 | 6252 } |
| 6253 | |
| 6254 DEFUN ("insert-extent", Finsert_extent, 1, 5, 0, /* | |
| 6255 Insert EXTENT from START to END in BUFFER-OR-STRING. | |
| 6256 BUFFER-OR-STRING defaults to the current buffer if omitted. | |
| 826 | 6257 If EXTENT is already on the same object, and overlaps or is adjacent to |
| 6258 the given range, its range is merely extended to include the new range. | |
| 6259 Otherwise, a copy is made of the extent at the new position and object. | |
| 6260 When a copy is made, the new extent is returned, copy/paste hooks are run, | |
| 6261 and the change is noted for undo recording. When no copy is made, nil is | |
| 6262 returned. See documentation on `detach-extent' for a discussion of undo | |
| 6263 recording. | |
| 6264 | |
| 428 | 6265 The fourth arg, NO-HOOKS, can be used to inhibit the running of the |
| 826 | 6266 extent's `paste-function' property if it has one. |
| 6267 | |
| 6268 It's not really clear why this function exists any more. It was a holdover | |
| 6269 from a much older implementation of extents, before extents could really | |
| 6270 exist on strings. | |
| 428 | 6271 */ |
| 6272 (extent, start, end, no_hooks, buffer_or_string)) | |
| 6273 { | |
| 6274 EXTENT ext = decode_extent (extent, 0); | |
| 6275 Lisp_Object copy; | |
| 826 | 6276 Bytexpos s, e; |
| 428 | 6277 |
| 6278 buffer_or_string = decode_buffer_or_string (buffer_or_string); | |
| 6279 get_buffer_or_string_range_byte (buffer_or_string, start, end, &s, &e, | |
| 6280 GB_ALLOW_PAST_ACCESSIBLE); | |
| 6281 | |
| 6282 copy = insert_extent (ext, s, e, buffer_or_string, NILP (no_hooks)); | |
| 6283 if (EXTENTP (copy)) | |
| 6284 { | |
| 6285 if (extent_duplicable_p (XEXTENT (copy))) | |
| 6286 record_extent (copy, 1); | |
| 6287 } | |
| 6288 return copy; | |
| 6289 } | |
| 6290 | |
| 6291 | |
| 6292 /* adding buffer extents to a string */ | |
| 6293 | |
| 6294 struct add_string_extents_arg | |
| 6295 { | |
| 826 | 6296 Bytexpos from; |
| 428 | 6297 Bytecount length; |
| 6298 Lisp_Object string; | |
| 6299 }; | |
| 6300 | |
| 6301 static int | |
| 6302 add_string_extents_mapper (EXTENT extent, void *arg) | |
| 6303 { | |
| 6304 /* This function can GC */ | |
| 6305 struct add_string_extents_arg *closure = | |
| 6306 (struct add_string_extents_arg *) arg; | |
| 826 | 6307 Bytecount start = extent_endpoint_byte (extent, 0) - closure->from; |
| 6308 Bytecount end = extent_endpoint_byte (extent, 1) - closure->from; | |
| 428 | 6309 |
| 6310 if (extent_duplicable_p (extent)) | |
| 6311 { | |
| 6312 start = max (start, 0); | |
| 6313 end = min (end, closure->length); | |
| 6314 | |
| 6315 /* Run the copy-function to give an extent the option of | |
| 6316 not being copied into the string (or kill ring). | |
| 6317 */ | |
| 6318 if (extent_duplicable_p (extent) && | |
| 6319 !run_extent_copy_function (extent, start + closure->from, | |
| 6320 end + closure->from)) | |
| 6321 return 0; | |
| 6322 copy_extent (extent, start, end, closure->string); | |
| 6323 } | |
| 6324 | |
| 6325 return 0; | |
| 6326 } | |
| 6327 | |
| 826 | 6328 struct add_string_extents_the_hard_way_arg |
| 6329 { | |
| 6330 Charxpos from; | |
| 6331 Charcount length; | |
| 6332 Lisp_Object string; | |
| 6333 }; | |
| 6334 | |
| 6335 static int | |
| 6336 add_string_extents_the_hard_way_mapper (EXTENT extent, void *arg) | |
| 6337 { | |
| 6338 /* This function can GC */ | |
| 6339 struct add_string_extents_arg *closure = | |
| 6340 (struct add_string_extents_arg *) arg; | |
| 6341 Charcount start = extent_endpoint_char (extent, 0) - closure->from; | |
| 6342 Charcount end = extent_endpoint_char (extent, 1) - closure->from; | |
| 6343 | |
| 6344 if (extent_duplicable_p (extent)) | |
| 6345 { | |
| 6346 start = max (start, 0); | |
| 6347 end = min (end, closure->length); | |
| 6348 | |
| 6349 /* Run the copy-function to give an extent the option of | |
| 6350 not being copied into the string (or kill ring). | |
| 6351 */ | |
| 6352 if (extent_duplicable_p (extent) && | |
| 6353 !run_extent_copy_function (extent, start + closure->from, | |
| 6354 end + closure->from)) | |
| 6355 return 0; | |
| 6356 copy_extent (extent, | |
| 6357 string_index_char_to_byte (closure->string, start), | |
| 6358 string_index_char_to_byte (closure->string, end), | |
| 6359 closure->string); | |
| 6360 } | |
| 6361 | |
| 6362 return 0; | |
| 6363 } | |
| 6364 | |
| 428 | 6365 /* Add the extents in buffer BUF from OPOINT to OPOINT+LENGTH to |
| 6366 the string STRING. */ | |
| 6367 void | |
| 826 | 6368 add_string_extents (Lisp_Object string, struct buffer *buf, Bytexpos opoint, |
| 428 | 6369 Bytecount length) |
| 6370 { | |
| 6371 /* This function can GC */ | |
| 6372 struct gcpro gcpro1, gcpro2; | |
| 6373 Lisp_Object buffer; | |
| 6374 | |
| 771 | 6375 buffer = wrap_buffer (buf); |
| 428 | 6376 GCPRO2 (buffer, string); |
| 826 | 6377 |
| 6378 if (XSTRING_FORMAT (string) == BUF_FORMAT (buf)) | |
| 6379 { | |
| 6380 struct add_string_extents_arg closure; | |
| 6381 closure.from = opoint; | |
| 6382 closure.length = length; | |
| 6383 closure.string = string; | |
| 6384 map_extents (opoint, opoint + length, add_string_extents_mapper, | |
| 6385 (void *) &closure, buffer, 0, | |
| 6386 /* ignore extents that just abut the region */ | |
| 6387 ME_END_CLOSED | ME_ALL_EXTENTS_OPEN | | |
| 6388 /* we are calling E-Lisp (the extent's copy function) | |
| 6389 so anything might happen */ | |
| 6390 ME_MIGHT_CALL_ELISP); | |
| 6391 } | |
| 6392 else | |
| 6393 { | |
| 6394 struct add_string_extents_the_hard_way_arg closure; | |
| 6395 closure.from = bytebpos_to_charbpos (buf, opoint); | |
| 6396 closure.length = (bytebpos_to_charbpos (buf, opoint + length) - | |
| 6397 closure.from); | |
| 6398 closure.string = string; | |
| 6399 | |
| 6400 /* If the string and buffer are in different formats, things get | |
| 6401 tricky; the only reasonable way to do the operation is entirely in | |
| 6402 char offsets, which are invariant to format changes. In practice, | |
| 6403 this won't be time-consuming because the byte/char conversions are | |
| 6404 mostly in the buffer, which will be in a fixed-width format. */ | |
| 6405 map_extents (opoint, opoint + length, | |
| 6406 add_string_extents_the_hard_way_mapper, | |
| 6407 (void *) &closure, buffer, 0, | |
| 6408 /* ignore extents that just abut the region */ | |
| 6409 ME_END_CLOSED | ME_ALL_EXTENTS_OPEN | | |
| 6410 /* we are calling E-Lisp (the extent's copy function) | |
| 6411 so anything might happen */ | |
| 6412 ME_MIGHT_CALL_ELISP); | |
| 6413 | |
| 6414 } | |
| 6415 | |
| 428 | 6416 UNGCPRO; |
| 6417 } | |
| 6418 | |
| 6419 struct splice_in_string_extents_arg | |
| 6420 { | |
| 6421 Bytecount pos; | |
| 6422 Bytecount length; | |
| 826 | 6423 Bytexpos opoint; |
| 428 | 6424 Lisp_Object buffer; |
| 6425 }; | |
| 6426 | |
| 6427 static int | |
| 6428 splice_in_string_extents_mapper (EXTENT extent, void *arg) | |
| 6429 { | |
| 6430 /* This function can GC */ | |
| 6431 struct splice_in_string_extents_arg *closure = | |
| 6432 (struct splice_in_string_extents_arg *) arg; | |
| 6433 /* BASE_START and BASE_END are the limits in the buffer of the string | |
| 6434 that was just inserted. | |
| 826 | 6435 |
| 428 | 6436 NEW_START and NEW_END are the prospective buffer positions of the |
| 6437 extent that is going into the buffer. */ | |
| 826 | 6438 Bytexpos base_start = closure->opoint; |
| 6439 Bytexpos base_end = base_start + closure->length; | |
| 6440 Bytexpos new_start = (base_start + extent_endpoint_byte (extent, 0) - | |
| 6441 closure->pos); | |
| 6442 Bytexpos new_end = (base_start + extent_endpoint_byte (extent, 1) - | |
| 428 | 6443 closure->pos); |
| 6444 | |
| 6445 if (new_start < base_start) | |
| 6446 new_start = base_start; | |
| 6447 if (new_end > base_end) | |
| 6448 new_end = base_end; | |
| 6449 if (new_end <= new_start) | |
| 6450 return 0; | |
| 6451 | |
| 6452 if (!extent_duplicable_p (extent)) | |
| 6453 return 0; | |
| 6454 | |
| 6455 if (!inside_undo && | |
| 6456 !run_extent_paste_function (extent, new_start, new_end, | |
| 6457 closure->buffer)) | |
| 6458 return 0; | |
| 6459 copy_extent (extent, new_start, new_end, closure->buffer); | |
| 6460 | |
| 6461 return 0; | |
| 6462 } | |
| 6463 | |
| 826 | 6464 struct splice_in_string_extents_the_hard_way_arg |
| 6465 { | |
| 6466 Charcount pos; | |
| 6467 Charcount length; | |
| 6468 Charxpos opoint; | |
| 6469 Lisp_Object buffer; | |
| 6470 }; | |
| 6471 | |
| 6472 static int | |
| 6473 splice_in_string_extents_the_hard_way_mapper (EXTENT extent, void *arg) | |
| 6474 { | |
| 6475 /* This function can GC */ | |
| 6476 struct splice_in_string_extents_arg *closure = | |
| 6477 (struct splice_in_string_extents_arg *) arg; | |
| 6478 /* BASE_START and BASE_END are the limits in the buffer of the string | |
| 6479 that was just inserted. | |
| 6480 | |
| 6481 NEW_START and NEW_END are the prospective buffer positions of the | |
| 6482 extent that is going into the buffer. */ | |
| 6483 Charxpos base_start = closure->opoint; | |
| 6484 Charxpos base_end = base_start + closure->length; | |
| 6485 Charxpos new_start = (base_start + extent_endpoint_char (extent, 0) - | |
| 6486 closure->pos); | |
| 6487 Charxpos new_end = (base_start + extent_endpoint_char (extent, 1) - | |
| 6488 closure->pos); | |
| 6489 | |
| 6490 if (new_start < base_start) | |
| 6491 new_start = base_start; | |
| 6492 if (new_end > base_end) | |
| 6493 new_end = base_end; | |
| 6494 if (new_end <= new_start) | |
| 6495 return 0; | |
| 6496 | |
| 6497 if (!extent_duplicable_p (extent)) | |
| 6498 return 0; | |
| 6499 | |
| 6500 if (!inside_undo && | |
| 6501 !run_extent_paste_function_char (extent, new_start, new_end, | |
| 6502 closure->buffer)) | |
| 6503 return 0; | |
| 6504 copy_extent (extent, | |
| 6505 charbpos_to_bytebpos (XBUFFER (closure->buffer), new_start), | |
| 6506 charbpos_to_bytebpos (XBUFFER (closure->buffer), new_end), | |
| 6507 closure->buffer); | |
| 6508 | |
| 6509 return 0; | |
| 6510 } | |
| 6511 | |
| 428 | 6512 /* We have just inserted a section of STRING (starting at POS, of |
| 6513 length LENGTH) into buffer BUF at OPOINT. Do whatever is necessary | |
| 6514 to get the string's extents into the buffer. */ | |
| 6515 | |
| 6516 void | |
| 6517 splice_in_string_extents (Lisp_Object string, struct buffer *buf, | |
| 826 | 6518 Bytexpos opoint, Bytecount length, Bytecount pos) |
| 6519 { | |
| 428 | 6520 struct gcpro gcpro1, gcpro2; |
| 793 | 6521 Lisp_Object buffer = wrap_buffer (buf); |
| 6522 | |
| 428 | 6523 GCPRO2 (buffer, string); |
| 826 | 6524 if (XSTRING_FORMAT (string) == BUF_FORMAT (buf)) |
| 6525 { | |
| 6526 struct splice_in_string_extents_arg closure; | |
| 6527 closure.opoint = opoint; | |
| 6528 closure.pos = pos; | |
| 6529 closure.length = length; | |
| 6530 closure.buffer = buffer; | |
| 6531 map_extents (pos, pos + length, | |
| 6532 splice_in_string_extents_mapper, | |
| 6533 (void *) &closure, string, 0, | |
| 6534 /* ignore extents that just abut the region */ | |
| 6535 ME_END_CLOSED | ME_ALL_EXTENTS_OPEN | | |
| 6536 /* we are calling E-Lisp (the extent's copy function) | |
| 6537 so anything might happen */ | |
| 6538 ME_MIGHT_CALL_ELISP); | |
| 6539 } | |
| 6540 else | |
| 6541 { | |
| 6542 struct splice_in_string_extents_the_hard_way_arg closure; | |
| 6543 closure.opoint = bytebpos_to_charbpos (buf, opoint); | |
| 6544 closure.pos = string_index_byte_to_char (string, pos); | |
| 6545 closure.length = string_offset_byte_to_char_len (string, pos, length); | |
| 6546 closure.buffer = buffer; | |
| 6547 | |
| 6548 /* If the string and buffer are in different formats, things get | |
| 6549 tricky; the only reasonable way to do the operation is entirely in | |
| 6550 char offsets, which are invariant to format changes. In practice, | |
| 6551 this won't be time-consuming because the byte/char conversions are | |
| 6552 mostly in the buffer, which will be in a fixed-width format. */ | |
| 6553 map_extents (pos, pos + length, | |
| 6554 splice_in_string_extents_the_hard_way_mapper, | |
| 6555 (void *) &closure, string, 0, | |
| 6556 /* ignore extents that just abut the region */ | |
| 6557 ME_END_CLOSED | ME_ALL_EXTENTS_OPEN | | |
| 6558 /* we are calling E-Lisp (the extent's copy function) | |
| 6559 so anything might happen */ | |
| 6560 ME_MIGHT_CALL_ELISP); | |
| 6561 | |
| 6562 } | |
| 428 | 6563 UNGCPRO; |
| 6564 } | |
| 6565 | |
| 6566 struct copy_string_extents_arg | |
| 6567 { | |
| 6568 Bytecount new_pos; | |
| 6569 Bytecount old_pos; | |
| 6570 Bytecount length; | |
| 6571 Lisp_Object new_string; | |
| 6572 }; | |
| 6573 | |
| 6574 struct copy_string_extents_1_arg | |
| 6575 { | |
| 6576 Lisp_Object parent_in_question; | |
| 6577 EXTENT found_extent; | |
| 6578 }; | |
| 6579 | |
| 6580 static int | |
| 6581 copy_string_extents_mapper (EXTENT extent, void *arg) | |
| 6582 { | |
| 6583 struct copy_string_extents_arg *closure = | |
| 6584 (struct copy_string_extents_arg *) arg; | |
| 6585 Bytecount old_start, old_end, new_start, new_end; | |
| 6586 | |
| 826 | 6587 old_start = extent_endpoint_byte (extent, 0); |
| 6588 old_end = extent_endpoint_byte (extent, 1); | |
| 428 | 6589 |
| 6590 old_start = max (closure->old_pos, old_start); | |
| 6591 old_end = min (closure->old_pos + closure->length, old_end); | |
| 6592 | |
| 6593 if (old_start >= old_end) | |
| 6594 return 0; | |
| 6595 | |
| 6596 new_start = old_start + closure->new_pos - closure->old_pos; | |
| 6597 new_end = old_end + closure->new_pos - closure->old_pos; | |
| 6598 | |
| 6599 copy_extent (extent, new_start, new_end, closure->new_string); | |
| 6600 return 0; | |
| 6601 } | |
| 6602 | |
| 6603 /* The string NEW_STRING was partially constructed from OLD_STRING. | |
| 6604 In particular, the section of length LEN starting at NEW_POS in | |
| 6605 NEW_STRING came from the section of the same length starting at | |
| 6606 OLD_POS in OLD_STRING. Copy the extents as appropriate. */ | |
| 6607 | |
| 6608 void | |
| 6609 copy_string_extents (Lisp_Object new_string, Lisp_Object old_string, | |
| 6610 Bytecount new_pos, Bytecount old_pos, | |
| 6611 Bytecount length) | |
| 6612 { | |
| 6613 struct copy_string_extents_arg closure; | |
| 6614 struct gcpro gcpro1, gcpro2; | |
| 6615 | |
| 6616 closure.new_pos = new_pos; | |
| 6617 closure.old_pos = old_pos; | |
| 6618 closure.new_string = new_string; | |
| 6619 closure.length = length; | |
| 6620 GCPRO2 (new_string, old_string); | |
| 826 | 6621 map_extents (old_pos, old_pos + length, |
| 6622 copy_string_extents_mapper, | |
| 6623 (void *) &closure, old_string, 0, | |
| 6624 /* ignore extents that just abut the region */ | |
| 6625 ME_END_CLOSED | ME_ALL_EXTENTS_OPEN | | |
| 6626 /* we are calling E-Lisp (the extent's copy function) | |
| 6627 so anything might happen */ | |
| 6628 ME_MIGHT_CALL_ELISP); | |
| 428 | 6629 UNGCPRO; |
| 6630 } | |
| 6631 | |
| 6632 /* Checklist for sanity checking: | |
| 6633 - {kill, yank, copy} at {open, closed} {start, end} of {writable, read-only} extent | |
| 6634 - {kill, copy} & yank {once, repeatedly} duplicable extent in {same, different} buffer | |
| 6635 */ | |
| 6636 | |
| 6637 | |
| 6638 /************************************************************************/ | |
| 6639 /* text properties */ | |
| 6640 /************************************************************************/ | |
| 6641 | |
| 6642 /* Text properties | |
| 6643 Originally this stuff was implemented in lisp (all of the functionality | |
| 6644 exists to make that possible) but speed was a problem. | |
| 6645 */ | |
| 6646 | |
| 6647 Lisp_Object Qtext_prop; | |
| 6648 Lisp_Object Qtext_prop_extent_paste_function; | |
| 6649 | |
| 826 | 6650 /* Retrieve the value of the property PROP of the text at position POSITION |
| 6651 in OBJECT. TEXT-PROPS-ONLY means only look at extents with the | |
| 6652 `text-prop' property, i.e. extents created by the text property | |
| 6653 routines. Otherwise, all extents are examined. &&#### finish Note that | |
| 6654 the default extent_at_flag is EXTENT_AT_DEFAULT (same as | |
| 6655 EXTENT_AT_AFTER). */ | |
| 6656 Lisp_Object | |
| 6657 get_char_property (Bytexpos position, Lisp_Object prop, | |
| 6658 Lisp_Object object, enum extent_at_flag fl, | |
| 6659 int text_props_only) | |
| 428 | 6660 { |
| 6661 Lisp_Object extent; | |
| 6662 | |
| 6663 /* text_props_only specifies whether we only consider text-property | |
| 3025 | 6664 extents (those with the `text-prop' property set) or all extents. */ |
| 428 | 6665 if (!text_props_only) |
| 826 | 6666 extent = extent_at (position, object, prop, 0, fl, 0); |
| 428 | 6667 else |
| 6668 { | |
| 6669 EXTENT prior = 0; | |
| 6670 while (1) | |
| 6671 { | |
| 826 | 6672 extent = extent_at (position, object, Qtext_prop, prior, fl, 0); |
| 428 | 6673 if (NILP (extent)) |
| 6674 return Qnil; | |
| 6675 if (EQ (prop, Fextent_property (extent, Qtext_prop, Qnil))) | |
| 6676 break; | |
| 6677 prior = XEXTENT (extent); | |
| 6678 } | |
| 6679 } | |
| 6680 | |
| 6681 if (!NILP (extent)) | |
| 6682 return Fextent_property (extent, prop, Qnil); | |
| 6683 if (!NILP (Vdefault_text_properties)) | |
| 6684 return Fplist_get (Vdefault_text_properties, prop, Qnil); | |
| 6685 return Qnil; | |
| 6686 } | |
| 6687 | |
| 6688 static Lisp_Object | |
| 826 | 6689 get_char_property_char (Lisp_Object pos, Lisp_Object prop, Lisp_Object object, |
| 6690 Lisp_Object at_flag, int text_props_only) | |
| 6691 { | |
| 6692 Bytexpos position; | |
| 428 | 6693 int invert = 0; |
| 6694 | |
| 6695 object = decode_buffer_or_string (object); | |
| 6696 position = get_buffer_or_string_pos_byte (object, pos, GB_NO_ERROR_IF_BAD); | |
| 6697 | |
| 6698 /* We canonicalize the start/end-open/closed properties to the | |
| 6699 non-default version -- "adding" the default property really | |
| 6700 needs to remove the non-default one. See below for more | |
| 6701 on this. */ | |
| 6702 if (EQ (prop, Qstart_closed)) | |
| 6703 { | |
| 6704 prop = Qstart_open; | |
| 6705 invert = 1; | |
| 6706 } | |
| 6707 | |
| 6708 if (EQ (prop, Qend_open)) | |
| 6709 { | |
| 6710 prop = Qend_closed; | |
| 6711 invert = 1; | |
| 6712 } | |
| 6713 | |
| 6714 { | |
| 6715 Lisp_Object val = | |
| 826 | 6716 get_char_property (position, prop, object, |
| 6717 decode_extent_at_flag (at_flag), | |
| 6718 text_props_only); | |
| 428 | 6719 if (invert) |
| 6720 val = NILP (val) ? Qt : Qnil; | |
| 6721 return val; | |
| 6722 } | |
| 6723 } | |
| 6724 | |
| 6725 DEFUN ("get-text-property", Fget_text_property, 2, 4, 0, /* | |
| 6726 Return the value of the PROP property at the given position. | |
| 6727 Optional arg OBJECT specifies the buffer or string to look in, and | |
| 6728 defaults to the current buffer. | |
| 6729 Optional arg AT-FLAG controls what it means for a property to be "at" | |
| 6730 a position, and has the same meaning as in `extent-at'. | |
| 6731 This examines only those properties added with `put-text-property'. | |
| 6732 See also `get-char-property'. | |
| 6733 */ | |
| 6734 (pos, prop, object, at_flag)) | |
| 6735 { | |
| 826 | 6736 return get_char_property_char (pos, prop, object, at_flag, 1); |
| 428 | 6737 } |
| 6738 | |
| 6739 DEFUN ("get-char-property", Fget_char_property, 2, 4, 0, /* | |
| 6740 Return the value of the PROP property at the given position. | |
| 6741 Optional arg OBJECT specifies the buffer or string to look in, and | |
| 6742 defaults to the current buffer. | |
| 6743 Optional arg AT-FLAG controls what it means for a property to be "at" | |
| 6744 a position, and has the same meaning as in `extent-at'. | |
| 6745 This examines properties on all extents. | |
| 6746 See also `get-text-property'. | |
| 6747 */ | |
| 6748 (pos, prop, object, at_flag)) | |
| 6749 { | |
| 826 | 6750 return get_char_property_char (pos, prop, object, at_flag, 0); |
| 428 | 6751 } |
| 6752 | |
| 6753 /* About start/end-open/closed: | |
| 6754 | |
| 6755 These properties have to be handled specially because of their | |
| 6756 strange behavior. If I put the "start-open" property on a region, | |
| 6757 then *all* text-property extents in the region have to have their | |
| 6758 start be open. This is unlike all other properties, which don't | |
| 6759 affect the extents of text properties other than their own. | |
| 6760 | |
| 6761 So: | |
| 6762 | |
| 6763 1) We have to map start-closed to (not start-open) and end-open | |
| 6764 to (not end-closed) -- i.e. adding the default is really the | |
| 6765 same as remove the non-default property. It won't work, for | |
| 6766 example, to have both "start-open" and "start-closed" on | |
| 6767 the same region. | |
| 6768 2) Whenever we add one of these properties, we go through all | |
| 6769 text-property extents in the region and set the appropriate | |
| 6770 open/closedness on them. | |
| 6771 3) Whenever we change a text-property extent for a property, | |
| 6772 we have to make sure we set the open/closedness properly. | |
| 6773 | |
| 6774 (2) and (3) together rely on, and maintain, the invariant | |
| 6775 that the open/closedness of text-property extents is correct | |
| 6776 at the beginning and end of each operation. | |
| 6777 */ | |
| 6778 | |
| 6779 struct put_text_prop_arg | |
| 6780 { | |
| 6781 Lisp_Object prop, value; /* The property and value we are storing */ | |
| 826 | 6782 Bytexpos start, end; /* The region into which we are storing it */ |
| 428 | 6783 Lisp_Object object; |
| 6784 Lisp_Object the_extent; /* Our chosen extent; this is used for | |
| 6785 communication between subsequent passes. */ | |
| 6786 int changed_p; /* Output: whether we have modified anything */ | |
| 6787 }; | |
| 6788 | |
| 6789 static int | |
| 6790 put_text_prop_mapper (EXTENT e, void *arg) | |
| 6791 { | |
| 6792 struct put_text_prop_arg *closure = (struct put_text_prop_arg *) arg; | |
| 6793 | |
| 6794 Lisp_Object object = closure->object; | |
| 6795 Lisp_Object value = closure->value; | |
| 826 | 6796 Bytexpos e_start, e_end; |
| 6797 Bytexpos start = closure->start; | |
| 6798 Bytexpos end = closure->end; | |
| 428 | 6799 Lisp_Object extent, e_val; |
| 6800 int is_eq; | |
| 6801 | |
| 793 | 6802 extent = wrap_extent (e); |
| 428 | 6803 |
| 3025 | 6804 /* Note: in some cases when the property itself is `start-open' |
| 6805 or `end-closed', the checks to set the openness may do a bit | |
| 428 | 6806 of extra work; but it won't hurt because we then fix up the |
| 6807 openness later on in put_text_prop_openness_mapper(). */ | |
| 6808 if (!EQ (Fextent_property (extent, Qtext_prop, Qnil), closure->prop)) | |
| 6809 /* It's not for this property; do nothing. */ | |
| 6810 return 0; | |
| 6811 | |
| 826 | 6812 e_start = extent_endpoint_byte (e, 0); |
| 6813 e_end = extent_endpoint_byte (e, 1); | |
| 428 | 6814 e_val = Fextent_property (extent, closure->prop, Qnil); |
| 6815 is_eq = EQ (value, e_val); | |
| 6816 | |
| 6817 if (!NILP (value) && NILP (closure->the_extent) && is_eq) | |
| 6818 { | |
| 6819 /* We want there to be an extent here at the end, and we haven't picked | |
| 6820 one yet, so use this one. Extend it as necessary. We only reuse an | |
| 6821 extent which has an EQ value for the prop in question to avoid | |
| 6822 side-effecting the kill ring (that is, we never change the property | |
| 6823 on an extent after it has been created.) | |
| 6824 */ | |
| 6825 if (e_start != start || e_end != end) | |
| 6826 { | |
| 826 | 6827 Bytexpos new_start = min (e_start, start); |
| 6828 Bytexpos new_end = max (e_end, end); | |
| 428 | 6829 set_extent_endpoints (e, new_start, new_end, Qnil); |
| 6830 /* If we changed the endpoint, then we need to set its | |
| 6831 openness. */ | |
| 6832 set_extent_openness (e, new_start != e_start | |
| 826 | 6833 ? !NILP (get_char_property |
| 428 | 6834 (start, Qstart_open, object, |
| 6835 EXTENT_AT_AFTER, 1)) : -1, | |
| 6836 new_end != e_end | |
| 826 | 6837 ? NILP (get_char_property |
| 6838 (prev_bytexpos (object, end), | |
| 6839 Qend_closed, object, | |
| 428 | 6840 EXTENT_AT_AFTER, 1)) |
| 6841 : -1); | |
| 6842 closure->changed_p = 1; | |
| 6843 } | |
| 6844 closure->the_extent = extent; | |
| 6845 } | |
| 6846 | |
| 6847 /* Even if we're adding a prop, at this point, we want all other extents of | |
| 6848 this prop to go away (as now they overlap). So the theory here is that, | |
| 6849 when we are adding a prop to a region that has multiple (disjoint) | |
| 6850 occurrences of that prop in it already, we pick one of those and extend | |
| 6851 it, and remove the others. | |
| 6852 */ | |
| 6853 | |
| 6854 else if (EQ (extent, closure->the_extent)) | |
| 6855 { | |
| 6856 /* just in case map-extents hits it again (does that happen?) */ | |
| 6857 ; | |
| 6858 } | |
| 6859 else if (e_start >= start && e_end <= end) | |
| 6860 { | |
| 6861 /* Extent is contained in region; remove it. Don't destroy or modify | |
| 6862 it, because we don't want to change the attributes pointed to by the | |
| 6863 duplicates in the kill ring. | |
| 6864 */ | |
| 6865 extent_detach (e); | |
| 6866 closure->changed_p = 1; | |
| 6867 } | |
| 6868 else if (!NILP (closure->the_extent) && | |
| 6869 is_eq && | |
| 6870 e_start <= end && | |
| 6871 e_end >= start) | |
| 6872 { | |
| 6873 EXTENT te = XEXTENT (closure->the_extent); | |
| 6874 /* This extent overlaps, and has the same prop/value as the extent we've | |
| 6875 decided to reuse, so we can remove this existing extent as well (the | |
| 6876 whole thing, even the part outside of the region) and extend | |
| 6877 the-extent to cover it, resulting in the minimum number of extents in | |
| 6878 the buffer. | |
| 6879 */ | |
| 826 | 6880 Bytexpos the_start = extent_endpoint_byte (te, 0); |
| 6881 Bytexpos the_end = extent_endpoint_byte (te, 1); | |
| 428 | 6882 if (e_start != the_start && /* note AND not OR -- hmm, why is this |
| 6883 the case? I think it's because the | |
| 6884 assumption that the text-property | |
| 6885 extents don't overlap makes it | |
| 6886 OK; changing it to an OR would | |
| 6887 result in changed_p sometimes getting | |
| 6888 falsely marked. Is this bad? */ | |
| 6889 e_end != the_end) | |
| 6890 { | |
| 826 | 6891 Bytexpos new_start = min (e_start, the_start); |
| 6892 Bytexpos new_end = max (e_end, the_end); | |
| 428 | 6893 set_extent_endpoints (te, new_start, new_end, Qnil); |
| 6894 /* If we changed the endpoint, then we need to set its | |
| 6895 openness. We are setting the endpoint to be the same as | |
| 6896 that of the extent we're about to remove, and we assume | |
| 6897 (the invariant mentioned above) that extent has the | |
| 6898 proper endpoint setting, so we just use it. */ | |
| 6899 set_extent_openness (te, new_start != e_start ? | |
| 6900 (int) extent_start_open_p (e) : -1, | |
| 6901 new_end != e_end ? | |
| 6902 (int) extent_end_open_p (e) : -1); | |
| 6903 closure->changed_p = 1; | |
| 6904 } | |
| 6905 extent_detach (e); | |
| 6906 } | |
| 6907 else if (e_end <= end) | |
| 6908 { | |
| 6909 /* Extent begins before start but ends before end, so we can just | |
| 6910 decrease its end position. | |
| 6911 */ | |
| 6912 if (e_end != start) | |
| 6913 { | |
| 6914 set_extent_endpoints (e, e_start, start, Qnil); | |
| 826 | 6915 set_extent_openness (e, -1, |
| 6916 NILP (get_char_property | |
| 6917 (prev_bytexpos (object, start), | |
| 6918 Qend_closed, object, | |
| 6919 EXTENT_AT_AFTER, 1))); | |
| 428 | 6920 closure->changed_p = 1; |
| 6921 } | |
| 6922 } | |
| 6923 else if (e_start >= start) | |
| 6924 { | |
| 6925 /* Extent ends after end but begins after start, so we can just | |
| 6926 increase its start position. | |
| 6927 */ | |
| 6928 if (e_start != end) | |
| 6929 { | |
| 6930 set_extent_endpoints (e, end, e_end, Qnil); | |
| 826 | 6931 set_extent_openness (e, !NILP (get_char_property |
| 428 | 6932 (end, Qstart_open, object, |
| 6933 EXTENT_AT_AFTER, 1)), -1); | |
| 6934 closure->changed_p = 1; | |
| 6935 } | |
| 6936 } | |
| 6937 else | |
| 6938 { | |
| 6939 /* Otherwise, `extent' straddles the region. We need to split it. | |
| 6940 */ | |
| 6941 set_extent_endpoints (e, e_start, start, Qnil); | |
| 826 | 6942 set_extent_openness (e, -1, NILP (get_char_property |
| 6943 (prev_bytexpos (object, start), | |
| 6944 Qend_closed, object, | |
| 428 | 6945 EXTENT_AT_AFTER, 1))); |
| 6946 set_extent_openness (copy_extent (e, end, e_end, extent_object (e)), | |
| 826 | 6947 !NILP (get_char_property |
| 428 | 6948 (end, Qstart_open, object, |
| 6949 EXTENT_AT_AFTER, 1)), -1); | |
| 6950 closure->changed_p = 1; | |
| 6951 } | |
| 6952 | |
| 6953 return 0; /* to continue mapping. */ | |
| 6954 } | |
| 6955 | |
| 6956 static int | |
| 6957 put_text_prop_openness_mapper (EXTENT e, void *arg) | |
| 6958 { | |
| 6959 struct put_text_prop_arg *closure = (struct put_text_prop_arg *) arg; | |
| 826 | 6960 Bytexpos e_start, e_end; |
| 6961 Bytexpos start = closure->start; | |
| 6962 Bytexpos end = closure->end; | |
| 793 | 6963 Lisp_Object extent = wrap_extent (e); |
| 6964 | |
| 826 | 6965 e_start = extent_endpoint_byte (e, 0); |
| 6966 e_end = extent_endpoint_byte (e, 1); | |
| 428 | 6967 |
| 6968 if (NILP (Fextent_property (extent, Qtext_prop, Qnil))) | |
| 6969 { | |
| 6970 /* It's not a text-property extent; do nothing. */ | |
| 6971 ; | |
| 6972 } | |
| 6973 /* Note end conditions and NILP/!NILP's carefully. */ | |
| 6974 else if (EQ (closure->prop, Qstart_open) | |
| 6975 && e_start >= start && e_start < end) | |
| 6976 set_extent_openness (e, !NILP (closure->value), -1); | |
| 6977 else if (EQ (closure->prop, Qend_closed) | |
| 6978 && e_end > start && e_end <= end) | |
| 6979 set_extent_openness (e, -1, NILP (closure->value)); | |
| 6980 | |
| 6981 return 0; /* to continue mapping. */ | |
| 6982 } | |
| 6983 | |
| 6984 static int | |
| 826 | 6985 put_text_prop (Bytexpos start, Bytexpos end, Lisp_Object object, |
| 428 | 6986 Lisp_Object prop, Lisp_Object value, |
| 6987 int duplicable_p) | |
| 6988 { | |
| 6989 /* This function can GC */ | |
| 6990 struct put_text_prop_arg closure; | |
| 6991 | |
| 6992 if (start == end) /* There are no characters in the region. */ | |
| 6993 return 0; | |
| 6994 | |
| 6995 /* convert to the non-default versions, since a nil property is | |
| 6996 the same as it not being present. */ | |
| 6997 if (EQ (prop, Qstart_closed)) | |
| 6998 { | |
| 6999 prop = Qstart_open; | |
| 7000 value = NILP (value) ? Qt : Qnil; | |
| 7001 } | |
| 7002 else if (EQ (prop, Qend_open)) | |
| 7003 { | |
| 7004 prop = Qend_closed; | |
| 7005 value = NILP (value) ? Qt : Qnil; | |
| 7006 } | |
| 7007 | |
| 7008 value = canonicalize_extent_property (prop, value); | |
| 7009 | |
| 7010 closure.prop = prop; | |
| 7011 closure.value = value; | |
| 7012 closure.start = start; | |
| 7013 closure.end = end; | |
| 7014 closure.object = object; | |
| 7015 closure.changed_p = 0; | |
| 7016 closure.the_extent = Qnil; | |
| 7017 | |
| 826 | 7018 map_extents (start, end, |
| 7019 put_text_prop_mapper, | |
| 7020 (void *) &closure, object, 0, | |
| 7021 /* get all extents that abut the region */ | |
| 7022 ME_ALL_EXTENTS_CLOSED | ME_END_CLOSED | | |
| 7023 #if 0 | |
| 7024 /* it might move the SOE because the callback function calls | |
| 7025 get_char_property(), which calls extent_at(), which calls | |
| 7026 map_extents() | |
| 7027 | |
| 7028 #### this was comment out before, and nothing seemed broken; | |
| 7029 #### but when I added the above comment and uncommented it, | |
| 7030 #### text property operations (e.g. font-lock) suddenly | |
| 7031 #### became *WAY* slow, and dominated font-lock, when a | |
| 7032 #### single extent spanning the entire buffer | |
| 7033 #### existed. --ben */ | |
| 7034 ME_MIGHT_MOVE_SOE | | |
| 7035 #endif | |
| 7036 /* it might QUIT or error if the user has | |
| 7037 fucked with the extent plist. */ | |
| 7038 ME_MIGHT_THROW | | |
| 7039 ME_MIGHT_MODIFY_EXTENTS); | |
| 428 | 7040 |
| 7041 /* If we made it through the loop without reusing an extent | |
| 7042 (and we want there to be one) make it now. | |
| 7043 */ | |
| 7044 if (!NILP (value) && NILP (closure.the_extent)) | |
| 7045 { | |
| 826 | 7046 Lisp_Object extent = |
| 7047 wrap_extent (make_extent (object, start, end)); | |
| 793 | 7048 |
| 428 | 7049 closure.changed_p = 1; |
| 7050 Fset_extent_property (extent, Qtext_prop, prop); | |
| 7051 Fset_extent_property (extent, prop, value); | |
| 7052 if (duplicable_p) | |
| 7053 { | |
| 7054 extent_duplicable_p (XEXTENT (extent)) = 1; | |
| 7055 Fset_extent_property (extent, Qpaste_function, | |
| 7056 Qtext_prop_extent_paste_function); | |
| 7057 } | |
| 7058 set_extent_openness (XEXTENT (extent), | |
| 826 | 7059 !NILP (get_char_property |
| 428 | 7060 (start, Qstart_open, object, |
| 7061 EXTENT_AT_AFTER, 1)), | |
| 826 | 7062 NILP (get_char_property |
| 7063 (prev_bytexpos (object, end), | |
| 7064 Qend_closed, object, | |
| 428 | 7065 EXTENT_AT_AFTER, 1))); |
| 7066 } | |
| 7067 | |
| 7068 if (EQ (prop, Qstart_open) || EQ (prop, Qend_closed)) | |
| 7069 { | |
| 826 | 7070 map_extents (start, end, put_text_prop_openness_mapper, |
| 7071 (void *) &closure, object, 0, | |
| 7072 /* get all extents that abut the region */ | |
| 7073 ME_ALL_EXTENTS_CLOSED | ME_END_CLOSED | | |
| 7074 ME_MIGHT_MODIFY_EXTENTS); | |
| 428 | 7075 } |
| 7076 | |
| 7077 return closure.changed_p; | |
| 7078 } | |
| 7079 | |
| 7080 DEFUN ("put-text-property", Fput_text_property, 4, 5, 0, /* | |
| 7081 Adds the given property/value to all characters in the specified region. | |
| 7082 The property is conceptually attached to the characters rather than the | |
| 7083 region. The properties are copied when the characters are copied/pasted. | |
| 7084 Fifth argument OBJECT is the buffer or string containing the text, and | |
| 7085 defaults to the current buffer. | |
| 7086 */ | |
| 7087 (start, end, prop, value, object)) | |
| 7088 { | |
| 7089 /* This function can GC */ | |
| 826 | 7090 Bytexpos s, e; |
| 428 | 7091 |
| 7092 object = decode_buffer_or_string (object); | |
| 7093 get_buffer_or_string_range_byte (object, start, end, &s, &e, 0); | |
| 7094 put_text_prop (s, e, object, prop, value, 1); | |
| 7095 return prop; | |
| 7096 } | |
| 7097 | |
| 7098 DEFUN ("put-nonduplicable-text-property", Fput_nonduplicable_text_property, | |
| 7099 4, 5, 0, /* | |
| 7100 Adds the given property/value to all characters in the specified region. | |
| 7101 The property is conceptually attached to the characters rather than the | |
| 7102 region, however the properties will not be copied when the characters | |
| 7103 are copied. | |
| 7104 Fifth argument OBJECT is the buffer or string containing the text, and | |
| 7105 defaults to the current buffer. | |
| 7106 */ | |
| 7107 (start, end, prop, value, object)) | |
| 7108 { | |
| 7109 /* This function can GC */ | |
| 826 | 7110 Bytexpos s, e; |
| 428 | 7111 |
| 7112 object = decode_buffer_or_string (object); | |
| 7113 get_buffer_or_string_range_byte (object, start, end, &s, &e, 0); | |
| 7114 put_text_prop (s, e, object, prop, value, 0); | |
| 7115 return prop; | |
| 7116 } | |
| 7117 | |
| 7118 DEFUN ("add-text-properties", Fadd_text_properties, 3, 4, 0, /* | |
| 7119 Add properties to the characters from START to END. | |
| 7120 The third argument PROPS is a property list specifying the property values | |
| 7121 to add. The optional fourth argument, OBJECT, is the buffer or string | |
| 7122 containing the text and defaults to the current buffer. Returns t if | |
| 7123 any property was changed, nil otherwise. | |
| 7124 */ | |
| 7125 (start, end, props, object)) | |
| 7126 { | |
| 7127 /* This function can GC */ | |
| 7128 int changed = 0; | |
| 826 | 7129 Bytexpos s, e; |
| 428 | 7130 |
| 7131 object = decode_buffer_or_string (object); | |
| 7132 get_buffer_or_string_range_byte (object, start, end, &s, &e, 0); | |
| 7133 CHECK_LIST (props); | |
| 7134 for (; !NILP (props); props = Fcdr (Fcdr (props))) | |
| 7135 { | |
| 7136 Lisp_Object prop = XCAR (props); | |
| 7137 Lisp_Object value = Fcar (XCDR (props)); | |
| 7138 changed |= put_text_prop (s, e, object, prop, value, 1); | |
| 7139 } | |
| 7140 return changed ? Qt : Qnil; | |
| 7141 } | |
| 7142 | |
| 7143 | |
| 7144 DEFUN ("add-nonduplicable-text-properties", Fadd_nonduplicable_text_properties, | |
| 7145 3, 4, 0, /* | |
| 7146 Add nonduplicable properties to the characters from START to END. | |
| 7147 \(The properties will not be copied when the characters are copied.) | |
| 7148 The third argument PROPS is a property list specifying the property values | |
| 7149 to add. The optional fourth argument, OBJECT, is the buffer or string | |
| 7150 containing the text and defaults to the current buffer. Returns t if | |
| 7151 any property was changed, nil otherwise. | |
| 7152 */ | |
| 7153 (start, end, props, object)) | |
| 7154 { | |
| 7155 /* This function can GC */ | |
| 7156 int changed = 0; | |
| 826 | 7157 Bytexpos s, e; |
| 428 | 7158 |
| 7159 object = decode_buffer_or_string (object); | |
| 7160 get_buffer_or_string_range_byte (object, start, end, &s, &e, 0); | |
| 7161 CHECK_LIST (props); | |
| 7162 for (; !NILP (props); props = Fcdr (Fcdr (props))) | |
| 7163 { | |
| 7164 Lisp_Object prop = XCAR (props); | |
| 7165 Lisp_Object value = Fcar (XCDR (props)); | |
| 7166 changed |= put_text_prop (s, e, object, prop, value, 0); | |
| 7167 } | |
| 7168 return changed ? Qt : Qnil; | |
| 7169 } | |
| 7170 | |
| 7171 DEFUN ("remove-text-properties", Fremove_text_properties, 3, 4, 0, /* | |
| 7172 Remove the given properties from all characters in the specified region. | |
| 7173 PROPS should be a plist, but the values in that plist are ignored (treated | |
| 7174 as nil). Returns t if any property was changed, nil otherwise. | |
| 7175 Fourth argument OBJECT is the buffer or string containing the text, and | |
| 7176 defaults to the current buffer. | |
| 7177 */ | |
| 7178 (start, end, props, object)) | |
| 7179 { | |
| 7180 /* This function can GC */ | |
| 7181 int changed = 0; | |
| 826 | 7182 Bytexpos s, e; |
| 428 | 7183 |
| 7184 object = decode_buffer_or_string (object); | |
| 7185 get_buffer_or_string_range_byte (object, start, end, &s, &e, 0); | |
| 7186 CHECK_LIST (props); | |
| 7187 for (; !NILP (props); props = Fcdr (Fcdr (props))) | |
| 7188 { | |
| 7189 Lisp_Object prop = XCAR (props); | |
| 7190 changed |= put_text_prop (s, e, object, prop, Qnil, 1); | |
| 7191 } | |
| 7192 return changed ? Qt : Qnil; | |
| 7193 } | |
| 7194 | |
| 7195 /* Whenever a text-prop extent is pasted into a buffer (via `yank' or `insert' | |
| 7196 or whatever) we attach the properties to the buffer by calling | |
| 7197 `put-text-property' instead of by simply allowing the extent to be copied or | |
| 7198 re-attached. Then we return nil, telling the extents code not to attach it | |
| 7199 again. By handing the insertion hackery in this way, we make kill/yank | |
| 7200 behave consistently with put-text-property and not fragment the extents | |
| 7201 (since text-prop extents must partition, not overlap). | |
| 7202 | |
| 7203 The lisp implementation of this was probably fast enough, but since I moved | |
| 7204 the rest of the put-text-prop code here, I moved this as well for | |
| 7205 completeness. | |
| 7206 */ | |
| 7207 DEFUN ("text-prop-extent-paste-function", Ftext_prop_extent_paste_function, | |
| 7208 3, 3, 0, /* | |
| 7209 Used as the `paste-function' property of `text-prop' extents. | |
| 7210 */ | |
| 7211 (extent, from, to)) | |
| 7212 { | |
| 7213 /* This function can GC */ | |
| 7214 Lisp_Object prop, val; | |
| 7215 | |
| 7216 prop = Fextent_property (extent, Qtext_prop, Qnil); | |
| 7217 if (NILP (prop)) | |
| 563 | 7218 signal_error (Qinternal_error, |
| 442 | 7219 "Internal error: no text-prop", extent); |
| 428 | 7220 val = Fextent_property (extent, prop, Qnil); |
| 7221 #if 0 | |
| 7222 /* removed by bill perry, 2/9/97 | |
| 7223 ** This little bit of code would not allow you to have a text property | |
| 7224 ** with a value of Qnil. This is bad bad bad. | |
| 7225 */ | |
| 7226 if (NILP (val)) | |
| 563 | 7227 signal_error_2 (Qinternal_error, |
| 442 | 7228 "Internal error: no text-prop", |
| 7229 extent, prop); | |
| 428 | 7230 #endif |
| 7231 Fput_text_property (from, to, prop, val, Qnil); | |
| 7232 return Qnil; /* important! */ | |
| 7233 } | |
| 7234 | |
| 826 | 7235 Bytexpos |
| 2506 | 7236 next_previous_single_property_change (Bytexpos pos, Lisp_Object prop, |
| 7237 Lisp_Object object, Bytexpos limit, | |
| 7238 Boolint next, Boolint text_props_only) | |
| 826 | 7239 { |
| 7240 Lisp_Object extent, value; | |
| 7241 int limit_was_nil; | |
| 2506 | 7242 enum extent_at_flag at_flag = next ? EXTENT_AT_AFTER : EXTENT_AT_BEFORE; |
| 826 | 7243 if (limit < 0) |
| 7244 { | |
| 2506 | 7245 limit = (next ? buffer_or_string_accessible_end_byte : |
| 7246 buffer_or_string_accessible_begin_byte) (object); | |
| 826 | 7247 limit_was_nil = 1; |
| 7248 } | |
| 7249 else | |
| 7250 limit_was_nil = 0; | |
| 7251 | |
| 2506 | 7252 /* Retrieve initial property value to compare against */ |
| 7253 extent = extent_at (pos, object, prop, 0, at_flag, 0); | |
| 7254 /* If we only want text-prop extents, ignore all others */ | |
| 7255 if (text_props_only && !NILP (extent) && | |
| 7256 NILP (Fextent_property (extent, Qtext_prop, Qnil))) | |
| 7257 extent = Qnil; | |
| 826 | 7258 if (!NILP (extent)) |
| 7259 value = Fextent_property (extent, prop, Qnil); | |
| 7260 else | |
| 7261 value = Qnil; | |
| 7262 | |
| 7263 while (1) | |
| 7264 { | |
| 2506 | 7265 pos = (next ? extent_find_end_of_run : extent_find_beginning_of_run) |
| 7266 (object, pos, 1); | |
| 7267 if (next ? pos >= limit : pos <= limit) | |
| 7268 break; /* property is the same all the way to the beginning/end */ | |
| 7269 extent = extent_at (pos, object, prop, 0, at_flag, 0); | |
| 7270 /* If we only want text-prop extents, ignore all others */ | |
| 7271 if (text_props_only && !NILP (extent) && | |
| 7272 NILP (Fextent_property (extent, Qtext_prop, Qnil))) | |
| 7273 extent = Qnil; | |
| 826 | 7274 if ((NILP (extent) && !NILP (value)) || |
| 7275 (!NILP (extent) && !EQ (value, | |
| 7276 Fextent_property (extent, prop, Qnil)))) | |
| 7277 return pos; | |
| 7278 } | |
| 7279 | |
| 7280 if (limit_was_nil) | |
| 7281 return -1; | |
| 7282 else | |
| 7283 return limit; | |
| 7284 } | |
| 7285 | |
| 2506 | 7286 static Lisp_Object |
| 7287 next_previous_single_property_change_fn (Lisp_Object pos, Lisp_Object prop, | |
| 7288 Lisp_Object object, Lisp_Object limit, | |
| 7289 Boolint next, Boolint text_props_only) | |
| 7290 { | |
| 7291 Bytexpos xpos; | |
| 7292 Bytexpos blim; | |
| 7293 | |
| 7294 object = decode_buffer_or_string (object); | |
| 7295 xpos = get_buffer_or_string_pos_byte (object, pos, 0); | |
| 7296 blim = !NILP (limit) ? get_buffer_or_string_pos_byte (object, limit, 0) : -1; | |
| 7297 blim = next_previous_single_property_change (xpos, prop, object, blim, | |
| 7298 next, text_props_only); | |
| 7299 | |
| 7300 if (blim < 0) | |
| 7301 return Qnil; | |
| 826 | 7302 else |
| 2506 | 7303 return make_int (buffer_or_string_bytexpos_to_charxpos (object, blim)); |
| 826 | 7304 } |
| 428 | 7305 |
| 7306 DEFUN ("next-single-property-change", Fnext_single_property_change, | |
| 7307 2, 4, 0, /* | |
| 7308 Return the position of next property change for a specific property. | |
| 7309 Scans characters forward from POS till it finds a change in the PROP | |
| 7310 property, then returns the position of the change. The optional third | |
| 7311 argument OBJECT is the buffer or string to scan (defaults to the current | |
| 7312 buffer). | |
| 7313 The property values are compared with `eq'. | |
| 444 | 7314 Return nil if the property is constant all the way to the end of OBJECT. |
| 428 | 7315 If the value is non-nil, it is a position greater than POS, never equal. |
| 7316 | |
| 7317 If the optional fourth argument LIMIT is non-nil, don't search | |
| 7318 past position LIMIT; return LIMIT if nothing is found before LIMIT. | |
| 7319 If two or more extents with conflicting non-nil values for PROP overlap | |
| 7320 a particular character, it is undefined which value is considered to be | |
| 7321 the value of PROP. (Note that this situation will not happen if you always | |
| 7322 use the text-property primitives.) | |
| 2506 | 7323 |
| 7324 This function looks only at extents created using the text-property primitives. | |
| 7325 To look at all extents, use `next-single-char-property-change'. | |
| 428 | 7326 */ |
| 7327 (pos, prop, object, limit)) | |
| 7328 { | |
| 2506 | 7329 return next_previous_single_property_change_fn (pos, prop, object, limit, |
| 7330 1, 1); | |
| 826 | 7331 } |
| 428 | 7332 |
| 7333 DEFUN ("previous-single-property-change", Fprevious_single_property_change, | |
| 7334 2, 4, 0, /* | |
| 7335 Return the position of next property change for a specific property. | |
| 7336 Scans characters backward from POS till it finds a change in the PROP | |
| 7337 property, then returns the position of the change. The optional third | |
| 7338 argument OBJECT is the buffer or string to scan (defaults to the current | |
| 7339 buffer). | |
| 7340 The property values are compared with `eq'. | |
| 444 | 7341 Return nil if the property is constant all the way to the start of OBJECT. |
| 428 | 7342 If the value is non-nil, it is a position less than POS, never equal. |
| 7343 | |
| 7344 If the optional fourth argument LIMIT is non-nil, don't search back | |
| 7345 past position LIMIT; return LIMIT if nothing is found until LIMIT. | |
| 7346 If two or more extents with conflicting non-nil values for PROP overlap | |
| 7347 a particular character, it is undefined which value is considered to be | |
| 7348 the value of PROP. (Note that this situation will not happen if you always | |
| 7349 use the text-property primitives.) | |
| 2506 | 7350 |
| 7351 This function looks only at extents created using the text-property primitives. | |
|
5147
b0ab9aa48977
fix up doc of next-single-char-property-change and friends
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
7352 To look at all extents, use `previous-single-char-property-change'. |
| 2506 | 7353 */ |
| 7354 (pos, prop, object, limit)) | |
| 7355 { | |
| 7356 return next_previous_single_property_change_fn (pos, prop, object, limit, | |
| 7357 0, 1); | |
| 7358 } | |
| 7359 | |
| 7360 DEFUN ("next-single-char-property-change", Fnext_single_char_property_change, | |
| 7361 2, 4, 0, /* | |
| 7362 Return the position of next property change for a specific property. | |
| 7363 Scans characters forward from POS till it finds a change in the PROP | |
| 7364 property, then returns the position of the change. The optional third | |
| 7365 argument OBJECT is the buffer or string to scan (defaults to the current | |
| 7366 buffer). | |
| 7367 The property values are compared with `eq'. | |
| 7368 Return nil if the property is constant all the way to the end of OBJECT. | |
| 7369 If the value is non-nil, it is a position greater than POS, never equal. | |
| 7370 | |
| 7371 If the optional fourth argument LIMIT is non-nil, don't search | |
| 7372 past position LIMIT; return LIMIT if nothing is found before LIMIT. | |
| 7373 If two or more extents with conflicting non-nil values for PROP overlap | |
| 7374 a particular character, it is undefined which value is considered to be | |
| 7375 the value of PROP. (Note that this situation will not happen if you always | |
| 7376 use the text-property primitives.) | |
| 7377 | |
| 7378 This function looks at all extents. To look at only extents created using the | |
|
5147
b0ab9aa48977
fix up doc of next-single-char-property-change and friends
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
7379 text-property primitives, use `next-single-property-change'. |
| 428 | 7380 */ |
| 7381 (pos, prop, object, limit)) | |
| 7382 { | |
| 2506 | 7383 return next_previous_single_property_change_fn (pos, prop, object, limit, |
| 7384 1, 0); | |
| 7385 } | |
| 7386 | |
| 7387 DEFUN ("previous-single-char-property-change", | |
| 7388 Fprevious_single_char_property_change, | |
| 7389 2, 4, 0, /* | |
| 7390 Return the position of next property change for a specific property. | |
| 7391 Scans characters backward from POS till it finds a change in the PROP | |
| 7392 property, then returns the position of the change. The optional third | |
| 7393 argument OBJECT is the buffer or string to scan (defaults to the current | |
| 7394 buffer). | |
| 7395 The property values are compared with `eq'. | |
| 7396 Return nil if the property is constant all the way to the start of OBJECT. | |
| 7397 If the value is non-nil, it is a position less than POS, never equal. | |
| 7398 | |
| 7399 If the optional fourth argument LIMIT is non-nil, don't search back | |
| 7400 past position LIMIT; return LIMIT if nothing is found until LIMIT. | |
| 7401 If two or more extents with conflicting non-nil values for PROP overlap | |
| 7402 a particular character, it is undefined which value is considered to be | |
| 7403 the value of PROP. (Note that this situation will not happen if you always | |
| 7404 use the text-property primitives.) | |
| 7405 | |
| 7406 This function looks at all extents. To look at only extents created using the | |
|
5147
b0ab9aa48977
fix up doc of next-single-char-property-change and friends
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
7407 text-property primitives, use `previous-single-property-change'. |
| 2506 | 7408 */ |
| 7409 (pos, prop, object, limit)) | |
| 7410 { | |
| 7411 return next_previous_single_property_change_fn (pos, prop, object, limit, | |
| 7412 0, 0); | |
| 428 | 7413 } |
| 7414 | |
| 7415 #ifdef MEMORY_USAGE_STATS | |
| 7416 | |
| 7417 int | |
| 2286 | 7418 compute_buffer_extent_usage (struct buffer *UNUSED (b), |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5147
diff
changeset
|
7419 struct usage_stats *UNUSED (ustats)) |
| 428 | 7420 { |
| 7421 /* #### not yet written */ | |
| 7422 return 0; | |
| 7423 } | |
| 7424 | |
| 7425 #endif /* MEMORY_USAGE_STATS */ | |
| 7426 | |
| 7427 | |
| 7428 /************************************************************************/ | |
| 7429 /* initialization */ | |
| 7430 /************************************************************************/ | |
| 7431 | |
| 7432 void | |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5147
diff
changeset
|
7433 extent_objects_create (void) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5147
diff
changeset
|
7434 { |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5147
diff
changeset
|
7435 OBJECT_HAS_METHOD (extent, getprop); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5147
diff
changeset
|
7436 OBJECT_HAS_METHOD (extent, putprop); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5147
diff
changeset
|
7437 OBJECT_HAS_METHOD (extent, remprop); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5147
diff
changeset
|
7438 OBJECT_HAS_METHOD (extent, plist); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5147
diff
changeset
|
7439 } |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5147
diff
changeset
|
7440 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5147
diff
changeset
|
7441 void |
| 428 | 7442 syms_of_extents (void) |
| 7443 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
7444 INIT_LISP_OBJECT (extent); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
7445 INIT_LISP_OBJECT (extent_info); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
7446 INIT_LISP_OBJECT (extent_auxiliary); |
| 3092 | 7447 #ifdef NEW_GC |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
7448 INIT_LISP_OBJECT (gap_array_marker); |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
7449 INIT_LISP_OBJECT (gap_array); |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
7450 INIT_LISP_OBJECT (extent_list_marker); |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
7451 INIT_LISP_OBJECT (extent_list); |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
7452 INIT_LISP_OBJECT (stack_of_extents); |
| 3263 | 7453 #endif /* NEW_GC */ |
| 442 | 7454 |
| 563 | 7455 DEFSYMBOL (Qextentp); |
| 7456 DEFSYMBOL (Qextent_live_p); | |
| 7457 | |
| 7458 DEFSYMBOL (Qall_extents_closed); | |
| 7459 DEFSYMBOL (Qall_extents_open); | |
| 7460 DEFSYMBOL (Qall_extents_closed_open); | |
| 7461 DEFSYMBOL (Qall_extents_open_closed); | |
| 7462 DEFSYMBOL (Qstart_in_region); | |
| 7463 DEFSYMBOL (Qend_in_region); | |
| 7464 DEFSYMBOL (Qstart_and_end_in_region); | |
| 7465 DEFSYMBOL (Qstart_or_end_in_region); | |
| 7466 DEFSYMBOL (Qnegate_in_region); | |
| 7467 | |
| 7468 DEFSYMBOL (Qdetached); | |
| 7469 DEFSYMBOL (Qdestroyed); | |
| 7470 DEFSYMBOL (Qbegin_glyph); | |
| 7471 DEFSYMBOL (Qend_glyph); | |
| 7472 DEFSYMBOL (Qstart_open); | |
| 7473 DEFSYMBOL (Qend_open); | |
| 7474 DEFSYMBOL (Qstart_closed); | |
| 7475 DEFSYMBOL (Qend_closed); | |
| 7476 DEFSYMBOL (Qread_only); | |
| 7477 /* DEFSYMBOL (Qhighlight); in faces.c */ | |
| 7478 DEFSYMBOL (Qunique); | |
| 7479 DEFSYMBOL (Qduplicable); | |
| 7480 DEFSYMBOL (Qdetachable); | |
| 7481 DEFSYMBOL (Qpriority); | |
| 7482 DEFSYMBOL (Qmouse_face); | |
| 7483 DEFSYMBOL (Qinitial_redisplay_function); | |
| 7484 | |
| 7485 | |
| 7486 DEFSYMBOL (Qglyph_layout); /* backwards compatibility */ | |
| 7487 DEFSYMBOL (Qbegin_glyph_layout); | |
| 7488 DEFSYMBOL (Qend_glyph_layout); | |
| 7489 DEFSYMBOL (Qoutside_margin); | |
| 7490 DEFSYMBOL (Qinside_margin); | |
| 7491 DEFSYMBOL (Qwhitespace); | |
| 428 | 7492 /* Qtext defined in general.c */ |
| 7493 | |
| 563 | 7494 DEFSYMBOL (Qpaste_function); |
| 7495 DEFSYMBOL (Qcopy_function); | |
| 7496 | |
| 7497 DEFSYMBOL (Qtext_prop); | |
| 7498 DEFSYMBOL (Qtext_prop_extent_paste_function); | |
| 428 | 7499 |
| 7500 DEFSUBR (Fextentp); | |
| 7501 DEFSUBR (Fextent_live_p); | |
| 7502 DEFSUBR (Fextent_detached_p); | |
| 7503 DEFSUBR (Fextent_start_position); | |
| 7504 DEFSUBR (Fextent_end_position); | |
| 7505 DEFSUBR (Fextent_object); | |
| 7506 DEFSUBR (Fextent_length); | |
| 7507 | |
| 7508 DEFSUBR (Fmake_extent); | |
| 7509 DEFSUBR (Fcopy_extent); | |
| 7510 DEFSUBR (Fdelete_extent); | |
| 7511 DEFSUBR (Fdetach_extent); | |
| 7512 DEFSUBR (Fset_extent_endpoints); | |
| 7513 DEFSUBR (Fnext_extent); | |
| 7514 DEFSUBR (Fprevious_extent); | |
| 1204 | 7515 #ifdef DEBUG_XEMACS |
| 428 | 7516 DEFSUBR (Fnext_e_extent); |
| 7517 DEFSUBR (Fprevious_e_extent); | |
| 7518 #endif | |
| 7519 DEFSUBR (Fnext_extent_change); | |
| 7520 DEFSUBR (Fprevious_extent_change); | |
| 7521 | |
| 7522 DEFSUBR (Fextent_parent); | |
| 7523 DEFSUBR (Fextent_children); | |
| 7524 DEFSUBR (Fset_extent_parent); | |
| 7525 | |
| 7526 DEFSUBR (Fextent_in_region_p); | |
| 7527 DEFSUBR (Fmap_extents); | |
| 7528 DEFSUBR (Fmap_extent_children); | |
| 7529 DEFSUBR (Fextent_at); | |
| 442 | 7530 DEFSUBR (Fextents_at); |
| 428 | 7531 |
| 7532 DEFSUBR (Fset_extent_initial_redisplay_function); | |
| 7533 DEFSUBR (Fextent_face); | |
| 7534 DEFSUBR (Fset_extent_face); | |
| 7535 DEFSUBR (Fextent_mouse_face); | |
| 7536 DEFSUBR (Fset_extent_mouse_face); | |
| 7537 DEFSUBR (Fset_extent_begin_glyph); | |
| 7538 DEFSUBR (Fset_extent_end_glyph); | |
| 7539 DEFSUBR (Fextent_begin_glyph); | |
| 7540 DEFSUBR (Fextent_end_glyph); | |
| 7541 DEFSUBR (Fset_extent_begin_glyph_layout); | |
| 7542 DEFSUBR (Fset_extent_end_glyph_layout); | |
| 7543 DEFSUBR (Fextent_begin_glyph_layout); | |
| 7544 DEFSUBR (Fextent_end_glyph_layout); | |
| 7545 DEFSUBR (Fset_extent_priority); | |
| 7546 DEFSUBR (Fextent_priority); | |
| 7547 DEFSUBR (Fset_extent_property); | |
| 7548 DEFSUBR (Fset_extent_properties); | |
| 7549 DEFSUBR (Fextent_property); | |
| 7550 DEFSUBR (Fextent_properties); | |
| 7551 | |
| 7552 DEFSUBR (Fhighlight_extent); | |
| 7553 DEFSUBR (Fforce_highlight_extent); | |
| 7554 | |
| 7555 DEFSUBR (Finsert_extent); | |
| 7556 | |
| 7557 DEFSUBR (Fget_text_property); | |
| 7558 DEFSUBR (Fget_char_property); | |
| 7559 DEFSUBR (Fput_text_property); | |
| 7560 DEFSUBR (Fput_nonduplicable_text_property); | |
| 7561 DEFSUBR (Fadd_text_properties); | |
| 7562 DEFSUBR (Fadd_nonduplicable_text_properties); | |
| 7563 DEFSUBR (Fremove_text_properties); | |
| 7564 DEFSUBR (Ftext_prop_extent_paste_function); | |
| 7565 DEFSUBR (Fnext_single_property_change); | |
| 7566 DEFSUBR (Fprevious_single_property_change); | |
| 2506 | 7567 DEFSUBR (Fnext_single_char_property_change); |
| 7568 DEFSUBR (Fprevious_single_char_property_change); | |
| 428 | 7569 } |
| 7570 | |
| 7571 void | |
| 7572 vars_of_extents (void) | |
| 7573 { | |
|
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
|
7574 #ifdef DEBUG_XEMACS |
|
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
|
7575 DEFVAR_BOOL ("debug-soe", &debug_soe /* |
|
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
|
7576 If non-nil, display debugging information about the SOE ("stack of extents"). |
|
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
|
7577 The SOE is a cache of extents overlapping a specified region, used to |
|
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
|
7578 speed up `map-extents' and certain other functions. |
|
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
|
7579 */ ); |
|
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
|
7580 debug_soe = 0; |
|
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
|
7581 #endif /* DEBUG_XEMACS */ |
|
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
|
7582 |
| 428 | 7583 DEFVAR_INT ("mouse-highlight-priority", &mouse_highlight_priority /* |
| 7584 The priority to use for the mouse-highlighting pseudo-extent | |
| 7585 that is used to highlight extents with the `mouse-face' attribute set. | |
| 7586 See `set-extent-priority'. | |
| 7587 */ ); | |
| 7588 /* Set mouse-highlight-priority (which ends up being used both for the | |
| 7589 mouse-highlighting pseudo-extent and the primary selection extent) | |
| 7590 to a very high value because very few extents should override it. | |
| 7591 1000 gives lots of room below it for different-prioritized extents. | |
| 7592 10 doesn't. ediff, for example, likes to use priorities around 100. | |
| 7593 --ben */ | |
| 7594 mouse_highlight_priority = /* 10 */ 1000; | |
| 7595 | |
| 7596 DEFVAR_LISP ("default-text-properties", &Vdefault_text_properties /* | |
| 7597 Property list giving default values for text properties. | |
| 7598 Whenever a character does not specify a value for a property, the value | |
| 7599 stored in this list is used instead. This only applies when the | |
| 7600 functions `get-text-property' or `get-char-property' are called. | |
| 7601 */ ); | |
| 7602 Vdefault_text_properties = Qnil; | |
| 7603 | |
| 7604 staticpro (&Vlast_highlighted_extent); | |
| 7605 Vlast_highlighted_extent = Qnil; | |
| 7606 | |
| 7607 Vextent_face_reusable_list = Fcons (Qnil, Qnil); | |
| 7608 staticpro (&Vextent_face_reusable_list); | |
| 771 | 7609 |
| 428 | 7610 staticpro (&Vextent_face_memoize_hash_table); |
| 7611 /* The memoize hash table maps from lists of symbols to lists of | |
| 7612 faces. It needs to be `equal' to implement the memoization. | |
| 7613 The reverse table maps in the other direction and just needs | |
| 7614 to do `eq' comparison because the lists of faces are already | |
| 7615 memoized. */ | |
| 7616 Vextent_face_memoize_hash_table = | |
| 7617 make_lisp_hash_table (100, HASH_TABLE_VALUE_WEAK, HASH_TABLE_EQUAL); | |
| 7618 staticpro (&Vextent_face_reverse_memoize_hash_table); | |
| 7619 Vextent_face_reverse_memoize_hash_table = | |
| 7620 make_lisp_hash_table (100, HASH_TABLE_KEY_WEAK, HASH_TABLE_EQ); | |
| 1292 | 7621 |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
7622 QSin_map_extents_internal = build_defer_string ("(in map-extents-internal)"); |
| 1292 | 7623 staticpro (&QSin_map_extents_internal); |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
7624 |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
7625 Vextent_auxiliary_defaults = |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
7626 allocate_extent_auxiliary (); |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
7627 staticpro (&Vextent_auxiliary_defaults); |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
7628 } |