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