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