Mercurial > hg > xemacs-beta
annotate src/extents.c @ 5146:88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
-------------------- ChangeLog entries follow: --------------------
src/ChangeLog addition:
2010-03-15 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (c_readonly):
* alloc.c (deadbeef_memory):
* alloc.c (make_compiled_function):
* alloc.c (make_button_data):
* alloc.c (make_motion_data):
* alloc.c (make_process_data):
* alloc.c (make_timeout_data):
* alloc.c (make_magic_data):
* alloc.c (make_magic_eval_data):
* alloc.c (make_eval_data):
* alloc.c (make_misc_user_data):
* alloc.c (noseeum_make_marker):
* alloc.c (ADDITIONAL_FREE_string):
* alloc.c (common_init_alloc_early):
* alloc.c (init_alloc_once_early):
* bytecode.c (print_compiled_function):
* bytecode.c (mark_compiled_function):
* casetab.c:
* casetab.c (print_case_table):
* console.c:
* console.c (print_console):
* database.c (print_database):
* database.c (finalize_database):
* device-msw.c (sync_printer_with_devmode):
* device-msw.c (print_devmode):
* device-msw.c (finalize_devmode):
* device.c:
* device.c (print_device):
* elhash.c:
* elhash.c (print_hash_table):
* eval.c (print_multiple_value):
* eval.c (mark_multiple_value):
* events.c (deinitialize_event):
* events.c (print_event):
* events.c (event_equal):
* extents.c:
* extents.c (soe_dump):
* extents.c (soe_insert):
* extents.c (soe_delete):
* extents.c (soe_move):
* extents.c (extent_fragment_update):
* extents.c (print_extent_1):
* extents.c (print_extent):
* extents.c (vars_of_extents):
* frame.c:
* frame.c (print_frame):
* free-hook.c:
* free-hook.c (check_free):
* glyphs.c:
* glyphs.c (print_image_instance):
* glyphs.c (print_glyph):
* gui.c:
* gui.c (copy_gui_item):
* hash.c:
* hash.c (NULL_ENTRY):
* hash.c (KEYS_DIFFER_P):
* keymap.c (print_keymap):
* keymap.c (MARKED_SLOT):
* lisp.h:
* lrecord.h:
* lrecord.h (LISP_OBJECT_UID):
* lrecord.h (set_lheader_implementation):
* lrecord.h (struct old_lcrecord_header):
* lstream.c (print_lstream):
* lstream.c (finalize_lstream):
* marker.c (print_marker):
* marker.c (marker_equal):
* mc-alloc.c (visit_all_used_page_headers):
* mule-charset.c:
* mule-charset.c (print_charset):
* objects.c (print_color_instance):
* objects.c (print_font_instance):
* objects.c (finalize_font_instance):
* opaque.c (print_opaque):
* opaque.c (print_opaque_ptr):
* opaque.c (equal_opaque_ptr):
* print.c (internal_object_printer):
* print.c (enum printing_badness):
* rangetab.c (print_range_table):
* rangetab.c (range_table_equal):
* specifier.c (print_specifier):
* specifier.c (finalize_specifier):
* symbols.c:
* symbols.c (print_symbol_value_magic):
* tooltalk.c:
* tooltalk.c (print_tooltalk_message):
* tooltalk.c (print_tooltalk_pattern):
* window.c (print_window):
* window.c (debug_print_window):
(1) Make lrecord UID's have a separate UID space for each object.
Otherwise, with 20-bit UID's, we rapidly wrap around, especially
when common objects like conses and strings increment the UID value
for every object created. (Originally I tried making two UID spaces,
one for objects that always print readably and hence don't display
the UID, and one for other objects. But certain objects like markers
for which a UID is displayed are still generated rapidly enough that
UID overflow is a serious issue.) This also has the advantage of
making UID values smaller, hence easier to remember -- their main
purpose is to make it easier to keep track of different objects of
the same type when debugging code. Make sure we dump lrecord UID's
so that we don't have problems with pdumped and non-dumped objects
having the same UID.
(2) Display UID's consistently whenever an object (a) doesn't
consistently print readably (objects like cons and string, which
always print readably, can't display a UID), and (b) doesn't
otherwise have a unique property that makes objects of a
particular type distinguishable. (E.g. buffers didn't and still
don't print an ID, but the buffer name uniquely identifies the
buffer.) Some types, such as event, extent, compiled-function,
didn't always (or didn't ever) display an ID; others (such as
marker, extent, lstream, opaque, opaque-ptr, any object using
internal_object_printer()) used to display the actual machine
pointer instead.
(3) Rename NORMAL_LISP_OBJECT_UID to LISP_OBJECT_UID; make it work
over all Lisp objects and take a Lisp object, not a struct pointer.
(4) Some misc cleanups in alloc.c, elhash.c.
(5) Change code in events.c that "deinitializes" an event so that
it doesn't increment the event UID counter in the process. Also
use deadbeef_memory() to overwrite memory instead of doing the same
with custom code. In the process, make deadbeef_memory() in
alloc.c always available, and delete extraneous copy in mc-alloc.c.
Also capitalize all uses of 0xDEADBEEF. Similarly in elhash.c
call deadbeef_memory().
(6) Resurrect "debug SOE" code in extents.c. Make it conditional
on DEBUG_XEMACS and on a `debug-soe' variable, rather than on
SOE_DEBUG. Make it output to stderr, not stdout.
(7) Delete some custom print methods that were identical to
external_object_printer().
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Mon, 15 Mar 2010 16:35:38 -0500 |
| parents | f965e31a35f0 |
| children | b0ab9aa48977 |
| 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 | |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
3465 DEFINE_DUMPABLE_FROB_BLOCK_GENERAL_LISP_OBJECT ("extent", extent, |
| 934 | 3466 mark_extent, |
| 3467 print_extent, | |
| 3468 /* NOTE: If you declare a | |
| 3469 finalization method here, | |
| 3470 it will NOT be called. | |
| 3471 Shaft city. */ | |
| 3472 0, | |
| 3473 extent_equal, extent_hash, | |
| 3474 extent_description, | |
| 3475 extent_getprop, extent_putprop, | |
| 3476 extent_remprop, extent_plist, | |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
3477 0 /* no disksaver */, |
| 934 | 3478 struct extent); |
| 428 | 3479 |
| 3480 /************************************************************************/ | |
| 3481 /* basic extent accessors */ | |
| 3482 /************************************************************************/ | |
| 3483 | |
| 3484 /* These functions are for checking externally-passed extent objects | |
| 3485 and returning an extent's basic properties, which include the | |
| 3486 buffer the extent is associated with, the endpoints of the extent's | |
| 3487 range, the open/closed-ness of those endpoints, and whether the | |
| 3488 extent is detached. Manipulating these properties requires | |
| 3489 manipulating the ordered lists that hold extents; thus, functions | |
| 3490 to do that are in a later section. */ | |
| 3491 | |
| 3492 /* Given a Lisp_Object that is supposed to be an extent, make sure it | |
| 3493 is OK and return an extent pointer. Extents can be in one of four | |
| 3494 states: | |
| 3495 | |
| 3496 1) destroyed | |
| 3497 2) detached and not associated with a buffer | |
| 3498 3) detached and associated with a buffer | |
| 3499 4) attached to a buffer | |
| 3500 | |
| 3501 If FLAGS is 0, types 2-4 are allowed. If FLAGS is DE_MUST_HAVE_BUFFER, | |
| 3502 types 3-4 are allowed. If FLAGS is DE_MUST_BE_ATTACHED, only type 4 | |
| 3503 is allowed. | |
| 3504 */ | |
| 3505 | |
| 3506 static EXTENT | |
| 3507 decode_extent (Lisp_Object extent_obj, unsigned int flags) | |
| 3508 { | |
| 3509 EXTENT extent; | |
| 3510 Lisp_Object obj; | |
| 3511 | |
| 3512 CHECK_LIVE_EXTENT (extent_obj); | |
| 3513 extent = XEXTENT (extent_obj); | |
| 3514 obj = extent_object (extent); | |
| 3515 | |
| 3516 /* the following condition will fail if we're dealing with a freed extent */ | |
| 3517 assert (NILP (obj) || BUFFERP (obj) || STRINGP (obj)); | |
| 3518 | |
| 3519 if (flags & DE_MUST_BE_ATTACHED) | |
| 3520 flags |= DE_MUST_HAVE_BUFFER; | |
| 3521 | |
| 3522 /* if buffer is dead, then convert extent to have no buffer. */ | |
| 3523 if (BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) | |
| 3524 obj = extent_object (extent) = Qnil; | |
| 3525 | |
| 3526 assert (!NILP (obj) || extent_detached_p (extent)); | |
| 3527 | |
| 3528 if ((NILP (obj) && (flags & DE_MUST_HAVE_BUFFER)) | |
| 3529 || (extent_detached_p (extent) && (flags & DE_MUST_BE_ATTACHED))) | |
| 3530 { | |
| 442 | 3531 invalid_argument ("extent doesn't belong to a buffer or string", |
| 3532 extent_obj); | |
| 428 | 3533 } |
| 3534 | |
| 3535 return extent; | |
| 3536 } | |
| 3537 | |
| 826 | 3538 /* Note that the returned value is a char position, not a byte position. */ |
| 428 | 3539 |
| 3540 static Lisp_Object | |
| 3541 extent_endpoint_external (Lisp_Object extent_obj, int endp) | |
| 3542 { | |
| 3543 EXTENT extent = decode_extent (extent_obj, 0); | |
| 3544 | |
| 3545 if (extent_detached_p (extent)) | |
| 3546 return Qnil; | |
| 3547 else | |
| 826 | 3548 return make_int (extent_endpoint_char (extent, endp)); |
| 428 | 3549 } |
| 3550 | |
| 3551 DEFUN ("extentp", Fextentp, 1, 1, 0, /* | |
| 3552 Return t if OBJECT is an extent. | |
| 3553 */ | |
| 3554 (object)) | |
| 3555 { | |
| 3556 return EXTENTP (object) ? Qt : Qnil; | |
| 3557 } | |
| 3558 | |
| 3559 DEFUN ("extent-live-p", Fextent_live_p, 1, 1, 0, /* | |
| 3560 Return t if OBJECT is an extent that has not been destroyed. | |
| 3561 */ | |
| 3562 (object)) | |
| 3563 { | |
| 3564 return EXTENTP (object) && EXTENT_LIVE_P (XEXTENT (object)) ? Qt : Qnil; | |
| 3565 } | |
| 3566 | |
| 3567 DEFUN ("extent-detached-p", Fextent_detached_p, 1, 1, 0, /* | |
| 3568 Return t if EXTENT is detached. | |
| 3569 */ | |
| 3570 (extent)) | |
| 3571 { | |
| 3572 return extent_detached_p (decode_extent (extent, 0)) ? Qt : Qnil; | |
| 3573 } | |
| 3574 | |
| 3575 DEFUN ("extent-object", Fextent_object, 1, 1, 0, /* | |
| 3576 Return object (buffer or string) that EXTENT refers to. | |
| 3577 */ | |
| 3578 (extent)) | |
| 3579 { | |
| 3580 return extent_object (decode_extent (extent, 0)); | |
| 3581 } | |
| 3582 | |
| 3583 DEFUN ("extent-start-position", Fextent_start_position, 1, 1, 0, /* | |
| 3584 Return start position of EXTENT, or nil if EXTENT is detached. | |
| 3585 */ | |
| 3586 (extent)) | |
| 3587 { | |
| 3588 return extent_endpoint_external (extent, 0); | |
| 3589 } | |
| 3590 | |
| 3591 DEFUN ("extent-end-position", Fextent_end_position, 1, 1, 0, /* | |
| 3592 Return end position of EXTENT, or nil if EXTENT is detached. | |
| 3593 */ | |
| 3594 (extent)) | |
| 3595 { | |
| 3596 return extent_endpoint_external (extent, 1); | |
| 3597 } | |
| 3598 | |
| 3599 DEFUN ("extent-length", Fextent_length, 1, 1, 0, /* | |
| 3600 Return length of EXTENT in characters. | |
| 3601 */ | |
| 3602 (extent)) | |
| 3603 { | |
| 3604 EXTENT e = decode_extent (extent, DE_MUST_BE_ATTACHED); | |
| 826 | 3605 return make_int (extent_endpoint_char (e, 1) |
| 3606 - extent_endpoint_char (e, 0)); | |
| 428 | 3607 } |
| 3608 | |
| 3609 DEFUN ("next-extent", Fnext_extent, 1, 1, 0, /* | |
| 3610 Find next extent after EXTENT. | |
| 3611 If EXTENT is a buffer return the first extent in the buffer; likewise | |
| 3612 for strings. | |
| 3613 Extents in a buffer are ordered in what is called the "display" | |
| 3614 order, which sorts by increasing start positions and then by *decreasing* | |
| 3615 end positions. | |
| 3616 If you want to perform an operation on a series of extents, use | |
| 3617 `map-extents' instead of this function; it is much more efficient. | |
| 3618 The primary use of this function should be to enumerate all the | |
| 3619 extents in a buffer. | |
| 3620 Note: The display order is not necessarily the order that `map-extents' | |
| 3621 processes extents in! | |
| 3622 */ | |
| 3623 (extent)) | |
| 3624 { | |
| 3625 EXTENT next; | |
| 3626 | |
| 3627 if (EXTENTP (extent)) | |
| 3628 next = extent_next (decode_extent (extent, DE_MUST_BE_ATTACHED)); | |
| 3629 else | |
| 3630 next = extent_first (decode_buffer_or_string (extent)); | |
| 3631 | |
| 3632 if (!next) | |
| 3633 return Qnil; | |
| 793 | 3634 return wrap_extent (next); |
| 428 | 3635 } |
| 3636 | |
| 3637 DEFUN ("previous-extent", Fprevious_extent, 1, 1, 0, /* | |
| 3638 Find last extent before EXTENT. | |
| 3639 If EXTENT is a buffer return the last extent in the buffer; likewise | |
| 3640 for strings. | |
| 3641 This function is analogous to `next-extent'. | |
| 3642 */ | |
| 3643 (extent)) | |
| 3644 { | |
| 3645 EXTENT prev; | |
| 3646 | |
| 3647 if (EXTENTP (extent)) | |
| 3648 prev = extent_previous (decode_extent (extent, DE_MUST_BE_ATTACHED)); | |
| 3649 else | |
| 3650 prev = extent_last (decode_buffer_or_string (extent)); | |
| 3651 | |
| 3652 if (!prev) | |
| 3653 return Qnil; | |
| 793 | 3654 return wrap_extent (prev); |
| 428 | 3655 } |
| 3656 | |
| 3657 #ifdef DEBUG_XEMACS | |
| 3658 | |
| 3659 DEFUN ("next-e-extent", Fnext_e_extent, 1, 1, 0, /* | |
| 3660 Find next extent after EXTENT using the "e" order. | |
| 3661 If EXTENT is a buffer return the first extent in the buffer; likewise | |
| 3662 for strings. | |
| 3663 */ | |
| 3664 (extent)) | |
| 3665 { | |
| 3666 EXTENT next; | |
| 3667 | |
| 3668 if (EXTENTP (extent)) | |
| 3669 next = extent_e_next (decode_extent (extent, DE_MUST_BE_ATTACHED)); | |
| 3670 else | |
| 3671 next = extent_e_first (decode_buffer_or_string (extent)); | |
| 3672 | |
| 3673 if (!next) | |
| 3674 return Qnil; | |
| 793 | 3675 return wrap_extent (next); |
| 428 | 3676 } |
| 3677 | |
| 3678 DEFUN ("previous-e-extent", Fprevious_e_extent, 1, 1, 0, /* | |
| 3679 Find last extent before EXTENT using the "e" order. | |
| 3680 If EXTENT is a buffer return the last extent in the buffer; likewise | |
| 3681 for strings. | |
| 3682 This function is analogous to `next-e-extent'. | |
| 3683 */ | |
| 3684 (extent)) | |
| 3685 { | |
| 3686 EXTENT prev; | |
| 3687 | |
| 3688 if (EXTENTP (extent)) | |
| 3689 prev = extent_e_previous (decode_extent (extent, DE_MUST_BE_ATTACHED)); | |
| 3690 else | |
| 3691 prev = extent_e_last (decode_buffer_or_string (extent)); | |
| 3692 | |
| 3693 if (!prev) | |
| 3694 return Qnil; | |
| 793 | 3695 return wrap_extent (prev); |
| 428 | 3696 } |
| 3697 | |
| 3698 #endif | |
| 3699 | |
| 3700 DEFUN ("next-extent-change", Fnext_extent_change, 1, 2, 0, /* | |
| 3701 Return the next position after POS where an extent begins or ends. | |
| 3702 If POS is at the end of the buffer or string, POS will be returned; | |
| 3703 otherwise a position greater than POS will always be returned. | |
| 444 | 3704 If OBJECT is nil, the current buffer is assumed. |
| 428 | 3705 */ |
| 3706 (pos, object)) | |
| 3707 { | |
| 3708 Lisp_Object obj = decode_buffer_or_string (object); | |
| 826 | 3709 Bytexpos xpos; |
| 3710 | |
| 3711 xpos = get_buffer_or_string_pos_byte (obj, pos, GB_ALLOW_PAST_ACCESSIBLE); | |
| 3712 xpos = extent_find_end_of_run (obj, xpos, 1); | |
| 3713 return make_int (buffer_or_string_bytexpos_to_charxpos (obj, xpos)); | |
| 428 | 3714 } |
| 3715 | |
| 3716 DEFUN ("previous-extent-change", Fprevious_extent_change, 1, 2, 0, /* | |
| 3717 Return the last position before POS where an extent begins or ends. | |
| 3718 If POS is at the beginning of the buffer or string, POS will be returned; | |
| 3719 otherwise a position less than POS will always be returned. | |
| 3720 If OBJECT is nil, the current buffer is assumed. | |
| 3721 */ | |
| 3722 (pos, object)) | |
| 3723 { | |
| 3724 Lisp_Object obj = decode_buffer_or_string (object); | |
| 826 | 3725 Bytexpos xpos; |
| 3726 | |
| 3727 xpos = get_buffer_or_string_pos_byte (obj, pos, GB_ALLOW_PAST_ACCESSIBLE); | |
| 3728 xpos = extent_find_beginning_of_run (obj, xpos, 1); | |
| 3729 return make_int (buffer_or_string_bytexpos_to_charxpos (obj, xpos)); | |
| 428 | 3730 } |
| 3731 | |
| 3732 | |
| 3733 /************************************************************************/ | |
| 3734 /* parent and children stuff */ | |
| 3735 /************************************************************************/ | |
| 3736 | |
| 3737 DEFUN ("extent-parent", Fextent_parent, 1, 1, 0, /* | |
| 3738 Return the parent (if any) of EXTENT. | |
| 3739 If an extent has a parent, it derives all its properties from that extent | |
| 3740 and has no properties of its own. (The only "properties" that the | |
| 3741 extent keeps are the buffer/string it refers to and the start and end | |
| 3742 points.) It is possible for an extent's parent to itself have a parent. | |
| 3743 */ | |
| 3744 (extent)) | |
| 3745 /* do I win the prize for the strangest split infinitive? */ | |
| 3746 { | |
| 3747 EXTENT e = decode_extent (extent, 0); | |
| 3748 return extent_parent (e); | |
| 3749 } | |
| 3750 | |
| 3751 DEFUN ("extent-children", Fextent_children, 1, 1, 0, /* | |
| 3752 Return a list of the children (if any) of EXTENT. | |
| 3753 The children of an extent are all those extents whose parent is that extent. | |
| 3754 This function does not recursively trace children of children. | |
| 3755 \(To do that, use `extent-descendants'.) | |
| 3756 */ | |
| 3757 (extent)) | |
| 3758 { | |
| 3759 EXTENT e = decode_extent (extent, 0); | |
| 3760 Lisp_Object children = extent_children (e); | |
| 3761 | |
| 3762 if (!NILP (children)) | |
| 3763 return Fcopy_sequence (XWEAK_LIST_LIST (children)); | |
| 3764 else | |
| 3765 return Qnil; | |
| 3766 } | |
| 3767 | |
| 3768 static void | |
| 3769 remove_extent_from_children_list (EXTENT e, Lisp_Object child) | |
| 3770 { | |
| 3771 Lisp_Object children = extent_children (e); | |
| 3772 | |
| 3773 #ifdef ERROR_CHECK_EXTENTS | |
| 3774 assert (!NILP (memq_no_quit (child, XWEAK_LIST_LIST (children)))); | |
| 3775 #endif | |
| 3776 XWEAK_LIST_LIST (children) = | |
| 3777 delq_no_quit (child, XWEAK_LIST_LIST (children)); | |
| 3778 } | |
| 3779 | |
| 3780 static void | |
| 3781 add_extent_to_children_list (EXTENT e, Lisp_Object child) | |
| 3782 { | |
| 3783 Lisp_Object children = extent_children (e); | |
| 3784 | |
| 3785 if (NILP (children)) | |
| 3786 { | |
| 3787 children = make_weak_list (WEAK_LIST_SIMPLE); | |
| 3788 set_extent_no_chase_aux_field (e, children, children); | |
| 3789 } | |
| 3790 | |
| 3791 #ifdef ERROR_CHECK_EXTENTS | |
| 3792 assert (NILP (memq_no_quit (child, XWEAK_LIST_LIST (children)))); | |
| 3793 #endif | |
| 3794 XWEAK_LIST_LIST (children) = Fcons (child, XWEAK_LIST_LIST (children)); | |
| 3795 } | |
| 3796 | |
| 826 | 3797 |
| 3798 static int | |
| 3799 compare_key_value_pairs (const void *humpty, const void *dumpty) | |
| 3800 { | |
| 3801 Lisp_Object_pair *foo = (Lisp_Object_pair *) humpty; | |
| 3802 Lisp_Object_pair *bar = (Lisp_Object_pair *) dumpty; | |
| 3803 if (EQ (foo->key, bar->key)) | |
| 3804 return 0; | |
| 3805 return !NILP (Fstring_lessp (foo->key, bar->key)) ? -1 : 1; | |
| 3806 } | |
| 3807 | |
| 428 | 3808 DEFUN ("set-extent-parent", Fset_extent_parent, 2, 2, 0, /* |
| 3809 Set the parent of EXTENT to PARENT (may be nil). | |
| 3810 See `extent-parent'. | |
| 3811 */ | |
| 3812 (extent, parent)) | |
| 3813 { | |
| 3814 EXTENT e = decode_extent (extent, 0); | |
| 3815 Lisp_Object cur_parent = extent_parent (e); | |
| 3816 Lisp_Object rest; | |
| 3817 | |
| 793 | 3818 extent = wrap_extent (e); |
| 428 | 3819 if (!NILP (parent)) |
| 3820 CHECK_LIVE_EXTENT (parent); | |
| 3821 if (EQ (parent, cur_parent)) | |
| 3822 return Qnil; | |
| 3823 for (rest = parent; !NILP (rest); rest = extent_parent (XEXTENT (rest))) | |
| 3824 if (EQ (rest, extent)) | |
| 563 | 3825 signal_error (Qinvalid_change, |
| 442 | 3826 "Circular parent chain would result", |
| 3827 extent); | |
| 428 | 3828 if (NILP (parent)) |
| 3829 { | |
| 3830 remove_extent_from_children_list (XEXTENT (cur_parent), extent); | |
| 3831 set_extent_no_chase_aux_field (e, parent, Qnil); | |
| 3832 e->flags.has_parent = 0; | |
| 3833 } | |
| 3834 else | |
| 3835 { | |
| 3836 add_extent_to_children_list (XEXTENT (parent), extent); | |
| 3837 set_extent_no_chase_aux_field (e, parent, parent); | |
| 3838 e->flags.has_parent = 1; | |
| 3839 } | |
| 3840 /* changing the parent also changes the properties of all children. */ | |
| 3841 { | |
| 826 | 3842 Lisp_Object_pair_dynarr *oldprops, *newprops; |
| 3843 int i, orignewlength; | |
| 3844 | |
| 3845 /* perhaps there's a smarter way, but the following will work, | |
| 3846 and it's O(N*log N): | |
| 3847 | |
| 3848 (1) get the old props. | |
| 3849 (2) get the new props. | |
| 3850 (3) sort both. | |
| 3851 (4) loop through old props; if key not in new, add it, with value | |
| 3852 Qunbound. | |
| 3853 (5) vice-versa for new props. | |
| 3854 (6) sort both again. | |
| 3855 (7) now we have identical lists of keys; we run through and compare | |
| 3856 the values. | |
| 3857 | |
| 3858 Of course in reality the number of properties will be low, so | |
| 3859 an N^2 algorithm wouldn't be a problem, but the stuff below is just | |
| 3860 as easy to write given the existence of qsort and bsearch. | |
| 3861 */ | |
| 3862 | |
| 3863 oldprops = Dynarr_new (Lisp_Object_pair); | |
| 3864 newprops = Dynarr_new (Lisp_Object_pair); | |
| 3865 if (!NILP (cur_parent)) | |
| 3866 extent_properties (XEXTENT (cur_parent), oldprops); | |
| 3867 if (!NILP (parent)) | |
| 3868 extent_properties (XEXTENT (parent), newprops); | |
| 3869 | |
| 4967 | 3870 qsort (Dynarr_begin (oldprops), Dynarr_length (oldprops), |
| 826 | 3871 sizeof (Lisp_Object_pair), compare_key_value_pairs); |
| 4967 | 3872 qsort (Dynarr_begin (newprops), Dynarr_length (newprops), |
| 826 | 3873 sizeof (Lisp_Object_pair), compare_key_value_pairs); |
| 3874 orignewlength = Dynarr_length (newprops); | |
| 3875 for (i = 0; i < Dynarr_length (oldprops); i++) | |
| 3876 { | |
| 4967 | 3877 if (!bsearch (Dynarr_atp (oldprops, i), Dynarr_begin (newprops), |
| 826 | 3878 Dynarr_length (newprops), sizeof (Lisp_Object_pair), |
| 3879 compare_key_value_pairs)) | |
| 3880 { | |
| 3025 | 3881 Lisp_Object_pair new_; |
| 3882 new_.key = Dynarr_at (oldprops, i).key; | |
| 3883 new_.value = Qunbound; | |
| 3884 Dynarr_add (newprops, new_); | |
| 826 | 3885 } |
| 3886 } | |
| 3887 for (i = 0; i < orignewlength; i++) | |
| 3888 { | |
| 859 | 3889 if (!Dynarr_length (oldprops) || !bsearch (Dynarr_atp (newprops, i), |
| 4967 | 3890 Dynarr_begin (oldprops), |
| 859 | 3891 Dynarr_length (oldprops), |
| 3892 sizeof (Lisp_Object_pair), | |
| 3893 compare_key_value_pairs)) | |
| 826 | 3894 { |
| 3025 | 3895 Lisp_Object_pair new_; |
| 3896 new_.key = Dynarr_at (newprops, i).key; | |
| 3897 new_.value = Qunbound; | |
| 3898 Dynarr_add (oldprops, new_); | |
| 826 | 3899 } |
| 3900 } | |
| 4967 | 3901 qsort (Dynarr_begin (oldprops), Dynarr_length (oldprops), |
| 826 | 3902 sizeof (Lisp_Object_pair), compare_key_value_pairs); |
| 4967 | 3903 qsort (Dynarr_begin (newprops), Dynarr_length (newprops), |
| 826 | 3904 sizeof (Lisp_Object_pair), compare_key_value_pairs); |
| 3905 for (i = 0; i < Dynarr_length (oldprops); i++) | |
| 3906 { | |
| 3907 assert (EQ (Dynarr_at (oldprops, i).key, Dynarr_at (newprops, i).key)); | |
| 3908 if (!EQ (Dynarr_at (oldprops, i).value, Dynarr_at (newprops, i).value)) | |
| 3909 signal_extent_property_changed (e, Dynarr_at (oldprops, i).key, 1); | |
| 3910 } | |
| 3911 | |
| 3912 Dynarr_free (oldprops); | |
| 3913 Dynarr_free (newprops); | |
| 3914 #if 0 | |
| 3915 { | |
| 428 | 3916 int old_invis = (!NILP (cur_parent) && |
| 3917 !NILP (extent_invisible (XEXTENT (cur_parent)))); | |
| 3918 int new_invis = (!NILP (parent) && | |
| 3919 !NILP (extent_invisible (XEXTENT (parent)))); | |
| 3920 | |
| 3921 extent_maybe_changed_for_redisplay (e, 1, new_invis != old_invis); | |
| 3922 } | |
| 826 | 3923 #endif /* 0 */ |
| 3924 } | |
| 428 | 3925 return Qnil; |
| 3926 } | |
| 3927 | |
| 3928 | |
| 3929 /************************************************************************/ | |
| 3930 /* basic extent mutators */ | |
| 3931 /************************************************************************/ | |
| 3932 | |
| 3933 /* Note: If you track non-duplicable extents by undo, you'll get bogus | |
| 3934 undo records for transient extents via update-extent. | |
| 3935 For example, query-replace will do this. | |
| 3936 */ | |
| 3937 | |
| 3938 static void | |
| 826 | 3939 set_extent_endpoints_1 (EXTENT extent, Memxpos start, Memxpos end) |
| 428 | 3940 { |
| 3941 #ifdef ERROR_CHECK_EXTENTS | |
| 3942 Lisp_Object obj = extent_object (extent); | |
| 3943 | |
| 3944 assert (start <= end); | |
| 3945 if (BUFFERP (obj)) | |
| 3946 { | |
| 665 | 3947 assert (valid_membpos_p (XBUFFER (obj), start)); |
| 3948 assert (valid_membpos_p (XBUFFER (obj), end)); | |
| 428 | 3949 } |
| 3950 #endif | |
| 3951 | |
| 3952 /* Optimization: if the extent is already where we want it to be, | |
| 3953 do nothing. */ | |
| 3954 if (!extent_detached_p (extent) && extent_start (extent) == start && | |
| 3955 extent_end (extent) == end) | |
| 3956 return; | |
| 3957 | |
| 3958 if (extent_detached_p (extent)) | |
| 3959 { | |
| 3960 if (extent_duplicable_p (extent)) | |
| 3961 { | |
| 793 | 3962 Lisp_Object extent_obj = wrap_extent (extent); |
| 3963 | |
| 428 | 3964 record_extent (extent_obj, 1); |
| 3965 } | |
| 3966 } | |
| 3967 else | |
| 3968 extent_detach (extent); | |
| 3969 | |
| 3970 set_extent_start (extent, start); | |
| 3971 set_extent_end (extent, end); | |
| 3972 extent_attach (extent); | |
| 3973 } | |
| 3974 | |
| 3975 /* Set extent's endpoints to S and E, and put extent in buffer or string | |
| 3976 OBJECT. (If OBJECT is nil, do not change the extent's object.) */ | |
| 3977 | |
| 3978 void | |
| 826 | 3979 set_extent_endpoints (EXTENT extent, Bytexpos s, Bytexpos e, |
| 3980 Lisp_Object object) | |
| 3981 { | |
| 3982 Memxpos start, end; | |
| 428 | 3983 |
| 3984 if (NILP (object)) | |
| 3985 { | |
| 3986 object = extent_object (extent); | |
| 3987 assert (!NILP (object)); | |
| 3988 } | |
| 3989 else if (!EQ (object, extent_object (extent))) | |
| 3990 { | |
| 3991 extent_detach (extent); | |
| 3992 extent_object (extent) = object; | |
| 3993 } | |
| 3994 | |
| 3995 start = s < 0 ? extent_start (extent) : | |
| 826 | 3996 buffer_or_string_bytexpos_to_memxpos (object, s); |
| 428 | 3997 end = e < 0 ? extent_end (extent) : |
| 826 | 3998 buffer_or_string_bytexpos_to_memxpos (object, e); |
| 428 | 3999 set_extent_endpoints_1 (extent, start, end); |
| 4000 } | |
| 4001 | |
| 4002 static void | |
| 4003 set_extent_openness (EXTENT extent, int start_open, int end_open) | |
| 4004 { | |
| 4005 if (start_open != -1) | |
| 826 | 4006 { |
| 4007 extent_start_open_p (extent) = start_open; | |
| 4008 signal_extent_property_changed (extent, Qstart_open, 1); | |
| 4009 } | |
| 428 | 4010 if (end_open != -1) |
| 826 | 4011 { |
| 4012 extent_end_open_p (extent) = end_open; | |
| 4013 signal_extent_property_changed (extent, Qend_open, 1); | |
| 4014 } | |
| 428 | 4015 } |
| 4016 | |
| 4017 static EXTENT | |
| 826 | 4018 make_extent (Lisp_Object object, Bytexpos from, Bytexpos to) |
| 428 | 4019 { |
| 4020 EXTENT extent; | |
| 4021 | |
| 4022 extent = make_extent_detached (object); | |
| 4023 set_extent_endpoints (extent, from, to, Qnil); | |
| 4024 return extent; | |
| 4025 } | |
| 4026 | |
| 826 | 4027 /* Copy ORIGINAL, changing it to span FROM,TO in OBJECT. */ |
| 4028 | |
| 428 | 4029 static EXTENT |
| 826 | 4030 copy_extent (EXTENT original, Bytexpos from, Bytexpos to, Lisp_Object object) |
| 428 | 4031 { |
| 4032 EXTENT e; | |
| 4033 | |
| 4034 e = make_extent_detached (object); | |
| 4035 if (from >= 0) | |
| 4036 set_extent_endpoints (e, from, to, Qnil); | |
| 4037 | |
| 4038 e->plist = Fcopy_sequence (original->plist); | |
| 4039 memcpy (&e->flags, &original->flags, sizeof (e->flags)); | |
| 4040 if (e->flags.has_aux) | |
| 4041 { | |
| 4042 /* also need to copy the aux struct. It won't work for | |
| 4043 this extent to share the same aux struct as the original | |
| 4044 one. */ | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
4045 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
|
4046 |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
4047 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
|
4048 XCAR (e->plist) = ea; |
| 428 | 4049 } |
| 4050 | |
| 4051 { | |
| 4052 /* we may have just added another child to the parent extent. */ | |
| 4053 Lisp_Object parent = extent_parent (e); | |
| 4054 if (!NILP (parent)) | |
| 4055 { | |
| 793 | 4056 Lisp_Object extent = wrap_extent (e); |
| 4057 | |
| 428 | 4058 add_extent_to_children_list (XEXTENT (parent), extent); |
| 4059 } | |
| 4060 } | |
| 4061 | |
| 4062 return e; | |
| 4063 } | |
| 4064 | |
| 4065 static void | |
| 4066 destroy_extent (EXTENT extent) | |
| 4067 { | |
| 4068 Lisp_Object rest, nextrest, children; | |
| 4069 Lisp_Object extent_obj; | |
| 4070 | |
| 4071 if (!extent_detached_p (extent)) | |
| 4072 extent_detach (extent); | |
| 4073 /* disassociate the extent from its children and parent */ | |
| 4074 children = extent_children (extent); | |
| 4075 if (!NILP (children)) | |
| 4076 { | |
| 4077 LIST_LOOP_DELETING (rest, nextrest, XWEAK_LIST_LIST (children)) | |
| 4078 Fset_extent_parent (XCAR (rest), Qnil); | |
| 4079 } | |
| 793 | 4080 extent_obj = wrap_extent (extent); |
| 428 | 4081 Fset_extent_parent (extent_obj, Qnil); |
| 4082 /* mark the extent as destroyed */ | |
| 4083 extent_object (extent) = Qt; | |
| 4084 } | |
| 4085 | |
| 4086 DEFUN ("make-extent", Fmake_extent, 2, 3, 0, /* | |
| 4087 Make an extent for the range [FROM, TO) in BUFFER-OR-STRING. | |
| 4088 BUFFER-OR-STRING defaults to the current buffer. Insertions at point | |
| 4089 TO will be outside of the extent; insertions at FROM will be inside the | |
| 4090 extent, causing the extent to grow. (This is the same way that markers | |
| 4091 behave.) You can change the behavior of insertions at the endpoints | |
| 4092 using `set-extent-property'. The extent is initially detached if both | |
| 4093 FROM and TO are nil, and in this case BUFFER-OR-STRING defaults to nil, | |
| 4094 meaning the extent is in no buffer and no string. | |
| 4095 */ | |
| 4096 (from, to, buffer_or_string)) | |
| 4097 { | |
| 4098 Lisp_Object extent_obj; | |
| 4099 Lisp_Object obj; | |
| 4100 | |
| 4101 obj = decode_buffer_or_string (buffer_or_string); | |
| 4102 if (NILP (from) && NILP (to)) | |
| 4103 { | |
| 4104 if (NILP (buffer_or_string)) | |
| 4105 obj = Qnil; | |
| 793 | 4106 extent_obj = wrap_extent (make_extent_detached (obj)); |
| 428 | 4107 } |
| 4108 else | |
| 4109 { | |
| 826 | 4110 Bytexpos start, end; |
| 428 | 4111 |
| 4112 get_buffer_or_string_range_byte (obj, from, to, &start, &end, | |
| 4113 GB_ALLOW_PAST_ACCESSIBLE); | |
| 826 | 4114 extent_obj = wrap_extent (make_extent (obj, start, end)); |
| 428 | 4115 } |
| 4116 return extent_obj; | |
| 4117 } | |
| 4118 | |
| 4119 DEFUN ("copy-extent", Fcopy_extent, 1, 2, 0, /* | |
| 4120 Make a copy of EXTENT. It is initially detached. | |
| 4121 Optional argument BUFFER-OR-STRING defaults to EXTENT's buffer or string. | |
| 4122 */ | |
| 4123 (extent, buffer_or_string)) | |
| 4124 { | |
| 4125 EXTENT ext = decode_extent (extent, 0); | |
| 4126 | |
| 4127 if (NILP (buffer_or_string)) | |
| 4128 buffer_or_string = extent_object (ext); | |
| 4129 else | |
| 4130 buffer_or_string = decode_buffer_or_string (buffer_or_string); | |
| 4131 | |
| 793 | 4132 return wrap_extent (copy_extent (ext, -1, -1, buffer_or_string)); |
| 428 | 4133 } |
| 4134 | |
| 4135 DEFUN ("delete-extent", Fdelete_extent, 1, 1, 0, /* | |
| 4136 Remove EXTENT from its buffer and destroy it. | |
| 4137 This does not modify the buffer's text, only its display properties. | |
| 4138 The extent cannot be used thereafter. | |
| 4139 */ | |
| 4140 (extent)) | |
| 4141 { | |
| 4142 EXTENT ext; | |
| 4143 | |
| 4144 /* We do not call decode_extent() here because already-destroyed | |
| 4145 extents are OK. */ | |
| 4146 CHECK_EXTENT (extent); | |
| 4147 ext = XEXTENT (extent); | |
| 4148 | |
| 4149 if (!EXTENT_LIVE_P (ext)) | |
| 4150 return Qnil; | |
| 4151 destroy_extent (ext); | |
| 4152 return Qnil; | |
| 4153 } | |
| 4154 | |
| 4155 DEFUN ("detach-extent", Fdetach_extent, 1, 1, 0, /* | |
| 4156 Remove EXTENT from its buffer in such a way that it can be re-inserted. | |
| 4157 An extent is also detached when all of its characters are all killed by a | |
| 4158 deletion, unless its `detachable' property has been unset. | |
| 4159 | |
| 4160 Extents which have the `duplicable' attribute are tracked by the undo | |
| 4161 mechanism. Detachment via `detach-extent' and string deletion is recorded, | |
| 4162 as is attachment via `insert-extent' and string insertion. Extent motion, | |
| 4163 face changes, and attachment via `make-extent' and `set-extent-endpoints' | |
| 4164 are not recorded. This means that extent changes which are to be undo-able | |
| 4165 must be performed by character editing, or by insertion and detachment of | |
| 4166 duplicable extents. | |
| 4167 */ | |
| 4168 (extent)) | |
| 4169 { | |
| 4170 EXTENT ext = decode_extent (extent, 0); | |
| 4171 | |
| 4172 if (extent_detached_p (ext)) | |
| 4173 return extent; | |
| 4174 if (extent_duplicable_p (ext)) | |
| 4175 record_extent (extent, 0); | |
| 4176 extent_detach (ext); | |
| 4177 | |
| 4178 return extent; | |
| 4179 } | |
| 4180 | |
| 4181 DEFUN ("set-extent-endpoints", Fset_extent_endpoints, 3, 4, 0, /* | |
| 4182 Set the endpoints of EXTENT to START, END. | |
| 4183 If START and END are null, call detach-extent on EXTENT. | |
| 4184 BUFFER-OR-STRING specifies the new buffer or string that the extent should | |
| 4185 be in, and defaults to EXTENT's buffer or string. (If nil, and EXTENT | |
| 4186 is in no buffer and no string, it defaults to the current buffer.) | |
| 4187 See documentation on `detach-extent' for a discussion of undo recording. | |
| 4188 */ | |
| 4189 (extent, start, end, buffer_or_string)) | |
| 4190 { | |
| 4191 EXTENT ext; | |
| 826 | 4192 Bytexpos s, e; |
| 428 | 4193 |
| 4194 ext = decode_extent (extent, 0); | |
| 4195 | |
| 4196 if (NILP (buffer_or_string)) | |
| 4197 { | |
| 4198 buffer_or_string = extent_object (ext); | |
| 4199 if (NILP (buffer_or_string)) | |
| 4200 buffer_or_string = Fcurrent_buffer (); | |
| 4201 } | |
| 4202 else | |
| 4203 buffer_or_string = decode_buffer_or_string (buffer_or_string); | |
| 4204 | |
| 4205 if (NILP (start) && NILP (end)) | |
| 4206 return Fdetach_extent (extent); | |
| 4207 | |
| 4208 get_buffer_or_string_range_byte (buffer_or_string, start, end, &s, &e, | |
| 4209 GB_ALLOW_PAST_ACCESSIBLE); | |
| 4210 | |
| 468 | 4211 buffer_or_string_extent_info_force (buffer_or_string); |
| 428 | 4212 set_extent_endpoints (ext, s, e, buffer_or_string); |
| 4213 return extent; | |
| 4214 } | |
| 4215 | |
| 4216 | |
| 4217 /************************************************************************/ | |
| 4218 /* mapping over extents */ | |
| 4219 /************************************************************************/ | |
| 4220 | |
| 4221 static unsigned int | |
| 4222 decode_map_extents_flags (Lisp_Object flags) | |
| 4223 { | |
| 4224 unsigned int retval = 0; | |
| 4225 unsigned int all_extents_specified = 0; | |
| 4226 unsigned int in_region_specified = 0; | |
| 4227 | |
| 4228 if (EQ (flags, Qt)) /* obsoleteness compatibility */ | |
| 4229 return ME_END_CLOSED; | |
| 4230 if (NILP (flags)) | |
| 4231 return 0; | |
| 4232 if (SYMBOLP (flags)) | |
| 4233 flags = Fcons (flags, Qnil); | |
| 4234 while (!NILP (flags)) | |
| 4235 { | |
| 4236 Lisp_Object sym; | |
| 4237 CHECK_CONS (flags); | |
| 4238 sym = XCAR (flags); | |
| 4239 CHECK_SYMBOL (sym); | |
| 4240 if (EQ (sym, Qall_extents_closed) || EQ (sym, Qall_extents_open) || | |
| 4241 EQ (sym, Qall_extents_closed_open) || | |
| 4242 EQ (sym, Qall_extents_open_closed)) | |
| 4243 { | |
| 4244 if (all_extents_specified) | |
| 563 | 4245 invalid_argument ("Only one `all-extents-*' flag may be specified", Qunbound); |
| 428 | 4246 all_extents_specified = 1; |
| 4247 } | |
| 4248 if (EQ (sym, Qstart_in_region) || EQ (sym, Qend_in_region) || | |
| 4249 EQ (sym, Qstart_and_end_in_region) || | |
| 4250 EQ (sym, Qstart_or_end_in_region)) | |
| 4251 { | |
| 4252 if (in_region_specified) | |
| 563 | 4253 invalid_argument ("Only one `*-in-region' flag may be specified", Qunbound); |
| 428 | 4254 in_region_specified = 1; |
| 4255 } | |
| 4256 | |
| 4257 /* I do so love that conditional operator ... */ | |
| 4258 retval |= | |
| 4259 EQ (sym, Qend_closed) ? ME_END_CLOSED : | |
| 4260 EQ (sym, Qstart_open) ? ME_START_OPEN : | |
| 4261 EQ (sym, Qall_extents_closed) ? ME_ALL_EXTENTS_CLOSED : | |
| 4262 EQ (sym, Qall_extents_open) ? ME_ALL_EXTENTS_OPEN : | |
| 4263 EQ (sym, Qall_extents_closed_open) ? ME_ALL_EXTENTS_CLOSED_OPEN : | |
| 4264 EQ (sym, Qall_extents_open_closed) ? ME_ALL_EXTENTS_OPEN_CLOSED : | |
| 4265 EQ (sym, Qstart_in_region) ? ME_START_IN_REGION : | |
| 4266 EQ (sym, Qend_in_region) ? ME_END_IN_REGION : | |
| 4267 EQ (sym, Qstart_and_end_in_region) ? ME_START_AND_END_IN_REGION : | |
| 4268 EQ (sym, Qstart_or_end_in_region) ? ME_START_OR_END_IN_REGION : | |
| 4269 EQ (sym, Qnegate_in_region) ? ME_NEGATE_IN_REGION : | |
| 563 | 4270 (invalid_constant ("Invalid `map-extents' flag", sym), 0); |
| 428 | 4271 |
| 4272 flags = XCDR (flags); | |
| 4273 } | |
| 4274 return retval; | |
| 4275 } | |
| 4276 | |
| 4277 DEFUN ("extent-in-region-p", Fextent_in_region_p, 1, 4, 0, /* | |
| 4278 Return whether EXTENT overlaps a specified region. | |
| 4279 This is equivalent to whether `map-extents' would visit EXTENT when called | |
| 4280 with these args. | |
| 4281 */ | |
| 4282 (extent, from, to, flags)) | |
| 4283 { | |
| 826 | 4284 Bytexpos start, end; |
| 428 | 4285 EXTENT ext = decode_extent (extent, DE_MUST_BE_ATTACHED); |
| 4286 Lisp_Object obj = extent_object (ext); | |
| 4287 | |
| 4288 get_buffer_or_string_range_byte (obj, from, to, &start, &end, GB_ALLOW_NIL | | |
| 4289 GB_ALLOW_PAST_ACCESSIBLE); | |
| 4290 | |
| 4291 return extent_in_region_p (ext, start, end, decode_map_extents_flags (flags)) ? | |
| 4292 Qt : Qnil; | |
| 4293 } | |
| 4294 | |
| 4295 struct slow_map_extents_arg | |
| 4296 { | |
| 4297 Lisp_Object map_arg; | |
| 4298 Lisp_Object map_routine; | |
| 4299 Lisp_Object result; | |
| 4300 Lisp_Object property; | |
| 4301 Lisp_Object value; | |
| 4302 }; | |
| 4303 | |
| 4304 static int | |
| 4305 slow_map_extents_function (EXTENT extent, void *arg) | |
| 4306 { | |
| 4307 /* This function can GC */ | |
| 4308 struct slow_map_extents_arg *closure = (struct slow_map_extents_arg *) arg; | |
| 793 | 4309 Lisp_Object extent_obj = wrap_extent (extent); |
| 4310 | |
| 428 | 4311 |
| 4312 /* make sure this extent qualifies according to the PROPERTY | |
| 4313 and VALUE args */ | |
| 4314 | |
| 4315 if (!NILP (closure->property)) | |
| 4316 { | |
| 4317 Lisp_Object value = Fextent_property (extent_obj, closure->property, | |
| 4318 Qnil); | |
| 4319 if ((NILP (closure->value) && NILP (value)) || | |
| 4320 (!NILP (closure->value) && !EQ (value, closure->value))) | |
| 4321 return 0; | |
| 4322 } | |
| 4323 | |
| 4324 closure->result = call2 (closure->map_routine, extent_obj, | |
| 4325 closure->map_arg); | |
| 4326 return !NILP (closure->result); | |
| 4327 } | |
| 4328 | |
| 4329 DEFUN ("map-extents", Fmap_extents, 1, 8, 0, /* | |
| 4330 Map FUNCTION over the extents which overlap a region in OBJECT. | |
| 4331 OBJECT is normally a buffer or string but could be an extent (see below). | |
| 4332 The region is normally bounded by [FROM, TO) (i.e. the beginning of the | |
| 4333 region is closed and the end of the region is open), but this can be | |
| 4334 changed with the FLAGS argument (see below for a complete discussion). | |
| 4335 | |
| 4336 FUNCTION is called with the arguments (extent, MAPARG). The arguments | |
| 4337 OBJECT, FROM, TO, MAPARG, and FLAGS are all optional and default to | |
| 4338 the current buffer, the beginning of OBJECT, the end of OBJECT, nil, | |
| 4339 and nil, respectively. `map-extents' returns the first non-nil result | |
| 4340 produced by FUNCTION, and no more calls to FUNCTION are made after it | |
| 4341 returns non-nil. | |
| 4342 | |
| 4343 If OBJECT is an extent, FROM and TO default to the extent's endpoints, | |
| 4344 and the mapping omits that extent and its predecessors. This feature | |
| 4345 supports restarting a loop based on `map-extents'. Note: OBJECT must | |
| 4346 be attached to a buffer or string, and the mapping is done over that | |
| 4347 buffer or string. | |
| 4348 | |
| 4349 An extent overlaps the region if there is any point in the extent that is | |
| 4350 also in the region. (For the purpose of overlap, zero-length extents and | |
| 4351 regions are treated as closed on both ends regardless of their endpoints' | |
| 4352 specified open/closedness.) Note that the endpoints of an extent or region | |
| 4353 are considered to be in that extent or region if and only if the | |
| 4354 corresponding end is closed. For example, the extent [5,7] overlaps the | |
| 4355 region [2,5] because 5 is in both the extent and the region. However, (5,7] | |
| 4356 does not overlap [2,5] because 5 is not in the extent, and neither [5,7] nor | |
| 4357 \(5,7] overlaps the region [2,5) because 5 is not in the region. | |
| 4358 | |
| 4359 The optional FLAGS can be a symbol or a list of one or more symbols, | |
| 4360 modifying the behavior of `map-extents'. Allowed symbols are: | |
| 4361 | |
| 4362 end-closed The region's end is closed. | |
| 4363 | |
| 4364 start-open The region's start is open. | |
| 4365 | |
| 4366 all-extents-closed Treat all extents as closed on both ends for the | |
| 4367 purpose of determining whether they overlap the | |
| 4368 region, irrespective of their actual open- or | |
| 4369 closedness. | |
| 4370 all-extents-open Treat all extents as open on both ends. | |
| 4371 all-extents-closed-open Treat all extents as start-closed, end-open. | |
| 4372 all-extents-open-closed Treat all extents as start-open, end-closed. | |
| 4373 | |
| 4374 start-in-region In addition to the above conditions for extent | |
| 4375 overlap, the extent's start position must lie within | |
| 4376 the specified region. Note that, for this | |
| 4377 condition, open start positions are treated as if | |
| 4378 0.5 was added to the endpoint's value, and open | |
| 4379 end positions are treated as if 0.5 was subtracted | |
| 4380 from the endpoint's value. | |
| 4381 end-in-region The extent's end position must lie within the | |
| 4382 region. | |
| 4383 start-and-end-in-region Both the extent's start and end positions must lie | |
| 4384 within the region. | |
| 4385 start-or-end-in-region Either the extent's start or end position must lie | |
| 4386 within the region. | |
| 4387 | |
| 4388 negate-in-region The condition specified by a `*-in-region' flag | |
| 4389 must NOT hold for the extent to be considered. | |
| 4390 | |
| 4391 | |
| 4392 At most one of `all-extents-closed', `all-extents-open', | |
| 4393 `all-extents-closed-open', and `all-extents-open-closed' may be specified. | |
| 4394 | |
| 4395 At most one of `start-in-region', `end-in-region', | |
| 4396 `start-and-end-in-region', and `start-or-end-in-region' may be specified. | |
| 4397 | |
| 4398 If optional arg PROPERTY is non-nil, only extents with that property set | |
| 4399 on them will be visited. If optional arg VALUE is non-nil, only extents | |
| 4400 whose value for that property is `eq' to VALUE will be visited. | |
| 4401 */ | |
| 4402 (function, object, from, to, maparg, flags, property, value)) | |
| 4403 { | |
| 4404 /* This function can GC */ | |
| 4405 struct slow_map_extents_arg closure; | |
| 4406 unsigned int me_flags; | |
| 826 | 4407 Bytexpos start, end; |
| 428 | 4408 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; |
| 4409 EXTENT after = 0; | |
| 4410 | |
| 4411 if (EXTENTP (object)) | |
| 4412 { | |
| 4413 after = decode_extent (object, DE_MUST_BE_ATTACHED); | |
| 4414 if (NILP (from)) | |
| 4415 from = Fextent_start_position (object); | |
| 4416 if (NILP (to)) | |
| 4417 to = Fextent_end_position (object); | |
| 4418 object = extent_object (after); | |
| 4419 } | |
| 4420 else | |
| 4421 object = decode_buffer_or_string (object); | |
| 4422 | |
| 4423 get_buffer_or_string_range_byte (object, from, to, &start, &end, | |
| 4424 GB_ALLOW_NIL | GB_ALLOW_PAST_ACCESSIBLE); | |
| 4425 | |
| 4426 me_flags = decode_map_extents_flags (flags); | |
| 4427 | |
| 4428 if (!NILP (property)) | |
| 4429 { | |
| 4430 if (!NILP (value)) | |
| 4431 value = canonicalize_extent_property (property, value); | |
| 4432 } | |
| 4433 | |
| 4434 GCPRO5 (function, maparg, object, property, value); | |
| 4435 | |
| 4436 closure.map_arg = maparg; | |
| 4437 closure.map_routine = function; | |
| 4438 closure.result = Qnil; | |
| 4439 closure.property = property; | |
| 4440 closure.value = value; | |
| 4441 | |
| 826 | 4442 map_extents (start, end, slow_map_extents_function, |
| 4443 (void *) &closure, object, after, | |
| 4444 /* You never know what the user might do ... */ | |
| 4445 me_flags | ME_MIGHT_CALL_ELISP); | |
| 428 | 4446 |
| 4447 UNGCPRO; | |
| 4448 return closure.result; | |
| 4449 } | |
| 4450 | |
| 4451 | |
| 4452 /************************************************************************/ | |
| 4453 /* mapping over extents -- other functions */ | |
| 4454 /************************************************************************/ | |
| 4455 | |
| 4456 /* ------------------------------- */ | |
| 4457 /* map-extent-children */ | |
| 4458 /* ------------------------------- */ | |
| 4459 | |
| 4460 struct slow_map_extent_children_arg | |
| 4461 { | |
| 4462 Lisp_Object map_arg; | |
| 4463 Lisp_Object map_routine; | |
| 4464 Lisp_Object result; | |
| 4465 Lisp_Object property; | |
| 4466 Lisp_Object value; | |
| 826 | 4467 Bytexpos start_min; |
| 4468 Bytexpos prev_start; | |
| 4469 Bytexpos prev_end; | |
| 428 | 4470 }; |
| 4471 | |
| 4472 static int | |
| 4473 slow_map_extent_children_function (EXTENT extent, void *arg) | |
| 4474 { | |
| 4475 /* This function can GC */ | |
| 4476 struct slow_map_extent_children_arg *closure = | |
| 4477 (struct slow_map_extent_children_arg *) arg; | |
| 4478 Lisp_Object extent_obj; | |
| 826 | 4479 Bytexpos start = extent_endpoint_byte (extent, 0); |
| 4480 Bytexpos end = extent_endpoint_byte (extent, 1); | |
| 428 | 4481 /* Make sure the extent starts inside the region of interest, |
| 4482 rather than just overlaps it. | |
| 4483 */ | |
| 4484 if (start < closure->start_min) | |
| 4485 return 0; | |
| 4486 /* Make sure the extent is not a child of a previous visited one. | |
| 4487 We know already, because of extent ordering, | |
| 4488 that start >= prev_start, and that if | |
| 4489 start == prev_start, then end <= prev_end. | |
| 4490 */ | |
| 4491 if (start == closure->prev_start) | |
| 4492 { | |
| 4493 if (end < closure->prev_end) | |
| 4494 return 0; | |
| 4495 } | |
| 4496 else /* start > prev_start */ | |
| 4497 { | |
| 4498 if (start < closure->prev_end) | |
| 4499 return 0; | |
| 4500 /* corner case: prev_end can be -1 if there is no prev */ | |
| 4501 } | |
| 793 | 4502 extent_obj = wrap_extent (extent); |
| 428 | 4503 |
| 4504 /* make sure this extent qualifies according to the PROPERTY | |
| 4505 and VALUE args */ | |
| 4506 | |
| 4507 if (!NILP (closure->property)) | |
| 4508 { | |
| 4509 Lisp_Object value = Fextent_property (extent_obj, closure->property, | |
| 4510 Qnil); | |
| 4511 if ((NILP (closure->value) && NILP (value)) || | |
| 4512 (!NILP (closure->value) && !EQ (value, closure->value))) | |
| 4513 return 0; | |
| 4514 } | |
| 4515 | |
| 4516 closure->result = call2 (closure->map_routine, extent_obj, | |
| 4517 closure->map_arg); | |
| 4518 | |
| 4519 /* Since the callback may change the buffer, compute all stored | |
| 4520 buffer positions here. | |
| 4521 */ | |
| 4522 closure->start_min = -1; /* no need for this any more */ | |
| 826 | 4523 closure->prev_start = extent_endpoint_byte (extent, 0); |
| 4524 closure->prev_end = extent_endpoint_byte (extent, 1); | |
| 428 | 4525 |
| 4526 return !NILP (closure->result); | |
| 4527 } | |
| 4528 | |
| 4529 DEFUN ("map-extent-children", Fmap_extent_children, 1, 8, 0, /* | |
| 4530 Map FUNCTION over the extents in the region from FROM to TO. | |
| 4531 FUNCTION is called with arguments (extent, MAPARG). See `map-extents' | |
| 4532 for a full discussion of the arguments FROM, TO, and FLAGS. | |
| 4533 | |
| 4534 The arguments are the same as for `map-extents', but this function differs | |
| 4535 in that it only visits extents which start in the given region, and also | |
| 4536 in that, after visiting an extent E, it skips all other extents which start | |
| 4537 inside E but end before E's end. | |
| 4538 | |
| 4539 Thus, this function may be used to walk a tree of extents in a buffer: | |
| 4540 (defun walk-extents (buffer &optional ignore) | |
| 4541 (map-extent-children 'walk-extents buffer)) | |
| 4542 */ | |
| 4543 (function, object, from, to, maparg, flags, property, value)) | |
| 4544 { | |
| 4545 /* This function can GC */ | |
| 4546 struct slow_map_extent_children_arg closure; | |
| 4547 unsigned int me_flags; | |
| 826 | 4548 Bytexpos start, end; |
| 428 | 4549 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; |
| 4550 EXTENT after = 0; | |
| 4551 | |
| 4552 if (EXTENTP (object)) | |
| 4553 { | |
| 4554 after = decode_extent (object, DE_MUST_BE_ATTACHED); | |
| 4555 if (NILP (from)) | |
| 4556 from = Fextent_start_position (object); | |
| 4557 if (NILP (to)) | |
| 4558 to = Fextent_end_position (object); | |
| 4559 object = extent_object (after); | |
| 4560 } | |
| 4561 else | |
| 4562 object = decode_buffer_or_string (object); | |
| 4563 | |
| 4564 get_buffer_or_string_range_byte (object, from, to, &start, &end, | |
| 4565 GB_ALLOW_NIL | GB_ALLOW_PAST_ACCESSIBLE); | |
| 4566 | |
| 4567 me_flags = decode_map_extents_flags (flags); | |
| 4568 | |
| 4569 if (!NILP (property)) | |
| 4570 { | |
| 4571 if (!NILP (value)) | |
| 4572 value = canonicalize_extent_property (property, value); | |
| 4573 } | |
| 4574 | |
| 4575 GCPRO5 (function, maparg, object, property, value); | |
| 4576 | |
| 4577 closure.map_arg = maparg; | |
| 4578 closure.map_routine = function; | |
| 4579 closure.result = Qnil; | |
| 4580 closure.property = property; | |
| 4581 closure.value = value; | |
| 4582 closure.start_min = start; | |
| 4583 closure.prev_start = -1; | |
| 4584 closure.prev_end = -1; | |
| 826 | 4585 map_extents (start, end, slow_map_extent_children_function, |
| 4586 (void *) &closure, object, after, | |
| 4587 /* You never know what the user might do ... */ | |
| 4588 me_flags | ME_MIGHT_CALL_ELISP); | |
| 428 | 4589 |
| 4590 UNGCPRO; | |
| 4591 return closure.result; | |
| 4592 } | |
| 4593 | |
| 4594 /* ------------------------------- */ | |
| 4595 /* extent-at */ | |
| 4596 /* ------------------------------- */ | |
| 4597 | |
| 4598 /* find "smallest" matching extent containing pos -- (flag == 0) means | |
| 4599 all extents match, else (EXTENT_FLAGS (extent) & flag) must be true; | |
| 4600 for more than one matching extent with precisely the same endpoints, | |
| 4601 we choose the last extent in the extents_list. | |
| 4602 The search stops just before "before", if that is non-null. | |
| 4603 */ | |
| 4604 | |
| 4605 struct extent_at_arg | |
| 4606 { | |
| 442 | 4607 Lisp_Object best_match; /* or list of extents */ |
| 826 | 4608 Memxpos best_start; |
| 4609 Memxpos best_end; | |
| 428 | 4610 Lisp_Object prop; |
| 4611 EXTENT before; | |
| 442 | 4612 int all_extents; |
| 428 | 4613 }; |
| 4614 | |
| 4615 static enum extent_at_flag | |
| 4616 decode_extent_at_flag (Lisp_Object at_flag) | |
| 4617 { | |
| 4618 if (NILP (at_flag)) | |
| 4619 return EXTENT_AT_AFTER; | |
| 4620 | |
| 4621 CHECK_SYMBOL (at_flag); | |
| 4622 if (EQ (at_flag, Qafter)) return EXTENT_AT_AFTER; | |
| 4623 if (EQ (at_flag, Qbefore)) return EXTENT_AT_BEFORE; | |
| 4624 if (EQ (at_flag, Qat)) return EXTENT_AT_AT; | |
| 4625 | |
| 563 | 4626 invalid_constant ("Invalid AT-FLAG in `extent-at'", at_flag); |
| 1204 | 4627 RETURN_NOT_REACHED (EXTENT_AT_AFTER); |
| 428 | 4628 } |
| 4629 | |
| 4630 static int | |
| 4631 extent_at_mapper (EXTENT e, void *arg) | |
| 4632 { | |
| 4633 struct extent_at_arg *closure = (struct extent_at_arg *) arg; | |
| 4634 | |
| 4635 if (e == closure->before) | |
| 4636 return 1; | |
| 4637 | |
| 4638 /* If closure->prop is non-nil, then the extent is only acceptable | |
| 4639 if it has a non-nil value for that property. */ | |
| 4640 if (!NILP (closure->prop)) | |
| 4641 { | |
| 793 | 4642 Lisp_Object extent = wrap_extent (e); |
| 4643 | |
| 428 | 4644 if (NILP (Fextent_property (extent, closure->prop, Qnil))) |
| 4645 return 0; | |
| 4646 } | |
| 4647 | |
| 442 | 4648 if (!closure->all_extents) |
| 428 | 4649 { |
| 442 | 4650 EXTENT current; |
| 4651 | |
| 4652 if (NILP (closure->best_match)) | |
| 428 | 4653 goto accept; |
| 442 | 4654 current = XEXTENT (closure->best_match); |
| 428 | 4655 /* redundant but quick test */ |
| 442 | 4656 if (extent_start (current) > extent_start (e)) |
| 428 | 4657 return 0; |
| 4658 | |
| 4659 /* we return the "last" best fit, instead of the first -- | |
| 4660 this is because then the glyph closest to two equivalent | |
| 4661 extents corresponds to the "extent-at" the text just past | |
| 4662 that same glyph */ | |
| 4663 else if (!EXTENT_LESS_VALS (e, closure->best_start, | |
| 4664 closure->best_end)) | |
| 4665 goto accept; | |
| 4666 else | |
| 4667 return 0; | |
| 4668 accept: | |
| 793 | 4669 closure->best_match = wrap_extent (e); |
| 428 | 4670 closure->best_start = extent_start (e); |
| 4671 closure->best_end = extent_end (e); | |
| 4672 } | |
| 442 | 4673 else |
| 4674 { | |
| 793 | 4675 Lisp_Object extent = wrap_extent (e); |
| 4676 | |
| 442 | 4677 closure->best_match = Fcons (extent, closure->best_match); |
| 4678 } | |
| 428 | 4679 |
| 4680 return 0; | |
| 4681 } | |
| 4682 | |
| 826 | 4683 Lisp_Object |
| 4684 extent_at (Bytexpos position, Lisp_Object object, | |
| 4685 Lisp_Object property, EXTENT before, | |
| 4686 enum extent_at_flag at_flag, int all_extents) | |
| 428 | 4687 { |
| 4688 struct extent_at_arg closure; | |
| 442 | 4689 struct gcpro gcpro1; |
| 428 | 4690 |
| 4691 /* it might be argued that invalid positions should cause | |
| 4692 errors, but the principle of least surprise dictates that | |
| 4693 nil should be returned (extent-at is often used in | |
| 4694 response to a mouse event, and in many cases previous events | |
| 4695 have changed the buffer contents). | |
| 4696 | |
| 4697 Also, the openness stuff in the text-property code currently | |
| 4698 does not check its limits and might go off the end. */ | |
| 4699 if ((at_flag == EXTENT_AT_BEFORE | |
| 4700 ? position <= buffer_or_string_absolute_begin_byte (object) | |
| 4701 : position < buffer_or_string_absolute_begin_byte (object)) | |
| 4702 || (at_flag == EXTENT_AT_AFTER | |
| 4703 ? position >= buffer_or_string_absolute_end_byte (object) | |
| 4704 : position > buffer_or_string_absolute_end_byte (object))) | |
| 4705 return Qnil; | |
| 4706 | |
| 442 | 4707 closure.best_match = Qnil; |
| 428 | 4708 closure.prop = property; |
| 4709 closure.before = before; | |
| 442 | 4710 closure.all_extents = all_extents; |
| 4711 | |
| 4712 GCPRO1 (closure.best_match); | |
| 826 | 4713 map_extents (at_flag == EXTENT_AT_BEFORE ? prev_bytexpos (object, position) : |
| 4714 position, | |
| 4715 at_flag == EXTENT_AT_AFTER ? next_bytexpos (object, position) : | |
| 4716 position, | |
| 4717 extent_at_mapper, (void *) &closure, object, 0, | |
| 4718 ME_START_OPEN | ME_ALL_EXTENTS_CLOSED); | |
| 442 | 4719 if (all_extents) |
| 4720 closure.best_match = Fnreverse (closure.best_match); | |
| 4721 UNGCPRO; | |
| 4722 | |
| 4723 return closure.best_match; | |
| 428 | 4724 } |
| 4725 | |
| 4726 DEFUN ("extent-at", Fextent_at, 1, 5, 0, /* | |
| 4727 Find "smallest" extent at POS in OBJECT having PROPERTY set. | |
| 4728 Normally, an extent is "at" POS if it overlaps the region (POS, POS+1); | |
| 4729 i.e. if it covers the character after POS. (However, see the definition | |
| 4730 of AT-FLAG.) "Smallest" means the extent that comes last in the display | |
| 4731 order; this normally means the extent whose start position is closest to | |
| 4732 POS. See `next-extent' for more information. | |
| 4733 OBJECT specifies a buffer or string and defaults to the current buffer. | |
| 4734 PROPERTY defaults to nil, meaning that any extent will do. | |
| 4735 Properties are attached to extents with `set-extent-property', which see. | |
| 4736 Returns nil if POS is invalid or there is no matching extent at POS. | |
| 4737 If the fourth argument BEFORE is not nil, it must be an extent; any returned | |
| 4738 extent will precede that extent. This feature allows `extent-at' to be | |
| 4739 used by a loop over extents. | |
| 4740 AT-FLAG controls how end cases are handled, and should be one of: | |
| 4741 | |
| 4742 nil or `after' An extent is at POS if it covers the character | |
| 4743 after POS. This is consistent with the way | |
| 4744 that text properties work. | |
| 4745 `before' An extent is at POS if it covers the character | |
| 4746 before POS. | |
| 4747 `at' An extent is at POS if it overlaps or abuts POS. | |
| 4748 This includes all zero-length extents at POS. | |
| 4749 | |
| 4750 Note that in all cases, the start-openness and end-openness of the extents | |
| 4751 considered is ignored. If you want to pay attention to those properties, | |
| 4752 you should use `map-extents', which gives you more control. | |
| 4753 */ | |
| 4754 (pos, object, property, before, at_flag)) | |
| 4755 { | |
| 826 | 4756 Bytexpos position; |
| 428 | 4757 EXTENT before_extent; |
| 4758 enum extent_at_flag fl; | |
| 4759 | |
| 4760 object = decode_buffer_or_string (object); | |
| 4761 position = get_buffer_or_string_pos_byte (object, pos, GB_NO_ERROR_IF_BAD); | |
| 4762 if (NILP (before)) | |
| 4763 before_extent = 0; | |
| 4764 else | |
| 4765 before_extent = decode_extent (before, DE_MUST_BE_ATTACHED); | |
| 4766 if (before_extent && !EQ (object, extent_object (before_extent))) | |
| 442 | 4767 invalid_argument ("extent not in specified buffer or string", object); |
| 428 | 4768 fl = decode_extent_at_flag (at_flag); |
| 4769 | |
| 826 | 4770 return extent_at (position, object, property, before_extent, fl, 0); |
| 442 | 4771 } |
| 4772 | |
| 4773 DEFUN ("extents-at", Fextents_at, 1, 5, 0, /* | |
| 4774 Find all extents at POS in OBJECT having PROPERTY set. | |
| 4775 Normally, an extent is "at" POS if it overlaps the region (POS, POS+1); | |
| 4776 i.e. if it covers the character after POS. (However, see the definition | |
| 4777 of AT-FLAG.) | |
| 4778 This provides similar functionality to `extent-list', but does so in a way | |
| 4779 that is compatible with `extent-at'. (For example, errors due to POS out of | |
| 4780 range are ignored; this makes it safer to use this function in response to | |
| 4781 a mouse event, because in many cases previous events have changed the buffer | |
| 4782 contents.) | |
| 4783 OBJECT specifies a buffer or string and defaults to the current buffer. | |
| 4784 PROPERTY defaults to nil, meaning that any extent will do. | |
| 4785 Properties are attached to extents with `set-extent-property', which see. | |
| 4786 Returns nil if POS is invalid or there is no matching extent at POS. | |
| 4787 If the fourth argument BEFORE is not nil, it must be an extent; any returned | |
| 4788 extent will precede that extent. This feature allows `extents-at' to be | |
| 4789 used by a loop over extents. | |
| 4790 AT-FLAG controls how end cases are handled, and should be one of: | |
| 4791 | |
| 4792 nil or `after' An extent is at POS if it covers the character | |
| 4793 after POS. This is consistent with the way | |
| 4794 that text properties work. | |
| 4795 `before' An extent is at POS if it covers the character | |
| 4796 before POS. | |
| 4797 `at' An extent is at POS if it overlaps or abuts POS. | |
| 4798 This includes all zero-length extents at POS. | |
| 4799 | |
| 4800 Note that in all cases, the start-openness and end-openness of the extents | |
| 4801 considered is ignored. If you want to pay attention to those properties, | |
| 4802 you should use `map-extents', which gives you more control. | |
| 4803 */ | |
| 4804 (pos, object, property, before, at_flag)) | |
| 4805 { | |
| 826 | 4806 Bytexpos position; |
| 442 | 4807 EXTENT before_extent; |
| 4808 enum extent_at_flag fl; | |
| 4809 | |
| 4810 object = decode_buffer_or_string (object); | |
| 4811 position = get_buffer_or_string_pos_byte (object, pos, GB_NO_ERROR_IF_BAD); | |
| 4812 if (NILP (before)) | |
| 4813 before_extent = 0; | |
| 4814 else | |
| 4815 before_extent = decode_extent (before, DE_MUST_BE_ATTACHED); | |
| 4816 if (before_extent && !EQ (object, extent_object (before_extent))) | |
| 4817 invalid_argument ("extent not in specified buffer or string", object); | |
| 4818 fl = decode_extent_at_flag (at_flag); | |
| 4819 | |
| 826 | 4820 return extent_at (position, object, property, before_extent, fl, 1); |
| 428 | 4821 } |
| 4822 | |
| 4823 /* ------------------------------- */ | |
| 4824 /* verify_extent_modification() */ | |
| 4825 /* ------------------------------- */ | |
| 4826 | |
| 4827 /* verify_extent_modification() is called when a buffer or string is | |
| 4828 modified to check whether the modification is occuring inside a | |
| 4829 read-only extent. | |
| 4830 */ | |
| 4831 | |
| 4832 struct verify_extents_arg | |
| 4833 { | |
| 4834 Lisp_Object object; | |
| 826 | 4835 Memxpos start; |
| 4836 Memxpos end; | |
| 428 | 4837 Lisp_Object iro; /* value of inhibit-read-only */ |
| 4838 }; | |
| 4839 | |
| 4840 static int | |
| 4841 verify_extent_mapper (EXTENT extent, void *arg) | |
| 4842 { | |
| 4843 struct verify_extents_arg *closure = (struct verify_extents_arg *) arg; | |
| 4844 Lisp_Object prop = extent_read_only (extent); | |
| 4845 | |
| 4846 if (NILP (prop)) | |
| 4847 return 0; | |
| 4848 | |
| 4849 if (CONSP (closure->iro) && !NILP (Fmemq (prop, closure->iro))) | |
| 4850 return 0; | |
| 4851 | |
| 4852 #if 0 /* Nobody seems to care for this any more -sb */ | |
| 4853 /* Allow deletion if the extent is completely contained in | |
| 4854 the region being deleted. | |
| 4855 This is important for supporting tokens which are internally | |
| 4856 write-protected, but which can be killed and yanked as a whole. | |
| 4857 Ignore open/closed distinctions at this point. | |
| 4858 -- Rose | |
| 4859 */ | |
| 4860 if (closure->start != closure->end && | |
| 4861 extent_start (extent) >= closure->start && | |
| 4862 extent_end (extent) <= closure->end) | |
| 4863 return 0; | |
| 4864 #endif | |
| 4865 | |
| 4866 while (1) | |
| 4867 Fsignal (Qbuffer_read_only, (list1 (closure->object))); | |
| 4868 | |
| 1204 | 4869 RETURN_NOT_REACHED(0); |
| 428 | 4870 } |
| 4871 | |
| 4872 /* Value of Vinhibit_read_only is precomputed and passed in for | |
| 4873 efficiency */ | |
| 4874 | |
| 4875 void | |
| 826 | 4876 verify_extent_modification (Lisp_Object object, Bytexpos from, Bytexpos to, |
| 428 | 4877 Lisp_Object inhibit_read_only_value) |
| 4878 { | |
| 4879 int closed; | |
| 4880 struct verify_extents_arg closure; | |
| 4881 | |
| 4882 /* If insertion, visit closed-endpoint extents touching the insertion | |
| 4883 point because the text would go inside those extents. If deletion, | |
| 4884 treat the range as open on both ends so that touching extents are not | |
| 4885 visited. Note that we assume that an insertion is occurring if the | |
| 4886 changed range has zero length, and a deletion otherwise. This | |
| 4887 fails if a change (i.e. non-insertion, non-deletion) is happening. | |
| 4888 As far as I know, this doesn't currently occur in XEmacs. --ben */ | |
| 4889 closed = (from==to); | |
| 4890 closure.object = object; | |
| 826 | 4891 closure.start = buffer_or_string_bytexpos_to_memxpos (object, from); |
| 4892 closure.end = buffer_or_string_bytexpos_to_memxpos (object, to); | |
| 428 | 4893 closure.iro = inhibit_read_only_value; |
| 4894 | |
| 826 | 4895 map_extents (from, to, verify_extent_mapper, (void *) &closure, |
| 4896 object, 0, closed ? ME_END_CLOSED : ME_START_OPEN); | |
| 428 | 4897 } |
| 4898 | |
| 4899 /* ------------------------------------ */ | |
| 4900 /* process_extents_for_insertion() */ | |
| 4901 /* ------------------------------------ */ | |
| 4902 | |
| 4903 struct process_extents_for_insertion_arg | |
| 4904 { | |
| 826 | 4905 Bytexpos opoint; |
| 428 | 4906 int length; |
| 4907 Lisp_Object object; | |
| 4908 }; | |
| 4909 | |
| 4910 /* A region of length LENGTH was just inserted at OPOINT. Modify all | |
| 4911 of the extents as required for the insertion, based on their | |
| 4912 start-open/end-open properties. | |
| 4913 */ | |
| 4914 | |
| 4915 static int | |
| 4916 process_extents_for_insertion_mapper (EXTENT extent, void *arg) | |
| 4917 { | |
| 4918 struct process_extents_for_insertion_arg *closure = | |
| 4919 (struct process_extents_for_insertion_arg *) arg; | |
| 826 | 4920 Memxpos indice = buffer_or_string_bytexpos_to_memxpos (closure->object, |
| 4921 closure->opoint); | |
| 428 | 4922 |
| 4923 /* When this function is called, one end of the newly-inserted text should | |
| 4924 be adjacent to some endpoint of the extent, or disjoint from it. If | |
| 4925 the insertion overlaps any existing extent, something is wrong. | |
| 4926 */ | |
| 4927 #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
|
4928 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
|
4929 assert (extent_end (extent) <= indice || extent_end (extent) >= indice + closure->length); |
| 428 | 4930 #endif |
| 4931 | |
| 4932 /* The extent-adjustment code adjusted the extent's endpoints as if | |
| 468 | 4933 all extents were closed-open -- endpoints at the insertion point |
| 4934 remain unchanged. We need to fix the other kinds of extents: | |
| 4935 | |
| 4936 1. Start position of start-open extents needs to be moved. | |
| 4937 | |
| 4938 2. End position of end-closed extents needs to be moved. | |
| 4939 | |
| 4940 Note that both conditions hold for zero-length (] extents at the | |
| 4941 insertion point. But under these rules, zero-length () extents | |
| 4942 would get adjusted such that their start is greater than their | |
| 4943 end; instead of allowing that, we treat them as [) extents by | |
| 4944 modifying condition #1 to not fire nothing when dealing with a | |
| 4945 zero-length open-open extent. | |
| 4946 | |
| 4947 Existence of zero-length open-open extents is unfortunately an | |
| 4948 inelegant part of the extent model, but there is no way around | |
| 4949 it. */ | |
| 428 | 4950 |
| 4951 { | |
| 826 | 4952 Memxpos new_start = extent_start (extent); |
| 4953 Memxpos new_end = extent_end (extent); | |
| 468 | 4954 |
| 4955 if (indice == extent_start (extent) && extent_start_open_p (extent) | |
| 4956 /* zero-length () extents are exempt; see comment above. */ | |
| 4957 && !(new_start == new_end && extent_end_open_p (extent)) | |
| 4958 ) | |
| 428 | 4959 new_start += closure->length; |
| 4960 if (indice == extent_end (extent) && !extent_end_open_p (extent)) | |
| 4961 new_end += closure->length; | |
| 468 | 4962 |
| 428 | 4963 set_extent_endpoints_1 (extent, new_start, new_end); |
| 4964 } | |
| 4965 | |
| 4966 return 0; | |
| 4967 } | |
| 4968 | |
| 4969 void | |
| 826 | 4970 process_extents_for_insertion (Lisp_Object object, Bytexpos opoint, |
| 428 | 4971 Bytecount length) |
| 4972 { | |
| 4973 struct process_extents_for_insertion_arg closure; | |
| 4974 | |
| 4975 closure.opoint = opoint; | |
| 4976 closure.length = length; | |
| 4977 closure.object = object; | |
| 4978 | |
| 826 | 4979 map_extents (opoint, opoint + length, |
| 4980 process_extents_for_insertion_mapper, | |
| 4981 (void *) &closure, object, 0, | |
| 4982 ME_END_CLOSED | ME_MIGHT_MODIFY_EXTENTS | | |
| 4983 ME_INCLUDE_INTERNAL); | |
| 428 | 4984 } |
| 4985 | |
| 4986 /* ------------------------------------ */ | |
| 4987 /* process_extents_for_deletion() */ | |
| 4988 /* ------------------------------------ */ | |
| 4989 | |
| 4990 struct process_extents_for_deletion_arg | |
| 4991 { | |
| 826 | 4992 Memxpos start, end; |
| 428 | 4993 int destroy_included_extents; |
| 4994 }; | |
| 4995 | |
| 4996 /* This function is called when we're about to delete the range [from, to]. | |
| 4997 Detach all of the extents that are completely inside the range [from, to], | |
| 4998 if they're detachable or open-open. */ | |
| 4999 | |
| 5000 static int | |
| 5001 process_extents_for_deletion_mapper (EXTENT extent, void *arg) | |
| 5002 { | |
| 5003 struct process_extents_for_deletion_arg *closure = | |
| 5004 (struct process_extents_for_deletion_arg *) arg; | |
| 5005 | |
| 5006 /* If the extent lies completely within the range that | |
| 5007 is being deleted, then nuke the extent if it's detachable | |
| 5008 (otherwise, it will become a zero-length extent). */ | |
| 5009 | |
| 5010 if (closure->start <= extent_start (extent) && | |
| 5011 extent_end (extent) <= closure->end) | |
| 5012 { | |
| 5013 if (extent_detachable_p (extent)) | |
| 5014 { | |
| 5015 if (closure->destroy_included_extents) | |
| 5016 destroy_extent (extent); | |
| 5017 else | |
| 5018 extent_detach (extent); | |
| 5019 } | |
| 5020 } | |
| 5021 | |
| 5022 return 0; | |
| 5023 } | |
| 5024 | |
| 5025 /* DESTROY_THEM means destroy the extents instead of just deleting them. | |
| 5026 It is unused currently, but perhaps might be used (there used to | |
| 5027 be a function process_extents_for_destruction(), #if 0'd out, | |
| 5028 that did the equivalent). */ | |
| 5029 void | |
| 826 | 5030 process_extents_for_deletion (Lisp_Object object, Bytexpos from, |
| 5031 Bytexpos to, int destroy_them) | |
| 428 | 5032 { |
| 5033 struct process_extents_for_deletion_arg closure; | |
| 5034 | |
| 826 | 5035 closure.start = buffer_or_string_bytexpos_to_memxpos (object, from); |
| 5036 closure.end = buffer_or_string_bytexpos_to_memxpos (object, to); | |
| 428 | 5037 closure.destroy_included_extents = destroy_them; |
| 5038 | |
| 826 | 5039 map_extents (from, to, process_extents_for_deletion_mapper, |
| 5040 (void *) &closure, object, 0, | |
| 5041 ME_END_CLOSED | ME_MIGHT_MODIFY_EXTENTS); | |
| 428 | 5042 } |
| 5043 | |
| 5044 /* ------------------------------- */ | |
| 5045 /* report_extent_modification() */ | |
| 5046 /* ------------------------------- */ | |
| 826 | 5047 |
| 5048 struct report_extent_modification_closure | |
| 5049 { | |
| 428 | 5050 Lisp_Object buffer; |
| 826 | 5051 Charxpos start, end; |
| 428 | 5052 int afterp; |
| 5053 int speccount; | |
| 5054 }; | |
| 5055 | |
| 5056 static Lisp_Object | |
| 5057 report_extent_modification_restore (Lisp_Object buffer) | |
| 5058 { | |
| 5059 if (current_buffer != XBUFFER (buffer)) | |
| 5060 Fset_buffer (buffer); | |
| 5061 return Qnil; | |
| 5062 } | |
| 5063 | |
| 5064 static int | |
| 5065 report_extent_modification_mapper (EXTENT extent, void *arg) | |
| 5066 { | |
| 5067 struct report_extent_modification_closure *closure = | |
| 5068 (struct report_extent_modification_closure *)arg; | |
| 5069 Lisp_Object exobj, startobj, endobj; | |
| 5070 Lisp_Object hook = (closure->afterp | |
| 5071 ? extent_after_change_functions (extent) | |
| 5072 : extent_before_change_functions (extent)); | |
| 5073 if (NILP (hook)) | |
| 5074 return 0; | |
| 5075 | |
| 793 | 5076 exobj = wrap_extent (extent); |
| 5077 startobj = make_int (closure->start); | |
| 5078 endobj = make_int (closure->end); | |
| 428 | 5079 |
| 5080 /* Now that we are sure to call elisp, set up an unwind-protect so | |
| 5081 inside_change_hook gets restored in case we throw. Also record | |
| 5082 the current buffer, in case we change it. Do the recording only | |
| 438 | 5083 once. |
| 5084 | |
| 5085 One confusing thing here is that our caller never actually calls | |
| 771 | 5086 unbind_to (closure.speccount). This is because |
| 826 | 5087 map_extents() unbinds before, and with a smaller |
| 771 | 5088 speccount. The additional unbind_to_1() in |
| 438 | 5089 report_extent_modification() would cause XEmacs to abort. */ |
| 428 | 5090 if (closure->speccount == -1) |
| 5091 { | |
| 5092 closure->speccount = specpdl_depth (); | |
| 5093 record_unwind_protect (report_extent_modification_restore, | |
| 5094 Fcurrent_buffer ()); | |
| 5095 } | |
| 5096 | |
| 5097 /* The functions will expect closure->buffer to be the current | |
| 5098 buffer, so change it if it isn't. */ | |
| 5099 if (current_buffer != XBUFFER (closure->buffer)) | |
| 5100 Fset_buffer (closure->buffer); | |
| 5101 | |
| 5102 /* #### It's a shame that we can't use any of the existing run_hook* | |
| 5103 functions here. This is so because all of them work with | |
| 5104 symbols, to be able to retrieve default values of local hooks. | |
| 438 | 5105 <sigh> |
| 5106 | |
| 5107 #### Idea: we could set up a dummy symbol, and call the hook | |
| 5108 functions on *that*. */ | |
| 428 | 5109 |
| 5110 if (!CONSP (hook) || EQ (XCAR (hook), Qlambda)) | |
| 5111 call3 (hook, exobj, startobj, endobj); | |
| 5112 else | |
| 5113 { | |
| 2367 | 5114 EXTERNAL_LIST_LOOP_2 (elt, hook) |
| 438 | 5115 /* #### Shouldn't this perform the same Fset_buffer() check as |
| 5116 above? */ | |
| 2367 | 5117 call3 (elt, exobj, startobj, endobj); |
| 428 | 5118 } |
| 5119 return 0; | |
| 5120 } | |
| 5121 | |
| 5122 void | |
| 665 | 5123 report_extent_modification (Lisp_Object buffer, Charbpos start, Charbpos end, |
| 438 | 5124 int afterp) |
| 428 | 5125 { |
| 5126 struct report_extent_modification_closure closure; | |
| 5127 | |
| 5128 closure.buffer = buffer; | |
| 5129 closure.start = start; | |
| 5130 closure.end = end; | |
| 5131 closure.afterp = afterp; | |
| 5132 closure.speccount = -1; | |
| 5133 | |
| 826 | 5134 map_extents (charbpos_to_bytebpos (XBUFFER (buffer), start), |
| 5135 charbpos_to_bytebpos (XBUFFER (buffer), end), | |
| 5136 report_extent_modification_mapper, (void *)&closure, | |
| 428 | 5137 buffer, NULL, ME_MIGHT_CALL_ELISP); |
| 5138 } | |
| 5139 | |
| 5140 | |
| 5141 /************************************************************************/ | |
| 5142 /* extent properties */ | |
| 5143 /************************************************************************/ | |
| 5144 | |
| 5145 static void | |
| 5146 set_extent_invisible (EXTENT extent, Lisp_Object value) | |
| 5147 { | |
| 5148 if (!EQ (extent_invisible (extent), value)) | |
| 5149 { | |
| 5150 set_extent_invisible_1 (extent, value); | |
| 826 | 5151 signal_extent_property_changed (extent, Qinvisible, 1); |
| 428 | 5152 } |
| 5153 } | |
| 5154 | |
| 5155 /* This function does "memoization" -- similar to the interning | |
| 5156 that happens with symbols. Given a list of faces, an equivalent | |
| 5157 list is returned such that if this function is called twice with | |
| 5158 input that is `equal', the resulting outputs will be `eq'. | |
| 5159 | |
| 5160 Note that the inputs and outputs are in general *not* `equal' -- | |
| 5161 faces in symbol form become actual face objects in the output. | |
| 5162 This is necessary so that temporary faces stay around. */ | |
| 5163 | |
| 5164 static Lisp_Object | |
| 5165 memoize_extent_face_internal (Lisp_Object list) | |
| 5166 { | |
| 5167 int len; | |
| 5168 int thelen; | |
| 5169 Lisp_Object cons, thecons; | |
| 5170 Lisp_Object oldtail, tail; | |
| 5171 struct gcpro gcpro1; | |
| 5172 | |
| 5173 if (NILP (list)) | |
| 5174 return Qnil; | |
| 5175 if (!CONSP (list)) | |
| 5176 return Fget_face (list); | |
| 5177 | |
| 5178 /* To do the memoization, we use a hash table mapping from | |
| 5179 external lists to internal lists. We do `equal' comparisons | |
| 5180 on the keys so the memoization works correctly. | |
| 5181 | |
| 5182 Note that we canonicalize things so that the keys in the | |
| 5183 hash table (the external lists) always contain symbols and | |
| 5184 the values (the internal lists) always contain face objects. | |
| 5185 | |
| 5186 We also maintain a "reverse" table that maps from the internal | |
| 5187 lists to the external equivalents. The idea here is twofold: | |
| 5188 | |
| 5189 1) `extent-face' wants to return a list containing face symbols | |
| 5190 rather than face objects. | |
| 5191 2) We don't want things to get quite so messed up if the user | |
| 5192 maliciously side-effects the returned lists. | |
| 5193 */ | |
| 5194 | |
| 5195 len = XINT (Flength (list)); | |
| 5196 thelen = XINT (Flength (Vextent_face_reusable_list)); | |
| 5197 oldtail = Qnil; | |
| 5198 tail = Qnil; | |
| 5199 GCPRO1 (oldtail); | |
| 5200 | |
| 5201 /* We canonicalize the given list into another list. | |
| 5202 We try to avoid consing except when necessary, so we have | |
| 5203 a reusable list. | |
| 5204 */ | |
| 5205 | |
| 5206 if (thelen < len) | |
| 5207 { | |
| 5208 cons = Vextent_face_reusable_list; | |
| 5209 while (!NILP (XCDR (cons))) | |
| 5210 cons = XCDR (cons); | |
| 5211 XCDR (cons) = Fmake_list (make_int (len - thelen), Qnil); | |
| 5212 } | |
| 5213 else if (thelen > len) | |
| 5214 { | |
| 5215 int i; | |
| 5216 | |
| 5217 /* Truncate the list temporarily so it's the right length; | |
| 5218 remember the old tail. */ | |
| 5219 cons = Vextent_face_reusable_list; | |
| 5220 for (i = 0; i < len - 1; i++) | |
| 5221 cons = XCDR (cons); | |
| 5222 tail = cons; | |
| 5223 oldtail = XCDR (cons); | |
| 5224 XCDR (cons) = Qnil; | |
| 5225 } | |
| 5226 | |
| 5227 thecons = Vextent_face_reusable_list; | |
| 2367 | 5228 { |
| 5229 EXTERNAL_LIST_LOOP_2 (face, list) | |
| 5230 { | |
| 5231 face = Fget_face (face); | |
| 5232 | |
| 5233 XCAR (thecons) = Fface_name (face); | |
| 5234 thecons = XCDR (thecons); | |
| 5235 } | |
| 5236 } | |
| 428 | 5237 |
| 5238 list = Fgethash (Vextent_face_reusable_list, Vextent_face_memoize_hash_table, | |
| 5239 Qnil); | |
| 5240 if (NILP (list)) | |
| 5241 { | |
| 5242 Lisp_Object symlist = Fcopy_sequence (Vextent_face_reusable_list); | |
| 5243 Lisp_Object facelist = Fcopy_sequence (Vextent_face_reusable_list); | |
| 5244 | |
| 5245 LIST_LOOP (cons, facelist) | |
| 5246 { | |
| 5247 XCAR (cons) = Fget_face (XCAR (cons)); | |
| 5248 } | |
| 5249 Fputhash (symlist, facelist, Vextent_face_memoize_hash_table); | |
| 5250 Fputhash (facelist, symlist, Vextent_face_reverse_memoize_hash_table); | |
| 5251 list = facelist; | |
| 5252 } | |
| 5253 | |
| 5254 /* Now restore the truncated tail of the reusable list, if necessary. */ | |
| 5255 if (!NILP (tail)) | |
| 5256 XCDR (tail) = oldtail; | |
| 5257 | |
| 5258 UNGCPRO; | |
| 5259 return list; | |
| 5260 } | |
| 5261 | |
| 5262 static Lisp_Object | |
| 5263 external_of_internal_memoized_face (Lisp_Object face) | |
| 5264 { | |
| 5265 if (NILP (face)) | |
| 5266 return Qnil; | |
| 5267 else if (!CONSP (face)) | |
| 5268 return XFACE (face)->name; | |
| 5269 else | |
| 5270 { | |
| 5271 face = Fgethash (face, Vextent_face_reverse_memoize_hash_table, | |
| 5272 Qunbound); | |
| 5273 assert (!UNBOUNDP (face)); | |
| 5274 return face; | |
| 5275 } | |
| 5276 } | |
| 5277 | |
| 826 | 5278 /* The idea here is that if we're given a list of faces, we |
| 5279 need to "memoize" this so that two lists of faces that are `equal' | |
| 5280 turn into the same object. When `set-extent-face' is called, we | |
| 5281 "memoize" into a list of actual faces; when `extent-face' is called, | |
| 5282 we do a reverse lookup to get the list of symbols. */ | |
| 5283 | |
| 428 | 5284 static Lisp_Object |
| 5285 canonicalize_extent_property (Lisp_Object prop, Lisp_Object value) | |
| 5286 { | |
| 5287 if (EQ (prop, Qface) || EQ (prop, Qmouse_face)) | |
| 5288 value = (external_of_internal_memoized_face | |
| 5289 (memoize_extent_face_internal (value))); | |
| 5290 return value; | |
| 5291 } | |
| 5292 | |
| 5293 /* Do we need a lisp-level function ? */ | |
| 826 | 5294 DEFUN ("set-extent-initial-redisplay-function", |
| 5295 Fset_extent_initial_redisplay_function, | |
| 444 | 5296 2,2,0, /* |
| 428 | 5297 Note: This feature is experimental! |
| 5298 | |
| 5299 Set initial-redisplay-function of EXTENT to the function | |
| 5300 FUNCTION. | |
| 5301 | |
| 5302 The first time the EXTENT is (re)displayed, an eval event will be | |
| 5303 dispatched calling FUNCTION with EXTENT as its only argument. | |
| 5304 */ | |
| 5305 (extent, function)) | |
| 5306 { | |
| 826 | 5307 /* #### This is totally broken. */ |
| 5308 EXTENT e = decode_extent (extent, DE_MUST_BE_ATTACHED); | |
| 428 | 5309 |
| 5310 e = extent_ancestor (e); /* Is this needed? Macro also does chasing!*/ | |
| 826 | 5311 set_extent_initial_redisplay_function (e, function); |
| 5312 extent_in_red_event_p (e) = 0; /* If the function changed we can spawn | |
| 428 | 5313 new events */ |
| 826 | 5314 signal_extent_property_changed (e, Qinitial_redisplay_function, 1); |
| 428 | 5315 return function; |
| 5316 } | |
| 5317 | |
| 5318 DEFUN ("extent-face", Fextent_face, 1, 1, 0, /* | |
| 5319 Return the name of the face in which EXTENT is displayed, or nil | |
| 5320 if the extent's face is unspecified. This might also return a list | |
| 5321 of face names. | |
| 5322 */ | |
| 5323 (extent)) | |
| 5324 { | |
| 5325 Lisp_Object face; | |
| 5326 | |
| 5327 CHECK_EXTENT (extent); | |
| 5328 face = extent_face (XEXTENT (extent)); | |
| 5329 | |
| 5330 return external_of_internal_memoized_face (face); | |
| 5331 } | |
| 5332 | |
| 5333 DEFUN ("set-extent-face", Fset_extent_face, 2, 2, 0, /* | |
| 5334 Make the given EXTENT have the graphic attributes specified by FACE. | |
| 5335 FACE can also be a list of faces, and all faces listed will apply, | |
| 5336 with faces earlier in the list taking priority over those later in the | |
| 5337 list. | |
| 5338 */ | |
| 5339 (extent, face)) | |
| 5340 { | |
| 5341 EXTENT e = decode_extent(extent, 0); | |
| 5342 Lisp_Object orig_face = face; | |
| 5343 | |
| 5344 /* retrieve the ancestor for efficiency and proper redisplay noting. */ | |
| 5345 e = extent_ancestor (e); | |
| 5346 | |
| 5347 face = memoize_extent_face_internal (face); | |
| 5348 | |
| 5349 extent_face (e) = face; | |
| 826 | 5350 signal_extent_property_changed (e, Qface, 1); |
| 428 | 5351 |
| 5352 return orig_face; | |
| 5353 } | |
| 5354 | |
| 5355 | |
| 5356 DEFUN ("extent-mouse-face", Fextent_mouse_face, 1, 1, 0, /* | |
| 5357 Return the face used to highlight EXTENT when the mouse passes over it. | |
| 5358 The return value will be a face name, a list of face names, or nil | |
| 5359 if the extent's mouse face is unspecified. | |
| 5360 */ | |
| 5361 (extent)) | |
| 5362 { | |
| 5363 Lisp_Object face; | |
| 5364 | |
| 5365 CHECK_EXTENT (extent); | |
| 5366 face = extent_mouse_face (XEXTENT (extent)); | |
| 5367 | |
| 5368 return external_of_internal_memoized_face (face); | |
| 5369 } | |
| 5370 | |
| 5371 DEFUN ("set-extent-mouse-face", Fset_extent_mouse_face, 2, 2, 0, /* | |
| 5372 Set the face used to highlight EXTENT when the mouse passes over it. | |
| 5373 FACE can also be a list of faces, and all faces listed will apply, | |
| 5374 with faces earlier in the list taking priority over those later in the | |
| 5375 list. | |
| 5376 */ | |
| 5377 (extent, face)) | |
| 5378 { | |
| 5379 EXTENT e; | |
| 5380 Lisp_Object orig_face = face; | |
| 5381 | |
| 5382 CHECK_EXTENT (extent); | |
| 5383 e = XEXTENT (extent); | |
| 5384 /* retrieve the ancestor for efficiency and proper redisplay noting. */ | |
| 5385 e = extent_ancestor (e); | |
| 5386 | |
| 5387 face = memoize_extent_face_internal (face); | |
| 5388 | |
| 5389 set_extent_mouse_face (e, face); | |
| 826 | 5390 signal_extent_property_changed (e, Qmouse_face, 1); |
| 428 | 5391 |
| 5392 return orig_face; | |
| 5393 } | |
| 5394 | |
| 5395 void | |
| 5396 set_extent_glyph (EXTENT extent, Lisp_Object glyph, int endp, | |
| 5397 glyph_layout layout) | |
| 5398 { | |
| 5399 extent = extent_ancestor (extent); | |
| 5400 | |
| 5401 if (!endp) | |
| 5402 { | |
| 5403 set_extent_begin_glyph (extent, glyph); | |
| 647 | 5404 set_extent_begin_glyph_layout (extent, layout); |
| 826 | 5405 signal_extent_property_changed (extent, Qbegin_glyph, 1); |
| 5406 signal_extent_property_changed (extent, Qbegin_glyph_layout, 1); | |
| 428 | 5407 } |
| 5408 else | |
| 5409 { | |
| 5410 set_extent_end_glyph (extent, glyph); | |
| 647 | 5411 set_extent_end_glyph_layout (extent, layout); |
| 826 | 5412 signal_extent_property_changed (extent, Qend_glyph, 1); |
| 5413 signal_extent_property_changed (extent, Qend_glyph_layout, 1); | |
| 428 | 5414 } |
| 5415 } | |
| 5416 | |
| 5417 static Lisp_Object | |
| 5418 glyph_layout_to_symbol (glyph_layout layout) | |
| 5419 { | |
| 5420 switch (layout) | |
| 5421 { | |
| 5422 case GL_TEXT: return Qtext; | |
| 5423 case GL_OUTSIDE_MARGIN: return Qoutside_margin; | |
| 5424 case GL_INSIDE_MARGIN: return Qinside_margin; | |
| 5425 case GL_WHITESPACE: return Qwhitespace; | |
| 5426 default: | |
| 2500 | 5427 ABORT (); |
| 428 | 5428 return Qnil; /* unreached */ |
| 5429 } | |
| 5430 } | |
| 5431 | |
| 5432 static glyph_layout | |
| 5433 symbol_to_glyph_layout (Lisp_Object layout_obj) | |
| 5434 { | |
| 5435 if (NILP (layout_obj)) | |
| 5436 return GL_TEXT; | |
| 5437 | |
| 5438 CHECK_SYMBOL (layout_obj); | |
| 5439 if (EQ (layout_obj, Qoutside_margin)) return GL_OUTSIDE_MARGIN; | |
| 5440 if (EQ (layout_obj, Qinside_margin)) return GL_INSIDE_MARGIN; | |
| 5441 if (EQ (layout_obj, Qwhitespace)) return GL_WHITESPACE; | |
| 5442 if (EQ (layout_obj, Qtext)) return GL_TEXT; | |
| 5443 | |
| 563 | 5444 invalid_constant ("Unknown glyph layout type", layout_obj); |
| 1204 | 5445 RETURN_NOT_REACHED (GL_TEXT); |
| 428 | 5446 } |
| 5447 | |
| 5448 static Lisp_Object | |
| 5449 set_extent_glyph_1 (Lisp_Object extent_obj, Lisp_Object glyph, int endp, | |
| 5450 Lisp_Object layout_obj) | |
| 5451 { | |
| 442 | 5452 EXTENT extent = decode_extent (extent_obj, 0); |
| 428 | 5453 glyph_layout layout = symbol_to_glyph_layout (layout_obj); |
| 5454 | |
| 5455 /* Make sure we've actually been given a valid glyph or it's nil | |
| 5456 (meaning we're deleting a glyph from an extent). */ | |
| 5457 if (!NILP (glyph)) | |
| 5458 CHECK_BUFFER_GLYPH (glyph); | |
| 5459 | |
| 5460 set_extent_glyph (extent, glyph, endp, layout); | |
| 5461 return glyph; | |
| 5462 } | |
| 5463 | |
| 5464 DEFUN ("set-extent-begin-glyph", Fset_extent_begin_glyph, 2, 3, 0, /* | |
| 5465 Display a bitmap, subwindow or string at the beginning of EXTENT. | |
| 5466 BEGIN-GLYPH must be a glyph object. The layout policy defaults to `text'. | |
| 5467 */ | |
| 5468 (extent, begin_glyph, layout)) | |
| 5469 { | |
| 5470 return set_extent_glyph_1 (extent, begin_glyph, 0, layout); | |
| 5471 } | |
| 5472 | |
| 5473 DEFUN ("set-extent-end-glyph", Fset_extent_end_glyph, 2, 3, 0, /* | |
| 5474 Display a bitmap, subwindow or string at the end of EXTENT. | |
| 5475 END-GLYPH must be a glyph object. The layout policy defaults to `text'. | |
| 5476 */ | |
| 5477 (extent, end_glyph, layout)) | |
| 5478 { | |
| 5479 return set_extent_glyph_1 (extent, end_glyph, 1, layout); | |
| 5480 } | |
| 5481 | |
| 5482 DEFUN ("extent-begin-glyph", Fextent_begin_glyph, 1, 1, 0, /* | |
| 5483 Return the glyph object displayed at the beginning of EXTENT. | |
| 5484 If there is none, nil is returned. | |
| 5485 */ | |
| 5486 (extent)) | |
| 5487 { | |
| 5488 return extent_begin_glyph (decode_extent (extent, 0)); | |
| 5489 } | |
| 5490 | |
| 5491 DEFUN ("extent-end-glyph", Fextent_end_glyph, 1, 1, 0, /* | |
| 5492 Return the glyph object displayed at the end of EXTENT. | |
| 5493 If there is none, nil is returned. | |
| 5494 */ | |
| 5495 (extent)) | |
| 5496 { | |
| 5497 return extent_end_glyph (decode_extent (extent, 0)); | |
| 5498 } | |
| 5499 | |
| 5500 DEFUN ("set-extent-begin-glyph-layout", Fset_extent_begin_glyph_layout, 2, 2, 0, /* | |
| 5501 Set the layout policy of EXTENT's begin glyph. | |
| 5502 Access this using the `extent-begin-glyph-layout' function. | |
| 5503 */ | |
| 5504 (extent, layout)) | |
| 5505 { | |
| 5506 EXTENT e = decode_extent (extent, 0); | |
| 5507 e = extent_ancestor (e); | |
| 647 | 5508 set_extent_begin_glyph_layout (e, symbol_to_glyph_layout (layout)); |
| 826 | 5509 signal_extent_property_changed (e, Qbegin_glyph_layout, 1); |
| 428 | 5510 return layout; |
| 5511 } | |
| 5512 | |
| 5513 DEFUN ("set-extent-end-glyph-layout", Fset_extent_end_glyph_layout, 2, 2, 0, /* | |
| 5514 Set the layout policy of EXTENT's end glyph. | |
| 5515 Access this using the `extent-end-glyph-layout' function. | |
| 5516 */ | |
| 5517 (extent, layout)) | |
| 5518 { | |
| 5519 EXTENT e = decode_extent (extent, 0); | |
| 5520 e = extent_ancestor (e); | |
| 647 | 5521 set_extent_end_glyph_layout (e, symbol_to_glyph_layout (layout)); |
| 826 | 5522 signal_extent_property_changed (e, Qend_glyph_layout, 1); |
| 428 | 5523 return layout; |
| 5524 } | |
| 5525 | |
| 5526 DEFUN ("extent-begin-glyph-layout", Fextent_begin_glyph_layout, 1, 1, 0, /* | |
| 5527 Return the layout policy associated with EXTENT's begin glyph. | |
| 5528 Set this using the `set-extent-begin-glyph-layout' function. | |
| 5529 */ | |
| 5530 (extent)) | |
| 5531 { | |
| 5532 EXTENT e = decode_extent (extent, 0); | |
| 5533 return glyph_layout_to_symbol ((glyph_layout) extent_begin_glyph_layout (e)); | |
| 5534 } | |
| 5535 | |
| 5536 DEFUN ("extent-end-glyph-layout", Fextent_end_glyph_layout, 1, 1, 0, /* | |
| 5537 Return the layout policy associated with EXTENT's end glyph. | |
| 5538 Set this using the `set-extent-end-glyph-layout' function. | |
| 5539 */ | |
| 5540 (extent)) | |
| 5541 { | |
| 5542 EXTENT e = decode_extent (extent, 0); | |
| 5543 return glyph_layout_to_symbol ((glyph_layout) extent_end_glyph_layout (e)); | |
| 5544 } | |
| 5545 | |
| 5546 DEFUN ("set-extent-priority", Fset_extent_priority, 2, 2, 0, /* | |
| 5547 Set the display priority of EXTENT to PRIORITY (an integer). | |
| 5548 When the extent attributes are being merged for display, the priority | |
| 5549 is used to determine which extent takes precedence in the event of a | |
| 5550 conflict (two extents whose faces both specify font, for example: the | |
| 5551 font of the extent with the higher priority will be used). | |
| 5552 Extents are created with priority 0; priorities may be negative. | |
| 5553 */ | |
| 5554 (extent, priority)) | |
| 5555 { | |
| 5556 EXTENT e = decode_extent (extent, 0); | |
| 5557 | |
| 5558 CHECK_INT (priority); | |
| 5559 e = extent_ancestor (e); | |
| 5560 set_extent_priority (e, XINT (priority)); | |
| 826 | 5561 signal_extent_property_changed (e, Qpriority, 1); |
| 428 | 5562 return priority; |
| 5563 } | |
| 5564 | |
| 5565 DEFUN ("extent-priority", Fextent_priority, 1, 1, 0, /* | |
| 5566 Return the display priority of EXTENT; see `set-extent-priority'. | |
| 5567 */ | |
| 5568 (extent)) | |
| 5569 { | |
| 5570 EXTENT e = decode_extent (extent, 0); | |
| 5571 return make_int (extent_priority (e)); | |
| 5572 } | |
| 5573 | |
| 5574 DEFUN ("set-extent-property", Fset_extent_property, 3, 3, 0, /* | |
| 5575 Change a property of an extent. | |
| 5576 PROPERTY may be any symbol; the value stored may be accessed with | |
| 5577 the `extent-property' function. | |
| 2758 | 5578 |
| 428 | 5579 The following symbols have predefined meanings: |
| 5580 | |
| 5581 detached Removes the extent from its buffer; setting this is | |
| 5582 the same as calling `detach-extent'. | |
| 5583 | |
| 5584 destroyed Removes the extent from its buffer, and makes it | |
| 5585 unusable in the future; this is the same calling | |
| 5586 `delete-extent'. | |
| 5587 | |
| 5588 priority Change redisplay priority; same as `set-extent-priority'. | |
| 5589 | |
| 5590 start-open Whether the set of characters within the extent is | |
| 5591 treated being open on the left, that is, whether | |
| 5592 the start position is an exclusive, rather than | |
| 5593 inclusive, boundary. If true, then characters | |
| 5594 inserted exactly at the beginning of the extent | |
| 5595 will remain outside of the extent; otherwise they | |
| 5596 will go into the extent, extending it. | |
| 5597 | |
| 5598 end-open Whether the set of characters within the extent is | |
| 5599 treated being open on the right, that is, whether | |
| 5600 the end position is an exclusive, rather than | |
| 5601 inclusive, boundary. If true, then characters | |
| 5602 inserted exactly at the end of the extent will | |
| 5603 remain outside of the extent; otherwise they will | |
| 5604 go into the extent, extending it. | |
| 5605 | |
| 5606 By default, extents have the `end-open' but not the | |
| 5607 `start-open' property set. | |
| 5608 | |
| 5609 read-only Text within this extent will be unmodifiable. | |
| 5610 | |
| 5611 initial-redisplay-function (EXPERIMENTAL) | |
| 5612 function to be called the first time (part of) the extent | |
| 5613 is redisplayed. It will be called with the extent as its | |
| 5614 first argument. | |
| 1041 | 5615 Note: The function will not be called immediately |
| 5616 during redisplay, an eval event will be dispatched. | |
| 428 | 5617 |
| 5618 detachable Whether the extent gets detached (as with | |
| 5619 `detach-extent') when all the text within the | |
| 5620 extent is deleted. This is true by default. If | |
| 5621 this property is not set, the extent becomes a | |
| 5622 zero-length extent when its text is deleted. (In | |
| 5623 such a case, the `start-open' property is | |
| 5624 automatically removed if both the `start-open' and | |
| 5625 `end-open' properties are set, since zero-length | |
| 5626 extents open on both ends are not allowed.) | |
| 5627 | |
| 5628 face The face in which to display the text. Setting | |
| 5629 this is the same as calling `set-extent-face'. | |
| 5630 | |
| 1041 | 5631 mouse-face If non-nil, the extent will be highlighted in this |
| 5632 face when the mouse moves over it. | |
| 428 | 5633 |
| 5634 pointer If non-nil, and a valid pointer glyph, this specifies | |
| 5635 the shape of the mouse pointer while over the extent. | |
| 5636 | |
| 5637 highlight Obsolete: Setting this property is equivalent to | |
| 1041 | 5638 setting a `mouse-face' property of `highlight'. |
| 5639 Reading this property returns non-nil if | |
| 5640 the extent has a non-nil `mouse-face' property. | |
| 428 | 5641 |
| 5642 duplicable Whether this extent should be copied into strings, | |
| 5643 so that kill, yank, and undo commands will restore | |
| 5644 or copy it. `duplicable' extents are copied from | |
| 5645 an extent into a string when `buffer-substring' or | |
| 5646 a similar function creates a string. The extents | |
| 5647 in a string are copied into other strings created | |
| 5648 from the string using `concat' or `substring'. | |
| 5649 When `insert' or a similar function inserts the | |
| 5650 string into a buffer, the extents are copied back | |
| 5651 into the buffer. | |
| 5652 | |
| 5653 unique Meaningful only in conjunction with `duplicable'. | |
| 5654 When this is set, there may be only one instance | |
| 5655 of this extent attached at a time: if it is copied | |
| 5656 to the kill ring and then yanked, the extent is | |
| 5657 not copied. If, however, it is killed (removed | |
| 5658 from the buffer) and then yanked, it will be | |
| 5659 re-attached at the new position. | |
| 5660 | |
| 5661 invisible If the value is non-nil, text under this extent | |
| 5662 may be treated as not present for the purpose of | |
| 5663 redisplay, or may be displayed using an ellipsis | |
| 5664 or other marker; see `buffer-invisibility-spec' | |
| 5665 and `invisible-text-glyph'. In all cases, | |
| 5666 however, the text is still visible to other | |
| 5667 functions that examine a buffer's text. | |
| 5668 | |
| 5669 keymap This keymap is consulted for mouse clicks on this | |
| 5670 extent, or keypresses made while point is within the | |
| 5671 extent. | |
| 5672 | |
| 5673 copy-function This is a hook that is run when a duplicable extent | |
| 5674 is about to be copied from a buffer to a string (or | |
| 5675 the kill ring). It is called with three arguments, | |
| 5676 the extent, and the buffer-positions within it | |
| 5677 which are being copied. If this function returns | |
| 5678 nil, then the extent will not be copied; otherwise | |
| 5679 it will. | |
| 5680 | |
| 5681 paste-function This is a hook that is run when a duplicable extent is | |
| 5682 about to be copied from a string (or the kill ring) | |
| 5683 into a buffer. It is called with three arguments, | |
| 5684 the original extent, and the buffer positions which | |
| 5685 the copied extent will occupy. (This hook is run | |
| 5686 after the corresponding text has already been | |
| 5687 inserted into the buffer.) Note that the extent | |
| 5688 argument may be detached when this function is run. | |
| 5689 If this function returns nil, no extent will be | |
| 5690 inserted. Otherwise, there will be an extent | |
| 5691 covering the range in question. | |
| 5692 | |
| 5693 If the original extent is not attached to a buffer, | |
| 5694 then it will be re-attached at this range. | |
| 5695 Otherwise, a copy will be made, and that copy | |
| 5696 attached here. | |
| 5697 | |
| 5698 The copy-function and paste-function are meaningful | |
| 5699 only for extents with the `duplicable' flag set, | |
| 5700 and if they are not specified, behave as if `t' was | |
| 5701 the returned value. When these hooks are invoked, | |
| 5702 the current buffer is the buffer which the extent | |
| 5703 is being copied from/to, respectively. | |
| 5704 | |
| 5705 begin-glyph A glyph to be displayed at the beginning of the extent, | |
| 5706 or nil. | |
| 5707 | |
| 5708 end-glyph A glyph to be displayed at the end of the extent, | |
| 5709 or nil. | |
| 5710 | |
| 5711 begin-glyph-layout The layout policy (one of `text', `whitespace', | |
| 5712 `inside-margin', or `outside-margin') of the extent's | |
| 5713 begin glyph. | |
| 5714 | |
| 1041 | 5715 end-glyph-layout The layout policy of the extent's end glyph. |
| 5716 | |
| 5717 syntax-table A cons or a syntax table object. If a cons, the car must | |
| 2767 | 5718 be an integer (interpreted as a syntax code, applicable |
| 5719 to all characters in the extent). Otherwise, syntax of | |
| 5720 characters in the extent is looked up in the syntax | |
| 5721 table. You should use the text property API to | |
| 5722 manipulate this property. (This may be required in the | |
| 5723 future.) | |
| 5724 | |
| 5725 The following property is available if `atomic-extents.el'--part of the | |
| 5726 `edit-utils' package--has been loaded: | |
| 2758 | 5727 |
| 5728 atomic When set, point will never fall inside the extent. | |
| 5729 Not as useful as you might think, as | |
| 5730 `delete-backward-char' still removes characters one by | |
| 2767 | 5731 one. This property as currently implemented is a |
| 5732 kludge, and be prepared for it to go away if and when we | |
| 5733 implement something better. | |
| 2758 | 5734 |
| 428 | 5735 */ |
| 5736 (extent, property, value)) | |
| 5737 { | |
| 5738 /* This function can GC if property is `keymap' */ | |
| 5739 EXTENT e = decode_extent (extent, 0); | |
| 826 | 5740 int signal_change = 0; |
| 5741 | |
| 5742 /* If VALUE is unbound, the property is being removed through `remprop'. | |
| 5743 Return Qunbound if removal disallowed, Qt if anything removed, | |
| 5744 Qnil otherwise. */ | |
| 5745 | |
| 5746 /* Keep in synch with stuff below. */ | |
| 5747 if (UNBOUNDP (value)) | |
| 5748 { | |
| 5749 int retval; | |
| 5750 | |
| 5751 if (EQ (property, Qread_only) | |
| 5752 || EQ (property, Qunique) | |
| 5753 || EQ (property, Qduplicable) | |
| 5754 || EQ (property, Qinvisible) | |
| 5755 || EQ (property, Qdetachable) | |
| 5756 || EQ (property, Qdetached) | |
| 5757 || EQ (property, Qdestroyed) | |
| 5758 || EQ (property, Qpriority) | |
| 5759 || EQ (property, Qface) | |
| 5760 || EQ (property, Qinitial_redisplay_function) | |
| 5761 || EQ (property, Qafter_change_functions) | |
| 5762 || EQ (property, Qbefore_change_functions) | |
| 5763 || EQ (property, Qmouse_face) | |
| 5764 || EQ (property, Qhighlight) | |
| 5765 || EQ (property, Qbegin_glyph_layout) | |
| 5766 || EQ (property, Qend_glyph_layout) | |
| 5767 || EQ (property, Qglyph_layout) | |
| 5768 || EQ (property, Qbegin_glyph) | |
| 5769 || EQ (property, Qend_glyph) | |
| 5770 || EQ (property, Qstart_open) | |
| 5771 || EQ (property, Qend_open) | |
| 5772 || EQ (property, Qstart_closed) | |
| 5773 || EQ (property, Qend_closed) | |
| 5774 || EQ (property, Qkeymap)) | |
| 5775 return Qunbound; | |
| 5776 | |
| 5777 retval = external_remprop (extent_plist_addr (e), property, 0, | |
| 5778 ERROR_ME); | |
| 5779 if (retval) | |
| 5780 signal_extent_property_changed (e, property, 1); | |
| 5781 return retval ? Qt : Qnil; | |
| 5782 } | |
| 428 | 5783 |
| 5784 if (EQ (property, Qread_only)) | |
| 826 | 5785 { |
| 5786 set_extent_read_only (e, value); | |
| 5787 signal_change = 1; | |
| 5788 } | |
| 428 | 5789 else if (EQ (property, Qunique)) |
| 826 | 5790 { |
| 5791 extent_unique_p (e) = !NILP (value); | |
| 5792 signal_change = 1; | |
| 5793 } | |
| 428 | 5794 else if (EQ (property, Qduplicable)) |
| 826 | 5795 { |
| 5796 extent_duplicable_p (e) = !NILP (value); | |
| 5797 signal_change = 1; | |
| 5798 } | |
| 428 | 5799 else if (EQ (property, Qinvisible)) |
| 5800 set_extent_invisible (e, value); | |
| 5801 else if (EQ (property, Qdetachable)) | |
| 826 | 5802 { |
| 5803 extent_detachable_p (e) = !NILP (value); | |
| 5804 signal_change = 1; | |
| 5805 } | |
| 428 | 5806 else if (EQ (property, Qdetached)) |
| 5807 { | |
| 5808 if (NILP (value)) | |
| 826 | 5809 invalid_operation ("can only set `detached' to t", Qunbound); |
| 428 | 5810 Fdetach_extent (extent); |
| 5811 } | |
| 5812 else if (EQ (property, Qdestroyed)) | |
| 5813 { | |
| 5814 if (NILP (value)) | |
| 826 | 5815 invalid_operation ("can only set `destroyed' to t", Qunbound); |
| 428 | 5816 Fdelete_extent (extent); |
| 5817 } | |
| 5818 else if (EQ (property, Qpriority)) | |
| 5819 Fset_extent_priority (extent, value); | |
| 5820 else if (EQ (property, Qface)) | |
| 5821 Fset_extent_face (extent, value); | |
| 5822 else if (EQ (property, Qinitial_redisplay_function)) | |
| 5823 Fset_extent_initial_redisplay_function (extent, value); | |
| 5824 else if (EQ (property, Qbefore_change_functions)) | |
| 826 | 5825 { |
| 5826 set_extent_before_change_functions (e, value); | |
| 5827 signal_change = 1; | |
| 5828 } | |
| 428 | 5829 else if (EQ (property, Qafter_change_functions)) |
| 826 | 5830 { |
| 5831 set_extent_after_change_functions (e, value); | |
| 5832 signal_change = 1; | |
| 5833 } | |
| 428 | 5834 else if (EQ (property, Qmouse_face)) |
| 5835 Fset_extent_mouse_face (extent, value); | |
| 5836 /* Obsolete: */ | |
| 5837 else if (EQ (property, Qhighlight)) | |
| 5838 Fset_extent_mouse_face (extent, Qhighlight); | |
| 5839 else if (EQ (property, Qbegin_glyph_layout)) | |
| 5840 Fset_extent_begin_glyph_layout (extent, value); | |
| 5841 else if (EQ (property, Qend_glyph_layout)) | |
| 5842 Fset_extent_end_glyph_layout (extent, value); | |
| 5843 /* For backwards compatibility. We use begin glyph because it is by | |
| 5844 far the more used of the two. */ | |
| 5845 else if (EQ (property, Qglyph_layout)) | |
| 5846 Fset_extent_begin_glyph_layout (extent, value); | |
| 5847 else if (EQ (property, Qbegin_glyph)) | |
| 5848 Fset_extent_begin_glyph (extent, value, Qnil); | |
| 5849 else if (EQ (property, Qend_glyph)) | |
| 5850 Fset_extent_end_glyph (extent, value, Qnil); | |
| 5851 else if (EQ (property, Qstart_open)) | |
| 5852 set_extent_openness (e, !NILP (value), -1); | |
| 5853 else if (EQ (property, Qend_open)) | |
| 5854 set_extent_openness (e, -1, !NILP (value)); | |
| 5855 /* Support (but don't document...) the obvious *_closed antonyms. */ | |
| 5856 else if (EQ (property, Qstart_closed)) | |
| 5857 set_extent_openness (e, NILP (value), -1); | |
| 5858 else if (EQ (property, Qend_closed)) | |
| 5859 set_extent_openness (e, -1, NILP (value)); | |
| 5860 else | |
| 5861 { | |
| 5862 if (EQ (property, Qkeymap)) | |
| 5863 while (!NILP (value) && NILP (Fkeymapp (value))) | |
| 5864 value = wrong_type_argument (Qkeymapp, value); | |
| 5865 | |
| 5866 external_plist_put (extent_plist_addr (e), property, value, 0, ERROR_ME); | |
| 826 | 5867 signal_change = 1; |
| 428 | 5868 } |
| 5869 | |
| 826 | 5870 if (signal_change) |
| 5871 signal_extent_property_changed (e, property, 1); | |
| 428 | 5872 return value; |
| 5873 } | |
| 5874 | |
| 5875 DEFUN ("set-extent-properties", Fset_extent_properties, 2, 2, 0, /* | |
| 5876 Change some properties of EXTENT. | |
| 5877 PLIST is a property list. | |
| 5878 For a list of built-in properties, see `set-extent-property'. | |
| 5879 */ | |
| 5880 (extent, plist)) | |
| 5881 { | |
| 5882 /* This function can GC, if one of the properties is `keymap' */ | |
| 5883 Lisp_Object property, value; | |
| 5884 struct gcpro gcpro1; | |
| 5885 GCPRO1 (plist); | |
| 5886 | |
| 5887 plist = Fcopy_sequence (plist); | |
| 5888 Fcanonicalize_plist (plist, Qnil); | |
| 5889 | |
| 5890 while (!NILP (plist)) | |
| 5891 { | |
| 5892 property = Fcar (plist); plist = Fcdr (plist); | |
| 5893 value = Fcar (plist); plist = Fcdr (plist); | |
| 5894 Fset_extent_property (extent, property, value); | |
| 5895 } | |
| 5896 UNGCPRO; | |
| 5897 return Qnil; | |
| 5898 } | |
| 5899 | |
| 5900 DEFUN ("extent-property", Fextent_property, 2, 3, 0, /* | |
| 5901 Return EXTENT's value for property PROPERTY. | |
| 444 | 5902 If no such property exists, DEFAULT is returned. |
| 428 | 5903 See `set-extent-property' for the built-in property names. |
| 5904 */ | |
| 5905 (extent, property, default_)) | |
| 5906 { | |
| 5907 EXTENT e = decode_extent (extent, 0); | |
| 5908 | |
| 5909 if (EQ (property, Qdetached)) | |
| 5910 return extent_detached_p (e) ? Qt : Qnil; | |
| 5911 else if (EQ (property, Qdestroyed)) | |
| 5912 return !EXTENT_LIVE_P (e) ? Qt : Qnil; | |
| 5913 else if (EQ (property, Qstart_open)) | |
| 5914 return extent_normal_field (e, start_open) ? Qt : Qnil; | |
| 5915 else if (EQ (property, Qend_open)) | |
| 5916 return extent_normal_field (e, end_open) ? Qt : Qnil; | |
| 5917 else if (EQ (property, Qunique)) | |
| 5918 return extent_normal_field (e, unique) ? Qt : Qnil; | |
| 5919 else if (EQ (property, Qduplicable)) | |
| 5920 return extent_normal_field (e, duplicable) ? Qt : Qnil; | |
| 5921 else if (EQ (property, Qdetachable)) | |
| 5922 return extent_normal_field (e, detachable) ? Qt : Qnil; | |
| 5923 /* Support (but don't document...) the obvious *_closed antonyms. */ | |
| 5924 else if (EQ (property, Qstart_closed)) | |
| 5925 return extent_start_open_p (e) ? Qnil : Qt; | |
| 5926 else if (EQ (property, Qend_closed)) | |
| 5927 return extent_end_open_p (e) ? Qnil : Qt; | |
| 5928 else if (EQ (property, Qpriority)) | |
| 5929 return make_int (extent_priority (e)); | |
| 5930 else if (EQ (property, Qread_only)) | |
| 5931 return extent_read_only (e); | |
| 5932 else if (EQ (property, Qinvisible)) | |
| 5933 return extent_invisible (e); | |
| 5934 else if (EQ (property, Qface)) | |
| 5935 return Fextent_face (extent); | |
| 5936 else if (EQ (property, Qinitial_redisplay_function)) | |
| 5937 return extent_initial_redisplay_function (e); | |
| 5938 else if (EQ (property, Qbefore_change_functions)) | |
| 5939 return extent_before_change_functions (e); | |
| 5940 else if (EQ (property, Qafter_change_functions)) | |
| 5941 return extent_after_change_functions (e); | |
| 5942 else if (EQ (property, Qmouse_face)) | |
| 5943 return Fextent_mouse_face (extent); | |
| 5944 /* Obsolete: */ | |
| 5945 else if (EQ (property, Qhighlight)) | |
| 5946 return !NILP (Fextent_mouse_face (extent)) ? Qt : Qnil; | |
| 5947 else if (EQ (property, Qbegin_glyph_layout)) | |
| 5948 return Fextent_begin_glyph_layout (extent); | |
| 5949 else if (EQ (property, Qend_glyph_layout)) | |
| 5950 return Fextent_end_glyph_layout (extent); | |
| 5951 /* For backwards compatibility. We use begin glyph because it is by | |
| 5952 far the more used of the two. */ | |
| 5953 else if (EQ (property, Qglyph_layout)) | |
| 5954 return Fextent_begin_glyph_layout (extent); | |
| 5955 else if (EQ (property, Qbegin_glyph)) | |
| 5956 return extent_begin_glyph (e); | |
| 5957 else if (EQ (property, Qend_glyph)) | |
| 5958 return extent_end_glyph (e); | |
| 5959 else | |
| 5960 { | |
| 5961 Lisp_Object value = external_plist_get (extent_plist_addr (e), | |
| 5962 property, 0, ERROR_ME); | |
| 5963 return UNBOUNDP (value) ? default_ : value; | |
| 5964 } | |
| 5965 } | |
| 5966 | |
| 826 | 5967 static void |
| 5968 extent_properties (EXTENT e, Lisp_Object_pair_dynarr *props) | |
| 5969 { | |
| 5970 Lisp_Object face, anc_obj; | |
| 428 | 5971 glyph_layout layout; |
| 826 | 5972 EXTENT anc; |
| 5973 | |
| 5974 #define ADD_PROP(miftaaH, maal) \ | |
| 5975 do { \ | |
| 5976 Lisp_Object_pair p; \ | |
| 5977 p.key = miftaaH; \ | |
| 5978 p.value = maal; \ | |
| 5979 Dynarr_add (props, p); \ | |
| 5980 } while (0) | |
| 5981 | |
| 428 | 5982 if (!EXTENT_LIVE_P (e)) |
| 826 | 5983 { |
| 5984 ADD_PROP (Qdestroyed, Qt); | |
| 5985 return; | |
| 5986 } | |
| 428 | 5987 |
| 5988 anc = extent_ancestor (e); | |
| 793 | 5989 anc_obj = wrap_extent (anc); |
| 428 | 5990 |
| 5991 /* For efficiency, use the ancestor for all properties except detached */ | |
| 826 | 5992 { |
| 5993 EXTERNAL_PROPERTY_LIST_LOOP_3 (key, value, extent_plist_slot (anc)) | |
| 5994 ADD_PROP (key, value); | |
| 5995 } | |
| 428 | 5996 |
| 5997 if (!NILP (face = Fextent_face (anc_obj))) | |
| 826 | 5998 ADD_PROP (Qface, face); |
| 428 | 5999 |
| 6000 if (!NILP (face = Fextent_mouse_face (anc_obj))) | |
| 826 | 6001 ADD_PROP (Qmouse_face, face); |
| 428 | 6002 |
| 6003 if ((layout = (glyph_layout) extent_begin_glyph_layout (anc)) != GL_TEXT) | |
| 6004 { | |
| 6005 Lisp_Object sym = glyph_layout_to_symbol (layout); | |
| 826 | 6006 ADD_PROP (Qglyph_layout, sym); /* compatibility */ |
| 6007 ADD_PROP (Qbegin_glyph_layout, sym); | |
| 428 | 6008 } |
| 6009 | |
| 6010 if ((layout = (glyph_layout) extent_end_glyph_layout (anc)) != GL_TEXT) | |
| 826 | 6011 ADD_PROP (Qend_glyph_layout, glyph_layout_to_symbol (layout)); |
| 428 | 6012 |
| 6013 if (!NILP (extent_end_glyph (anc))) | |
| 826 | 6014 ADD_PROP (Qend_glyph, extent_end_glyph (anc)); |
| 428 | 6015 |
| 6016 if (!NILP (extent_begin_glyph (anc))) | |
| 826 | 6017 ADD_PROP (Qbegin_glyph, extent_begin_glyph (anc)); |
| 428 | 6018 |
| 6019 if (extent_priority (anc) != 0) | |
| 826 | 6020 ADD_PROP (Qpriority, make_int (extent_priority (anc))); |
| 428 | 6021 |
| 6022 if (!NILP (extent_initial_redisplay_function (anc))) | |
| 826 | 6023 ADD_PROP (Qinitial_redisplay_function, |
| 6024 extent_initial_redisplay_function (anc)); | |
| 428 | 6025 |
| 6026 if (!NILP (extent_before_change_functions (anc))) | |
| 826 | 6027 ADD_PROP (Qbefore_change_functions, extent_before_change_functions (anc)); |
| 428 | 6028 |
| 6029 if (!NILP (extent_after_change_functions (anc))) | |
| 826 | 6030 ADD_PROP (Qafter_change_functions, extent_after_change_functions (anc)); |
| 428 | 6031 |
| 6032 if (!NILP (extent_invisible (anc))) | |
| 826 | 6033 ADD_PROP (Qinvisible, extent_invisible (anc)); |
| 428 | 6034 |
| 6035 if (!NILP (extent_read_only (anc))) | |
| 826 | 6036 ADD_PROP (Qread_only, extent_read_only (anc)); |
| 428 | 6037 |
| 6038 if (extent_normal_field (anc, end_open)) | |
| 826 | 6039 ADD_PROP (Qend_open, Qt); |
| 428 | 6040 |
| 6041 if (extent_normal_field (anc, start_open)) | |
| 826 | 6042 ADD_PROP (Qstart_open, Qt); |
| 428 | 6043 |
| 6044 if (extent_normal_field (anc, detachable)) | |
| 826 | 6045 ADD_PROP (Qdetachable, Qt); |
| 428 | 6046 |
| 6047 if (extent_normal_field (anc, duplicable)) | |
| 826 | 6048 ADD_PROP (Qduplicable, Qt); |
| 428 | 6049 |
| 6050 if (extent_normal_field (anc, unique)) | |
| 826 | 6051 ADD_PROP (Qunique, Qt); |
| 428 | 6052 |
| 6053 /* detached is not an inherited property */ | |
| 6054 if (extent_detached_p (e)) | |
| 826 | 6055 ADD_PROP (Qdetached, Qt); |
| 6056 | |
| 6057 #undef ADD_PROP | |
| 6058 } | |
| 6059 | |
| 6060 DEFUN ("extent-properties", Fextent_properties, 1, 1, 0, /* | |
| 6061 Return a property list of the attributes of EXTENT. | |
| 6062 Do not modify this list; use `set-extent-property' instead. | |
| 6063 */ | |
| 6064 (extent)) | |
| 6065 { | |
| 6066 EXTENT e; | |
| 6067 Lisp_Object result = Qnil; | |
| 6068 Lisp_Object_pair_dynarr *props; | |
| 6069 int i; | |
| 6070 | |
| 6071 CHECK_EXTENT (extent); | |
| 6072 e = XEXTENT (extent); | |
| 6073 props = Dynarr_new (Lisp_Object_pair); | |
| 6074 extent_properties (e, props); | |
| 6075 | |
| 6076 for (i = 0; i < Dynarr_length (props); i++) | |
| 6077 result = cons3 (Dynarr_at (props, i).key, Dynarr_at (props, i).value, | |
| 6078 result); | |
| 6079 | |
| 6080 Dynarr_free (props); | |
| 428 | 6081 return result; |
| 6082 } | |
| 6083 | |
| 6084 | |
| 6085 /************************************************************************/ | |
| 6086 /* highlighting */ | |
| 6087 /************************************************************************/ | |
| 6088 | |
| 6089 /* The display code looks into the Vlast_highlighted_extent variable to | |
| 6090 correctly display highlighted extents. This updates that variable, | |
| 6091 and marks the appropriate buffers as needing some redisplay. | |
| 6092 */ | |
| 6093 static void | |
| 6094 do_highlight (Lisp_Object extent_obj, int highlight_p) | |
| 6095 { | |
| 6096 if (( highlight_p && (EQ (Vlast_highlighted_extent, extent_obj))) || | |
| 6097 (!highlight_p && (EQ (Vlast_highlighted_extent, Qnil)))) | |
| 6098 return; | |
| 6099 if (EXTENTP (Vlast_highlighted_extent) && | |
| 6100 EXTENT_LIVE_P (XEXTENT (Vlast_highlighted_extent))) | |
| 6101 { | |
| 6102 /* do not recurse on descendants. Only one extent is highlighted | |
| 6103 at a time. */ | |
| 826 | 6104 /* A bit of a lie. */ |
| 6105 signal_extent_property_changed (XEXTENT (Vlast_highlighted_extent), | |
| 6106 Qface, 0); | |
| 428 | 6107 } |
| 6108 Vlast_highlighted_extent = Qnil; | |
| 6109 if (!NILP (extent_obj) | |
| 6110 && BUFFERP (extent_object (XEXTENT (extent_obj))) | |
| 6111 && highlight_p) | |
| 6112 { | |
| 826 | 6113 signal_extent_property_changed (XEXTENT (extent_obj), Qface, 0); |
| 428 | 6114 Vlast_highlighted_extent = extent_obj; |
| 6115 } | |
| 6116 } | |
| 6117 | |
| 6118 DEFUN ("force-highlight-extent", Fforce_highlight_extent, 1, 2, 0, /* | |
| 6119 Highlight or unhighlight the given extent. | |
| 6120 If the second arg is non-nil, it will be highlighted, else dehighlighted. | |
| 6121 This is the same as `highlight-extent', except that it will work even | |
| 6122 on extents without the `mouse-face' property. | |
| 6123 */ | |
| 6124 (extent, highlight_p)) | |
| 6125 { | |
| 6126 if (NILP (extent)) | |
| 6127 highlight_p = Qnil; | |
| 6128 else | |
| 793 | 6129 extent = wrap_extent (decode_extent (extent, DE_MUST_BE_ATTACHED)); |
| 428 | 6130 do_highlight (extent, !NILP (highlight_p)); |
| 6131 return Qnil; | |
| 6132 } | |
| 6133 | |
| 6134 DEFUN ("highlight-extent", Fhighlight_extent, 1, 2, 0, /* | |
| 6135 Highlight EXTENT, if it is highlightable. | |
| 6136 \(that is, if it has the `mouse-face' property). | |
| 6137 If the second arg is non-nil, it will be highlighted, else dehighlighted. | |
| 6138 Highlighted extents are displayed as if they were merged with the face | |
| 6139 or faces specified by the `mouse-face' property. | |
| 6140 */ | |
| 6141 (extent, highlight_p)) | |
| 6142 { | |
| 6143 if (EXTENTP (extent) && NILP (extent_mouse_face (XEXTENT (extent)))) | |
| 6144 return Qnil; | |
| 6145 else | |
| 6146 return Fforce_highlight_extent (extent, highlight_p); | |
| 6147 } | |
| 6148 | |
| 6149 | |
| 6150 /************************************************************************/ | |
| 6151 /* strings and extents */ | |
| 6152 /************************************************************************/ | |
| 6153 | |
| 6154 /* copy/paste hooks */ | |
| 6155 | |
| 6156 static int | |
| 826 | 6157 run_extent_copy_paste_internal (EXTENT e, Charxpos from, Charxpos to, |
| 428 | 6158 Lisp_Object object, |
| 6159 Lisp_Object prop) | |
| 6160 { | |
| 6161 /* This function can GC */ | |
| 6162 Lisp_Object extent; | |
| 6163 Lisp_Object copy_fn; | |
| 793 | 6164 extent = wrap_extent (e); |
| 428 | 6165 copy_fn = Fextent_property (extent, prop, Qnil); |
| 6166 if (!NILP (copy_fn)) | |
| 6167 { | |
| 6168 Lisp_Object flag; | |
| 6169 struct gcpro gcpro1, gcpro2, gcpro3; | |
| 6170 GCPRO3 (extent, copy_fn, object); | |
| 6171 if (BUFFERP (object)) | |
| 6172 flag = call3_in_buffer (XBUFFER (object), copy_fn, extent, | |
| 6173 make_int (from), make_int (to)); | |
| 6174 else | |
| 6175 flag = call3 (copy_fn, extent, make_int (from), make_int (to)); | |
| 6176 UNGCPRO; | |
| 6177 if (NILP (flag) || !EXTENT_LIVE_P (XEXTENT (extent))) | |
| 6178 return 0; | |
| 6179 } | |
| 6180 return 1; | |
| 6181 } | |
| 6182 | |
| 6183 static int | |
| 826 | 6184 run_extent_copy_function (EXTENT e, Bytexpos from, Bytexpos to) |
| 428 | 6185 { |
| 6186 Lisp_Object object = extent_object (e); | |
| 6187 /* This function can GC */ | |
| 6188 return run_extent_copy_paste_internal | |
| 826 | 6189 (e, buffer_or_string_bytexpos_to_charxpos (object, from), |
| 6190 buffer_or_string_bytexpos_to_charxpos (object, to), object, | |
| 428 | 6191 Qcopy_function); |
| 6192 } | |
| 6193 | |
| 6194 static int | |
| 826 | 6195 run_extent_paste_function (EXTENT e, Bytexpos from, Bytexpos to, |
| 428 | 6196 Lisp_Object object) |
| 6197 { | |
| 6198 /* This function can GC */ | |
| 6199 return run_extent_copy_paste_internal | |
| 826 | 6200 (e, buffer_or_string_bytexpos_to_charxpos (object, from), |
| 6201 buffer_or_string_bytexpos_to_charxpos (object, to), object, | |
| 428 | 6202 Qpaste_function); |
| 6203 } | |
| 6204 | |
| 826 | 6205 static int |
| 6206 run_extent_paste_function_char (EXTENT e, Charxpos from, Charxpos to, | |
| 6207 Lisp_Object object) | |
| 6208 { | |
| 6209 /* This function can GC */ | |
| 6210 return run_extent_copy_paste_internal (e, from, to, object, Qpaste_function); | |
| 6211 } | |
| 6212 | |
| 428 | 6213 static Lisp_Object |
| 826 | 6214 insert_extent (EXTENT extent, Bytexpos new_start, Bytexpos new_end, |
| 428 | 6215 Lisp_Object object, int run_hooks) |
| 6216 { | |
| 6217 /* This function can GC */ | |
| 6218 if (!EQ (extent_object (extent), object)) | |
| 6219 goto copy_it; | |
| 6220 | |
| 6221 if (extent_detached_p (extent)) | |
| 6222 { | |
| 6223 if (run_hooks && | |
| 6224 !run_extent_paste_function (extent, new_start, new_end, object)) | |
| 6225 /* The paste-function said don't re-attach this extent here. */ | |
| 6226 return Qnil; | |
| 6227 else | |
| 826 | 6228 set_extent_endpoints (extent, new_start, new_end, Qnil); |
| 428 | 6229 } |
| 6230 else | |
| 6231 { | |
| 826 | 6232 Bytexpos exstart = extent_endpoint_byte (extent, 0); |
| 6233 Bytexpos exend = extent_endpoint_byte (extent, 1); | |
| 428 | 6234 |
| 6235 if (exend < new_start || exstart > new_end) | |
| 6236 goto copy_it; | |
| 6237 else | |
| 6238 { | |
| 6239 new_start = min (exstart, new_start); | |
| 6240 new_end = max (exend, new_end); | |
| 6241 if (exstart != new_start || exend != new_end) | |
| 826 | 6242 set_extent_endpoints (extent, new_start, new_end, Qnil); |
| 428 | 6243 } |
| 6244 } | |
| 6245 | |
| 793 | 6246 return wrap_extent (extent); |
| 428 | 6247 |
| 6248 copy_it: | |
| 6249 if (run_hooks && | |
| 6250 !run_extent_paste_function (extent, new_start, new_end, object)) | |
| 6251 /* The paste-function said don't attach a copy of the extent here. */ | |
| 6252 return Qnil; | |
| 6253 else | |
| 793 | 6254 return wrap_extent (copy_extent (extent, new_start, new_end, object)); |
| 428 | 6255 } |
| 6256 | |
| 6257 DEFUN ("insert-extent", Finsert_extent, 1, 5, 0, /* | |
| 6258 Insert EXTENT from START to END in BUFFER-OR-STRING. | |
| 6259 BUFFER-OR-STRING defaults to the current buffer if omitted. | |
| 826 | 6260 If EXTENT is already on the same object, and overlaps or is adjacent to |
| 6261 the given range, its range is merely extended to include the new range. | |
| 6262 Otherwise, a copy is made of the extent at the new position and object. | |
| 6263 When a copy is made, the new extent is returned, copy/paste hooks are run, | |
| 6264 and the change is noted for undo recording. When no copy is made, nil is | |
| 6265 returned. See documentation on `detach-extent' for a discussion of undo | |
| 6266 recording. | |
| 6267 | |
| 428 | 6268 The fourth arg, NO-HOOKS, can be used to inhibit the running of the |
| 826 | 6269 extent's `paste-function' property if it has one. |
| 6270 | |
| 6271 It's not really clear why this function exists any more. It was a holdover | |
| 6272 from a much older implementation of extents, before extents could really | |
| 6273 exist on strings. | |
| 428 | 6274 */ |
| 6275 (extent, start, end, no_hooks, buffer_or_string)) | |
| 6276 { | |
| 6277 EXTENT ext = decode_extent (extent, 0); | |
| 6278 Lisp_Object copy; | |
| 826 | 6279 Bytexpos s, e; |
| 428 | 6280 |
| 6281 buffer_or_string = decode_buffer_or_string (buffer_or_string); | |
| 6282 get_buffer_or_string_range_byte (buffer_or_string, start, end, &s, &e, | |
| 6283 GB_ALLOW_PAST_ACCESSIBLE); | |
| 6284 | |
| 6285 copy = insert_extent (ext, s, e, buffer_or_string, NILP (no_hooks)); | |
| 6286 if (EXTENTP (copy)) | |
| 6287 { | |
| 6288 if (extent_duplicable_p (XEXTENT (copy))) | |
| 6289 record_extent (copy, 1); | |
| 6290 } | |
| 6291 return copy; | |
| 6292 } | |
| 6293 | |
| 6294 | |
| 6295 /* adding buffer extents to a string */ | |
| 6296 | |
| 6297 struct add_string_extents_arg | |
| 6298 { | |
| 826 | 6299 Bytexpos from; |
| 428 | 6300 Bytecount length; |
| 6301 Lisp_Object string; | |
| 6302 }; | |
| 6303 | |
| 6304 static int | |
| 6305 add_string_extents_mapper (EXTENT extent, void *arg) | |
| 6306 { | |
| 6307 /* This function can GC */ | |
| 6308 struct add_string_extents_arg *closure = | |
| 6309 (struct add_string_extents_arg *) arg; | |
| 826 | 6310 Bytecount start = extent_endpoint_byte (extent, 0) - closure->from; |
| 6311 Bytecount end = extent_endpoint_byte (extent, 1) - closure->from; | |
| 428 | 6312 |
| 6313 if (extent_duplicable_p (extent)) | |
| 6314 { | |
| 6315 start = max (start, 0); | |
| 6316 end = min (end, closure->length); | |
| 6317 | |
| 6318 /* Run the copy-function to give an extent the option of | |
| 6319 not being copied into the string (or kill ring). | |
| 6320 */ | |
| 6321 if (extent_duplicable_p (extent) && | |
| 6322 !run_extent_copy_function (extent, start + closure->from, | |
| 6323 end + closure->from)) | |
| 6324 return 0; | |
| 6325 copy_extent (extent, start, end, closure->string); | |
| 6326 } | |
| 6327 | |
| 6328 return 0; | |
| 6329 } | |
| 6330 | |
| 826 | 6331 struct add_string_extents_the_hard_way_arg |
| 6332 { | |
| 6333 Charxpos from; | |
| 6334 Charcount length; | |
| 6335 Lisp_Object string; | |
| 6336 }; | |
| 6337 | |
| 6338 static int | |
| 6339 add_string_extents_the_hard_way_mapper (EXTENT extent, void *arg) | |
| 6340 { | |
| 6341 /* This function can GC */ | |
| 6342 struct add_string_extents_arg *closure = | |
| 6343 (struct add_string_extents_arg *) arg; | |
| 6344 Charcount start = extent_endpoint_char (extent, 0) - closure->from; | |
| 6345 Charcount end = extent_endpoint_char (extent, 1) - closure->from; | |
| 6346 | |
| 6347 if (extent_duplicable_p (extent)) | |
| 6348 { | |
| 6349 start = max (start, 0); | |
| 6350 end = min (end, closure->length); | |
| 6351 | |
| 6352 /* Run the copy-function to give an extent the option of | |
| 6353 not being copied into the string (or kill ring). | |
| 6354 */ | |
| 6355 if (extent_duplicable_p (extent) && | |
| 6356 !run_extent_copy_function (extent, start + closure->from, | |
| 6357 end + closure->from)) | |
| 6358 return 0; | |
| 6359 copy_extent (extent, | |
| 6360 string_index_char_to_byte (closure->string, start), | |
| 6361 string_index_char_to_byte (closure->string, end), | |
| 6362 closure->string); | |
| 6363 } | |
| 6364 | |
| 6365 return 0; | |
| 6366 } | |
| 6367 | |
| 428 | 6368 /* Add the extents in buffer BUF from OPOINT to OPOINT+LENGTH to |
| 6369 the string STRING. */ | |
| 6370 void | |
| 826 | 6371 add_string_extents (Lisp_Object string, struct buffer *buf, Bytexpos opoint, |
| 428 | 6372 Bytecount length) |
| 6373 { | |
| 6374 /* This function can GC */ | |
| 6375 struct gcpro gcpro1, gcpro2; | |
| 6376 Lisp_Object buffer; | |
| 6377 | |
| 771 | 6378 buffer = wrap_buffer (buf); |
| 428 | 6379 GCPRO2 (buffer, string); |
| 826 | 6380 |
| 6381 if (XSTRING_FORMAT (string) == BUF_FORMAT (buf)) | |
| 6382 { | |
| 6383 struct add_string_extents_arg closure; | |
| 6384 closure.from = opoint; | |
| 6385 closure.length = length; | |
| 6386 closure.string = string; | |
| 6387 map_extents (opoint, opoint + length, add_string_extents_mapper, | |
| 6388 (void *) &closure, buffer, 0, | |
| 6389 /* ignore extents that just abut the region */ | |
| 6390 ME_END_CLOSED | ME_ALL_EXTENTS_OPEN | | |
| 6391 /* we are calling E-Lisp (the extent's copy function) | |
| 6392 so anything might happen */ | |
| 6393 ME_MIGHT_CALL_ELISP); | |
| 6394 } | |
| 6395 else | |
| 6396 { | |
| 6397 struct add_string_extents_the_hard_way_arg closure; | |
| 6398 closure.from = bytebpos_to_charbpos (buf, opoint); | |
| 6399 closure.length = (bytebpos_to_charbpos (buf, opoint + length) - | |
| 6400 closure.from); | |
| 6401 closure.string = string; | |
| 6402 | |
| 6403 /* If the string and buffer are in different formats, things get | |
| 6404 tricky; the only reasonable way to do the operation is entirely in | |
| 6405 char offsets, which are invariant to format changes. In practice, | |
| 6406 this won't be time-consuming because the byte/char conversions are | |
| 6407 mostly in the buffer, which will be in a fixed-width format. */ | |
| 6408 map_extents (opoint, opoint + length, | |
| 6409 add_string_extents_the_hard_way_mapper, | |
| 6410 (void *) &closure, buffer, 0, | |
| 6411 /* ignore extents that just abut the region */ | |
| 6412 ME_END_CLOSED | ME_ALL_EXTENTS_OPEN | | |
| 6413 /* we are calling E-Lisp (the extent's copy function) | |
| 6414 so anything might happen */ | |
| 6415 ME_MIGHT_CALL_ELISP); | |
| 6416 | |
| 6417 } | |
| 6418 | |
| 428 | 6419 UNGCPRO; |
| 6420 } | |
| 6421 | |
| 6422 struct splice_in_string_extents_arg | |
| 6423 { | |
| 6424 Bytecount pos; | |
| 6425 Bytecount length; | |
| 826 | 6426 Bytexpos opoint; |
| 428 | 6427 Lisp_Object buffer; |
| 6428 }; | |
| 6429 | |
| 6430 static int | |
| 6431 splice_in_string_extents_mapper (EXTENT extent, void *arg) | |
| 6432 { | |
| 6433 /* This function can GC */ | |
| 6434 struct splice_in_string_extents_arg *closure = | |
| 6435 (struct splice_in_string_extents_arg *) arg; | |
| 6436 /* BASE_START and BASE_END are the limits in the buffer of the string | |
| 6437 that was just inserted. | |
| 826 | 6438 |
| 428 | 6439 NEW_START and NEW_END are the prospective buffer positions of the |
| 6440 extent that is going into the buffer. */ | |
| 826 | 6441 Bytexpos base_start = closure->opoint; |
| 6442 Bytexpos base_end = base_start + closure->length; | |
| 6443 Bytexpos new_start = (base_start + extent_endpoint_byte (extent, 0) - | |
| 6444 closure->pos); | |
| 6445 Bytexpos new_end = (base_start + extent_endpoint_byte (extent, 1) - | |
| 428 | 6446 closure->pos); |
| 6447 | |
| 6448 if (new_start < base_start) | |
| 6449 new_start = base_start; | |
| 6450 if (new_end > base_end) | |
| 6451 new_end = base_end; | |
| 6452 if (new_end <= new_start) | |
| 6453 return 0; | |
| 6454 | |
| 6455 if (!extent_duplicable_p (extent)) | |
| 6456 return 0; | |
| 6457 | |
| 6458 if (!inside_undo && | |
| 6459 !run_extent_paste_function (extent, new_start, new_end, | |
| 6460 closure->buffer)) | |
| 6461 return 0; | |
| 6462 copy_extent (extent, new_start, new_end, closure->buffer); | |
| 6463 | |
| 6464 return 0; | |
| 6465 } | |
| 6466 | |
| 826 | 6467 struct splice_in_string_extents_the_hard_way_arg |
| 6468 { | |
| 6469 Charcount pos; | |
| 6470 Charcount length; | |
| 6471 Charxpos opoint; | |
| 6472 Lisp_Object buffer; | |
| 6473 }; | |
| 6474 | |
| 6475 static int | |
| 6476 splice_in_string_extents_the_hard_way_mapper (EXTENT extent, void *arg) | |
| 6477 { | |
| 6478 /* This function can GC */ | |
| 6479 struct splice_in_string_extents_arg *closure = | |
| 6480 (struct splice_in_string_extents_arg *) arg; | |
| 6481 /* BASE_START and BASE_END are the limits in the buffer of the string | |
| 6482 that was just inserted. | |
| 6483 | |
| 6484 NEW_START and NEW_END are the prospective buffer positions of the | |
| 6485 extent that is going into the buffer. */ | |
| 6486 Charxpos base_start = closure->opoint; | |
| 6487 Charxpos base_end = base_start + closure->length; | |
| 6488 Charxpos new_start = (base_start + extent_endpoint_char (extent, 0) - | |
| 6489 closure->pos); | |
| 6490 Charxpos new_end = (base_start + extent_endpoint_char (extent, 1) - | |
| 6491 closure->pos); | |
| 6492 | |
| 6493 if (new_start < base_start) | |
| 6494 new_start = base_start; | |
| 6495 if (new_end > base_end) | |
| 6496 new_end = base_end; | |
| 6497 if (new_end <= new_start) | |
| 6498 return 0; | |
| 6499 | |
| 6500 if (!extent_duplicable_p (extent)) | |
| 6501 return 0; | |
| 6502 | |
| 6503 if (!inside_undo && | |
| 6504 !run_extent_paste_function_char (extent, new_start, new_end, | |
| 6505 closure->buffer)) | |
| 6506 return 0; | |
| 6507 copy_extent (extent, | |
| 6508 charbpos_to_bytebpos (XBUFFER (closure->buffer), new_start), | |
| 6509 charbpos_to_bytebpos (XBUFFER (closure->buffer), new_end), | |
| 6510 closure->buffer); | |
| 6511 | |
| 6512 return 0; | |
| 6513 } | |
| 6514 | |
| 428 | 6515 /* We have just inserted a section of STRING (starting at POS, of |
| 6516 length LENGTH) into buffer BUF at OPOINT. Do whatever is necessary | |
| 6517 to get the string's extents into the buffer. */ | |
| 6518 | |
| 6519 void | |
| 6520 splice_in_string_extents (Lisp_Object string, struct buffer *buf, | |
| 826 | 6521 Bytexpos opoint, Bytecount length, Bytecount pos) |
| 6522 { | |
| 428 | 6523 struct gcpro gcpro1, gcpro2; |
| 793 | 6524 Lisp_Object buffer = wrap_buffer (buf); |
| 6525 | |
| 428 | 6526 GCPRO2 (buffer, string); |
| 826 | 6527 if (XSTRING_FORMAT (string) == BUF_FORMAT (buf)) |
| 6528 { | |
| 6529 struct splice_in_string_extents_arg closure; | |
| 6530 closure.opoint = opoint; | |
| 6531 closure.pos = pos; | |
| 6532 closure.length = length; | |
| 6533 closure.buffer = buffer; | |
| 6534 map_extents (pos, pos + length, | |
| 6535 splice_in_string_extents_mapper, | |
| 6536 (void *) &closure, string, 0, | |
| 6537 /* ignore extents that just abut the region */ | |
| 6538 ME_END_CLOSED | ME_ALL_EXTENTS_OPEN | | |
| 6539 /* we are calling E-Lisp (the extent's copy function) | |
| 6540 so anything might happen */ | |
| 6541 ME_MIGHT_CALL_ELISP); | |
| 6542 } | |
| 6543 else | |
| 6544 { | |
| 6545 struct splice_in_string_extents_the_hard_way_arg closure; | |
| 6546 closure.opoint = bytebpos_to_charbpos (buf, opoint); | |
| 6547 closure.pos = string_index_byte_to_char (string, pos); | |
| 6548 closure.length = string_offset_byte_to_char_len (string, pos, length); | |
| 6549 closure.buffer = buffer; | |
| 6550 | |
| 6551 /* If the string and buffer are in different formats, things get | |
| 6552 tricky; the only reasonable way to do the operation is entirely in | |
| 6553 char offsets, which are invariant to format changes. In practice, | |
| 6554 this won't be time-consuming because the byte/char conversions are | |
| 6555 mostly in the buffer, which will be in a fixed-width format. */ | |
| 6556 map_extents (pos, pos + length, | |
| 6557 splice_in_string_extents_the_hard_way_mapper, | |
| 6558 (void *) &closure, string, 0, | |
| 6559 /* ignore extents that just abut the region */ | |
| 6560 ME_END_CLOSED | ME_ALL_EXTENTS_OPEN | | |
| 6561 /* we are calling E-Lisp (the extent's copy function) | |
| 6562 so anything might happen */ | |
| 6563 ME_MIGHT_CALL_ELISP); | |
| 6564 | |
| 6565 } | |
| 428 | 6566 UNGCPRO; |
| 6567 } | |
| 6568 | |
| 6569 struct copy_string_extents_arg | |
| 6570 { | |
| 6571 Bytecount new_pos; | |
| 6572 Bytecount old_pos; | |
| 6573 Bytecount length; | |
| 6574 Lisp_Object new_string; | |
| 6575 }; | |
| 6576 | |
| 6577 struct copy_string_extents_1_arg | |
| 6578 { | |
| 6579 Lisp_Object parent_in_question; | |
| 6580 EXTENT found_extent; | |
| 6581 }; | |
| 6582 | |
| 6583 static int | |
| 6584 copy_string_extents_mapper (EXTENT extent, void *arg) | |
| 6585 { | |
| 6586 struct copy_string_extents_arg *closure = | |
| 6587 (struct copy_string_extents_arg *) arg; | |
| 6588 Bytecount old_start, old_end, new_start, new_end; | |
| 6589 | |
| 826 | 6590 old_start = extent_endpoint_byte (extent, 0); |
| 6591 old_end = extent_endpoint_byte (extent, 1); | |
| 428 | 6592 |
| 6593 old_start = max (closure->old_pos, old_start); | |
| 6594 old_end = min (closure->old_pos + closure->length, old_end); | |
| 6595 | |
| 6596 if (old_start >= old_end) | |
| 6597 return 0; | |
| 6598 | |
| 6599 new_start = old_start + closure->new_pos - closure->old_pos; | |
| 6600 new_end = old_end + closure->new_pos - closure->old_pos; | |
| 6601 | |
| 6602 copy_extent (extent, new_start, new_end, closure->new_string); | |
| 6603 return 0; | |
| 6604 } | |
| 6605 | |
| 6606 /* The string NEW_STRING was partially constructed from OLD_STRING. | |
| 6607 In particular, the section of length LEN starting at NEW_POS in | |
| 6608 NEW_STRING came from the section of the same length starting at | |
| 6609 OLD_POS in OLD_STRING. Copy the extents as appropriate. */ | |
| 6610 | |
| 6611 void | |
| 6612 copy_string_extents (Lisp_Object new_string, Lisp_Object old_string, | |
| 6613 Bytecount new_pos, Bytecount old_pos, | |
| 6614 Bytecount length) | |
| 6615 { | |
| 6616 struct copy_string_extents_arg closure; | |
| 6617 struct gcpro gcpro1, gcpro2; | |
| 6618 | |
| 6619 closure.new_pos = new_pos; | |
| 6620 closure.old_pos = old_pos; | |
| 6621 closure.new_string = new_string; | |
| 6622 closure.length = length; | |
| 6623 GCPRO2 (new_string, old_string); | |
| 826 | 6624 map_extents (old_pos, old_pos + length, |
| 6625 copy_string_extents_mapper, | |
| 6626 (void *) &closure, old_string, 0, | |
| 6627 /* ignore extents that just abut the region */ | |
| 6628 ME_END_CLOSED | ME_ALL_EXTENTS_OPEN | | |
| 6629 /* we are calling E-Lisp (the extent's copy function) | |
| 6630 so anything might happen */ | |
| 6631 ME_MIGHT_CALL_ELISP); | |
| 428 | 6632 UNGCPRO; |
| 6633 } | |
| 6634 | |
| 6635 /* Checklist for sanity checking: | |
| 6636 - {kill, yank, copy} at {open, closed} {start, end} of {writable, read-only} extent | |
| 6637 - {kill, copy} & yank {once, repeatedly} duplicable extent in {same, different} buffer | |
| 6638 */ | |
| 6639 | |
| 6640 | |
| 6641 /************************************************************************/ | |
| 6642 /* text properties */ | |
| 6643 /************************************************************************/ | |
| 6644 | |
| 6645 /* Text properties | |
| 6646 Originally this stuff was implemented in lisp (all of the functionality | |
| 6647 exists to make that possible) but speed was a problem. | |
| 6648 */ | |
| 6649 | |
| 6650 Lisp_Object Qtext_prop; | |
| 6651 Lisp_Object Qtext_prop_extent_paste_function; | |
| 6652 | |
| 826 | 6653 /* Retrieve the value of the property PROP of the text at position POSITION |
| 6654 in OBJECT. TEXT-PROPS-ONLY means only look at extents with the | |
| 6655 `text-prop' property, i.e. extents created by the text property | |
| 6656 routines. Otherwise, all extents are examined. &&#### finish Note that | |
| 6657 the default extent_at_flag is EXTENT_AT_DEFAULT (same as | |
| 6658 EXTENT_AT_AFTER). */ | |
| 6659 Lisp_Object | |
| 6660 get_char_property (Bytexpos position, Lisp_Object prop, | |
| 6661 Lisp_Object object, enum extent_at_flag fl, | |
| 6662 int text_props_only) | |
| 428 | 6663 { |
| 6664 Lisp_Object extent; | |
| 6665 | |
| 6666 /* text_props_only specifies whether we only consider text-property | |
| 3025 | 6667 extents (those with the `text-prop' property set) or all extents. */ |
| 428 | 6668 if (!text_props_only) |
| 826 | 6669 extent = extent_at (position, object, prop, 0, fl, 0); |
| 428 | 6670 else |
| 6671 { | |
| 6672 EXTENT prior = 0; | |
| 6673 while (1) | |
| 6674 { | |
| 826 | 6675 extent = extent_at (position, object, Qtext_prop, prior, fl, 0); |
| 428 | 6676 if (NILP (extent)) |
| 6677 return Qnil; | |
| 6678 if (EQ (prop, Fextent_property (extent, Qtext_prop, Qnil))) | |
| 6679 break; | |
| 6680 prior = XEXTENT (extent); | |
| 6681 } | |
| 6682 } | |
| 6683 | |
| 6684 if (!NILP (extent)) | |
| 6685 return Fextent_property (extent, prop, Qnil); | |
| 6686 if (!NILP (Vdefault_text_properties)) | |
| 6687 return Fplist_get (Vdefault_text_properties, prop, Qnil); | |
| 6688 return Qnil; | |
| 6689 } | |
| 6690 | |
| 6691 static Lisp_Object | |
| 826 | 6692 get_char_property_char (Lisp_Object pos, Lisp_Object prop, Lisp_Object object, |
| 6693 Lisp_Object at_flag, int text_props_only) | |
| 6694 { | |
| 6695 Bytexpos position; | |
| 428 | 6696 int invert = 0; |
| 6697 | |
| 6698 object = decode_buffer_or_string (object); | |
| 6699 position = get_buffer_or_string_pos_byte (object, pos, GB_NO_ERROR_IF_BAD); | |
| 6700 | |
| 6701 /* We canonicalize the start/end-open/closed properties to the | |
| 6702 non-default version -- "adding" the default property really | |
| 6703 needs to remove the non-default one. See below for more | |
| 6704 on this. */ | |
| 6705 if (EQ (prop, Qstart_closed)) | |
| 6706 { | |
| 6707 prop = Qstart_open; | |
| 6708 invert = 1; | |
| 6709 } | |
| 6710 | |
| 6711 if (EQ (prop, Qend_open)) | |
| 6712 { | |
| 6713 prop = Qend_closed; | |
| 6714 invert = 1; | |
| 6715 } | |
| 6716 | |
| 6717 { | |
| 6718 Lisp_Object val = | |
| 826 | 6719 get_char_property (position, prop, object, |
| 6720 decode_extent_at_flag (at_flag), | |
| 6721 text_props_only); | |
| 428 | 6722 if (invert) |
| 6723 val = NILP (val) ? Qt : Qnil; | |
| 6724 return val; | |
| 6725 } | |
| 6726 } | |
| 6727 | |
| 6728 DEFUN ("get-text-property", Fget_text_property, 2, 4, 0, /* | |
| 6729 Return the value of the PROP property at the given position. | |
| 6730 Optional arg OBJECT specifies the buffer or string to look in, and | |
| 6731 defaults to the current buffer. | |
| 6732 Optional arg AT-FLAG controls what it means for a property to be "at" | |
| 6733 a position, and has the same meaning as in `extent-at'. | |
| 6734 This examines only those properties added with `put-text-property'. | |
| 6735 See also `get-char-property'. | |
| 6736 */ | |
| 6737 (pos, prop, object, at_flag)) | |
| 6738 { | |
| 826 | 6739 return get_char_property_char (pos, prop, object, at_flag, 1); |
| 428 | 6740 } |
| 6741 | |
| 6742 DEFUN ("get-char-property", Fget_char_property, 2, 4, 0, /* | |
| 6743 Return the value of the PROP property at the given position. | |
| 6744 Optional arg OBJECT specifies the buffer or string to look in, and | |
| 6745 defaults to the current buffer. | |
| 6746 Optional arg AT-FLAG controls what it means for a property to be "at" | |
| 6747 a position, and has the same meaning as in `extent-at'. | |
| 6748 This examines properties on all extents. | |
| 6749 See also `get-text-property'. | |
| 6750 */ | |
| 6751 (pos, prop, object, at_flag)) | |
| 6752 { | |
| 826 | 6753 return get_char_property_char (pos, prop, object, at_flag, 0); |
| 428 | 6754 } |
| 6755 | |
| 6756 /* About start/end-open/closed: | |
| 6757 | |
| 6758 These properties have to be handled specially because of their | |
| 6759 strange behavior. If I put the "start-open" property on a region, | |
| 6760 then *all* text-property extents in the region have to have their | |
| 6761 start be open. This is unlike all other properties, which don't | |
| 6762 affect the extents of text properties other than their own. | |
| 6763 | |
| 6764 So: | |
| 6765 | |
| 6766 1) We have to map start-closed to (not start-open) and end-open | |
| 6767 to (not end-closed) -- i.e. adding the default is really the | |
| 6768 same as remove the non-default property. It won't work, for | |
| 6769 example, to have both "start-open" and "start-closed" on | |
| 6770 the same region. | |
| 6771 2) Whenever we add one of these properties, we go through all | |
| 6772 text-property extents in the region and set the appropriate | |
| 6773 open/closedness on them. | |
| 6774 3) Whenever we change a text-property extent for a property, | |
| 6775 we have to make sure we set the open/closedness properly. | |
| 6776 | |
| 6777 (2) and (3) together rely on, and maintain, the invariant | |
| 6778 that the open/closedness of text-property extents is correct | |
| 6779 at the beginning and end of each operation. | |
| 6780 */ | |
| 6781 | |
| 6782 struct put_text_prop_arg | |
| 6783 { | |
| 6784 Lisp_Object prop, value; /* The property and value we are storing */ | |
| 826 | 6785 Bytexpos start, end; /* The region into which we are storing it */ |
| 428 | 6786 Lisp_Object object; |
| 6787 Lisp_Object the_extent; /* Our chosen extent; this is used for | |
| 6788 communication between subsequent passes. */ | |
| 6789 int changed_p; /* Output: whether we have modified anything */ | |
| 6790 }; | |
| 6791 | |
| 6792 static int | |
| 6793 put_text_prop_mapper (EXTENT e, void *arg) | |
| 6794 { | |
| 6795 struct put_text_prop_arg *closure = (struct put_text_prop_arg *) arg; | |
| 6796 | |
| 6797 Lisp_Object object = closure->object; | |
| 6798 Lisp_Object value = closure->value; | |
| 826 | 6799 Bytexpos e_start, e_end; |
| 6800 Bytexpos start = closure->start; | |
| 6801 Bytexpos end = closure->end; | |
| 428 | 6802 Lisp_Object extent, e_val; |
| 6803 int is_eq; | |
| 6804 | |
| 793 | 6805 extent = wrap_extent (e); |
| 428 | 6806 |
| 3025 | 6807 /* Note: in some cases when the property itself is `start-open' |
| 6808 or `end-closed', the checks to set the openness may do a bit | |
| 428 | 6809 of extra work; but it won't hurt because we then fix up the |
| 6810 openness later on in put_text_prop_openness_mapper(). */ | |
| 6811 if (!EQ (Fextent_property (extent, Qtext_prop, Qnil), closure->prop)) | |
| 6812 /* It's not for this property; do nothing. */ | |
| 6813 return 0; | |
| 6814 | |
| 826 | 6815 e_start = extent_endpoint_byte (e, 0); |
| 6816 e_end = extent_endpoint_byte (e, 1); | |
| 428 | 6817 e_val = Fextent_property (extent, closure->prop, Qnil); |
| 6818 is_eq = EQ (value, e_val); | |
| 6819 | |
| 6820 if (!NILP (value) && NILP (closure->the_extent) && is_eq) | |
| 6821 { | |
| 6822 /* We want there to be an extent here at the end, and we haven't picked | |
| 6823 one yet, so use this one. Extend it as necessary. We only reuse an | |
| 6824 extent which has an EQ value for the prop in question to avoid | |
| 6825 side-effecting the kill ring (that is, we never change the property | |
| 6826 on an extent after it has been created.) | |
| 6827 */ | |
| 6828 if (e_start != start || e_end != end) | |
| 6829 { | |
| 826 | 6830 Bytexpos new_start = min (e_start, start); |
| 6831 Bytexpos new_end = max (e_end, end); | |
| 428 | 6832 set_extent_endpoints (e, new_start, new_end, Qnil); |
| 6833 /* If we changed the endpoint, then we need to set its | |
| 6834 openness. */ | |
| 6835 set_extent_openness (e, new_start != e_start | |
| 826 | 6836 ? !NILP (get_char_property |
| 428 | 6837 (start, Qstart_open, object, |
| 6838 EXTENT_AT_AFTER, 1)) : -1, | |
| 6839 new_end != e_end | |
| 826 | 6840 ? NILP (get_char_property |
| 6841 (prev_bytexpos (object, end), | |
| 6842 Qend_closed, object, | |
| 428 | 6843 EXTENT_AT_AFTER, 1)) |
| 6844 : -1); | |
| 6845 closure->changed_p = 1; | |
| 6846 } | |
| 6847 closure->the_extent = extent; | |
| 6848 } | |
| 6849 | |
| 6850 /* Even if we're adding a prop, at this point, we want all other extents of | |
| 6851 this prop to go away (as now they overlap). So the theory here is that, | |
| 6852 when we are adding a prop to a region that has multiple (disjoint) | |
| 6853 occurrences of that prop in it already, we pick one of those and extend | |
| 6854 it, and remove the others. | |
| 6855 */ | |
| 6856 | |
| 6857 else if (EQ (extent, closure->the_extent)) | |
| 6858 { | |
| 6859 /* just in case map-extents hits it again (does that happen?) */ | |
| 6860 ; | |
| 6861 } | |
| 6862 else if (e_start >= start && e_end <= end) | |
| 6863 { | |
| 6864 /* Extent is contained in region; remove it. Don't destroy or modify | |
| 6865 it, because we don't want to change the attributes pointed to by the | |
| 6866 duplicates in the kill ring. | |
| 6867 */ | |
| 6868 extent_detach (e); | |
| 6869 closure->changed_p = 1; | |
| 6870 } | |
| 6871 else if (!NILP (closure->the_extent) && | |
| 6872 is_eq && | |
| 6873 e_start <= end && | |
| 6874 e_end >= start) | |
| 6875 { | |
| 6876 EXTENT te = XEXTENT (closure->the_extent); | |
| 6877 /* This extent overlaps, and has the same prop/value as the extent we've | |
| 6878 decided to reuse, so we can remove this existing extent as well (the | |
| 6879 whole thing, even the part outside of the region) and extend | |
| 6880 the-extent to cover it, resulting in the minimum number of extents in | |
| 6881 the buffer. | |
| 6882 */ | |
| 826 | 6883 Bytexpos the_start = extent_endpoint_byte (te, 0); |
| 6884 Bytexpos the_end = extent_endpoint_byte (te, 1); | |
| 428 | 6885 if (e_start != the_start && /* note AND not OR -- hmm, why is this |
| 6886 the case? I think it's because the | |
| 6887 assumption that the text-property | |
| 6888 extents don't overlap makes it | |
| 6889 OK; changing it to an OR would | |
| 6890 result in changed_p sometimes getting | |
| 6891 falsely marked. Is this bad? */ | |
| 6892 e_end != the_end) | |
| 6893 { | |
| 826 | 6894 Bytexpos new_start = min (e_start, the_start); |
| 6895 Bytexpos new_end = max (e_end, the_end); | |
| 428 | 6896 set_extent_endpoints (te, new_start, new_end, Qnil); |
| 6897 /* If we changed the endpoint, then we need to set its | |
| 6898 openness. We are setting the endpoint to be the same as | |
| 6899 that of the extent we're about to remove, and we assume | |
| 6900 (the invariant mentioned above) that extent has the | |
| 6901 proper endpoint setting, so we just use it. */ | |
| 6902 set_extent_openness (te, new_start != e_start ? | |
| 6903 (int) extent_start_open_p (e) : -1, | |
| 6904 new_end != e_end ? | |
| 6905 (int) extent_end_open_p (e) : -1); | |
| 6906 closure->changed_p = 1; | |
| 6907 } | |
| 6908 extent_detach (e); | |
| 6909 } | |
| 6910 else if (e_end <= end) | |
| 6911 { | |
| 6912 /* Extent begins before start but ends before end, so we can just | |
| 6913 decrease its end position. | |
| 6914 */ | |
| 6915 if (e_end != start) | |
| 6916 { | |
| 6917 set_extent_endpoints (e, e_start, start, Qnil); | |
| 826 | 6918 set_extent_openness (e, -1, |
| 6919 NILP (get_char_property | |
| 6920 (prev_bytexpos (object, start), | |
| 6921 Qend_closed, object, | |
| 6922 EXTENT_AT_AFTER, 1))); | |
| 428 | 6923 closure->changed_p = 1; |
| 6924 } | |
| 6925 } | |
| 6926 else if (e_start >= start) | |
| 6927 { | |
| 6928 /* Extent ends after end but begins after start, so we can just | |
| 6929 increase its start position. | |
| 6930 */ | |
| 6931 if (e_start != end) | |
| 6932 { | |
| 6933 set_extent_endpoints (e, end, e_end, Qnil); | |
| 826 | 6934 set_extent_openness (e, !NILP (get_char_property |
| 428 | 6935 (end, Qstart_open, object, |
| 6936 EXTENT_AT_AFTER, 1)), -1); | |
| 6937 closure->changed_p = 1; | |
| 6938 } | |
| 6939 } | |
| 6940 else | |
| 6941 { | |
| 6942 /* Otherwise, `extent' straddles the region. We need to split it. | |
| 6943 */ | |
| 6944 set_extent_endpoints (e, e_start, start, Qnil); | |
| 826 | 6945 set_extent_openness (e, -1, NILP (get_char_property |
| 6946 (prev_bytexpos (object, start), | |
| 6947 Qend_closed, object, | |
| 428 | 6948 EXTENT_AT_AFTER, 1))); |
| 6949 set_extent_openness (copy_extent (e, end, e_end, extent_object (e)), | |
| 826 | 6950 !NILP (get_char_property |
| 428 | 6951 (end, Qstart_open, object, |
| 6952 EXTENT_AT_AFTER, 1)), -1); | |
| 6953 closure->changed_p = 1; | |
| 6954 } | |
| 6955 | |
| 6956 return 0; /* to continue mapping. */ | |
| 6957 } | |
| 6958 | |
| 6959 static int | |
| 6960 put_text_prop_openness_mapper (EXTENT e, void *arg) | |
| 6961 { | |
| 6962 struct put_text_prop_arg *closure = (struct put_text_prop_arg *) arg; | |
| 826 | 6963 Bytexpos e_start, e_end; |
| 6964 Bytexpos start = closure->start; | |
| 6965 Bytexpos end = closure->end; | |
| 793 | 6966 Lisp_Object extent = wrap_extent (e); |
| 6967 | |
| 826 | 6968 e_start = extent_endpoint_byte (e, 0); |
| 6969 e_end = extent_endpoint_byte (e, 1); | |
| 428 | 6970 |
| 6971 if (NILP (Fextent_property (extent, Qtext_prop, Qnil))) | |
| 6972 { | |
| 6973 /* It's not a text-property extent; do nothing. */ | |
| 6974 ; | |
| 6975 } | |
| 6976 /* Note end conditions and NILP/!NILP's carefully. */ | |
| 6977 else if (EQ (closure->prop, Qstart_open) | |
| 6978 && e_start >= start && e_start < end) | |
| 6979 set_extent_openness (e, !NILP (closure->value), -1); | |
| 6980 else if (EQ (closure->prop, Qend_closed) | |
| 6981 && e_end > start && e_end <= end) | |
| 6982 set_extent_openness (e, -1, NILP (closure->value)); | |
| 6983 | |
| 6984 return 0; /* to continue mapping. */ | |
| 6985 } | |
| 6986 | |
| 6987 static int | |
| 826 | 6988 put_text_prop (Bytexpos start, Bytexpos end, Lisp_Object object, |
| 428 | 6989 Lisp_Object prop, Lisp_Object value, |
| 6990 int duplicable_p) | |
| 6991 { | |
| 6992 /* This function can GC */ | |
| 6993 struct put_text_prop_arg closure; | |
| 6994 | |
| 6995 if (start == end) /* There are no characters in the region. */ | |
| 6996 return 0; | |
| 6997 | |
| 6998 /* convert to the non-default versions, since a nil property is | |
| 6999 the same as it not being present. */ | |
| 7000 if (EQ (prop, Qstart_closed)) | |
| 7001 { | |
| 7002 prop = Qstart_open; | |
| 7003 value = NILP (value) ? Qt : Qnil; | |
| 7004 } | |
| 7005 else if (EQ (prop, Qend_open)) | |
| 7006 { | |
| 7007 prop = Qend_closed; | |
| 7008 value = NILP (value) ? Qt : Qnil; | |
| 7009 } | |
| 7010 | |
| 7011 value = canonicalize_extent_property (prop, value); | |
| 7012 | |
| 7013 closure.prop = prop; | |
| 7014 closure.value = value; | |
| 7015 closure.start = start; | |
| 7016 closure.end = end; | |
| 7017 closure.object = object; | |
| 7018 closure.changed_p = 0; | |
| 7019 closure.the_extent = Qnil; | |
| 7020 | |
| 826 | 7021 map_extents (start, end, |
| 7022 put_text_prop_mapper, | |
| 7023 (void *) &closure, object, 0, | |
| 7024 /* get all extents that abut the region */ | |
| 7025 ME_ALL_EXTENTS_CLOSED | ME_END_CLOSED | | |
| 7026 #if 0 | |
| 7027 /* it might move the SOE because the callback function calls | |
| 7028 get_char_property(), which calls extent_at(), which calls | |
| 7029 map_extents() | |
| 7030 | |
| 7031 #### this was comment out before, and nothing seemed broken; | |
| 7032 #### but when I added the above comment and uncommented it, | |
| 7033 #### text property operations (e.g. font-lock) suddenly | |
| 7034 #### became *WAY* slow, and dominated font-lock, when a | |
| 7035 #### single extent spanning the entire buffer | |
| 7036 #### existed. --ben */ | |
| 7037 ME_MIGHT_MOVE_SOE | | |
| 7038 #endif | |
| 7039 /* it might QUIT or error if the user has | |
| 7040 fucked with the extent plist. */ | |
| 7041 ME_MIGHT_THROW | | |
| 7042 ME_MIGHT_MODIFY_EXTENTS); | |
| 428 | 7043 |
| 7044 /* If we made it through the loop without reusing an extent | |
| 7045 (and we want there to be one) make it now. | |
| 7046 */ | |
| 7047 if (!NILP (value) && NILP (closure.the_extent)) | |
| 7048 { | |
| 826 | 7049 Lisp_Object extent = |
| 7050 wrap_extent (make_extent (object, start, end)); | |
| 793 | 7051 |
| 428 | 7052 closure.changed_p = 1; |
| 7053 Fset_extent_property (extent, Qtext_prop, prop); | |
| 7054 Fset_extent_property (extent, prop, value); | |
| 7055 if (duplicable_p) | |
| 7056 { | |
| 7057 extent_duplicable_p (XEXTENT (extent)) = 1; | |
| 7058 Fset_extent_property (extent, Qpaste_function, | |
| 7059 Qtext_prop_extent_paste_function); | |
| 7060 } | |
| 7061 set_extent_openness (XEXTENT (extent), | |
| 826 | 7062 !NILP (get_char_property |
| 428 | 7063 (start, Qstart_open, object, |
| 7064 EXTENT_AT_AFTER, 1)), | |
| 826 | 7065 NILP (get_char_property |
| 7066 (prev_bytexpos (object, end), | |
| 7067 Qend_closed, object, | |
| 428 | 7068 EXTENT_AT_AFTER, 1))); |
| 7069 } | |
| 7070 | |
| 7071 if (EQ (prop, Qstart_open) || EQ (prop, Qend_closed)) | |
| 7072 { | |
| 826 | 7073 map_extents (start, end, put_text_prop_openness_mapper, |
| 7074 (void *) &closure, object, 0, | |
| 7075 /* get all extents that abut the region */ | |
| 7076 ME_ALL_EXTENTS_CLOSED | ME_END_CLOSED | | |
| 7077 ME_MIGHT_MODIFY_EXTENTS); | |
| 428 | 7078 } |
| 7079 | |
| 7080 return closure.changed_p; | |
| 7081 } | |
| 7082 | |
| 7083 DEFUN ("put-text-property", Fput_text_property, 4, 5, 0, /* | |
| 7084 Adds the given property/value to all characters in the specified region. | |
| 7085 The property is conceptually attached to the characters rather than the | |
| 7086 region. The properties are copied when the characters are copied/pasted. | |
| 7087 Fifth argument OBJECT is the buffer or string containing the text, and | |
| 7088 defaults to the current buffer. | |
| 7089 */ | |
| 7090 (start, end, prop, value, object)) | |
| 7091 { | |
| 7092 /* This function can GC */ | |
| 826 | 7093 Bytexpos s, e; |
| 428 | 7094 |
| 7095 object = decode_buffer_or_string (object); | |
| 7096 get_buffer_or_string_range_byte (object, start, end, &s, &e, 0); | |
| 7097 put_text_prop (s, e, object, prop, value, 1); | |
| 7098 return prop; | |
| 7099 } | |
| 7100 | |
| 7101 DEFUN ("put-nonduplicable-text-property", Fput_nonduplicable_text_property, | |
| 7102 4, 5, 0, /* | |
| 7103 Adds the given property/value to all characters in the specified region. | |
| 7104 The property is conceptually attached to the characters rather than the | |
| 7105 region, however the properties will not be copied when the characters | |
| 7106 are copied. | |
| 7107 Fifth argument OBJECT is the buffer or string containing the text, and | |
| 7108 defaults to the current buffer. | |
| 7109 */ | |
| 7110 (start, end, prop, value, object)) | |
| 7111 { | |
| 7112 /* This function can GC */ | |
| 826 | 7113 Bytexpos s, e; |
| 428 | 7114 |
| 7115 object = decode_buffer_or_string (object); | |
| 7116 get_buffer_or_string_range_byte (object, start, end, &s, &e, 0); | |
| 7117 put_text_prop (s, e, object, prop, value, 0); | |
| 7118 return prop; | |
| 7119 } | |
| 7120 | |
| 7121 DEFUN ("add-text-properties", Fadd_text_properties, 3, 4, 0, /* | |
| 7122 Add properties to the characters from START to END. | |
| 7123 The third argument PROPS is a property list specifying the property values | |
| 7124 to add. The optional fourth argument, OBJECT, is the buffer or string | |
| 7125 containing the text and defaults to the current buffer. Returns t if | |
| 7126 any property was changed, nil otherwise. | |
| 7127 */ | |
| 7128 (start, end, props, object)) | |
| 7129 { | |
| 7130 /* This function can GC */ | |
| 7131 int changed = 0; | |
| 826 | 7132 Bytexpos s, e; |
| 428 | 7133 |
| 7134 object = decode_buffer_or_string (object); | |
| 7135 get_buffer_or_string_range_byte (object, start, end, &s, &e, 0); | |
| 7136 CHECK_LIST (props); | |
| 7137 for (; !NILP (props); props = Fcdr (Fcdr (props))) | |
| 7138 { | |
| 7139 Lisp_Object prop = XCAR (props); | |
| 7140 Lisp_Object value = Fcar (XCDR (props)); | |
| 7141 changed |= put_text_prop (s, e, object, prop, value, 1); | |
| 7142 } | |
| 7143 return changed ? Qt : Qnil; | |
| 7144 } | |
| 7145 | |
| 7146 | |
| 7147 DEFUN ("add-nonduplicable-text-properties", Fadd_nonduplicable_text_properties, | |
| 7148 3, 4, 0, /* | |
| 7149 Add nonduplicable properties to the characters from START to END. | |
| 7150 \(The properties will not be copied when the characters are copied.) | |
| 7151 The third argument PROPS is a property list specifying the property values | |
| 7152 to add. The optional fourth argument, OBJECT, is the buffer or string | |
| 7153 containing the text and defaults to the current buffer. Returns t if | |
| 7154 any property was changed, nil otherwise. | |
| 7155 */ | |
| 7156 (start, end, props, object)) | |
| 7157 { | |
| 7158 /* This function can GC */ | |
| 7159 int changed = 0; | |
| 826 | 7160 Bytexpos s, e; |
| 428 | 7161 |
| 7162 object = decode_buffer_or_string (object); | |
| 7163 get_buffer_or_string_range_byte (object, start, end, &s, &e, 0); | |
| 7164 CHECK_LIST (props); | |
| 7165 for (; !NILP (props); props = Fcdr (Fcdr (props))) | |
| 7166 { | |
| 7167 Lisp_Object prop = XCAR (props); | |
| 7168 Lisp_Object value = Fcar (XCDR (props)); | |
| 7169 changed |= put_text_prop (s, e, object, prop, value, 0); | |
| 7170 } | |
| 7171 return changed ? Qt : Qnil; | |
| 7172 } | |
| 7173 | |
| 7174 DEFUN ("remove-text-properties", Fremove_text_properties, 3, 4, 0, /* | |
| 7175 Remove the given properties from all characters in the specified region. | |
| 7176 PROPS should be a plist, but the values in that plist are ignored (treated | |
| 7177 as nil). Returns t if any property was changed, nil otherwise. | |
| 7178 Fourth argument OBJECT is the buffer or string containing the text, and | |
| 7179 defaults to the current buffer. | |
| 7180 */ | |
| 7181 (start, end, props, object)) | |
| 7182 { | |
| 7183 /* This function can GC */ | |
| 7184 int changed = 0; | |
| 826 | 7185 Bytexpos s, e; |
| 428 | 7186 |
| 7187 object = decode_buffer_or_string (object); | |
| 7188 get_buffer_or_string_range_byte (object, start, end, &s, &e, 0); | |
| 7189 CHECK_LIST (props); | |
| 7190 for (; !NILP (props); props = Fcdr (Fcdr (props))) | |
| 7191 { | |
| 7192 Lisp_Object prop = XCAR (props); | |
| 7193 changed |= put_text_prop (s, e, object, prop, Qnil, 1); | |
| 7194 } | |
| 7195 return changed ? Qt : Qnil; | |
| 7196 } | |
| 7197 | |
| 7198 /* Whenever a text-prop extent is pasted into a buffer (via `yank' or `insert' | |
| 7199 or whatever) we attach the properties to the buffer by calling | |
| 7200 `put-text-property' instead of by simply allowing the extent to be copied or | |
| 7201 re-attached. Then we return nil, telling the extents code not to attach it | |
| 7202 again. By handing the insertion hackery in this way, we make kill/yank | |
| 7203 behave consistently with put-text-property and not fragment the extents | |
| 7204 (since text-prop extents must partition, not overlap). | |
| 7205 | |
| 7206 The lisp implementation of this was probably fast enough, but since I moved | |
| 7207 the rest of the put-text-prop code here, I moved this as well for | |
| 7208 completeness. | |
| 7209 */ | |
| 7210 DEFUN ("text-prop-extent-paste-function", Ftext_prop_extent_paste_function, | |
| 7211 3, 3, 0, /* | |
| 7212 Used as the `paste-function' property of `text-prop' extents. | |
| 7213 */ | |
| 7214 (extent, from, to)) | |
| 7215 { | |
| 7216 /* This function can GC */ | |
| 7217 Lisp_Object prop, val; | |
| 7218 | |
| 7219 prop = Fextent_property (extent, Qtext_prop, Qnil); | |
| 7220 if (NILP (prop)) | |
| 563 | 7221 signal_error (Qinternal_error, |
| 442 | 7222 "Internal error: no text-prop", extent); |
| 428 | 7223 val = Fextent_property (extent, prop, Qnil); |
| 7224 #if 0 | |
| 7225 /* removed by bill perry, 2/9/97 | |
| 7226 ** This little bit of code would not allow you to have a text property | |
| 7227 ** with a value of Qnil. This is bad bad bad. | |
| 7228 */ | |
| 7229 if (NILP (val)) | |
| 563 | 7230 signal_error_2 (Qinternal_error, |
| 442 | 7231 "Internal error: no text-prop", |
| 7232 extent, prop); | |
| 428 | 7233 #endif |
| 7234 Fput_text_property (from, to, prop, val, Qnil); | |
| 7235 return Qnil; /* important! */ | |
| 7236 } | |
| 7237 | |
| 826 | 7238 Bytexpos |
| 2506 | 7239 next_previous_single_property_change (Bytexpos pos, Lisp_Object prop, |
| 7240 Lisp_Object object, Bytexpos limit, | |
| 7241 Boolint next, Boolint text_props_only) | |
| 826 | 7242 { |
| 7243 Lisp_Object extent, value; | |
| 7244 int limit_was_nil; | |
| 2506 | 7245 enum extent_at_flag at_flag = next ? EXTENT_AT_AFTER : EXTENT_AT_BEFORE; |
| 826 | 7246 if (limit < 0) |
| 7247 { | |
| 2506 | 7248 limit = (next ? buffer_or_string_accessible_end_byte : |
| 7249 buffer_or_string_accessible_begin_byte) (object); | |
| 826 | 7250 limit_was_nil = 1; |
| 7251 } | |
| 7252 else | |
| 7253 limit_was_nil = 0; | |
| 7254 | |
| 2506 | 7255 /* Retrieve initial property value to compare against */ |
| 7256 extent = extent_at (pos, object, prop, 0, at_flag, 0); | |
| 7257 /* If we only want text-prop extents, ignore all others */ | |
| 7258 if (text_props_only && !NILP (extent) && | |
| 7259 NILP (Fextent_property (extent, Qtext_prop, Qnil))) | |
| 7260 extent = Qnil; | |
| 826 | 7261 if (!NILP (extent)) |
| 7262 value = Fextent_property (extent, prop, Qnil); | |
| 7263 else | |
| 7264 value = Qnil; | |
| 7265 | |
| 7266 while (1) | |
| 7267 { | |
| 2506 | 7268 pos = (next ? extent_find_end_of_run : extent_find_beginning_of_run) |
| 7269 (object, pos, 1); | |
| 7270 if (next ? pos >= limit : pos <= limit) | |
| 7271 break; /* property is the same all the way to the beginning/end */ | |
| 7272 extent = extent_at (pos, object, prop, 0, at_flag, 0); | |
| 7273 /* If we only want text-prop extents, ignore all others */ | |
| 7274 if (text_props_only && !NILP (extent) && | |
| 7275 NILP (Fextent_property (extent, Qtext_prop, Qnil))) | |
| 7276 extent = Qnil; | |
| 826 | 7277 if ((NILP (extent) && !NILP (value)) || |
| 7278 (!NILP (extent) && !EQ (value, | |
| 7279 Fextent_property (extent, prop, Qnil)))) | |
| 7280 return pos; | |
| 7281 } | |
| 7282 | |
| 7283 if (limit_was_nil) | |
| 7284 return -1; | |
| 7285 else | |
| 7286 return limit; | |
| 7287 } | |
| 7288 | |
| 2506 | 7289 static Lisp_Object |
| 7290 next_previous_single_property_change_fn (Lisp_Object pos, Lisp_Object prop, | |
| 7291 Lisp_Object object, Lisp_Object limit, | |
| 7292 Boolint next, Boolint text_props_only) | |
| 7293 { | |
| 7294 Bytexpos xpos; | |
| 7295 Bytexpos blim; | |
| 7296 | |
| 7297 object = decode_buffer_or_string (object); | |
| 7298 xpos = get_buffer_or_string_pos_byte (object, pos, 0); | |
| 7299 blim = !NILP (limit) ? get_buffer_or_string_pos_byte (object, limit, 0) : -1; | |
| 7300 blim = next_previous_single_property_change (xpos, prop, object, blim, | |
| 7301 next, text_props_only); | |
| 7302 | |
| 7303 if (blim < 0) | |
| 7304 return Qnil; | |
| 826 | 7305 else |
| 2506 | 7306 return make_int (buffer_or_string_bytexpos_to_charxpos (object, blim)); |
| 826 | 7307 } |
| 428 | 7308 |
| 7309 DEFUN ("next-single-property-change", Fnext_single_property_change, | |
| 7310 2, 4, 0, /* | |
| 7311 Return the position of next property change for a specific property. | |
| 7312 Scans characters forward from POS till it finds a change in the PROP | |
| 7313 property, then returns the position of the change. The optional third | |
| 7314 argument OBJECT is the buffer or string to scan (defaults to the current | |
| 7315 buffer). | |
| 7316 The property values are compared with `eq'. | |
| 444 | 7317 Return nil if the property is constant all the way to the end of OBJECT. |
| 428 | 7318 If the value is non-nil, it is a position greater than POS, never equal. |
| 7319 | |
| 7320 If the optional fourth argument LIMIT is non-nil, don't search | |
| 7321 past position LIMIT; return LIMIT if nothing is found before LIMIT. | |
| 7322 If two or more extents with conflicting non-nil values for PROP overlap | |
| 7323 a particular character, it is undefined which value is considered to be | |
| 7324 the value of PROP. (Note that this situation will not happen if you always | |
| 7325 use the text-property primitives.) | |
| 2506 | 7326 |
| 7327 This function looks only at extents created using the text-property primitives. | |
| 7328 To look at all extents, use `next-single-char-property-change'. | |
| 428 | 7329 */ |
| 7330 (pos, prop, object, limit)) | |
| 7331 { | |
| 2506 | 7332 return next_previous_single_property_change_fn (pos, prop, object, limit, |
| 7333 1, 1); | |
| 826 | 7334 } |
| 428 | 7335 |
| 7336 DEFUN ("previous-single-property-change", Fprevious_single_property_change, | |
| 7337 2, 4, 0, /* | |
| 7338 Return the position of next property change for a specific property. | |
| 7339 Scans characters backward from POS till it finds a change in the PROP | |
| 7340 property, then returns the position of the change. The optional third | |
| 7341 argument OBJECT is the buffer or string to scan (defaults to the current | |
| 7342 buffer). | |
| 7343 The property values are compared with `eq'. | |
| 444 | 7344 Return nil if the property is constant all the way to the start of OBJECT. |
| 428 | 7345 If the value is non-nil, it is a position less than POS, never equal. |
| 7346 | |
| 7347 If the optional fourth argument LIMIT is non-nil, don't search back | |
| 7348 past position LIMIT; return LIMIT if nothing is found until LIMIT. | |
| 7349 If two or more extents with conflicting non-nil values for PROP overlap | |
| 7350 a particular character, it is undefined which value is considered to be | |
| 7351 the value of PROP. (Note that this situation will not happen if you always | |
| 7352 use the text-property primitives.) | |
| 2506 | 7353 |
| 7354 This function looks only at extents created using the text-property primitives. | |
| 7355 To look at all extents, use `next-single-char-property-change'. | |
| 7356 */ | |
| 7357 (pos, prop, object, limit)) | |
| 7358 { | |
| 7359 return next_previous_single_property_change_fn (pos, prop, object, limit, | |
| 7360 0, 1); | |
| 7361 } | |
| 7362 | |
| 7363 DEFUN ("next-single-char-property-change", Fnext_single_char_property_change, | |
| 7364 2, 4, 0, /* | |
| 7365 Return the position of next property change for a specific property. | |
| 7366 Scans characters forward from POS till it finds a change in the PROP | |
| 7367 property, then returns the position of the change. The optional third | |
| 7368 argument OBJECT is the buffer or string to scan (defaults to the current | |
| 7369 buffer). | |
| 7370 The property values are compared with `eq'. | |
| 7371 Return nil if the property is constant all the way to the end of OBJECT. | |
| 7372 If the value is non-nil, it is a position greater than POS, never equal. | |
| 7373 | |
| 7374 If the optional fourth argument LIMIT is non-nil, don't search | |
| 7375 past position LIMIT; return LIMIT if nothing is found before LIMIT. | |
| 7376 If two or more extents with conflicting non-nil values for PROP overlap | |
| 7377 a particular character, it is undefined which value is considered to be | |
| 7378 the value of PROP. (Note that this situation will not happen if you always | |
| 7379 use the text-property primitives.) | |
| 7380 | |
| 7381 This function looks at all extents. To look at only extents created using the | |
| 7382 text-property primitives, use `next-single-char-property-change'. | |
| 428 | 7383 */ |
| 7384 (pos, prop, object, limit)) | |
| 7385 { | |
| 2506 | 7386 return next_previous_single_property_change_fn (pos, prop, object, limit, |
| 7387 1, 0); | |
| 7388 } | |
| 7389 | |
| 7390 DEFUN ("previous-single-char-property-change", | |
| 7391 Fprevious_single_char_property_change, | |
| 7392 2, 4, 0, /* | |
| 7393 Return the position of next property change for a specific property. | |
| 7394 Scans characters backward from POS till it finds a change in the PROP | |
| 7395 property, then returns the position of the change. The optional third | |
| 7396 argument OBJECT is the buffer or string to scan (defaults to the current | |
| 7397 buffer). | |
| 7398 The property values are compared with `eq'. | |
| 7399 Return nil if the property is constant all the way to the start of OBJECT. | |
| 7400 If the value is non-nil, it is a position less than POS, never equal. | |
| 7401 | |
| 7402 If the optional fourth argument LIMIT is non-nil, don't search back | |
| 7403 past position LIMIT; return LIMIT if nothing is found until LIMIT. | |
| 7404 If two or more extents with conflicting non-nil values for PROP overlap | |
| 7405 a particular character, it is undefined which value is considered to be | |
| 7406 the value of PROP. (Note that this situation will not happen if you always | |
| 7407 use the text-property primitives.) | |
| 7408 | |
| 7409 This function looks at all extents. To look at only extents created using the | |
| 7410 text-property primitives, use `next-single-char-property-change'. | |
| 7411 */ | |
| 7412 (pos, prop, object, limit)) | |
| 7413 { | |
| 7414 return next_previous_single_property_change_fn (pos, prop, object, limit, | |
| 7415 0, 0); | |
| 428 | 7416 } |
| 7417 | |
| 7418 #ifdef MEMORY_USAGE_STATS | |
| 7419 | |
| 7420 int | |
| 2286 | 7421 compute_buffer_extent_usage (struct buffer *UNUSED (b), |
| 7422 struct overhead_stats *UNUSED (ovstats)) | |
| 428 | 7423 { |
| 7424 /* #### not yet written */ | |
| 7425 return 0; | |
| 7426 } | |
| 7427 | |
| 7428 #endif /* MEMORY_USAGE_STATS */ | |
| 7429 | |
| 7430 | |
| 7431 /************************************************************************/ | |
| 7432 /* initialization */ | |
| 7433 /************************************************************************/ | |
| 7434 | |
| 7435 void | |
| 7436 syms_of_extents (void) | |
| 7437 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
7438 INIT_LISP_OBJECT (extent); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
7439 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
|
7440 INIT_LISP_OBJECT (extent_auxiliary); |
| 3092 | 7441 #ifdef NEW_GC |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
7442 INIT_LISP_OBJECT (gap_array_marker); |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
7443 INIT_LISP_OBJECT (gap_array); |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
7444 INIT_LISP_OBJECT (extent_list_marker); |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
7445 INIT_LISP_OBJECT (extent_list); |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
7446 INIT_LISP_OBJECT (stack_of_extents); |
| 3263 | 7447 #endif /* NEW_GC */ |
| 442 | 7448 |
| 563 | 7449 DEFSYMBOL (Qextentp); |
| 7450 DEFSYMBOL (Qextent_live_p); | |
| 7451 | |
| 7452 DEFSYMBOL (Qall_extents_closed); | |
| 7453 DEFSYMBOL (Qall_extents_open); | |
| 7454 DEFSYMBOL (Qall_extents_closed_open); | |
| 7455 DEFSYMBOL (Qall_extents_open_closed); | |
| 7456 DEFSYMBOL (Qstart_in_region); | |
| 7457 DEFSYMBOL (Qend_in_region); | |
| 7458 DEFSYMBOL (Qstart_and_end_in_region); | |
| 7459 DEFSYMBOL (Qstart_or_end_in_region); | |
| 7460 DEFSYMBOL (Qnegate_in_region); | |
| 7461 | |
| 7462 DEFSYMBOL (Qdetached); | |
| 7463 DEFSYMBOL (Qdestroyed); | |
| 7464 DEFSYMBOL (Qbegin_glyph); | |
| 7465 DEFSYMBOL (Qend_glyph); | |
| 7466 DEFSYMBOL (Qstart_open); | |
| 7467 DEFSYMBOL (Qend_open); | |
| 7468 DEFSYMBOL (Qstart_closed); | |
| 7469 DEFSYMBOL (Qend_closed); | |
| 7470 DEFSYMBOL (Qread_only); | |
| 7471 /* DEFSYMBOL (Qhighlight); in faces.c */ | |
| 7472 DEFSYMBOL (Qunique); | |
| 7473 DEFSYMBOL (Qduplicable); | |
| 7474 DEFSYMBOL (Qdetachable); | |
| 7475 DEFSYMBOL (Qpriority); | |
| 7476 DEFSYMBOL (Qmouse_face); | |
| 7477 DEFSYMBOL (Qinitial_redisplay_function); | |
| 7478 | |
| 7479 | |
| 7480 DEFSYMBOL (Qglyph_layout); /* backwards compatibility */ | |
| 7481 DEFSYMBOL (Qbegin_glyph_layout); | |
| 7482 DEFSYMBOL (Qend_glyph_layout); | |
| 7483 DEFSYMBOL (Qoutside_margin); | |
| 7484 DEFSYMBOL (Qinside_margin); | |
| 7485 DEFSYMBOL (Qwhitespace); | |
| 428 | 7486 /* Qtext defined in general.c */ |
| 7487 | |
| 563 | 7488 DEFSYMBOL (Qpaste_function); |
| 7489 DEFSYMBOL (Qcopy_function); | |
| 7490 | |
| 7491 DEFSYMBOL (Qtext_prop); | |
| 7492 DEFSYMBOL (Qtext_prop_extent_paste_function); | |
| 428 | 7493 |
| 7494 DEFSUBR (Fextentp); | |
| 7495 DEFSUBR (Fextent_live_p); | |
| 7496 DEFSUBR (Fextent_detached_p); | |
| 7497 DEFSUBR (Fextent_start_position); | |
| 7498 DEFSUBR (Fextent_end_position); | |
| 7499 DEFSUBR (Fextent_object); | |
| 7500 DEFSUBR (Fextent_length); | |
| 7501 | |
| 7502 DEFSUBR (Fmake_extent); | |
| 7503 DEFSUBR (Fcopy_extent); | |
| 7504 DEFSUBR (Fdelete_extent); | |
| 7505 DEFSUBR (Fdetach_extent); | |
| 7506 DEFSUBR (Fset_extent_endpoints); | |
| 7507 DEFSUBR (Fnext_extent); | |
| 7508 DEFSUBR (Fprevious_extent); | |
| 1204 | 7509 #ifdef DEBUG_XEMACS |
| 428 | 7510 DEFSUBR (Fnext_e_extent); |
| 7511 DEFSUBR (Fprevious_e_extent); | |
| 7512 #endif | |
| 7513 DEFSUBR (Fnext_extent_change); | |
| 7514 DEFSUBR (Fprevious_extent_change); | |
| 7515 | |
| 7516 DEFSUBR (Fextent_parent); | |
| 7517 DEFSUBR (Fextent_children); | |
| 7518 DEFSUBR (Fset_extent_parent); | |
| 7519 | |
| 7520 DEFSUBR (Fextent_in_region_p); | |
| 7521 DEFSUBR (Fmap_extents); | |
| 7522 DEFSUBR (Fmap_extent_children); | |
| 7523 DEFSUBR (Fextent_at); | |
| 442 | 7524 DEFSUBR (Fextents_at); |
| 428 | 7525 |
| 7526 DEFSUBR (Fset_extent_initial_redisplay_function); | |
| 7527 DEFSUBR (Fextent_face); | |
| 7528 DEFSUBR (Fset_extent_face); | |
| 7529 DEFSUBR (Fextent_mouse_face); | |
| 7530 DEFSUBR (Fset_extent_mouse_face); | |
| 7531 DEFSUBR (Fset_extent_begin_glyph); | |
| 7532 DEFSUBR (Fset_extent_end_glyph); | |
| 7533 DEFSUBR (Fextent_begin_glyph); | |
| 7534 DEFSUBR (Fextent_end_glyph); | |
| 7535 DEFSUBR (Fset_extent_begin_glyph_layout); | |
| 7536 DEFSUBR (Fset_extent_end_glyph_layout); | |
| 7537 DEFSUBR (Fextent_begin_glyph_layout); | |
| 7538 DEFSUBR (Fextent_end_glyph_layout); | |
| 7539 DEFSUBR (Fset_extent_priority); | |
| 7540 DEFSUBR (Fextent_priority); | |
| 7541 DEFSUBR (Fset_extent_property); | |
| 7542 DEFSUBR (Fset_extent_properties); | |
| 7543 DEFSUBR (Fextent_property); | |
| 7544 DEFSUBR (Fextent_properties); | |
| 7545 | |
| 7546 DEFSUBR (Fhighlight_extent); | |
| 7547 DEFSUBR (Fforce_highlight_extent); | |
| 7548 | |
| 7549 DEFSUBR (Finsert_extent); | |
| 7550 | |
| 7551 DEFSUBR (Fget_text_property); | |
| 7552 DEFSUBR (Fget_char_property); | |
| 7553 DEFSUBR (Fput_text_property); | |
| 7554 DEFSUBR (Fput_nonduplicable_text_property); | |
| 7555 DEFSUBR (Fadd_text_properties); | |
| 7556 DEFSUBR (Fadd_nonduplicable_text_properties); | |
| 7557 DEFSUBR (Fremove_text_properties); | |
| 7558 DEFSUBR (Ftext_prop_extent_paste_function); | |
| 7559 DEFSUBR (Fnext_single_property_change); | |
| 7560 DEFSUBR (Fprevious_single_property_change); | |
| 2506 | 7561 DEFSUBR (Fnext_single_char_property_change); |
| 7562 DEFSUBR (Fprevious_single_char_property_change); | |
| 428 | 7563 } |
| 7564 | |
| 7565 void | |
| 7566 vars_of_extents (void) | |
| 7567 { | |
|
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
|
7568 #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
|
7569 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
|
7570 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
|
7571 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
|
7572 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
|
7573 */ ); |
|
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 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
|
7575 #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
|
7576 |
| 428 | 7577 DEFVAR_INT ("mouse-highlight-priority", &mouse_highlight_priority /* |
| 7578 The priority to use for the mouse-highlighting pseudo-extent | |
| 7579 that is used to highlight extents with the `mouse-face' attribute set. | |
| 7580 See `set-extent-priority'. | |
| 7581 */ ); | |
| 7582 /* Set mouse-highlight-priority (which ends up being used both for the | |
| 7583 mouse-highlighting pseudo-extent and the primary selection extent) | |
| 7584 to a very high value because very few extents should override it. | |
| 7585 1000 gives lots of room below it for different-prioritized extents. | |
| 7586 10 doesn't. ediff, for example, likes to use priorities around 100. | |
| 7587 --ben */ | |
| 7588 mouse_highlight_priority = /* 10 */ 1000; | |
| 7589 | |
| 7590 DEFVAR_LISP ("default-text-properties", &Vdefault_text_properties /* | |
| 7591 Property list giving default values for text properties. | |
| 7592 Whenever a character does not specify a value for a property, the value | |
| 7593 stored in this list is used instead. This only applies when the | |
| 7594 functions `get-text-property' or `get-char-property' are called. | |
| 7595 */ ); | |
| 7596 Vdefault_text_properties = Qnil; | |
| 7597 | |
| 7598 staticpro (&Vlast_highlighted_extent); | |
| 7599 Vlast_highlighted_extent = Qnil; | |
| 7600 | |
| 7601 Vextent_face_reusable_list = Fcons (Qnil, Qnil); | |
| 7602 staticpro (&Vextent_face_reusable_list); | |
| 771 | 7603 |
| 428 | 7604 staticpro (&Vextent_face_memoize_hash_table); |
| 7605 /* The memoize hash table maps from lists of symbols to lists of | |
| 7606 faces. It needs to be `equal' to implement the memoization. | |
| 7607 The reverse table maps in the other direction and just needs | |
| 7608 to do `eq' comparison because the lists of faces are already | |
| 7609 memoized. */ | |
| 7610 Vextent_face_memoize_hash_table = | |
| 7611 make_lisp_hash_table (100, HASH_TABLE_VALUE_WEAK, HASH_TABLE_EQUAL); | |
| 7612 staticpro (&Vextent_face_reverse_memoize_hash_table); | |
| 7613 Vextent_face_reverse_memoize_hash_table = | |
| 7614 make_lisp_hash_table (100, HASH_TABLE_KEY_WEAK, HASH_TABLE_EQ); | |
| 1292 | 7615 |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
7616 QSin_map_extents_internal = build_defer_string ("(in map-extents-internal)"); |
| 1292 | 7617 staticpro (&QSin_map_extents_internal); |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
7618 |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
7619 Vextent_auxiliary_defaults = |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
7620 allocate_extent_auxiliary (); |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
7621 staticpro (&Vextent_auxiliary_defaults); |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
7622 } |