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