#include <config.h>
#include "lisp.h"
#include "intervals.h"
#include "buffer.h"
#include "window.h"
#ifndef NULL
#define NULL (void *)0
#endif
#define TMEM(sym, set) (CONSP (set) ? ! NILP (Fmemq (sym, set)) : ! NILP (set))
Lisp_Object Qmouse_left;
Lisp_Object Qmouse_entered;
Lisp_Object Qpoint_left;
Lisp_Object Qpoint_entered;
Lisp_Object Qcategory;
Lisp_Object Qlocal_map;
Lisp_Object Qforeground, Qbackground, Qfont, Qunderline, Qstipple;
Lisp_Object Qinvisible, Qread_only, Qintangible, Qmouse_face;
Lisp_Object Qfront_sticky, Qrear_nonsticky;
#define PLIST_ELT_P(o1, o2) (CONSP (o1) && ((o2)=XCDR (o1), CONSP (o2)))
Lisp_Object Vinhibit_point_motion_hooks;
Lisp_Object Vdefault_text_properties;
Lisp_Object Vchar_property_alias_alist;
Lisp_Object Vtext_property_default_nonsticky;
Lisp_Object interval_insert_behind_hooks;
Lisp_Object interval_insert_in_front_hooks;
static void text_read_only P_ ((Lisp_Object)) NO_RETURN;
static void
text_read_only (propval)
Lisp_Object propval;
{
if (STRINGP (propval))
xsignal1 (Qtext_read_only, propval);
xsignal0 (Qtext_read_only);
}
#define soft 0
#define hard 1
INTERVAL
validate_interval_range (object, begin, end, force)
Lisp_Object object, *begin, *end;
int force;
{
register INTERVAL i;
int searchpos;
CHECK_STRING_OR_BUFFER (object);
CHECK_NUMBER_COERCE_MARKER (*begin);
CHECK_NUMBER_COERCE_MARKER (*end);
if (EQ (*begin, *end) && begin != end)
return NULL_INTERVAL;
if (XINT (*begin) > XINT (*end))
{
Lisp_Object n;
n = *begin;
*begin = *end;
*end = n;
}
if (BUFFERP (object))
{
register struct buffer *b = XBUFFER (object);
if (!(BUF_BEGV (b) <= XINT (*begin) && XINT (*begin) <= XINT (*end)
&& XINT (*end) <= BUF_ZV (b)))
args_out_of_range (*begin, *end);
i = BUF_INTERVALS (b);
if (BUF_BEGV (b) == BUF_ZV (b))
return NULL_INTERVAL;
searchpos = XINT (*begin);
}
else
{
int len = SCHARS (object);
if (! (0 <= XINT (*begin) && XINT (*begin) <= XINT (*end)
&& XINT (*end) <= len))
args_out_of_range (*begin, *end);
XSETFASTINT (*begin, XFASTINT (*begin));
if (begin != end)
XSETFASTINT (*end, XFASTINT (*end));
i = STRING_INTERVALS (object);
if (len == 0)
return NULL_INTERVAL;
searchpos = XINT (*begin);
}
if (NULL_INTERVAL_P (i))
return (force ? create_root_interval (object) : i);
return find_interval (i, searchpos);
}
static Lisp_Object
validate_plist (list)
Lisp_Object list;
{
if (NILP (list))
return Qnil;
if (CONSP (list))
{
register int i;
register Lisp_Object tail;
for (i = 0, tail = list; !NILP (tail); i++)
{
tail = Fcdr (tail);
QUIT;
}
if (i & 1)
error ("Odd length text property list");
return list;
}
return Fcons (list, Fcons (Qnil, Qnil));
}
static int
interval_has_all_properties (plist, i)
Lisp_Object plist;
INTERVAL i;
{
register Lisp_Object tail1, tail2, sym1;
register int found;
for (tail1 = plist; ! NILP (tail1); tail1 = Fcdr (Fcdr (tail1)))
{
sym1 = Fcar (tail1);
found = 0;
for (tail2 = i->plist; ! NILP (tail2); tail2 = Fcdr (Fcdr (tail2)))
if (EQ (sym1, Fcar (tail2)))
{
if (! EQ (Fcar (Fcdr (tail1)), Fcar (Fcdr (tail2))))
return 0;
found = 1;
break;
}
if (! found)
return 0;
}
return 1;
}
static INLINE int
interval_has_some_properties (plist, i)
Lisp_Object plist;
INTERVAL i;
{
register Lisp_Object tail1, tail2, sym;
for (tail1 = plist; ! NILP (tail1); tail1 = Fcdr (Fcdr (tail1)))
{
sym = Fcar (tail1);
for (tail2 = i->plist; ! NILP (tail2); tail2 = Fcdr (Fcdr (tail2)))
if (EQ (sym, Fcar (tail2)))
return 1;
}
return 0;
}
static INLINE int
interval_has_some_properties_list (list, i)
Lisp_Object list;
INTERVAL i;
{
register Lisp_Object tail1, tail2, sym;
for (tail1 = list; ! NILP (tail1); tail1 = XCDR (tail1))
{
sym = Fcar (tail1);
for (tail2 = i->plist; ! NILP (tail2); tail2 = XCDR (XCDR (tail2)))
if (EQ (sym, XCAR (tail2)))
return 1;
}
return 0;
}
static Lisp_Object
property_value (plist, prop)
Lisp_Object plist, prop;
{
Lisp_Object value;
while (PLIST_ELT_P (plist, value))
if (EQ (XCAR (plist), prop))
return XCAR (value);
else
plist = XCDR (value);
return Qunbound;
}
static void
set_properties (properties, interval, object)
Lisp_Object properties, object;
INTERVAL interval;
{
Lisp_Object sym, value;
if (BUFFERP (object))
{
for (sym = interval->plist;
PLIST_ELT_P (sym, value);
sym = XCDR (value))
if (! EQ (property_value (properties, XCAR (sym)),
XCAR (value)))
{
record_property_change (interval->position, LENGTH (interval),
XCAR (sym), XCAR (value),
object);
}
for (sym = properties;
PLIST_ELT_P (sym, value);
sym = XCDR (value))
if (EQ (property_value (interval->plist, XCAR (sym)), Qunbound))
{
record_property_change (interval->position, LENGTH (interval),
XCAR (sym), Qnil,
object);
}
}
interval->plist = Fcopy_sequence (properties);
}
static int
add_properties (plist, i, object)
Lisp_Object plist;
INTERVAL i;
Lisp_Object object;
{
Lisp_Object tail1, tail2, sym1, val1;
register int changed = 0;
register int found;
struct gcpro gcpro1, gcpro2, gcpro3;
tail1 = plist;
sym1 = Qnil;
val1 = Qnil;
GCPRO3 (tail1, sym1, val1);
for (tail1 = plist; ! NILP (tail1); tail1 = Fcdr (Fcdr (tail1)))
{
sym1 = Fcar (tail1);
val1 = Fcar (Fcdr (tail1));
found = 0;
for (tail2 = i->plist; ! NILP (tail2); tail2 = Fcdr (Fcdr (tail2)))
if (EQ (sym1, Fcar (tail2)))
{
register Lisp_Object this_cdr;
this_cdr = Fcdr (tail2);
found = 1;
if (EQ (val1, Fcar (this_cdr)))
break;
if (BUFFERP (object))
{
record_property_change (i->position, LENGTH (i),
sym1, Fcar (this_cdr), object);
}
Fsetcar (this_cdr, val1);
changed++;
break;
}
if (! found)
{
if (BUFFERP (object))
{
record_property_change (i->position, LENGTH (i),
sym1, Qnil, object);
}
i->plist = Fcons (sym1, Fcons (val1, i->plist));
changed++;
}
}
UNGCPRO;
return changed;
}
static int
remove_properties (plist, list, i, object)
Lisp_Object plist, list;
INTERVAL i;
Lisp_Object object;
{
register Lisp_Object tail1, tail2, sym, current_plist;
register int changed = 0;
int use_plist;
current_plist = i->plist;
if (! NILP (plist))
tail1 = plist, use_plist = 1;
else
tail1 = list, use_plist = 0;
while (CONSP (tail1))
{
sym = XCAR (tail1);
while (CONSP (current_plist) && EQ (sym, XCAR (current_plist)))
{
if (BUFFERP (object))
record_property_change (i->position, LENGTH (i),
sym, XCAR (XCDR (current_plist)),
object);
current_plist = XCDR (XCDR (current_plist));
changed++;
}
tail2 = current_plist;
while (! NILP (tail2))
{
register Lisp_Object this;
this = XCDR (XCDR (tail2));
if (CONSP (this) && EQ (sym, XCAR (this)))
{
if (BUFFERP (object))
record_property_change (i->position, LENGTH (i),
sym, XCAR (XCDR (this)), object);
Fsetcdr (XCDR (tail2), XCDR (XCDR (this)));
changed++;
}
tail2 = this;
}
tail1 = XCDR (tail1);
if (use_plist && CONSP (tail1))
tail1 = XCDR (tail1);
}
if (changed)
i->plist = current_plist;
return changed;
}
#if 0
static INLINE int
erase_properties (i)
INTERVAL i;
{
if (NILP (i->plist))
return 0;
i->plist = Qnil;
return 1;
}
#endif
INTERVAL
interval_of (position, object)
int position;
Lisp_Object object;
{
register INTERVAL i;
int beg, end;
if (NILP (object))
XSETBUFFER (object, current_buffer);
else if (EQ (object, Qt))
return NULL_INTERVAL;
CHECK_STRING_OR_BUFFER (object);
if (BUFFERP (object))
{
register struct buffer *b = XBUFFER (object);
beg = BUF_BEGV (b);
end = BUF_ZV (b);
i = BUF_INTERVALS (b);
}
else
{
beg = 0;
end = SCHARS (object);
i = STRING_INTERVALS (object);
}
if (!(beg <= position && position <= end))
args_out_of_range (make_number (position), make_number (position));
if (beg == end || NULL_INTERVAL_P (i))
return NULL_INTERVAL;
return find_interval (i, position);
}
DEFUN ("text-properties-at", Ftext_properties_at,
Stext_properties_at, 1, 2, 0,
doc: )
(position, object)
Lisp_Object position, object;
{
register INTERVAL i;
if (NILP (object))
XSETBUFFER (object, current_buffer);
i = validate_interval_range (object, &position, &position, soft);
if (NULL_INTERVAL_P (i))
return Qnil;
if (XINT (position) == LENGTH (i) + i->position)
return Qnil;
return i->plist;
}
DEFUN ("get-text-property", Fget_text_property, Sget_text_property, 2, 3, 0,
doc: )
(position, prop, object)
Lisp_Object position, object;
Lisp_Object prop;
{
return textget (Ftext_properties_at (position, object), prop);
}
Lisp_Object
get_char_property_and_overlay (position, prop, object, overlay)
Lisp_Object position, object;
register Lisp_Object prop;
Lisp_Object *overlay;
{
struct window *w = 0;
CHECK_NUMBER_COERCE_MARKER (position);
if (NILP (object))
XSETBUFFER (object, current_buffer);
if (WINDOWP (object))
{
w = XWINDOW (object);
object = w->buffer;
}
if (BUFFERP (object))
{
int noverlays;
Lisp_Object *overlay_vec;
struct buffer *obuf = current_buffer;
set_buffer_temp (XBUFFER (object));
GET_OVERLAYS_AT (XINT (position), overlay_vec, noverlays, NULL, 0);
noverlays = sort_overlays (overlay_vec, noverlays, w);
set_buffer_temp (obuf);
while (--noverlays >= 0)
{
Lisp_Object tem = Foverlay_get (overlay_vec[noverlays], prop);
if (!NILP (tem))
{
if (overlay)
*overlay = overlay_vec[noverlays];
return tem;
}
}
}
if (overlay)
*overlay = Qnil;
return Fget_text_property (position, prop, object);
}
DEFUN ("get-char-property", Fget_char_property, Sget_char_property, 2, 3, 0,
doc: )
(position, prop, object)
Lisp_Object position, object;
register Lisp_Object prop;
{
return get_char_property_and_overlay (position, prop, object, 0);
}
DEFUN ("get-char-property-and-overlay", Fget_char_property_and_overlay,
Sget_char_property_and_overlay, 2, 3, 0,
doc: )
(position, prop, object)
Lisp_Object position, object;
register Lisp_Object prop;
{
Lisp_Object overlay;
Lisp_Object val
= get_char_property_and_overlay (position, prop, object, &overlay);
return Fcons(val, overlay);
}
DEFUN ("next-char-property-change", Fnext_char_property_change,
Snext_char_property_change, 1, 2, 0,
doc: )
(position, limit)
Lisp_Object position, limit;
{
Lisp_Object temp;
temp = Fnext_overlay_change (position);
if (! NILP (limit))
{
CHECK_NUMBER_COERCE_MARKER (limit);
if (XINT (limit) < XINT (temp))
temp = limit;
}
return Fnext_property_change (position, Qnil, temp);
}
DEFUN ("previous-char-property-change", Fprevious_char_property_change,
Sprevious_char_property_change, 1, 2, 0,
doc: )
(position, limit)
Lisp_Object position, limit;
{
Lisp_Object temp;
temp = Fprevious_overlay_change (position);
if (! NILP (limit))
{
CHECK_NUMBER_COERCE_MARKER (limit);
if (XINT (limit) > XINT (temp))
temp = limit;
}
return Fprevious_property_change (position, Qnil, temp);
}
DEFUN ("next-single-char-property-change", Fnext_single_char_property_change,
Snext_single_char_property_change, 2, 4, 0,
doc: )
(position, prop, object, limit)
Lisp_Object prop, position, object, limit;
{
if (STRINGP (object))
{
position = Fnext_single_property_change (position, prop, object, limit);
if (NILP (position))
{
if (NILP (limit))
position = make_number (SCHARS (object));
else
{
CHECK_NUMBER (limit);
position = limit;
}
}
}
else
{
Lisp_Object initial_value, value;
int count = SPECPDL_INDEX ();
if (! NILP (object))
CHECK_BUFFER (object);
if (BUFFERP (object) && current_buffer != XBUFFER (object))
{
record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
Fset_buffer (object);
}
CHECK_NUMBER_COERCE_MARKER (position);
initial_value = Fget_char_property (position, prop, object);
if (NILP (limit))
XSETFASTINT (limit, ZV);
else
CHECK_NUMBER_COERCE_MARKER (limit);
if (XFASTINT (position) >= XFASTINT (limit))
{
position = limit;
if (XFASTINT (position) > ZV)
XSETFASTINT (position, ZV);
}
else
while (1)
{
position = Fnext_char_property_change (position, limit);
if (XFASTINT (position) >= XFASTINT (limit))
{
position = limit;
break;
}
value = Fget_char_property (position, prop, object);
if (!EQ (value, initial_value))
break;
}
unbind_to (count, Qnil);
}
return position;
}
DEFUN ("previous-single-char-property-change",
Fprevious_single_char_property_change,
Sprevious_single_char_property_change, 2, 4, 0,
doc: )
(position, prop, object, limit)
Lisp_Object prop, position, object, limit;
{
if (STRINGP (object))
{
position = Fprevious_single_property_change (position, prop, object, limit);
if (NILP (position))
{
if (NILP (limit))
position = make_number (SCHARS (object));
else
{
CHECK_NUMBER (limit);
position = limit;
}
}
}
else
{
int count = SPECPDL_INDEX ();
if (! NILP (object))
CHECK_BUFFER (object);
if (BUFFERP (object) && current_buffer != XBUFFER (object))
{
record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
Fset_buffer (object);
}
CHECK_NUMBER_COERCE_MARKER (position);
if (NILP (limit))
XSETFASTINT (limit, BEGV);
else
CHECK_NUMBER_COERCE_MARKER (limit);
if (XFASTINT (position) <= XFASTINT (limit))
{
position = limit;
if (XFASTINT (position) < BEGV)
XSETFASTINT (position, BEGV);
}
else
{
Lisp_Object initial_value
= Fget_char_property (make_number (XFASTINT (position) - 1),
prop, object);
while (1)
{
position = Fprevious_char_property_change (position, limit);
if (XFASTINT (position) <= XFASTINT (limit))
{
position = limit;
break;
}
else
{
Lisp_Object value
= Fget_char_property (make_number (XFASTINT (position) - 1),
prop, object);
if (!EQ (value, initial_value))
break;
}
}
}
unbind_to (count, Qnil);
}
return position;
}
DEFUN ("next-property-change", Fnext_property_change,
Snext_property_change, 1, 3, 0,
doc: )
(position, object, limit)
Lisp_Object position, object, limit;
{
register INTERVAL i, next;
if (NILP (object))
XSETBUFFER (object, current_buffer);
if (!NILP (limit) && !EQ (limit, Qt))
CHECK_NUMBER_COERCE_MARKER (limit);
i = validate_interval_range (object, &position, &position, soft);
if (EQ (limit, Qt))
{
if (NULL_INTERVAL_P (i))
next = i;
else
next = next_interval (i);
if (NULL_INTERVAL_P (next))
XSETFASTINT (position, (STRINGP (object)
? SCHARS (object)
: BUF_ZV (XBUFFER (object))));
else
XSETFASTINT (position, next->position);
return position;
}
if (NULL_INTERVAL_P (i))
return limit;
next = next_interval (i);
while (!NULL_INTERVAL_P (next) && intervals_equal (i, next)
&& (NILP (limit) || next->position < XFASTINT (limit)))
next = next_interval (next);
if (NULL_INTERVAL_P (next)
|| (next->position
>= (INTEGERP (limit)
? XFASTINT (limit)
: (STRINGP (object)
? SCHARS (object)
: BUF_ZV (XBUFFER (object))))))
return limit;
else
return make_number (next->position);
}
int
property_change_between_p (beg, end)
int beg, end;
{
register INTERVAL i, next;
Lisp_Object object, pos;
XSETBUFFER (object, current_buffer);
XSETFASTINT (pos, beg);
i = validate_interval_range (object, &pos, &pos, soft);
if (NULL_INTERVAL_P (i))
return 0;
next = next_interval (i);
while (! NULL_INTERVAL_P (next) && intervals_equal (i, next))
{
next = next_interval (next);
if (NULL_INTERVAL_P (next))
return 0;
if (next->position >= end)
return 0;
}
if (NULL_INTERVAL_P (next))
return 0;
return 1;
}
DEFUN ("next-single-property-change", Fnext_single_property_change,
Snext_single_property_change, 2, 4, 0,
doc: )
(position, prop, object, limit)
Lisp_Object position, prop, object, limit;
{
register INTERVAL i, next;
register Lisp_Object here_val;
if (NILP (object))
XSETBUFFER (object, current_buffer);
if (!NILP (limit))
CHECK_NUMBER_COERCE_MARKER (limit);
i = validate_interval_range (object, &position, &position, soft);
if (NULL_INTERVAL_P (i))
return limit;
here_val = textget (i->plist, prop);
next = next_interval (i);
while (! NULL_INTERVAL_P (next)
&& EQ (here_val, textget (next->plist, prop))
&& (NILP (limit) || next->position < XFASTINT (limit)))
next = next_interval (next);
if (NULL_INTERVAL_P (next)
|| (next->position
>= (INTEGERP (limit)
? XFASTINT (limit)
: (STRINGP (object)
? SCHARS (object)
: BUF_ZV (XBUFFER (object))))))
return limit;
else
return make_number (next->position);
}
DEFUN ("previous-property-change", Fprevious_property_change,
Sprevious_property_change, 1, 3, 0,
doc: )
(position, object, limit)
Lisp_Object position, object, limit;
{
register INTERVAL i, previous;
if (NILP (object))
XSETBUFFER (object, current_buffer);
if (!NILP (limit))
CHECK_NUMBER_COERCE_MARKER (limit);
i = validate_interval_range (object, &position, &position, soft);
if (NULL_INTERVAL_P (i))
return limit;
if (i->position == XFASTINT (position))
i = previous_interval (i);
previous = previous_interval (i);
while (!NULL_INTERVAL_P (previous) && intervals_equal (previous, i)
&& (NILP (limit)
|| (previous->position + LENGTH (previous) > XFASTINT (limit))))
previous = previous_interval (previous);
if (NULL_INTERVAL_P (previous)
|| (previous->position + LENGTH (previous)
<= (INTEGERP (limit)
? XFASTINT (limit)
: (STRINGP (object) ? 0 : BUF_BEGV (XBUFFER (object))))))
return limit;
else
return make_number (previous->position + LENGTH (previous));
}
DEFUN ("previous-single-property-change", Fprevious_single_property_change,
Sprevious_single_property_change, 2, 4, 0,
doc: )
(position, prop, object, limit)
Lisp_Object position, prop, object, limit;
{
register INTERVAL i, previous;
register Lisp_Object here_val;
if (NILP (object))
XSETBUFFER (object, current_buffer);
if (!NILP (limit))
CHECK_NUMBER_COERCE_MARKER (limit);
i = validate_interval_range (object, &position, &position, soft);
if (!NULL_INTERVAL_P (i) && i->position == XFASTINT (position))
i = previous_interval (i);
if (NULL_INTERVAL_P (i))
return limit;
here_val = textget (i->plist, prop);
previous = previous_interval (i);
while (!NULL_INTERVAL_P (previous)
&& EQ (here_val, textget (previous->plist, prop))
&& (NILP (limit)
|| (previous->position + LENGTH (previous) > XFASTINT (limit))))
previous = previous_interval (previous);
if (NULL_INTERVAL_P (previous)
|| (previous->position + LENGTH (previous)
<= (INTEGERP (limit)
? XFASTINT (limit)
: (STRINGP (object) ? 0 : BUF_BEGV (XBUFFER (object))))))
return limit;
else
return make_number (previous->position + LENGTH (previous));
}
DEFUN ("add-text-properties", Fadd_text_properties,
Sadd_text_properties, 3, 4, 0,
doc: )
(start, end, properties, object)
Lisp_Object start, end, properties, object;
{
register INTERVAL i, unchanged;
register int s, len, modified = 0;
struct gcpro gcpro1;
properties = validate_plist (properties);
if (NILP (properties))
return Qnil;
if (NILP (object))
XSETBUFFER (object, current_buffer);
i = validate_interval_range (object, &start, &end, hard);
if (NULL_INTERVAL_P (i))
return Qnil;
s = XINT (start);
len = XINT (end) - s;
GCPRO1 (properties);
if (i->position != s)
{
if (interval_has_all_properties (properties, i))
{
int got = (LENGTH (i) - (s - i->position));
if (got >= len)
RETURN_UNGCPRO (Qnil);
len -= got;
i = next_interval (i);
}
else
{
unchanged = i;
i = split_interval_right (unchanged, s - unchanged->position);
copy_properties (unchanged, i);
}
}
if (BUFFERP (object))
modify_region (XBUFFER (object), XINT (start), XINT (end), 1);
for (;;)
{
if (i == 0)
abort ();
if (LENGTH (i) >= len)
{
UNGCPRO;
if (interval_has_all_properties (properties, i))
{
if (BUFFERP (object))
signal_after_change (XINT (start), XINT (end) - XINT (start),
XINT (end) - XINT (start));
return modified ? Qt : Qnil;
}
if (LENGTH (i) == len)
{
add_properties (properties, i, object);
if (BUFFERP (object))
signal_after_change (XINT (start), XINT (end) - XINT (start),
XINT (end) - XINT (start));
return Qt;
}
unchanged = i;
i = split_interval_left (unchanged, len);
copy_properties (unchanged, i);
add_properties (properties, i, object);
if (BUFFERP (object))
signal_after_change (XINT (start), XINT (end) - XINT (start),
XINT (end) - XINT (start));
return Qt;
}
len -= LENGTH (i);
modified += add_properties (properties, i, object);
i = next_interval (i);
}
}
DEFUN ("put-text-property", Fput_text_property,
Sput_text_property, 4, 5, 0,
doc: )
(start, end, property, value, object)
Lisp_Object start, end, property, value, object;
{
Fadd_text_properties (start, end,
Fcons (property, Fcons (value, Qnil)),
object);
return Qnil;
}
DEFUN ("set-text-properties", Fset_text_properties,
Sset_text_properties, 3, 4, 0,
doc: )
(start, end, properties, object)
Lisp_Object start, end, properties, object;
{
return set_text_properties (start, end, properties, object, Qt);
}
Lisp_Object
set_text_properties (start, end, properties, object, signal_after_change_p)
Lisp_Object start, end, properties, object, signal_after_change_p;
{
register INTERVAL i;
Lisp_Object ostart, oend;
ostart = start;
oend = end;
properties = validate_plist (properties);
if (NILP (object))
XSETBUFFER (object, current_buffer);
if (NILP (properties) && STRINGP (object)
&& XFASTINT (start) == 0
&& XFASTINT (end) == SCHARS (object))
{
if (! STRING_INTERVALS (object))
return Qnil;
STRING_SET_INTERVALS (object, NULL_INTERVAL);
return Qt;
}
i = validate_interval_range (object, &start, &end, soft);
if (NULL_INTERVAL_P (i))
{
if (NILP (properties))
return Qnil;
start = ostart;
end = oend;
i = validate_interval_range (object, &start, &end, hard);
if (NULL_INTERVAL_P (i))
return Qnil;
}
if (BUFFERP (object))
modify_region (XBUFFER (object), XINT (start), XINT (end), 1);
set_text_properties_1 (start, end, properties, object, i);
if (BUFFERP (object) && !NILP (signal_after_change_p))
signal_after_change (XINT (start), XINT (end) - XINT (start),
XINT (end) - XINT (start));
return Qt;
}
void
set_text_properties_1 (start, end, properties, buffer, i)
Lisp_Object start, end, properties, buffer;
INTERVAL i;
{
register INTERVAL prev_changed = NULL_INTERVAL;
register int s, len;
INTERVAL unchanged;
s = XINT (start);
len = XINT (end) - s;
if (len == 0)
return;
if (len < 0)
{
s = s + len;
len = - len;
}
if (i == 0)
i = find_interval (BUF_INTERVALS (XBUFFER (buffer)), s);
if (i->position != s)
{
unchanged = i;
i = split_interval_right (unchanged, s - unchanged->position);
if (LENGTH (i) > len)
{
copy_properties (unchanged, i);
i = split_interval_left (i, len);
set_properties (properties, i, buffer);
return;
}
set_properties (properties, i, buffer);
if (LENGTH (i) == len)
return;
prev_changed = i;
len -= LENGTH (i);
i = next_interval (i);
}
while (len > 0)
{
if (i == 0)
abort ();
if (LENGTH (i) >= len)
{
if (LENGTH (i) > len)
i = split_interval_left (i, len);
set_properties (properties, i, buffer);
if (!NULL_INTERVAL_P (prev_changed))
merge_interval_left (i);
return;
}
len -= LENGTH (i);
set_properties (properties, i, buffer);
if (NULL_INTERVAL_P (prev_changed))
prev_changed = i;
else
prev_changed = i = merge_interval_left (i);
i = next_interval (i);
}
}
DEFUN ("remove-text-properties", Fremove_text_properties,
Sremove_text_properties, 3, 4, 0,
doc: )
(start, end, properties, object)
Lisp_Object start, end, properties, object;
{
register INTERVAL i, unchanged;
register int s, len, modified = 0;
if (NILP (object))
XSETBUFFER (object, current_buffer);
i = validate_interval_range (object, &start, &end, soft);
if (NULL_INTERVAL_P (i))
return Qnil;
s = XINT (start);
len = XINT (end) - s;
if (i->position != s)
{
if (! interval_has_some_properties (properties, i))
{
int got = (LENGTH (i) - (s - i->position));
if (got >= len)
return Qnil;
len -= got;
i = next_interval (i);
}
else
{
unchanged = i;
i = split_interval_right (unchanged, s - unchanged->position);
copy_properties (unchanged, i);
}
}
if (BUFFERP (object))
modify_region (XBUFFER (object), XINT (start), XINT (end), 1);
for (;;)
{
if (i == 0)
abort ();
if (LENGTH (i) >= len)
{
if (! interval_has_some_properties (properties, i))
return modified ? Qt : Qnil;
if (LENGTH (i) == len)
{
remove_properties (properties, Qnil, i, object);
if (BUFFERP (object))
signal_after_change (XINT (start), XINT (end) - XINT (start),
XINT (end) - XINT (start));
return Qt;
}
unchanged = i;
i = split_interval_left (i, len);
copy_properties (unchanged, i);
remove_properties (properties, Qnil, i, object);
if (BUFFERP (object))
signal_after_change (XINT (start), XINT (end) - XINT (start),
XINT (end) - XINT (start));
return Qt;
}
len -= LENGTH (i);
modified += remove_properties (properties, Qnil, i, object);
i = next_interval (i);
}
}
DEFUN ("remove-list-of-text-properties", Fremove_list_of_text_properties,
Sremove_list_of_text_properties, 3, 4, 0,
doc: )
(start, end, list_of_properties, object)
Lisp_Object start, end, list_of_properties, object;
{
register INTERVAL i, unchanged;
register int s, len, modified = 0;
Lisp_Object properties;
properties = list_of_properties;
if (NILP (object))
XSETBUFFER (object, current_buffer);
i = validate_interval_range (object, &start, &end, soft);
if (NULL_INTERVAL_P (i))
return Qnil;
s = XINT (start);
len = XINT (end) - s;
if (i->position != s)
{
if (! interval_has_some_properties_list (properties, i))
{
int got = (LENGTH (i) - (s - i->position));
if (got >= len)
return Qnil;
len -= got;
i = next_interval (i);
}
else
{
unchanged = i;
i = split_interval_right (unchanged, s - unchanged->position);
copy_properties (unchanged, i);
}
}
for (;;)
{
if (i == 0)
abort ();
if (LENGTH (i) >= len)
{
if (! interval_has_some_properties_list (properties, i))
if (modified)
{
if (BUFFERP (object))
signal_after_change (XINT (start), XINT (end) - XINT (start),
XINT (end) - XINT (start));
return Qt;
}
else
return Qnil;
if (LENGTH (i) == len)
{
if (!modified && BUFFERP (object))
modify_region (XBUFFER (object), XINT (start), XINT (end), 1);
remove_properties (Qnil, properties, i, object);
if (BUFFERP (object))
signal_after_change (XINT (start), XINT (end) - XINT (start),
XINT (end) - XINT (start));
return Qt;
}
unchanged = i;
i = split_interval_left (i, len);
copy_properties (unchanged, i);
if (!modified && BUFFERP (object))
modify_region (XBUFFER (object), XINT (start), XINT (end), 1);
remove_properties (Qnil, properties, i, object);
if (BUFFERP (object))
signal_after_change (XINT (start), XINT (end) - XINT (start),
XINT (end) - XINT (start));
return Qt;
}
if (interval_has_some_properties_list (properties, i))
{
if (!modified && BUFFERP (object))
modify_region (XBUFFER (object), XINT (start), XINT (end), 1);
remove_properties (Qnil, properties, i, object);
modified = 1;
}
len -= LENGTH (i);
i = next_interval (i);
}
}
DEFUN ("text-property-any", Ftext_property_any,
Stext_property_any, 4, 5, 0,
doc: )
(start, end, property, value, object)
Lisp_Object start, end, property, value, object;
{
register INTERVAL i;
register int e, pos;
if (NILP (object))
XSETBUFFER (object, current_buffer);
i = validate_interval_range (object, &start, &end, soft);
if (NULL_INTERVAL_P (i))
return (!NILP (value) || EQ (start, end) ? Qnil : start);
e = XINT (end);
while (! NULL_INTERVAL_P (i))
{
if (i->position >= e)
break;
if (EQ (textget (i->plist, property), value))
{
pos = i->position;
if (pos < XINT (start))
pos = XINT (start);
return make_number (pos);
}
i = next_interval (i);
}
return Qnil;
}
DEFUN ("text-property-not-all", Ftext_property_not_all,
Stext_property_not_all, 4, 5, 0,
doc: )
(start, end, property, value, object)
Lisp_Object start, end, property, value, object;
{
register INTERVAL i;
register int s, e;
if (NILP (object))
XSETBUFFER (object, current_buffer);
i = validate_interval_range (object, &start, &end, soft);
if (NULL_INTERVAL_P (i))
return (NILP (value) || EQ (start, end)) ? Qnil : start;
s = XINT (start);
e = XINT (end);
while (! NULL_INTERVAL_P (i))
{
if (i->position >= e)
break;
if (! EQ (textget (i->plist, property), value))
{
if (i->position > s)
s = i->position;
return make_number (s);
}
i = next_interval (i);
}
return Qnil;
}
int
text_property_stickiness (prop, pos, buffer)
Lisp_Object prop, pos, buffer;
{
Lisp_Object prev_pos, front_sticky;
int is_rear_sticky = 1, is_front_sticky = 0;
if (NILP (buffer))
XSETBUFFER (buffer, current_buffer);
if (XINT (pos) > BUF_BEGV (XBUFFER (buffer)))
{
Lisp_Object rear_non_sticky;
prev_pos = make_number (XINT (pos) - 1);
rear_non_sticky = Fget_text_property (prev_pos, Qrear_nonsticky, buffer);
if (!NILP (CONSP (rear_non_sticky)
? Fmemq (prop, rear_non_sticky)
: rear_non_sticky))
is_rear_sticky = 0;
}
else
return 0;
front_sticky = Fget_text_property (pos, Qfront_sticky, buffer);
if (EQ (front_sticky, Qt)
|| (CONSP (front_sticky)
&& !NILP (Fmemq (prop, front_sticky))))
is_front_sticky = 1;
if (is_rear_sticky && !is_front_sticky)
return -1;
else if (!is_rear_sticky && is_front_sticky)
return 1;
else if (!is_rear_sticky && !is_front_sticky)
return 0;
if (XINT (pos) == BUF_BEGV (XBUFFER (buffer))
|| NILP (Fget_text_property (prev_pos, prop, buffer)))
return 1;
else
return -1;
}
Lisp_Object
copy_text_properties (start, end, src, pos, dest, prop)
Lisp_Object start, end, src, pos, dest, prop;
{
INTERVAL i;
Lisp_Object res;
Lisp_Object stuff;
Lisp_Object plist;
int s, e, e2, p, len, modified = 0;
struct gcpro gcpro1, gcpro2;
i = validate_interval_range (src, &start, &end, soft);
if (NULL_INTERVAL_P (i))
return Qnil;
CHECK_NUMBER_COERCE_MARKER (pos);
{
Lisp_Object dest_start, dest_end;
dest_start = pos;
XSETFASTINT (dest_end, XINT (dest_start) + (XINT (end) - XINT (start)));
validate_interval_range (dest, &dest_start, &dest_end, soft);
}
s = XINT (start);
e = XINT (end);
p = XINT (pos);
stuff = Qnil;
while (s < e)
{
e2 = i->position + LENGTH (i);
if (e2 > e)
e2 = e;
len = e2 - s;
plist = i->plist;
if (! NILP (prop))
while (! NILP (plist))
{
if (EQ (Fcar (plist), prop))
{
plist = Fcons (prop, Fcons (Fcar (Fcdr (plist)), Qnil));
break;
}
plist = Fcdr (Fcdr (plist));
}
if (! NILP (plist))
{
stuff = Fcons (Fcons (make_number (p),
Fcons (make_number (p + len),
Fcons (plist, Qnil))),
stuff);
}
i = next_interval (i);
if (NULL_INTERVAL_P (i))
break;
p += len;
s = i->position;
}
GCPRO2 (stuff, dest);
while (! NILP (stuff))
{
res = Fcar (stuff);
res = Fadd_text_properties (Fcar (res), Fcar (Fcdr (res)),
Fcar (Fcdr (Fcdr (res))), dest);
if (! NILP (res))
modified++;
stuff = Fcdr (stuff);
}
UNGCPRO;
return modified ? Qt : Qnil;
}
Lisp_Object
text_property_list (object, start, end, prop)
Lisp_Object object, start, end, prop;
{
struct interval *i;
Lisp_Object result;
result = Qnil;
i = validate_interval_range (object, &start, &end, soft);
if (!NULL_INTERVAL_P (i))
{
int s = XINT (start);
int e = XINT (end);
while (s < e)
{
int interval_end, len;
Lisp_Object plist;
interval_end = i->position + LENGTH (i);
if (interval_end > e)
interval_end = e;
len = interval_end - s;
plist = i->plist;
if (!NILP (prop))
for (; !NILP (plist); plist = Fcdr (Fcdr (plist)))
if (EQ (Fcar (plist), prop))
{
plist = Fcons (prop, Fcons (Fcar (Fcdr (plist)), Qnil));
break;
}
if (!NILP (plist))
result = Fcons (Fcons (make_number (s),
Fcons (make_number (s + len),
Fcons (plist, Qnil))),
result);
i = next_interval (i);
if (NULL_INTERVAL_P (i))
break;
s = i->position;
}
}
return result;
}
int
add_text_properties_from_list (object, list, delta)
Lisp_Object object, list, delta;
{
struct gcpro gcpro1, gcpro2;
int modified_p = 0;
GCPRO2 (list, object);
for (; CONSP (list); list = XCDR (list))
{
Lisp_Object item, start, end, plist, tem;
item = XCAR (list);
start = make_number (XINT (XCAR (item)) + XINT (delta));
end = make_number (XINT (XCAR (XCDR (item))) + XINT (delta));
plist = XCAR (XCDR (XCDR (item)));
tem = Fadd_text_properties (start, end, plist, object);
if (!NILP (tem))
modified_p = 1;
}
UNGCPRO;
return modified_p;
}
void
extend_property_ranges (list, old_end, new_end)
Lisp_Object list, old_end, new_end;
{
for (; CONSP (list); list = XCDR (list))
{
Lisp_Object item, end;
item = XCAR (list);
end = XCAR (XCDR (item));
if (EQ (end, old_end))
XSETCAR (XCDR (item), new_end);
}
}
static void
call_mod_hooks (list, start, end)
Lisp_Object list, start, end;
{
struct gcpro gcpro1;
GCPRO1 (list);
while (!NILP (list))
{
call2 (Fcar (list), start, end);
list = Fcdr (list);
}
UNGCPRO;
}
void
verify_interval_modification (buf, start, end)
struct buffer *buf;
int start, end;
{
register INTERVAL intervals = BUF_INTERVALS (buf);
register INTERVAL i;
Lisp_Object hooks;
register Lisp_Object prev_mod_hooks;
Lisp_Object mod_hooks;
struct gcpro gcpro1;
hooks = Qnil;
prev_mod_hooks = Qnil;
mod_hooks = Qnil;
interval_insert_behind_hooks = Qnil;
interval_insert_in_front_hooks = Qnil;
if (NULL_INTERVAL_P (intervals))
return;
if (start > end)
{
int temp = start;
start = end;
end = temp;
}
if (start == end)
{
INTERVAL prev = NULL;
Lisp_Object before, after;
i = find_interval (intervals, start);
if (start == BUF_BEGV (buf))
prev = 0;
else if (i->position == start)
prev = previous_interval (i);
else if (i->position < start)
prev = i;
if (start == BUF_ZV (buf))
i = 0;
if (NILP (Vinhibit_read_only) || CONSP (Vinhibit_read_only))
{
if (i != prev)
{
if (! NULL_INTERVAL_P (i))
{
after = textget (i->plist, Qread_only);
if (! NILP (after)
&& NILP (Fmemq (after, Vinhibit_read_only)))
{
Lisp_Object tem;
tem = textget (i->plist, Qfront_sticky);
if (TMEM (Qread_only, tem)
|| (NILP (Fplist_get (i->plist, Qread_only))
&& TMEM (Qcategory, tem)))
text_read_only (after);
}
}
if (! NULL_INTERVAL_P (prev))
{
before = textget (prev->plist, Qread_only);
if (! NILP (before)
&& NILP (Fmemq (before, Vinhibit_read_only)))
{
Lisp_Object tem;
tem = textget (prev->plist, Qrear_nonsticky);
if (! TMEM (Qread_only, tem)
&& (! NILP (Fplist_get (prev->plist,Qread_only))
|| ! TMEM (Qcategory, tem)))
text_read_only (before);
}
}
}
else if (! NULL_INTERVAL_P (i))
{
after = textget (i->plist, Qread_only);
if (! NILP (after) && NILP (Fmemq (after, Vinhibit_read_only)))
{
Lisp_Object tem;
tem = textget (i->plist, Qfront_sticky);
if (TMEM (Qread_only, tem)
|| (NILP (Fplist_get (i->plist, Qread_only))
&& TMEM (Qcategory, tem)))
text_read_only (after);
tem = textget (prev->plist, Qrear_nonsticky);
if (! TMEM (Qread_only, tem)
&& (! NILP (Fplist_get (prev->plist, Qread_only))
|| ! TMEM (Qcategory, tem)))
text_read_only (after);
}
}
}
if (!NULL_INTERVAL_P (prev))
interval_insert_behind_hooks
= textget (prev->plist, Qinsert_behind_hooks);
if (!NULL_INTERVAL_P (i))
interval_insert_in_front_hooks
= textget (i->plist, Qinsert_in_front_hooks);
}
else
{
i = find_interval (intervals, start);
do
{
if (! INTERVAL_WRITABLE_P (i))
text_read_only (textget (i->plist, Qread_only));
if (!inhibit_modification_hooks)
{
mod_hooks = textget (i->plist, Qmodification_hooks);
if (! NILP (mod_hooks) && ! EQ (mod_hooks, prev_mod_hooks))
{
hooks = Fcons (mod_hooks, hooks);
prev_mod_hooks = mod_hooks;
}
}
i = next_interval (i);
}
while (! NULL_INTERVAL_P (i) && i->position < end);
if (!inhibit_modification_hooks)
{
GCPRO1 (hooks);
hooks = Fnreverse (hooks);
while (! EQ (hooks, Qnil))
{
call_mod_hooks (Fcar (hooks), make_number (start),
make_number (end));
hooks = Fcdr (hooks);
}
UNGCPRO;
}
}
}
void
report_interval_modification (start, end)
Lisp_Object start, end;
{
if (! NILP (interval_insert_behind_hooks))
call_mod_hooks (interval_insert_behind_hooks, start, end);
if (! NILP (interval_insert_in_front_hooks)
&& ! EQ (interval_insert_in_front_hooks,
interval_insert_behind_hooks))
call_mod_hooks (interval_insert_in_front_hooks, start, end);
}
void
syms_of_textprop ()
{
DEFVAR_LISP ("default-text-properties", &Vdefault_text_properties,
doc: );
Vdefault_text_properties = Qnil;
DEFVAR_LISP ("char-property-alias-alist", &Vchar_property_alias_alist,
doc: );
Vchar_property_alias_alist = Qnil;
DEFVAR_LISP ("inhibit-point-motion-hooks", &Vinhibit_point_motion_hooks,
doc: );
Vinhibit_point_motion_hooks = Qnil;
DEFVAR_LISP ("text-property-default-nonsticky",
&Vtext_property_default_nonsticky,
doc: );
Vtext_property_default_nonsticky
= Fcons (Fcons (intern ("syntax-table"), Qt), Qnil);
staticpro (&interval_insert_behind_hooks);
staticpro (&interval_insert_in_front_hooks);
interval_insert_behind_hooks = Qnil;
interval_insert_in_front_hooks = Qnil;
staticpro (&Qforeground);
Qforeground = intern ("foreground");
staticpro (&Qbackground);
Qbackground = intern ("background");
staticpro (&Qfont);
Qfont = intern ("font");
staticpro (&Qstipple);
Qstipple = intern ("stipple");
staticpro (&Qunderline);
Qunderline = intern ("underline");
staticpro (&Qread_only);
Qread_only = intern ("read-only");
staticpro (&Qinvisible);
Qinvisible = intern ("invisible");
staticpro (&Qintangible);
Qintangible = intern ("intangible");
staticpro (&Qcategory);
Qcategory = intern ("category");
staticpro (&Qlocal_map);
Qlocal_map = intern ("local-map");
staticpro (&Qfront_sticky);
Qfront_sticky = intern ("front-sticky");
staticpro (&Qrear_nonsticky);
Qrear_nonsticky = intern ("rear-nonsticky");
staticpro (&Qmouse_face);
Qmouse_face = intern ("mouse-face");
staticpro (&Qmouse_left);
Qmouse_left = intern ("mouse-left");
staticpro (&Qmouse_entered);
Qmouse_entered = intern ("mouse-entered");
staticpro (&Qpoint_left);
Qpoint_left = intern ("point-left");
staticpro (&Qpoint_entered);
Qpoint_entered = intern ("point-entered");
defsubr (&Stext_properties_at);
defsubr (&Sget_text_property);
defsubr (&Sget_char_property);
defsubr (&Sget_char_property_and_overlay);
defsubr (&Snext_char_property_change);
defsubr (&Sprevious_char_property_change);
defsubr (&Snext_single_char_property_change);
defsubr (&Sprevious_single_char_property_change);
defsubr (&Snext_property_change);
defsubr (&Snext_single_property_change);
defsubr (&Sprevious_property_change);
defsubr (&Sprevious_single_property_change);
defsubr (&Sadd_text_properties);
defsubr (&Sput_text_property);
defsubr (&Sset_text_properties);
defsubr (&Sremove_text_properties);
defsubr (&Sremove_list_of_text_properties);
defsubr (&Stext_property_any);
defsubr (&Stext_property_not_all);
}