comparison src/extents.c @ 428:3ecd8885ac67 r21-2-22

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