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 }