]> code.delx.au - gnu-emacs/blob - src/textprop.c
Use SAFE_ALLOCA etc. to avoid unbounded stack allocation.
[gnu-emacs] / src / textprop.c
1 /* Interface code for dealing with text properties.
2 Copyright (C) 1993-1995, 1997, 1999-2014 Free Software Foundation,
3 Inc.
4
5 This file is part of GNU Emacs.
6
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
11
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
19
20 #include <config.h>
21
22 #include "lisp.h"
23 #include "intervals.h"
24 #include "character.h"
25 #include "buffer.h"
26 #include "window.h"
27
28 /* Test for membership, allowing for t (actually any non-cons) to mean the
29 universal set. */
30
31 #define TMEM(sym, set) (CONSP (set) ? ! NILP (Fmemq (sym, set)) : ! NILP (set))
32 \f
33
34 /* NOTES: previous- and next- property change will have to skip
35 zero-length intervals if they are implemented. This could be done
36 inside next_interval and previous_interval.
37
38 set_properties needs to deal with the interval property cache.
39
40 It is assumed that for any interval plist, a property appears
41 only once on the list. Although some code i.e., remove_properties,
42 handles the more general case, the uniqueness of properties is
43 necessary for the system to remain consistent. This requirement
44 is enforced by the subrs installing properties onto the intervals. */
45
46 \f
47 /* Types of hooks. */
48 static Lisp_Object Qmouse_left;
49 static Lisp_Object Qmouse_entered;
50 Lisp_Object Qpoint_left;
51 Lisp_Object Qpoint_entered;
52 Lisp_Object Qcategory;
53 Lisp_Object Qlocal_map;
54
55 /* Visual properties text (including strings) may have. */
56 static Lisp_Object Qforeground, Qbackground, Qunderline;
57 Lisp_Object Qfont;
58 static Lisp_Object Qstipple;
59 Lisp_Object Qinvisible, Qintangible, Qmouse_face;
60 static Lisp_Object Qread_only;
61 Lisp_Object Qminibuffer_prompt;
62
63 enum property_set_type
64 {
65 TEXT_PROPERTY_REPLACE,
66 TEXT_PROPERTY_PREPEND,
67 TEXT_PROPERTY_APPEND
68 };
69
70 /* Sticky properties. */
71 Lisp_Object Qfront_sticky, Qrear_nonsticky;
72
73 /* If o1 is a cons whose cdr is a cons, return non-zero and set o2 to
74 the o1's cdr. Otherwise, return zero. This is handy for
75 traversing plists. */
76 #define PLIST_ELT_P(o1, o2) (CONSP (o1) && ((o2)=XCDR (o1), CONSP (o2)))
77
78 /* verify_interval_modification saves insertion hooks here
79 to be run later by report_interval_modification. */
80 static Lisp_Object interval_insert_behind_hooks;
81 static Lisp_Object interval_insert_in_front_hooks;
82
83
84 /* Signal a `text-read-only' error. This function makes it easier
85 to capture that error in GDB by putting a breakpoint on it. */
86
87 static _Noreturn void
88 text_read_only (Lisp_Object propval)
89 {
90 if (STRINGP (propval))
91 xsignal1 (Qtext_read_only, propval);
92
93 xsignal0 (Qtext_read_only);
94 }
95
96 /* Prepare to modify the text properties of BUFFER from START to END. */
97
98 static void
99 modify_text_properties (Lisp_Object buffer, Lisp_Object start, Lisp_Object end)
100 {
101 ptrdiff_t b = XINT (start), e = XINT (end);
102 struct buffer *buf = XBUFFER (buffer), *old = current_buffer;
103
104 set_buffer_internal (buf);
105
106 prepare_to_modify_buffer_1 (b, e, NULL);
107
108 BUF_COMPUTE_UNCHANGED (buf, b - 1, e);
109 if (MODIFF <= SAVE_MODIFF)
110 record_first_change ();
111 MODIFF++;
112
113 bset_point_before_scroll (current_buffer, Qnil);
114
115 set_buffer_internal (old);
116 }
117
118 /* Complain if object is not string or buffer type. */
119
120 static void
121 CHECK_STRING_OR_BUFFER (Lisp_Object x)
122 {
123 CHECK_TYPE (STRINGP (x) || BUFFERP (x), Qbuffer_or_string_p, x);
124 }
125
126 /* Extract the interval at the position pointed to by BEGIN from
127 OBJECT, a string or buffer. Additionally, check that the positions
128 pointed to by BEGIN and END are within the bounds of OBJECT, and
129 reverse them if *BEGIN is greater than *END. The objects pointed
130 to by BEGIN and END may be integers or markers; if the latter, they
131 are coerced to integers.
132
133 When OBJECT is a string, we increment *BEGIN and *END
134 to make them origin-one.
135
136 Note that buffer points don't correspond to interval indices.
137 For example, point-max is 1 greater than the index of the last
138 character. This difference is handled in the caller, which uses
139 the validated points to determine a length, and operates on that.
140 Exceptions are Ftext_properties_at, Fnext_property_change, and
141 Fprevious_property_change which call this function with BEGIN == END.
142 Handle this case specially.
143
144 If FORCE is soft (0), it's OK to return NULL. Otherwise,
145 create an interval tree for OBJECT if one doesn't exist, provided
146 the object actually contains text. In the current design, if there
147 is no text, there can be no text properties. */
148
149 #define soft 0
150 #define hard 1
151
152 INTERVAL
153 validate_interval_range (Lisp_Object object, Lisp_Object *begin,
154 Lisp_Object *end, bool force)
155 {
156 INTERVAL i;
157 ptrdiff_t searchpos;
158
159 CHECK_STRING_OR_BUFFER (object);
160 CHECK_NUMBER_COERCE_MARKER (*begin);
161 CHECK_NUMBER_COERCE_MARKER (*end);
162
163 /* If we are asked for a point, but from a subr which operates
164 on a range, then return nothing. */
165 if (EQ (*begin, *end) && begin != end)
166 return NULL;
167
168 if (XINT (*begin) > XINT (*end))
169 {
170 Lisp_Object n;
171 n = *begin;
172 *begin = *end;
173 *end = n;
174 }
175
176 if (BUFFERP (object))
177 {
178 register struct buffer *b = XBUFFER (object);
179
180 if (!(BUF_BEGV (b) <= XINT (*begin) && XINT (*begin) <= XINT (*end)
181 && XINT (*end) <= BUF_ZV (b)))
182 args_out_of_range (*begin, *end);
183 i = buffer_intervals (b);
184
185 /* If there's no text, there are no properties. */
186 if (BUF_BEGV (b) == BUF_ZV (b))
187 return NULL;
188
189 searchpos = XINT (*begin);
190 }
191 else
192 {
193 ptrdiff_t len = SCHARS (object);
194
195 if (! (0 <= XINT (*begin) && XINT (*begin) <= XINT (*end)
196 && XINT (*end) <= len))
197 args_out_of_range (*begin, *end);
198 XSETFASTINT (*begin, XFASTINT (*begin));
199 if (begin != end)
200 XSETFASTINT (*end, XFASTINT (*end));
201 i = string_intervals (object);
202
203 if (len == 0)
204 return NULL;
205
206 searchpos = XINT (*begin);
207 }
208
209 if (!i)
210 return (force ? create_root_interval (object) : i);
211
212 return find_interval (i, searchpos);
213 }
214
215 /* Validate LIST as a property list. If LIST is not a list, then
216 make one consisting of (LIST nil). Otherwise, verify that LIST
217 is even numbered and thus suitable as a plist. */
218
219 static Lisp_Object
220 validate_plist (Lisp_Object list)
221 {
222 if (NILP (list))
223 return Qnil;
224
225 if (CONSP (list))
226 {
227 bool odd_length = 0;
228 Lisp_Object tail;
229 for (tail = list; CONSP (tail); tail = XCDR (tail))
230 {
231 odd_length ^= 1;
232 QUIT;
233 }
234 if (odd_length)
235 error ("Odd length text property list");
236 return list;
237 }
238
239 return list2 (list, Qnil);
240 }
241
242 /* Return true if interval I has all the properties,
243 with the same values, of list PLIST. */
244
245 static bool
246 interval_has_all_properties (Lisp_Object plist, INTERVAL i)
247 {
248 Lisp_Object tail1, tail2;
249
250 /* Go through each element of PLIST. */
251 for (tail1 = plist; CONSP (tail1); tail1 = Fcdr (XCDR (tail1)))
252 {
253 Lisp_Object sym1 = XCAR (tail1);
254 bool found = 0;
255
256 /* Go through I's plist, looking for sym1 */
257 for (tail2 = i->plist; CONSP (tail2); tail2 = Fcdr (XCDR (tail2)))
258 if (EQ (sym1, XCAR (tail2)))
259 {
260 /* Found the same property on both lists. If the
261 values are unequal, return zero. */
262 if (! EQ (Fcar (XCDR (tail1)), Fcar (XCDR (tail2))))
263 return 0;
264
265 /* Property has same value on both lists; go to next one. */
266 found = 1;
267 break;
268 }
269
270 if (! found)
271 return 0;
272 }
273
274 return 1;
275 }
276
277 /* Return true if the plist of interval I has any of the
278 properties of PLIST, regardless of their values. */
279
280 static bool
281 interval_has_some_properties (Lisp_Object plist, INTERVAL i)
282 {
283 Lisp_Object tail1, tail2, sym;
284
285 /* Go through each element of PLIST. */
286 for (tail1 = plist; CONSP (tail1); tail1 = Fcdr (XCDR (tail1)))
287 {
288 sym = XCAR (tail1);
289
290 /* Go through i's plist, looking for tail1 */
291 for (tail2 = i->plist; CONSP (tail2); tail2 = Fcdr (XCDR (tail2)))
292 if (EQ (sym, XCAR (tail2)))
293 return 1;
294 }
295
296 return 0;
297 }
298
299 /* Return nonzero if the plist of interval I has any of the
300 property names in LIST, regardless of their values. */
301
302 static bool
303 interval_has_some_properties_list (Lisp_Object list, INTERVAL i)
304 {
305 Lisp_Object tail1, tail2, sym;
306
307 /* Go through each element of LIST. */
308 for (tail1 = list; CONSP (tail1); tail1 = XCDR (tail1))
309 {
310 sym = XCAR (tail1);
311
312 /* Go through i's plist, looking for tail1 */
313 for (tail2 = i->plist; CONSP (tail2); tail2 = XCDR (XCDR (tail2)))
314 if (EQ (sym, XCAR (tail2)))
315 return 1;
316 }
317
318 return 0;
319 }
320 \f
321 /* Changing the plists of individual intervals. */
322
323 /* Return the value of PROP in property-list PLIST, or Qunbound if it
324 has none. */
325 static Lisp_Object
326 property_value (Lisp_Object plist, Lisp_Object prop)
327 {
328 Lisp_Object value;
329
330 while (PLIST_ELT_P (plist, value))
331 if (EQ (XCAR (plist), prop))
332 return XCAR (value);
333 else
334 plist = XCDR (value);
335
336 return Qunbound;
337 }
338
339 /* Set the properties of INTERVAL to PROPERTIES,
340 and record undo info for the previous values.
341 OBJECT is the string or buffer that INTERVAL belongs to. */
342
343 static void
344 set_properties (Lisp_Object properties, INTERVAL interval, Lisp_Object object)
345 {
346 Lisp_Object sym, value;
347
348 if (BUFFERP (object))
349 {
350 /* For each property in the old plist which is missing from PROPERTIES,
351 or has a different value in PROPERTIES, make an undo record. */
352 for (sym = interval->plist;
353 PLIST_ELT_P (sym, value);
354 sym = XCDR (value))
355 if (! EQ (property_value (properties, XCAR (sym)),
356 XCAR (value)))
357 {
358 record_property_change (interval->position, LENGTH (interval),
359 XCAR (sym), XCAR (value),
360 object);
361 }
362
363 /* For each new property that has no value at all in the old plist,
364 make an undo record binding it to nil, so it will be removed. */
365 for (sym = properties;
366 PLIST_ELT_P (sym, value);
367 sym = XCDR (value))
368 if (EQ (property_value (interval->plist, XCAR (sym)), Qunbound))
369 {
370 record_property_change (interval->position, LENGTH (interval),
371 XCAR (sym), Qnil,
372 object);
373 }
374 }
375
376 /* Store new properties. */
377 set_interval_plist (interval, Fcopy_sequence (properties));
378 }
379
380 /* Add the properties of PLIST to the interval I, or set
381 the value of I's property to the value of the property on PLIST
382 if they are different.
383
384 OBJECT should be the string or buffer the interval is in.
385
386 Return true if this changes I (i.e., if any members of PLIST
387 are actually added to I's plist) */
388
389 static bool
390 add_properties (Lisp_Object plist, INTERVAL i, Lisp_Object object,
391 enum property_set_type set_type)
392 {
393 Lisp_Object tail1, tail2, sym1, val1;
394 bool changed = 0;
395 struct gcpro gcpro1, gcpro2, gcpro3;
396
397 tail1 = plist;
398 sym1 = Qnil;
399 val1 = Qnil;
400 /* No need to protect OBJECT, because we can GC only in the case
401 where it is a buffer, and live buffers are always protected.
402 I and its plist are also protected, via OBJECT. */
403 GCPRO3 (tail1, sym1, val1);
404
405 /* Go through each element of PLIST. */
406 for (tail1 = plist; CONSP (tail1); tail1 = Fcdr (XCDR (tail1)))
407 {
408 bool found = 0;
409 sym1 = XCAR (tail1);
410 val1 = Fcar (XCDR (tail1));
411
412 /* Go through I's plist, looking for sym1 */
413 for (tail2 = i->plist; CONSP (tail2); tail2 = Fcdr (XCDR (tail2)))
414 if (EQ (sym1, XCAR (tail2)))
415 {
416 /* No need to gcpro, because tail2 protects this
417 and it must be a cons cell (we get an error otherwise). */
418 register Lisp_Object this_cdr;
419
420 this_cdr = XCDR (tail2);
421 /* Found the property. Now check its value. */
422 found = 1;
423
424 /* The properties have the same value on both lists.
425 Continue to the next property. */
426 if (EQ (val1, Fcar (this_cdr)))
427 break;
428
429 /* Record this change in the buffer, for undo purposes. */
430 if (BUFFERP (object))
431 {
432 record_property_change (i->position, LENGTH (i),
433 sym1, Fcar (this_cdr), object);
434 }
435
436 /* I's property has a different value -- change it */
437 if (set_type == TEXT_PROPERTY_REPLACE)
438 Fsetcar (this_cdr, val1);
439 else {
440 if (CONSP (Fcar (this_cdr)) &&
441 /* Special-case anonymous face properties. */
442 (! EQ (sym1, Qface) ||
443 NILP (Fkeywordp (Fcar (Fcar (this_cdr))))))
444 /* The previous value is a list, so prepend (or
445 append) the new value to this list. */
446 if (set_type == TEXT_PROPERTY_PREPEND)
447 Fsetcar (this_cdr, Fcons (val1, Fcar (this_cdr)));
448 else
449 nconc2 (Fcar (this_cdr), list1 (val1));
450 else {
451 /* The previous value is a single value, so make it
452 into a list. */
453 if (set_type == TEXT_PROPERTY_PREPEND)
454 Fsetcar (this_cdr, list2 (val1, Fcar (this_cdr)));
455 else
456 Fsetcar (this_cdr, list2 (Fcar (this_cdr), val1));
457 }
458 }
459 changed = 1;
460 break;
461 }
462
463 if (! found)
464 {
465 /* Record this change in the buffer, for undo purposes. */
466 if (BUFFERP (object))
467 {
468 record_property_change (i->position, LENGTH (i),
469 sym1, Qnil, object);
470 }
471 set_interval_plist (i, Fcons (sym1, Fcons (val1, i->plist)));
472 changed = 1;
473 }
474 }
475
476 UNGCPRO;
477
478 return changed;
479 }
480
481 /* For any members of PLIST, or LIST,
482 which are properties of I, remove them from I's plist.
483 (If PLIST is non-nil, use that, otherwise use LIST.)
484 OBJECT is the string or buffer containing I. */
485
486 static bool
487 remove_properties (Lisp_Object plist, Lisp_Object list, INTERVAL i, Lisp_Object object)
488 {
489 Lisp_Object tail1, tail2, sym, current_plist;
490 bool changed = 0;
491
492 /* True means tail1 is a plist, otherwise it is a list. */
493 bool use_plist;
494
495 current_plist = i->plist;
496
497 if (! NILP (plist))
498 tail1 = plist, use_plist = 1;
499 else
500 tail1 = list, use_plist = 0;
501
502 /* Go through each element of LIST or PLIST. */
503 while (CONSP (tail1))
504 {
505 sym = XCAR (tail1);
506
507 /* First, remove the symbol if it's at the head of the list */
508 while (CONSP (current_plist) && EQ (sym, XCAR (current_plist)))
509 {
510 if (BUFFERP (object))
511 record_property_change (i->position, LENGTH (i),
512 sym, XCAR (XCDR (current_plist)),
513 object);
514
515 current_plist = XCDR (XCDR (current_plist));
516 changed = 1;
517 }
518
519 /* Go through I's plist, looking for SYM. */
520 tail2 = current_plist;
521 while (! NILP (tail2))
522 {
523 register Lisp_Object this;
524 this = XCDR (XCDR (tail2));
525 if (CONSP (this) && EQ (sym, XCAR (this)))
526 {
527 if (BUFFERP (object))
528 record_property_change (i->position, LENGTH (i),
529 sym, XCAR (XCDR (this)), object);
530
531 Fsetcdr (XCDR (tail2), XCDR (XCDR (this)));
532 changed = 1;
533 }
534 tail2 = this;
535 }
536
537 /* Advance thru TAIL1 one way or the other. */
538 tail1 = XCDR (tail1);
539 if (use_plist && CONSP (tail1))
540 tail1 = XCDR (tail1);
541 }
542
543 if (changed)
544 set_interval_plist (i, current_plist);
545 return changed;
546 }
547 \f
548 /* Returns the interval of POSITION in OBJECT.
549 POSITION is BEG-based. */
550
551 INTERVAL
552 interval_of (ptrdiff_t position, Lisp_Object object)
553 {
554 register INTERVAL i;
555 ptrdiff_t beg, end;
556
557 if (NILP (object))
558 XSETBUFFER (object, current_buffer);
559 else if (EQ (object, Qt))
560 return NULL;
561
562 CHECK_STRING_OR_BUFFER (object);
563
564 if (BUFFERP (object))
565 {
566 register struct buffer *b = XBUFFER (object);
567
568 beg = BUF_BEGV (b);
569 end = BUF_ZV (b);
570 i = buffer_intervals (b);
571 }
572 else
573 {
574 beg = 0;
575 end = SCHARS (object);
576 i = string_intervals (object);
577 }
578
579 if (!(beg <= position && position <= end))
580 args_out_of_range (make_number (position), make_number (position));
581 if (beg == end || !i)
582 return NULL;
583
584 return find_interval (i, position);
585 }
586 \f
587 DEFUN ("text-properties-at", Ftext_properties_at,
588 Stext_properties_at, 1, 2, 0,
589 doc: /* Return the list of properties of the character at POSITION in OBJECT.
590 If the optional second argument OBJECT is a buffer (or nil, which means
591 the current buffer), POSITION is a buffer position (integer or marker).
592 If OBJECT is a string, POSITION is a 0-based index into it.
593 If POSITION is at the end of OBJECT, the value is nil. */)
594 (Lisp_Object position, Lisp_Object object)
595 {
596 register INTERVAL i;
597
598 if (NILP (object))
599 XSETBUFFER (object, current_buffer);
600
601 i = validate_interval_range (object, &position, &position, soft);
602 if (!i)
603 return Qnil;
604 /* If POSITION is at the end of the interval,
605 it means it's the end of OBJECT.
606 There are no properties at the very end,
607 since no character follows. */
608 if (XINT (position) == LENGTH (i) + i->position)
609 return Qnil;
610
611 return i->plist;
612 }
613
614 DEFUN ("get-text-property", Fget_text_property, Sget_text_property, 2, 3, 0,
615 doc: /* Return the value of POSITION's property PROP, in OBJECT.
616 OBJECT should be a buffer or a string; if omitted or nil, it defaults
617 to the current buffer.
618 If POSITION is at the end of OBJECT, the value is nil. */)
619 (Lisp_Object position, Lisp_Object prop, Lisp_Object object)
620 {
621 return textget (Ftext_properties_at (position, object), prop);
622 }
623
624 /* Return the value of char's property PROP, in OBJECT at POSITION.
625 OBJECT is optional and defaults to the current buffer.
626 If OVERLAY is non-0, then in the case that the returned property is from
627 an overlay, the overlay found is returned in *OVERLAY, otherwise nil is
628 returned in *OVERLAY.
629 If POSITION is at the end of OBJECT, the value is nil.
630 If OBJECT is a buffer, then overlay properties are considered as well as
631 text properties.
632 If OBJECT is a window, then that window's buffer is used, but
633 window-specific overlays are considered only if they are associated
634 with OBJECT. */
635 Lisp_Object
636 get_char_property_and_overlay (Lisp_Object position, register Lisp_Object prop, Lisp_Object object, Lisp_Object *overlay)
637 {
638 struct window *w = 0;
639
640 CHECK_NUMBER_COERCE_MARKER (position);
641
642 if (NILP (object))
643 XSETBUFFER (object, current_buffer);
644
645 if (WINDOWP (object))
646 {
647 CHECK_LIVE_WINDOW (object);
648 w = XWINDOW (object);
649 object = w->contents;
650 }
651 if (BUFFERP (object))
652 {
653 ptrdiff_t noverlays;
654 Lisp_Object *overlay_vec;
655 struct buffer *obuf = current_buffer;
656
657 if (XINT (position) < BUF_BEGV (XBUFFER (object))
658 || XINT (position) > BUF_ZV (XBUFFER (object)))
659 xsignal1 (Qargs_out_of_range, position);
660
661 set_buffer_temp (XBUFFER (object));
662
663 USE_SAFE_ALLOCA;
664 GET_OVERLAYS_AT (XINT (position), overlay_vec, noverlays, NULL, 0);
665 noverlays = sort_overlays (overlay_vec, noverlays, w);
666
667 set_buffer_temp (obuf);
668
669 /* Now check the overlays in order of decreasing priority. */
670 while (--noverlays >= 0)
671 {
672 Lisp_Object tem = Foverlay_get (overlay_vec[noverlays], prop);
673 if (!NILP (tem))
674 {
675 if (overlay)
676 /* Return the overlay we got the property from. */
677 *overlay = overlay_vec[noverlays];
678 SAFE_FREE ();
679 return tem;
680 }
681 }
682 SAFE_FREE ();
683 }
684
685 if (overlay)
686 /* Indicate that the return value is not from an overlay. */
687 *overlay = Qnil;
688
689 /* Not a buffer, or no appropriate overlay, so fall through to the
690 simpler case. */
691 return Fget_text_property (position, prop, object);
692 }
693
694 DEFUN ("get-char-property", Fget_char_property, Sget_char_property, 2, 3, 0,
695 doc: /* Return the value of POSITION's property PROP, in OBJECT.
696 Both overlay properties and text properties are checked.
697 OBJECT is optional and defaults to the current buffer.
698 If POSITION is at the end of OBJECT, the value is nil.
699 If OBJECT is a buffer, then overlay properties are considered as well as
700 text properties.
701 If OBJECT is a window, then that window's buffer is used, but window-specific
702 overlays are considered only if they are associated with OBJECT. */)
703 (Lisp_Object position, Lisp_Object prop, Lisp_Object object)
704 {
705 return get_char_property_and_overlay (position, prop, object, 0);
706 }
707
708 DEFUN ("get-char-property-and-overlay", Fget_char_property_and_overlay,
709 Sget_char_property_and_overlay, 2, 3, 0,
710 doc: /* Like `get-char-property', but with extra overlay information.
711 The value is a cons cell. Its car is the return value of `get-char-property'
712 with the same arguments--that is, the value of POSITION's property
713 PROP in OBJECT. Its cdr is the overlay in which the property was
714 found, or nil, if it was found as a text property or not found at all.
715
716 OBJECT is optional and defaults to the current buffer. OBJECT may be
717 a string, a buffer or a window. For strings, the cdr of the return
718 value is always nil, since strings do not have overlays. If OBJECT is
719 a window, then that window's buffer is used, but window-specific
720 overlays are considered only if they are associated with OBJECT. If
721 POSITION is at the end of OBJECT, both car and cdr are nil. */)
722 (Lisp_Object position, Lisp_Object prop, Lisp_Object object)
723 {
724 Lisp_Object overlay;
725 Lisp_Object val
726 = get_char_property_and_overlay (position, prop, object, &overlay);
727 return Fcons (val, overlay);
728 }
729
730 \f
731 DEFUN ("next-char-property-change", Fnext_char_property_change,
732 Snext_char_property_change, 1, 2, 0,
733 doc: /* Return the position of next text property or overlay change.
734 This scans characters forward in the current buffer from POSITION till
735 it finds a change in some text property, or the beginning or end of an
736 overlay, and returns the position of that.
737 If none is found up to (point-max), the function returns (point-max).
738
739 If the optional second argument LIMIT is non-nil, don't search
740 past position LIMIT; return LIMIT if nothing is found before LIMIT.
741 LIMIT is a no-op if it is greater than (point-max). */)
742 (Lisp_Object position, Lisp_Object limit)
743 {
744 Lisp_Object temp;
745
746 temp = Fnext_overlay_change (position);
747 if (! NILP (limit))
748 {
749 CHECK_NUMBER_COERCE_MARKER (limit);
750 if (XINT (limit) < XINT (temp))
751 temp = limit;
752 }
753 return Fnext_property_change (position, Qnil, temp);
754 }
755
756 DEFUN ("previous-char-property-change", Fprevious_char_property_change,
757 Sprevious_char_property_change, 1, 2, 0,
758 doc: /* Return the position of previous text property or overlay change.
759 Scans characters backward in the current buffer from POSITION till it
760 finds a change in some text property, or the beginning or end of an
761 overlay, and returns the position of that.
762 If none is found since (point-min), the function returns (point-min).
763
764 If the optional second argument LIMIT is non-nil, don't search
765 past position LIMIT; return LIMIT if nothing is found before LIMIT.
766 LIMIT is a no-op if it is less than (point-min). */)
767 (Lisp_Object position, Lisp_Object limit)
768 {
769 Lisp_Object temp;
770
771 temp = Fprevious_overlay_change (position);
772 if (! NILP (limit))
773 {
774 CHECK_NUMBER_COERCE_MARKER (limit);
775 if (XINT (limit) > XINT (temp))
776 temp = limit;
777 }
778 return Fprevious_property_change (position, Qnil, temp);
779 }
780
781
782 DEFUN ("next-single-char-property-change", Fnext_single_char_property_change,
783 Snext_single_char_property_change, 2, 4, 0,
784 doc: /* Return the position of next text property or overlay change for a specific property.
785 Scans characters forward from POSITION till it finds
786 a change in the PROP property, then returns the position of the change.
787 If the optional third argument OBJECT is a buffer (or nil, which means
788 the current buffer), POSITION is a buffer position (integer or marker).
789 If OBJECT is a string, POSITION is a 0-based index into it.
790
791 In a string, scan runs to the end of the string.
792 In a buffer, it runs to (point-max), and the value cannot exceed that.
793
794 The property values are compared with `eq'.
795 If the property is constant all the way to the end of OBJECT, return the
796 last valid position in OBJECT.
797 If the optional fourth argument LIMIT is non-nil, don't search
798 past position LIMIT; return LIMIT if nothing is found before LIMIT. */)
799 (Lisp_Object position, Lisp_Object prop, Lisp_Object object, Lisp_Object limit)
800 {
801 if (STRINGP (object))
802 {
803 position = Fnext_single_property_change (position, prop, object, limit);
804 if (NILP (position))
805 {
806 if (NILP (limit))
807 position = make_number (SCHARS (object));
808 else
809 {
810 CHECK_NUMBER (limit);
811 position = limit;
812 }
813 }
814 }
815 else
816 {
817 Lisp_Object initial_value, value;
818 ptrdiff_t count = SPECPDL_INDEX ();
819
820 if (! NILP (object))
821 CHECK_BUFFER (object);
822
823 if (BUFFERP (object) && current_buffer != XBUFFER (object))
824 {
825 record_unwind_current_buffer ();
826 Fset_buffer (object);
827 }
828
829 CHECK_NUMBER_COERCE_MARKER (position);
830
831 initial_value = Fget_char_property (position, prop, object);
832
833 if (NILP (limit))
834 XSETFASTINT (limit, ZV);
835 else
836 CHECK_NUMBER_COERCE_MARKER (limit);
837
838 if (XFASTINT (position) >= XFASTINT (limit))
839 {
840 position = limit;
841 if (XFASTINT (position) > ZV)
842 XSETFASTINT (position, ZV);
843 }
844 else
845 while (1)
846 {
847 position = Fnext_char_property_change (position, limit);
848 if (XFASTINT (position) >= XFASTINT (limit))
849 {
850 position = limit;
851 break;
852 }
853
854 value = Fget_char_property (position, prop, object);
855 if (!EQ (value, initial_value))
856 break;
857 }
858
859 unbind_to (count, Qnil);
860 }
861
862 return position;
863 }
864
865 DEFUN ("previous-single-char-property-change",
866 Fprevious_single_char_property_change,
867 Sprevious_single_char_property_change, 2, 4, 0,
868 doc: /* Return the position of previous text property or overlay change for a specific property.
869 Scans characters backward from POSITION till it finds
870 a change in the PROP property, then returns the position of the change.
871 If the optional third argument OBJECT is a buffer (or nil, which means
872 the current buffer), POSITION is a buffer position (integer or marker).
873 If OBJECT is a string, POSITION is a 0-based index into it.
874
875 In a string, scan runs to the start of the string.
876 In a buffer, it runs to (point-min), and the value cannot be less than that.
877
878 The property values are compared with `eq'.
879 If the property is constant all the way to the start of OBJECT, return the
880 first valid position in OBJECT.
881 If the optional fourth argument LIMIT is non-nil, don't search back past
882 position LIMIT; return LIMIT if nothing is found before reaching LIMIT. */)
883 (Lisp_Object position, Lisp_Object prop, Lisp_Object object, Lisp_Object limit)
884 {
885 if (STRINGP (object))
886 {
887 position = Fprevious_single_property_change (position, prop, object, limit);
888 if (NILP (position))
889 {
890 if (NILP (limit))
891 position = make_number (0);
892 else
893 {
894 CHECK_NUMBER (limit);
895 position = limit;
896 }
897 }
898 }
899 else
900 {
901 ptrdiff_t count = SPECPDL_INDEX ();
902
903 if (! NILP (object))
904 CHECK_BUFFER (object);
905
906 if (BUFFERP (object) && current_buffer != XBUFFER (object))
907 {
908 record_unwind_current_buffer ();
909 Fset_buffer (object);
910 }
911
912 CHECK_NUMBER_COERCE_MARKER (position);
913
914 if (NILP (limit))
915 XSETFASTINT (limit, BEGV);
916 else
917 CHECK_NUMBER_COERCE_MARKER (limit);
918
919 if (XFASTINT (position) <= XFASTINT (limit))
920 {
921 position = limit;
922 if (XFASTINT (position) < BEGV)
923 XSETFASTINT (position, BEGV);
924 }
925 else
926 {
927 Lisp_Object initial_value
928 = Fget_char_property (make_number (XFASTINT (position) - 1),
929 prop, object);
930
931 while (1)
932 {
933 position = Fprevious_char_property_change (position, limit);
934
935 if (XFASTINT (position) <= XFASTINT (limit))
936 {
937 position = limit;
938 break;
939 }
940 else
941 {
942 Lisp_Object value
943 = Fget_char_property (make_number (XFASTINT (position) - 1),
944 prop, object);
945
946 if (!EQ (value, initial_value))
947 break;
948 }
949 }
950 }
951
952 unbind_to (count, Qnil);
953 }
954
955 return position;
956 }
957 \f
958 DEFUN ("next-property-change", Fnext_property_change,
959 Snext_property_change, 1, 3, 0,
960 doc: /* Return the position of next property change.
961 Scans characters forward from POSITION in OBJECT till it finds
962 a change in some text property, then returns the position of the change.
963 If the optional second argument OBJECT is a buffer (or nil, which means
964 the current buffer), POSITION is a buffer position (integer or marker).
965 If OBJECT is a string, POSITION is a 0-based index into it.
966 Return nil if the property is constant all the way to the end of OBJECT.
967 If the value is non-nil, it is a position greater than POSITION, never equal.
968
969 If the optional third argument LIMIT is non-nil, don't search
970 past position LIMIT; return LIMIT if nothing is found before LIMIT. */)
971 (Lisp_Object position, Lisp_Object object, Lisp_Object limit)
972 {
973 register INTERVAL i, next;
974
975 if (NILP (object))
976 XSETBUFFER (object, current_buffer);
977
978 if (!NILP (limit) && !EQ (limit, Qt))
979 CHECK_NUMBER_COERCE_MARKER (limit);
980
981 i = validate_interval_range (object, &position, &position, soft);
982
983 /* If LIMIT is t, return start of next interval--don't
984 bother checking further intervals. */
985 if (EQ (limit, Qt))
986 {
987 if (!i)
988 next = i;
989 else
990 next = next_interval (i);
991
992 if (!next)
993 XSETFASTINT (position, (STRINGP (object)
994 ? SCHARS (object)
995 : BUF_ZV (XBUFFER (object))));
996 else
997 XSETFASTINT (position, next->position);
998 return position;
999 }
1000
1001 if (!i)
1002 return limit;
1003
1004 next = next_interval (i);
1005
1006 while (next && intervals_equal (i, next)
1007 && (NILP (limit) || next->position < XFASTINT (limit)))
1008 next = next_interval (next);
1009
1010 if (!next
1011 || (next->position
1012 >= (INTEGERP (limit)
1013 ? XFASTINT (limit)
1014 : (STRINGP (object)
1015 ? SCHARS (object)
1016 : BUF_ZV (XBUFFER (object))))))
1017 return limit;
1018 else
1019 return make_number (next->position);
1020 }
1021
1022 DEFUN ("next-single-property-change", Fnext_single_property_change,
1023 Snext_single_property_change, 2, 4, 0,
1024 doc: /* Return the position of next property change for a specific property.
1025 Scans characters forward from POSITION till it finds
1026 a change in the PROP property, then returns the position of the change.
1027 If the optional third argument OBJECT is a buffer (or nil, which means
1028 the current buffer), POSITION is a buffer position (integer or marker).
1029 If OBJECT is a string, POSITION is a 0-based index into it.
1030 The property values are compared with `eq'.
1031 Return nil if the property is constant all the way to the end of OBJECT.
1032 If the value is non-nil, it is a position greater than POSITION, never equal.
1033
1034 If the optional fourth argument LIMIT is non-nil, don't search
1035 past position LIMIT; return LIMIT if nothing is found before LIMIT. */)
1036 (Lisp_Object position, Lisp_Object prop, Lisp_Object object, Lisp_Object limit)
1037 {
1038 register INTERVAL i, next;
1039 register Lisp_Object here_val;
1040
1041 if (NILP (object))
1042 XSETBUFFER (object, current_buffer);
1043
1044 if (!NILP (limit))
1045 CHECK_NUMBER_COERCE_MARKER (limit);
1046
1047 i = validate_interval_range (object, &position, &position, soft);
1048 if (!i)
1049 return limit;
1050
1051 here_val = textget (i->plist, prop);
1052 next = next_interval (i);
1053 while (next
1054 && EQ (here_val, textget (next->plist, prop))
1055 && (NILP (limit) || next->position < XFASTINT (limit)))
1056 next = next_interval (next);
1057
1058 if (!next
1059 || (next->position
1060 >= (INTEGERP (limit)
1061 ? XFASTINT (limit)
1062 : (STRINGP (object)
1063 ? SCHARS (object)
1064 : BUF_ZV (XBUFFER (object))))))
1065 return limit;
1066 else
1067 return make_number (next->position);
1068 }
1069
1070 DEFUN ("previous-property-change", Fprevious_property_change,
1071 Sprevious_property_change, 1, 3, 0,
1072 doc: /* Return the position of previous property change.
1073 Scans characters backwards from POSITION in OBJECT till it finds
1074 a change in some text property, then returns the position of the change.
1075 If the optional second argument OBJECT is a buffer (or nil, which means
1076 the current buffer), POSITION is a buffer position (integer or marker).
1077 If OBJECT is a string, POSITION is a 0-based index into it.
1078 Return nil if the property is constant all the way to the start of OBJECT.
1079 If the value is non-nil, it is a position less than POSITION, never equal.
1080
1081 If the optional third argument LIMIT is non-nil, don't search
1082 back past position LIMIT; return LIMIT if nothing is found until LIMIT. */)
1083 (Lisp_Object position, Lisp_Object object, Lisp_Object limit)
1084 {
1085 register INTERVAL i, previous;
1086
1087 if (NILP (object))
1088 XSETBUFFER (object, current_buffer);
1089
1090 if (!NILP (limit))
1091 CHECK_NUMBER_COERCE_MARKER (limit);
1092
1093 i = validate_interval_range (object, &position, &position, soft);
1094 if (!i)
1095 return limit;
1096
1097 /* Start with the interval containing the char before point. */
1098 if (i->position == XFASTINT (position))
1099 i = previous_interval (i);
1100
1101 previous = previous_interval (i);
1102 while (previous && intervals_equal (previous, i)
1103 && (NILP (limit)
1104 || (previous->position + LENGTH (previous) > XFASTINT (limit))))
1105 previous = previous_interval (previous);
1106
1107 if (!previous
1108 || (previous->position + LENGTH (previous)
1109 <= (INTEGERP (limit)
1110 ? XFASTINT (limit)
1111 : (STRINGP (object) ? 0 : BUF_BEGV (XBUFFER (object))))))
1112 return limit;
1113 else
1114 return make_number (previous->position + LENGTH (previous));
1115 }
1116
1117 DEFUN ("previous-single-property-change", Fprevious_single_property_change,
1118 Sprevious_single_property_change, 2, 4, 0,
1119 doc: /* Return the position of previous property change for a specific property.
1120 Scans characters backward from POSITION till it finds
1121 a change in the PROP property, then returns the position of the change.
1122 If the optional third argument OBJECT is a buffer (or nil, which means
1123 the current buffer), POSITION is a buffer position (integer or marker).
1124 If OBJECT is a string, POSITION is a 0-based index into it.
1125 The property values are compared with `eq'.
1126 Return nil if the property is constant all the way to the start of OBJECT.
1127 If the value is non-nil, it is a position less than POSITION, never equal.
1128
1129 If the optional fourth argument LIMIT is non-nil, don't search
1130 back past position LIMIT; return LIMIT if nothing is found until LIMIT. */)
1131 (Lisp_Object position, Lisp_Object prop, Lisp_Object object, Lisp_Object limit)
1132 {
1133 register INTERVAL i, previous;
1134 register Lisp_Object here_val;
1135
1136 if (NILP (object))
1137 XSETBUFFER (object, current_buffer);
1138
1139 if (!NILP (limit))
1140 CHECK_NUMBER_COERCE_MARKER (limit);
1141
1142 i = validate_interval_range (object, &position, &position, soft);
1143
1144 /* Start with the interval containing the char before point. */
1145 if (i && i->position == XFASTINT (position))
1146 i = previous_interval (i);
1147
1148 if (!i)
1149 return limit;
1150
1151 here_val = textget (i->plist, prop);
1152 previous = previous_interval (i);
1153 while (previous
1154 && EQ (here_val, textget (previous->plist, prop))
1155 && (NILP (limit)
1156 || (previous->position + LENGTH (previous) > XFASTINT (limit))))
1157 previous = previous_interval (previous);
1158
1159 if (!previous
1160 || (previous->position + LENGTH (previous)
1161 <= (INTEGERP (limit)
1162 ? XFASTINT (limit)
1163 : (STRINGP (object) ? 0 : BUF_BEGV (XBUFFER (object))))))
1164 return limit;
1165 else
1166 return make_number (previous->position + LENGTH (previous));
1167 }
1168 \f
1169 /* Used by add-text-properties and add-face-text-property. */
1170
1171 static Lisp_Object
1172 add_text_properties_1 (Lisp_Object start, Lisp_Object end,
1173 Lisp_Object properties, Lisp_Object object,
1174 enum property_set_type set_type) {
1175 INTERVAL i, unchanged;
1176 ptrdiff_t s, len;
1177 bool modified = 0;
1178 struct gcpro gcpro1;
1179 bool first_time = 1;
1180
1181 properties = validate_plist (properties);
1182 if (NILP (properties))
1183 return Qnil;
1184
1185 if (NILP (object))
1186 XSETBUFFER (object, current_buffer);
1187
1188 retry:
1189 i = validate_interval_range (object, &start, &end, hard);
1190 if (!i)
1191 return Qnil;
1192
1193 s = XINT (start);
1194 len = XINT (end) - s;
1195
1196 /* No need to protect OBJECT, because we GC only if it's a buffer,
1197 and live buffers are always protected. */
1198 GCPRO1 (properties);
1199
1200 /* If this interval already has the properties, we can skip it. */
1201 if (interval_has_all_properties (properties, i))
1202 {
1203 ptrdiff_t got = LENGTH (i) - (s - i->position);
1204
1205 do
1206 {
1207 if (got >= len)
1208 RETURN_UNGCPRO (Qnil);
1209 len -= got;
1210 i = next_interval (i);
1211 got = LENGTH (i);
1212 }
1213 while (interval_has_all_properties (properties, i));
1214 }
1215 else if (i->position != s)
1216 {
1217 /* If we're not starting on an interval boundary, we have to
1218 split this interval. */
1219 unchanged = i;
1220 i = split_interval_right (unchanged, s - unchanged->position);
1221 copy_properties (unchanged, i);
1222 }
1223
1224 if (BUFFERP (object) && first_time)
1225 {
1226 ptrdiff_t prev_total_length = TOTAL_LENGTH (i);
1227 ptrdiff_t prev_pos = i->position;
1228
1229 modify_text_properties (object, start, end);
1230 /* If someone called us recursively as a side effect of
1231 modify_text_properties, and changed the intervals behind our back
1232 (could happen if lock_file, called by prepare_to_modify_buffer,
1233 triggers redisplay, and that calls add-text-properties again
1234 in the same buffer), we cannot continue with I, because its
1235 data changed. So we restart the interval analysis anew. */
1236 if (TOTAL_LENGTH (i) != prev_total_length
1237 || i->position != prev_pos)
1238 {
1239 first_time = 0;
1240 goto retry;
1241 }
1242 }
1243
1244 /* We are at the beginning of interval I, with LEN chars to scan. */
1245 for (;;)
1246 {
1247 eassert (i != 0);
1248
1249 if (LENGTH (i) >= len)
1250 {
1251 /* We can UNGCPRO safely here, because there will be just
1252 one more chance to gc, in the next call to add_properties,
1253 and after that we will not need PROPERTIES or OBJECT again. */
1254 UNGCPRO;
1255
1256 if (interval_has_all_properties (properties, i))
1257 {
1258 if (BUFFERP (object))
1259 signal_after_change (XINT (start), XINT (end) - XINT (start),
1260 XINT (end) - XINT (start));
1261
1262 eassert (modified);
1263 return Qt;
1264 }
1265
1266 if (LENGTH (i) == len)
1267 {
1268 add_properties (properties, i, object, set_type);
1269 if (BUFFERP (object))
1270 signal_after_change (XINT (start), XINT (end) - XINT (start),
1271 XINT (end) - XINT (start));
1272 return Qt;
1273 }
1274
1275 /* i doesn't have the properties, and goes past the change limit */
1276 unchanged = i;
1277 i = split_interval_left (unchanged, len);
1278 copy_properties (unchanged, i);
1279 add_properties (properties, i, object, set_type);
1280 if (BUFFERP (object))
1281 signal_after_change (XINT (start), XINT (end) - XINT (start),
1282 XINT (end) - XINT (start));
1283 return Qt;
1284 }
1285
1286 len -= LENGTH (i);
1287 modified |= add_properties (properties, i, object, set_type);
1288 i = next_interval (i);
1289 }
1290 }
1291
1292 /* Callers note, this can GC when OBJECT is a buffer (or nil). */
1293
1294 DEFUN ("add-text-properties", Fadd_text_properties,
1295 Sadd_text_properties, 3, 4, 0,
1296 doc: /* Add properties to the text from START to END.
1297 The third argument PROPERTIES is a property list
1298 specifying the property values to add. If the optional fourth argument
1299 OBJECT is a buffer (or nil, which means the current buffer),
1300 START and END are buffer positions (integers or markers).
1301 If OBJECT is a string, START and END are 0-based indices into it.
1302 Return t if any property value actually changed, nil otherwise. */)
1303 (Lisp_Object start, Lisp_Object end, Lisp_Object properties,
1304 Lisp_Object object)
1305 {
1306 return add_text_properties_1 (start, end, properties, object,
1307 TEXT_PROPERTY_REPLACE);
1308 }
1309
1310 /* Callers note, this can GC when OBJECT is a buffer (or nil). */
1311
1312 DEFUN ("put-text-property", Fput_text_property,
1313 Sput_text_property, 4, 5, 0,
1314 doc: /* Set one property of the text from START to END.
1315 The third and fourth arguments PROPERTY and VALUE
1316 specify the property to add.
1317 If the optional fifth argument OBJECT is a buffer (or nil, which means
1318 the current buffer), START and END are buffer positions (integers or
1319 markers). If OBJECT is a string, START and END are 0-based indices into it. */)
1320 (Lisp_Object start, Lisp_Object end, Lisp_Object property, Lisp_Object value, Lisp_Object object)
1321 {
1322 Fadd_text_properties (start, end, list2 (property, value), object);
1323 return Qnil;
1324 }
1325
1326 DEFUN ("set-text-properties", Fset_text_properties,
1327 Sset_text_properties, 3, 4, 0,
1328 doc: /* Completely replace properties of text from START to END.
1329 The third argument PROPERTIES is the new property list.
1330 If the optional fourth argument OBJECT is a buffer (or nil, which means
1331 the current buffer), START and END are buffer positions (integers or
1332 markers). If OBJECT is a string, START and END are 0-based indices into it.
1333 If PROPERTIES is nil, the effect is to remove all properties from
1334 the designated part of OBJECT. */)
1335 (Lisp_Object start, Lisp_Object end, Lisp_Object properties, Lisp_Object object)
1336 {
1337 return set_text_properties (start, end, properties, object, Qt);
1338 }
1339
1340
1341 DEFUN ("add-face-text-property", Fadd_face_text_property,
1342 Sadd_face_text_property, 3, 5, 0,
1343 doc: /* Add the face property to the text from START to END.
1344 FACE specifies the face to add. It should be a valid value of the
1345 `face' property (typically a face name or a plist of face attributes
1346 and values).
1347
1348 If any text in the region already has a non-nil `face' property, those
1349 face(s) are retained. This is done by setting the `face' property to
1350 a list of faces, with FACE as the first element (by default) and the
1351 pre-existing faces as the remaining elements.
1352
1353 If optional fourth argument APPEND is non-nil, append FACE to the end
1354 of the face list instead.
1355
1356 If optional fifth argument OBJECT is a buffer (or nil, which means the
1357 current buffer), START and END are buffer positions (integers or
1358 markers). If OBJECT is a string, START and END are 0-based indices
1359 into it. */)
1360 (Lisp_Object start, Lisp_Object end, Lisp_Object face,
1361 Lisp_Object append, Lisp_Object object)
1362 {
1363 add_text_properties_1 (start, end, list2 (Qface, face), object,
1364 (NILP (append)
1365 ? TEXT_PROPERTY_PREPEND
1366 : TEXT_PROPERTY_APPEND));
1367 return Qnil;
1368 }
1369
1370 /* Replace properties of text from START to END with new list of
1371 properties PROPERTIES. OBJECT is the buffer or string containing
1372 the text. OBJECT nil means use the current buffer.
1373 COHERENT_CHANGE_P nil means this is being called as an internal
1374 subroutine, rather than as a change primitive with checking of
1375 read-only, invoking change hooks, etc.. Value is nil if the
1376 function _detected_ that it did not replace any properties, non-nil
1377 otherwise. */
1378
1379 Lisp_Object
1380 set_text_properties (Lisp_Object start, Lisp_Object end, Lisp_Object properties,
1381 Lisp_Object object, Lisp_Object coherent_change_p)
1382 {
1383 register INTERVAL i;
1384 Lisp_Object ostart, oend;
1385
1386 ostart = start;
1387 oend = end;
1388
1389 properties = validate_plist (properties);
1390
1391 if (NILP (object))
1392 XSETBUFFER (object, current_buffer);
1393
1394 /* If we want no properties for a whole string,
1395 get rid of its intervals. */
1396 if (NILP (properties) && STRINGP (object)
1397 && XFASTINT (start) == 0
1398 && XFASTINT (end) == SCHARS (object))
1399 {
1400 if (!string_intervals (object))
1401 return Qnil;
1402
1403 set_string_intervals (object, NULL);
1404 return Qt;
1405 }
1406
1407 i = validate_interval_range (object, &start, &end, soft);
1408
1409 if (!i)
1410 {
1411 /* If buffer has no properties, and we want none, return now. */
1412 if (NILP (properties))
1413 return Qnil;
1414
1415 /* Restore the original START and END values
1416 because validate_interval_range increments them for strings. */
1417 start = ostart;
1418 end = oend;
1419
1420 i = validate_interval_range (object, &start, &end, hard);
1421 /* This can return if start == end. */
1422 if (!i)
1423 return Qnil;
1424 }
1425
1426 if (BUFFERP (object) && !NILP (coherent_change_p))
1427 modify_text_properties (object, start, end);
1428
1429 set_text_properties_1 (start, end, properties, object, i);
1430
1431 if (BUFFERP (object) && !NILP (coherent_change_p))
1432 signal_after_change (XINT (start), XINT (end) - XINT (start),
1433 XINT (end) - XINT (start));
1434 return Qt;
1435 }
1436
1437 /* Replace properties of text from START to END with new list of
1438 properties PROPERTIES. OBJECT is the buffer or string containing
1439 the text. This does not obey any hooks.
1440 You should provide the interval that START is located in as I.
1441 START and END can be in any order. */
1442
1443 void
1444 set_text_properties_1 (Lisp_Object start, Lisp_Object end, Lisp_Object properties, Lisp_Object object, INTERVAL i)
1445 {
1446 register INTERVAL prev_changed = NULL;
1447 register ptrdiff_t s, len;
1448 INTERVAL unchanged;
1449
1450 if (XINT (start) < XINT (end))
1451 {
1452 s = XINT (start);
1453 len = XINT (end) - s;
1454 }
1455 else if (XINT (end) < XINT (start))
1456 {
1457 s = XINT (end);
1458 len = XINT (start) - s;
1459 }
1460 else
1461 return;
1462
1463 eassert (i);
1464
1465 if (i->position != s)
1466 {
1467 unchanged = i;
1468 i = split_interval_right (unchanged, s - unchanged->position);
1469
1470 if (LENGTH (i) > len)
1471 {
1472 copy_properties (unchanged, i);
1473 i = split_interval_left (i, len);
1474 set_properties (properties, i, object);
1475 return;
1476 }
1477
1478 set_properties (properties, i, object);
1479
1480 if (LENGTH (i) == len)
1481 return;
1482
1483 prev_changed = i;
1484 len -= LENGTH (i);
1485 i = next_interval (i);
1486 }
1487
1488 /* We are starting at the beginning of an interval I. LEN is positive. */
1489 do
1490 {
1491 eassert (i != 0);
1492
1493 if (LENGTH (i) >= len)
1494 {
1495 if (LENGTH (i) > len)
1496 i = split_interval_left (i, len);
1497
1498 /* We have to call set_properties even if we are going to
1499 merge the intervals, so as to make the undo records
1500 and cause redisplay to happen. */
1501 set_properties (properties, i, object);
1502 if (prev_changed)
1503 merge_interval_left (i);
1504 return;
1505 }
1506
1507 len -= LENGTH (i);
1508
1509 /* We have to call set_properties even if we are going to
1510 merge the intervals, so as to make the undo records
1511 and cause redisplay to happen. */
1512 set_properties (properties, i, object);
1513 if (!prev_changed)
1514 prev_changed = i;
1515 else
1516 prev_changed = i = merge_interval_left (i);
1517
1518 i = next_interval (i);
1519 }
1520 while (len > 0);
1521 }
1522
1523 DEFUN ("remove-text-properties", Fremove_text_properties,
1524 Sremove_text_properties, 3, 4, 0,
1525 doc: /* Remove some properties from text from START to END.
1526 The third argument PROPERTIES is a property list
1527 whose property names specify the properties to remove.
1528 \(The values stored in PROPERTIES are ignored.)
1529 If the optional fourth argument OBJECT is a buffer (or nil, which means
1530 the current buffer), START and END are buffer positions (integers or
1531 markers). If OBJECT is a string, START and END are 0-based indices into it.
1532 Return t if any property was actually removed, nil otherwise.
1533
1534 Use `set-text-properties' if you want to remove all text properties. */)
1535 (Lisp_Object start, Lisp_Object end, Lisp_Object properties, Lisp_Object object)
1536 {
1537 INTERVAL i, unchanged;
1538 ptrdiff_t s, len;
1539 bool modified = 0;
1540 bool first_time = 1;
1541
1542 if (NILP (object))
1543 XSETBUFFER (object, current_buffer);
1544
1545 retry:
1546 i = validate_interval_range (object, &start, &end, soft);
1547 if (!i)
1548 return Qnil;
1549
1550 s = XINT (start);
1551 len = XINT (end) - s;
1552
1553 /* If there are no properties on this entire interval, return. */
1554 if (! interval_has_some_properties (properties, i))
1555 {
1556 ptrdiff_t got = LENGTH (i) - (s - i->position);
1557
1558 do
1559 {
1560 if (got >= len)
1561 return Qnil;
1562 len -= got;
1563 i = next_interval (i);
1564 got = LENGTH (i);
1565 }
1566 while (! interval_has_some_properties (properties, i));
1567 }
1568 /* Split away the beginning of this interval; what we don't
1569 want to modify. */
1570 else if (i->position != s)
1571 {
1572 unchanged = i;
1573 i = split_interval_right (unchanged, s - unchanged->position);
1574 copy_properties (unchanged, i);
1575 }
1576
1577 if (BUFFERP (object) && first_time)
1578 {
1579 ptrdiff_t prev_total_length = TOTAL_LENGTH (i);
1580 ptrdiff_t prev_pos = i->position;
1581
1582 modify_text_properties (object, start, end);
1583 /* If someone called us recursively as a side effect of
1584 modify_text_properties, and changed the intervals behind our back
1585 (could happen if lock_file, called by prepare_to_modify_buffer,
1586 triggers redisplay, and that calls add-text-properties again
1587 in the same buffer), we cannot continue with I, because its
1588 data changed. So we restart the interval analysis anew. */
1589 if (TOTAL_LENGTH (i) != prev_total_length
1590 || i->position != prev_pos)
1591 {
1592 first_time = 0;
1593 goto retry;
1594 }
1595 }
1596
1597 /* We are at the beginning of an interval, with len to scan */
1598 for (;;)
1599 {
1600 eassert (i != 0);
1601
1602 if (LENGTH (i) >= len)
1603 {
1604 if (! interval_has_some_properties (properties, i))
1605 {
1606 eassert (modified);
1607 if (BUFFERP (object))
1608 signal_after_change (XINT (start), XINT (end) - XINT (start),
1609 XINT (end) - XINT (start));
1610 return Qt;
1611 }
1612
1613 if (LENGTH (i) == len)
1614 {
1615 remove_properties (properties, Qnil, i, object);
1616 if (BUFFERP (object))
1617 signal_after_change (XINT (start), XINT (end) - XINT (start),
1618 XINT (end) - XINT (start));
1619 return Qt;
1620 }
1621
1622 /* i has the properties, and goes past the change limit */
1623 unchanged = i;
1624 i = split_interval_left (i, len);
1625 copy_properties (unchanged, i);
1626 remove_properties (properties, Qnil, i, object);
1627 if (BUFFERP (object))
1628 signal_after_change (XINT (start), XINT (end) - XINT (start),
1629 XINT (end) - XINT (start));
1630 return Qt;
1631 }
1632
1633 len -= LENGTH (i);
1634 modified |= remove_properties (properties, Qnil, i, object);
1635 i = next_interval (i);
1636 }
1637 }
1638
1639 DEFUN ("remove-list-of-text-properties", Fremove_list_of_text_properties,
1640 Sremove_list_of_text_properties, 3, 4, 0,
1641 doc: /* Remove some properties from text from START to END.
1642 The third argument LIST-OF-PROPERTIES is a list of property names to remove.
1643 If the optional fourth argument OBJECT is a buffer (or nil, which means
1644 the current buffer), START and END are buffer positions (integers or
1645 markers). If OBJECT is a string, START and END are 0-based indices into it.
1646 Return t if any property was actually removed, nil otherwise. */)
1647 (Lisp_Object start, Lisp_Object end, Lisp_Object list_of_properties, Lisp_Object object)
1648 {
1649 INTERVAL i, unchanged;
1650 ptrdiff_t s, len;
1651 bool modified = 0;
1652 Lisp_Object properties;
1653 properties = list_of_properties;
1654
1655 if (NILP (object))
1656 XSETBUFFER (object, current_buffer);
1657
1658 i = validate_interval_range (object, &start, &end, soft);
1659 if (!i)
1660 return Qnil;
1661
1662 s = XINT (start);
1663 len = XINT (end) - s;
1664
1665 /* If there are no properties on the interval, return. */
1666 if (! interval_has_some_properties_list (properties, i))
1667 {
1668 ptrdiff_t got = LENGTH (i) - (s - i->position);
1669
1670 do
1671 {
1672 if (got >= len)
1673 return Qnil;
1674 len -= got;
1675 i = next_interval (i);
1676 got = LENGTH (i);
1677 }
1678 while (! interval_has_some_properties_list (properties, i));
1679 }
1680 /* Split away the beginning of this interval; what we don't
1681 want to modify. */
1682 else if (i->position != s)
1683 {
1684 unchanged = i;
1685 i = split_interval_right (unchanged, s - unchanged->position);
1686 copy_properties (unchanged, i);
1687 }
1688
1689 /* We are at the beginning of an interval, with len to scan.
1690 The flag `modified' records if changes have been made.
1691 When object is a buffer, we must call modify_text_properties
1692 before changes are made and signal_after_change when we are done.
1693 We call modify_text_properties before calling remove_properties if modified == 0,
1694 and we call signal_after_change before returning if modified != 0. */
1695 for (;;)
1696 {
1697 eassert (i != 0);
1698
1699 if (LENGTH (i) >= len)
1700 {
1701 if (! interval_has_some_properties_list (properties, i))
1702 {
1703 if (modified)
1704 {
1705 if (BUFFERP (object))
1706 signal_after_change (XINT (start),
1707 XINT (end) - XINT (start),
1708 XINT (end) - XINT (start));
1709 return Qt;
1710 }
1711 else
1712 return Qnil;
1713 }
1714 else if (LENGTH (i) == len)
1715 {
1716 if (!modified && BUFFERP (object))
1717 modify_text_properties (object, start, end);
1718 remove_properties (Qnil, properties, i, object);
1719 if (BUFFERP (object))
1720 signal_after_change (XINT (start), XINT (end) - XINT (start),
1721 XINT (end) - XINT (start));
1722 return Qt;
1723 }
1724 else
1725 { /* i has the properties, and goes past the change limit. */
1726 unchanged = i;
1727 i = split_interval_left (i, len);
1728 copy_properties (unchanged, i);
1729 if (!modified && BUFFERP (object))
1730 modify_text_properties (object, start, end);
1731 remove_properties (Qnil, properties, i, object);
1732 if (BUFFERP (object))
1733 signal_after_change (XINT (start), XINT (end) - XINT (start),
1734 XINT (end) - XINT (start));
1735 return Qt;
1736 }
1737 }
1738 if (interval_has_some_properties_list (properties, i))
1739 {
1740 if (!modified && BUFFERP (object))
1741 modify_text_properties (object, start, end);
1742 remove_properties (Qnil, properties, i, object);
1743 modified = 1;
1744 }
1745 len -= LENGTH (i);
1746 i = next_interval (i);
1747 if (!i)
1748 {
1749 if (modified)
1750 {
1751 if (BUFFERP (object))
1752 signal_after_change (XINT (start),
1753 XINT (end) - XINT (start),
1754 XINT (end) - XINT (start));
1755 return Qt;
1756 }
1757 else
1758 return Qnil;
1759 }
1760 }
1761 }
1762 \f
1763 DEFUN ("text-property-any", Ftext_property_any,
1764 Stext_property_any, 4, 5, 0,
1765 doc: /* Check text from START to END for property PROPERTY equaling VALUE.
1766 If so, return the position of the first character whose property PROPERTY
1767 is `eq' to VALUE. Otherwise return nil.
1768 If the optional fifth argument OBJECT is a buffer (or nil, which means
1769 the current buffer), START and END are buffer positions (integers or
1770 markers). If OBJECT is a string, START and END are 0-based indices into it. */)
1771 (Lisp_Object start, Lisp_Object end, Lisp_Object property, Lisp_Object value, Lisp_Object object)
1772 {
1773 register INTERVAL i;
1774 register ptrdiff_t e, pos;
1775
1776 if (NILP (object))
1777 XSETBUFFER (object, current_buffer);
1778 i = validate_interval_range (object, &start, &end, soft);
1779 if (!i)
1780 return (!NILP (value) || EQ (start, end) ? Qnil : start);
1781 e = XINT (end);
1782
1783 while (i)
1784 {
1785 if (i->position >= e)
1786 break;
1787 if (EQ (textget (i->plist, property), value))
1788 {
1789 pos = i->position;
1790 if (pos < XINT (start))
1791 pos = XINT (start);
1792 return make_number (pos);
1793 }
1794 i = next_interval (i);
1795 }
1796 return Qnil;
1797 }
1798
1799 DEFUN ("text-property-not-all", Ftext_property_not_all,
1800 Stext_property_not_all, 4, 5, 0,
1801 doc: /* Check text from START to END for property PROPERTY not equaling VALUE.
1802 If so, return the position of the first character whose property PROPERTY
1803 is not `eq' to VALUE. Otherwise, return nil.
1804 If the optional fifth argument OBJECT is a buffer (or nil, which means
1805 the current buffer), START and END are buffer positions (integers or
1806 markers). If OBJECT is a string, START and END are 0-based indices into it. */)
1807 (Lisp_Object start, Lisp_Object end, Lisp_Object property, Lisp_Object value, Lisp_Object object)
1808 {
1809 register INTERVAL i;
1810 register ptrdiff_t s, e;
1811
1812 if (NILP (object))
1813 XSETBUFFER (object, current_buffer);
1814 i = validate_interval_range (object, &start, &end, soft);
1815 if (!i)
1816 return (NILP (value) || EQ (start, end)) ? Qnil : start;
1817 s = XINT (start);
1818 e = XINT (end);
1819
1820 while (i)
1821 {
1822 if (i->position >= e)
1823 break;
1824 if (! EQ (textget (i->plist, property), value))
1825 {
1826 if (i->position > s)
1827 s = i->position;
1828 return make_number (s);
1829 }
1830 i = next_interval (i);
1831 }
1832 return Qnil;
1833 }
1834
1835 \f
1836 /* Return the direction from which the text-property PROP would be
1837 inherited by any new text inserted at POS: 1 if it would be
1838 inherited from the char after POS, -1 if it would be inherited from
1839 the char before POS, and 0 if from neither.
1840 BUFFER can be either a buffer or nil (meaning current buffer). */
1841
1842 int
1843 text_property_stickiness (Lisp_Object prop, Lisp_Object pos, Lisp_Object buffer)
1844 {
1845 bool ignore_previous_character;
1846 Lisp_Object prev_pos = make_number (XINT (pos) - 1);
1847 Lisp_Object front_sticky;
1848 bool is_rear_sticky = true, is_front_sticky = false; /* defaults */
1849 Lisp_Object defalt = Fassq (prop, Vtext_property_default_nonsticky);
1850
1851 if (NILP (buffer))
1852 XSETBUFFER (buffer, current_buffer);
1853
1854 ignore_previous_character = XINT (pos) <= BUF_BEGV (XBUFFER (buffer));
1855
1856 if (ignore_previous_character || (CONSP (defalt) && !NILP (XCDR (defalt))))
1857 is_rear_sticky = false;
1858 else
1859 {
1860 Lisp_Object rear_non_sticky
1861 = Fget_text_property (prev_pos, Qrear_nonsticky, buffer);
1862
1863 if (!NILP (CONSP (rear_non_sticky)
1864 ? Fmemq (prop, rear_non_sticky)
1865 : rear_non_sticky))
1866 /* PROP is rear-non-sticky. */
1867 is_rear_sticky = false;
1868 }
1869
1870 /* Consider following character. */
1871 /* This signals an arg-out-of-range error if pos is outside the
1872 buffer's accessible range. */
1873 front_sticky = Fget_text_property (pos, Qfront_sticky, buffer);
1874
1875 if (EQ (front_sticky, Qt)
1876 || (CONSP (front_sticky)
1877 && !NILP (Fmemq (prop, front_sticky))))
1878 /* PROP is inherited from after. */
1879 is_front_sticky = true;
1880
1881 /* Simple cases, where the properties are consistent. */
1882 if (is_rear_sticky && !is_front_sticky)
1883 return -1;
1884 else if (!is_rear_sticky && is_front_sticky)
1885 return 1;
1886 else if (!is_rear_sticky && !is_front_sticky)
1887 return 0;
1888
1889 /* The stickiness properties are inconsistent, so we have to
1890 disambiguate. Basically, rear-sticky wins, _except_ if the
1891 property that would be inherited has a value of nil, in which case
1892 front-sticky wins. */
1893 if (ignore_previous_character
1894 || NILP (Fget_text_property (prev_pos, prop, buffer)))
1895 return 1;
1896 else
1897 return -1;
1898 }
1899
1900 \f
1901 /* Copying properties between objects. */
1902
1903 /* Add properties from START to END of SRC, starting at POS in DEST.
1904 SRC and DEST may each refer to strings or buffers.
1905 Optional sixth argument PROP causes only that property to be copied.
1906 Properties are copied to DEST as if by `add-text-properties'.
1907 Return t if any property value actually changed, nil otherwise. */
1908
1909 /* Note this can GC when DEST is a buffer. */
1910
1911 Lisp_Object
1912 copy_text_properties (Lisp_Object start, Lisp_Object end, Lisp_Object src, Lisp_Object pos, Lisp_Object dest, Lisp_Object prop)
1913 {
1914 INTERVAL i;
1915 Lisp_Object res;
1916 Lisp_Object stuff;
1917 Lisp_Object plist;
1918 ptrdiff_t s, e, e2, p, len;
1919 bool modified = 0;
1920 struct gcpro gcpro1, gcpro2;
1921
1922 i = validate_interval_range (src, &start, &end, soft);
1923 if (!i)
1924 return Qnil;
1925
1926 CHECK_NUMBER_COERCE_MARKER (pos);
1927 {
1928 Lisp_Object dest_start, dest_end;
1929
1930 e = XINT (pos) + (XINT (end) - XINT (start));
1931 if (MOST_POSITIVE_FIXNUM < e)
1932 args_out_of_range (pos, end);
1933 dest_start = pos;
1934 XSETFASTINT (dest_end, e);
1935 /* Apply this to a copy of pos; it will try to increment its arguments,
1936 which we don't want. */
1937 validate_interval_range (dest, &dest_start, &dest_end, soft);
1938 }
1939
1940 s = XINT (start);
1941 e = XINT (end);
1942 p = XINT (pos);
1943
1944 stuff = Qnil;
1945
1946 while (s < e)
1947 {
1948 e2 = i->position + LENGTH (i);
1949 if (e2 > e)
1950 e2 = e;
1951 len = e2 - s;
1952
1953 plist = i->plist;
1954 if (! NILP (prop))
1955 while (! NILP (plist))
1956 {
1957 if (EQ (Fcar (plist), prop))
1958 {
1959 plist = list2 (prop, Fcar (Fcdr (plist)));
1960 break;
1961 }
1962 plist = Fcdr (Fcdr (plist));
1963 }
1964 if (! NILP (plist))
1965 {
1966 /* Must defer modifications to the interval tree in case src
1967 and dest refer to the same string or buffer. */
1968 stuff = Fcons (list3 (make_number (p), make_number (p + len), plist),
1969 stuff);
1970 }
1971
1972 i = next_interval (i);
1973 if (!i)
1974 break;
1975
1976 p += len;
1977 s = i->position;
1978 }
1979
1980 GCPRO2 (stuff, dest);
1981
1982 while (! NILP (stuff))
1983 {
1984 res = Fcar (stuff);
1985 res = Fadd_text_properties (Fcar (res), Fcar (Fcdr (res)),
1986 Fcar (Fcdr (Fcdr (res))), dest);
1987 if (! NILP (res))
1988 modified = 1;
1989 stuff = Fcdr (stuff);
1990 }
1991
1992 UNGCPRO;
1993
1994 return modified ? Qt : Qnil;
1995 }
1996
1997
1998 /* Return a list representing the text properties of OBJECT between
1999 START and END. if PROP is non-nil, report only on that property.
2000 Each result list element has the form (S E PLIST), where S and E
2001 are positions in OBJECT and PLIST is a property list containing the
2002 text properties of OBJECT between S and E. Value is nil if OBJECT
2003 doesn't contain text properties between START and END. */
2004
2005 Lisp_Object
2006 text_property_list (Lisp_Object object, Lisp_Object start, Lisp_Object end, Lisp_Object prop)
2007 {
2008 struct interval *i;
2009 Lisp_Object result;
2010
2011 result = Qnil;
2012
2013 i = validate_interval_range (object, &start, &end, soft);
2014 if (i)
2015 {
2016 ptrdiff_t s = XINT (start);
2017 ptrdiff_t e = XINT (end);
2018
2019 while (s < e)
2020 {
2021 ptrdiff_t interval_end, len;
2022 Lisp_Object plist;
2023
2024 interval_end = i->position + LENGTH (i);
2025 if (interval_end > e)
2026 interval_end = e;
2027 len = interval_end - s;
2028
2029 plist = i->plist;
2030
2031 if (!NILP (prop))
2032 for (; CONSP (plist); plist = Fcdr (XCDR (plist)))
2033 if (EQ (XCAR (plist), prop))
2034 {
2035 plist = list2 (prop, Fcar (XCDR (plist)));
2036 break;
2037 }
2038
2039 if (!NILP (plist))
2040 result = Fcons (list3 (make_number (s), make_number (s + len),
2041 plist),
2042 result);
2043
2044 i = next_interval (i);
2045 if (!i)
2046 break;
2047 s = i->position;
2048 }
2049 }
2050
2051 return result;
2052 }
2053
2054
2055 /* Add text properties to OBJECT from LIST. LIST is a list of triples
2056 (START END PLIST), where START and END are positions and PLIST is a
2057 property list containing the text properties to add. Adjust START
2058 and END positions by DELTA before adding properties. */
2059
2060 void
2061 add_text_properties_from_list (Lisp_Object object, Lisp_Object list, Lisp_Object delta)
2062 {
2063 struct gcpro gcpro1, gcpro2;
2064
2065 GCPRO2 (list, object);
2066
2067 for (; CONSP (list); list = XCDR (list))
2068 {
2069 Lisp_Object item, start, end, plist;
2070
2071 item = XCAR (list);
2072 start = make_number (XINT (XCAR (item)) + XINT (delta));
2073 end = make_number (XINT (XCAR (XCDR (item))) + XINT (delta));
2074 plist = XCAR (XCDR (XCDR (item)));
2075
2076 Fadd_text_properties (start, end, plist, object);
2077 }
2078
2079 UNGCPRO;
2080 }
2081
2082
2083
2084 /* Modify end-points of ranges in LIST destructively, and return the
2085 new list. LIST is a list as returned from text_property_list.
2086 Discard properties that begin at or after NEW_END, and limit
2087 end-points to NEW_END. */
2088
2089 Lisp_Object
2090 extend_property_ranges (Lisp_Object list, Lisp_Object new_end)
2091 {
2092 Lisp_Object prev = Qnil, head = list;
2093 ptrdiff_t max = XINT (new_end);
2094
2095 for (; CONSP (list); prev = list, list = XCDR (list))
2096 {
2097 Lisp_Object item, beg, end;
2098
2099 item = XCAR (list);
2100 beg = XCAR (item);
2101 end = XCAR (XCDR (item));
2102
2103 if (XINT (beg) >= max)
2104 {
2105 /* The start-point is past the end of the new string.
2106 Discard this property. */
2107 if (EQ (head, list))
2108 head = XCDR (list);
2109 else
2110 XSETCDR (prev, XCDR (list));
2111 }
2112 else if (XINT (end) > max)
2113 /* The end-point is past the end of the new string. */
2114 XSETCAR (XCDR (item), new_end);
2115 }
2116
2117 return head;
2118 }
2119
2120
2121 \f
2122 /* Call the modification hook functions in LIST, each with START and END. */
2123
2124 static void
2125 call_mod_hooks (Lisp_Object list, Lisp_Object start, Lisp_Object end)
2126 {
2127 struct gcpro gcpro1;
2128 GCPRO1 (list);
2129 while (!NILP (list))
2130 {
2131 call2 (Fcar (list), start, end);
2132 list = Fcdr (list);
2133 }
2134 UNGCPRO;
2135 }
2136
2137 /* Check for read-only intervals between character positions START ... END,
2138 in BUF, and signal an error if we find one.
2139
2140 Then check for any modification hooks in the range.
2141 Create a list of all these hooks in lexicographic order,
2142 eliminating consecutive extra copies of the same hook. Then call
2143 those hooks in order, with START and END - 1 as arguments. */
2144
2145 void
2146 verify_interval_modification (struct buffer *buf,
2147 ptrdiff_t start, ptrdiff_t end)
2148 {
2149 INTERVAL intervals = buffer_intervals (buf);
2150 INTERVAL i;
2151 Lisp_Object hooks;
2152 Lisp_Object prev_mod_hooks;
2153 Lisp_Object mod_hooks;
2154 struct gcpro gcpro1;
2155
2156 hooks = Qnil;
2157 prev_mod_hooks = Qnil;
2158 mod_hooks = Qnil;
2159
2160 interval_insert_behind_hooks = Qnil;
2161 interval_insert_in_front_hooks = Qnil;
2162
2163 if (!intervals)
2164 return;
2165
2166 if (start > end)
2167 {
2168 ptrdiff_t temp = start;
2169 start = end;
2170 end = temp;
2171 }
2172
2173 /* For an insert operation, check the two chars around the position. */
2174 if (start == end)
2175 {
2176 INTERVAL prev = NULL;
2177 Lisp_Object before, after;
2178
2179 /* Set I to the interval containing the char after START,
2180 and PREV to the interval containing the char before START.
2181 Either one may be null. They may be equal. */
2182 i = find_interval (intervals, start);
2183
2184 if (start == BUF_BEGV (buf))
2185 prev = 0;
2186 else if (i->position == start)
2187 prev = previous_interval (i);
2188 else if (i->position < start)
2189 prev = i;
2190 if (start == BUF_ZV (buf))
2191 i = 0;
2192
2193 /* If Vinhibit_read_only is set and is not a list, we can
2194 skip the read_only checks. */
2195 if (NILP (Vinhibit_read_only) || CONSP (Vinhibit_read_only))
2196 {
2197 /* If I and PREV differ we need to check for the read-only
2198 property together with its stickiness. If either I or
2199 PREV are 0, this check is all we need.
2200 We have to take special care, since read-only may be
2201 indirectly defined via the category property. */
2202 if (i != prev)
2203 {
2204 if (i)
2205 {
2206 after = textget (i->plist, Qread_only);
2207
2208 /* If interval I is read-only and read-only is
2209 front-sticky, inhibit insertion.
2210 Check for read-only as well as category. */
2211 if (! NILP (after)
2212 && NILP (Fmemq (after, Vinhibit_read_only)))
2213 {
2214 Lisp_Object tem;
2215
2216 tem = textget (i->plist, Qfront_sticky);
2217 if (TMEM (Qread_only, tem)
2218 || (NILP (Fplist_get (i->plist, Qread_only))
2219 && TMEM (Qcategory, tem)))
2220 text_read_only (after);
2221 }
2222 }
2223
2224 if (prev)
2225 {
2226 before = textget (prev->plist, Qread_only);
2227
2228 /* If interval PREV is read-only and read-only isn't
2229 rear-nonsticky, inhibit insertion.
2230 Check for read-only as well as category. */
2231 if (! NILP (before)
2232 && NILP (Fmemq (before, Vinhibit_read_only)))
2233 {
2234 Lisp_Object tem;
2235
2236 tem = textget (prev->plist, Qrear_nonsticky);
2237 if (! TMEM (Qread_only, tem)
2238 && (! NILP (Fplist_get (prev->plist,Qread_only))
2239 || ! TMEM (Qcategory, tem)))
2240 text_read_only (before);
2241 }
2242 }
2243 }
2244 else if (i)
2245 {
2246 after = textget (i->plist, Qread_only);
2247
2248 /* If interval I is read-only and read-only is
2249 front-sticky, inhibit insertion.
2250 Check for read-only as well as category. */
2251 if (! NILP (after) && NILP (Fmemq (after, Vinhibit_read_only)))
2252 {
2253 Lisp_Object tem;
2254
2255 tem = textget (i->plist, Qfront_sticky);
2256 if (TMEM (Qread_only, tem)
2257 || (NILP (Fplist_get (i->plist, Qread_only))
2258 && TMEM (Qcategory, tem)))
2259 text_read_only (after);
2260
2261 tem = textget (prev->plist, Qrear_nonsticky);
2262 if (! TMEM (Qread_only, tem)
2263 && (! NILP (Fplist_get (prev->plist, Qread_only))
2264 || ! TMEM (Qcategory, tem)))
2265 text_read_only (after);
2266 }
2267 }
2268 }
2269
2270 /* Run both insert hooks (just once if they're the same). */
2271 if (prev)
2272 interval_insert_behind_hooks
2273 = textget (prev->plist, Qinsert_behind_hooks);
2274 if (i)
2275 interval_insert_in_front_hooks
2276 = textget (i->plist, Qinsert_in_front_hooks);
2277 }
2278 else
2279 {
2280 /* Loop over intervals on or next to START...END,
2281 collecting their hooks. */
2282
2283 i = find_interval (intervals, start);
2284 do
2285 {
2286 if (! INTERVAL_WRITABLE_P (i))
2287 text_read_only (textget (i->plist, Qread_only));
2288
2289 if (!inhibit_modification_hooks)
2290 {
2291 mod_hooks = textget (i->plist, Qmodification_hooks);
2292 if (! NILP (mod_hooks) && ! EQ (mod_hooks, prev_mod_hooks))
2293 {
2294 hooks = Fcons (mod_hooks, hooks);
2295 prev_mod_hooks = mod_hooks;
2296 }
2297 }
2298
2299 i = next_interval (i);
2300 }
2301 /* Keep going thru the interval containing the char before END. */
2302 while (i && i->position < end);
2303
2304 if (!inhibit_modification_hooks)
2305 {
2306 GCPRO1 (hooks);
2307 hooks = Fnreverse (hooks);
2308 while (! EQ (hooks, Qnil))
2309 {
2310 call_mod_hooks (Fcar (hooks), make_number (start),
2311 make_number (end));
2312 hooks = Fcdr (hooks);
2313 }
2314 UNGCPRO;
2315 }
2316 }
2317 }
2318
2319 /* Run the interval hooks for an insertion on character range START ... END.
2320 verify_interval_modification chose which hooks to run;
2321 this function is called after the insertion happens
2322 so it can indicate the range of inserted text. */
2323
2324 void
2325 report_interval_modification (Lisp_Object start, Lisp_Object end)
2326 {
2327 if (! NILP (interval_insert_behind_hooks))
2328 call_mod_hooks (interval_insert_behind_hooks, start, end);
2329 if (! NILP (interval_insert_in_front_hooks)
2330 && ! EQ (interval_insert_in_front_hooks,
2331 interval_insert_behind_hooks))
2332 call_mod_hooks (interval_insert_in_front_hooks, start, end);
2333 }
2334 \f
2335 void
2336 syms_of_textprop (void)
2337 {
2338 DEFVAR_LISP ("default-text-properties", Vdefault_text_properties,
2339 doc: /* Property-list used as default values.
2340 The value of a property in this list is seen as the value for every
2341 character that does not have its own value for that property. */);
2342 Vdefault_text_properties = Qnil;
2343
2344 DEFVAR_LISP ("char-property-alias-alist", Vchar_property_alias_alist,
2345 doc: /* Alist of alternative properties for properties without a value.
2346 Each element should look like (PROPERTY ALTERNATIVE1 ALTERNATIVE2...).
2347 If a piece of text has no direct value for a particular property, then
2348 this alist is consulted. If that property appears in the alist, then
2349 the first non-nil value from the associated alternative properties is
2350 returned. */);
2351 Vchar_property_alias_alist = Qnil;
2352
2353 DEFVAR_LISP ("inhibit-point-motion-hooks", Vinhibit_point_motion_hooks,
2354 doc: /* If non-nil, don't run `point-left' and `point-entered' text properties.
2355 This also inhibits the use of the `intangible' text property. */);
2356 Vinhibit_point_motion_hooks = Qnil;
2357
2358 DEFVAR_LISP ("text-property-default-nonsticky",
2359 Vtext_property_default_nonsticky,
2360 doc: /* Alist of properties vs the corresponding non-stickiness.
2361 Each element has the form (PROPERTY . NONSTICKINESS).
2362
2363 If a character in a buffer has PROPERTY, new text inserted adjacent to
2364 the character doesn't inherit PROPERTY if NONSTICKINESS is non-nil,
2365 inherits it if NONSTICKINESS is nil. The `front-sticky' and
2366 `rear-nonsticky' properties of the character override NONSTICKINESS. */);
2367 /* Text properties `syntax-table'and `display' should be nonsticky
2368 by default. */
2369 Vtext_property_default_nonsticky
2370 = list2 (Fcons (intern_c_string ("syntax-table"), Qt),
2371 Fcons (intern_c_string ("display"), Qt));
2372
2373 staticpro (&interval_insert_behind_hooks);
2374 staticpro (&interval_insert_in_front_hooks);
2375 interval_insert_behind_hooks = Qnil;
2376 interval_insert_in_front_hooks = Qnil;
2377
2378
2379 /* Common attributes one might give text */
2380
2381 DEFSYM (Qforeground, "foreground");
2382 DEFSYM (Qbackground, "background");
2383 DEFSYM (Qfont, "font");
2384 DEFSYM (Qface, "face");
2385 DEFSYM (Qstipple, "stipple");
2386 DEFSYM (Qunderline, "underline");
2387 DEFSYM (Qread_only, "read-only");
2388 DEFSYM (Qinvisible, "invisible");
2389 DEFSYM (Qintangible, "intangible");
2390 DEFSYM (Qcategory, "category");
2391 DEFSYM (Qlocal_map, "local-map");
2392 DEFSYM (Qfront_sticky, "front-sticky");
2393 DEFSYM (Qrear_nonsticky, "rear-nonsticky");
2394 DEFSYM (Qmouse_face, "mouse-face");
2395 DEFSYM (Qminibuffer_prompt, "minibuffer-prompt");
2396
2397 /* Properties that text might use to specify certain actions */
2398
2399 DEFSYM (Qmouse_left, "mouse-left");
2400 DEFSYM (Qmouse_entered, "mouse-entered");
2401 DEFSYM (Qpoint_left, "point-left");
2402 DEFSYM (Qpoint_entered, "point-entered");
2403
2404 defsubr (&Stext_properties_at);
2405 defsubr (&Sget_text_property);
2406 defsubr (&Sget_char_property);
2407 defsubr (&Sget_char_property_and_overlay);
2408 defsubr (&Snext_char_property_change);
2409 defsubr (&Sprevious_char_property_change);
2410 defsubr (&Snext_single_char_property_change);
2411 defsubr (&Sprevious_single_char_property_change);
2412 defsubr (&Snext_property_change);
2413 defsubr (&Snext_single_property_change);
2414 defsubr (&Sprevious_property_change);
2415 defsubr (&Sprevious_single_property_change);
2416 defsubr (&Sadd_text_properties);
2417 defsubr (&Sput_text_property);
2418 defsubr (&Sset_text_properties);
2419 defsubr (&Sadd_face_text_property);
2420 defsubr (&Sremove_text_properties);
2421 defsubr (&Sremove_list_of_text_properties);
2422 defsubr (&Stext_property_any);
2423 defsubr (&Stext_property_not_all);
2424 }