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