#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 Vtext_property_default_nonsticky;
Lisp_Object interval_insert_behind_hooks;
Lisp_Object interval_insert_in_front_hooks;
static void
text_read_only ()
{
Fsignal (Qtext_read_only, Qnil);
}
#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, 0);
CHECK_NUMBER_COERCE_MARKER (*begin, 0);
CHECK_NUMBER_COERCE_MARKER (*end, 0);
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
{
register struct Lisp_String *s = XSTRING (object);
if (! (0 <= XINT (*begin) && XINT (*begin) <= XINT (*end)
&& XINT (*end) <= s->size))
args_out_of_range (*begin, *end);
XSETFASTINT (*begin, XFASTINT (*begin));
if (begin != end)
XSETFASTINT (*end, XFASTINT (*end));
i = s->intervals;
if (s->size == 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 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, i, object)
Lisp_Object plist;
INTERVAL i;
Lisp_Object object;
{
register Lisp_Object tail1, tail2, sym, current_plist;
register int changed = 0;
current_plist = i->plist;
for (tail1 = plist; ! NILP (tail1); tail1 = Fcdr (Fcdr (tail1)))
{
sym = Fcar (tail1);
while (! NILP (current_plist) && EQ (sym, Fcar (current_plist)))
{
if (BUFFERP (object))
{
record_property_change (i->position, LENGTH (i),
sym, Fcar (Fcdr (current_plist)),
object);
}
current_plist = Fcdr (Fcdr (current_plist));
changed++;
}
tail2 = current_plist;
while (! NILP (tail2))
{
register Lisp_Object this;
this = Fcdr (Fcdr (tail2));
if (EQ (sym, Fcar (this)))
{
if (BUFFERP (object))
{
record_property_change (i->position, LENGTH (i),
sym, Fcar (Fcdr (this)), object);
}
Fsetcdr (Fcdr (tail2), Fcdr (Fcdr (this)));
changed++;
}
tail2 = this;
}
}
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, 0);
if (BUFFERP (object))
{
register struct buffer *b = XBUFFER (object);
beg = BUF_BEGV (b);
end = BUF_ZV (b);
i = BUF_INTERVALS (b);
}
else
{
register struct Lisp_String *s = XSTRING (object);
beg = 0;
end = s->size;
i = s->intervals;
}
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,
"Return the list of properties of the character at POSITION in OBJECT.\n\
OBJECT is the string or buffer to look for the properties in;\n\
nil means the current buffer.\n\
If POSITION is at the end of OBJECT, the value is nil.")
(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,
"Return the value of POSITION's property PROP, in OBJECT.\n\
OBJECT is optional and defaults to the current buffer.\n\
If POSITION is at the end of OBJECT, the value is nil.")
(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, 0);
if (NILP (object))
XSETBUFFER (object, current_buffer);
if (WINDOWP (object))
{
w = XWINDOW (object);
object = w->buffer;
}
if (BUFFERP (object))
{
int posn = XINT (position);
int noverlays;
Lisp_Object *overlay_vec, tem;
int next_overlay;
int len;
struct buffer *obuf = current_buffer;
set_buffer_temp (XBUFFER (object));
len = 40;
overlay_vec = (Lisp_Object *) alloca (len * sizeof (Lisp_Object));
noverlays = overlays_at (posn, 0, &overlay_vec, &len,
&next_overlay, NULL, 0);
if (noverlays > len)
{
len = noverlays;
overlay_vec = (Lisp_Object *) alloca (len * sizeof (Lisp_Object));
noverlays = overlays_at (posn, 0, &overlay_vec, &len,
&next_overlay, NULL, 0);
}
noverlays = sort_overlays (overlay_vec, noverlays, w);
set_buffer_temp (obuf);
while (--noverlays >= 0)
{
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,
"Return the value of POSITION's property PROP, in OBJECT.\n\
OBJECT is optional and defaults to the current buffer.\n\
If POSITION is at the end of OBJECT, the value is nil.\n\
If OBJECT is a buffer, then overlay properties are considered as well as\n\
text properties.\n\
If OBJECT is a window, then that window's buffer is used, but window-specific\n\
overlays are considered only if they are associated with OBJECT.")
(position, prop, object)
Lisp_Object position, object;
register Lisp_Object prop;
{
return get_char_property_and_overlay (position, prop, object, 0);
}
DEFUN ("next-char-property-change", Fnext_char_property_change,
Snext_char_property_change, 1, 2, 0,
"Return the position of next text property or overlay change.\n\
This scans characters forward from POSITION till it finds a change in\n\
some text property, or the beginning or end of an overlay, and returns\n\
the position of that.\n\
If none is found, the function returns (point-max).\n\
\n\
If the optional third argument LIMIT is non-nil, don't search\n\
past position LIMIT; return LIMIT if nothing is found before LIMIT.")
(position, limit)
Lisp_Object position, limit;
{
Lisp_Object temp;
temp = Fnext_overlay_change (position);
if (! NILP (limit))
{
CHECK_NUMBER (limit, 2);
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,
"Return the position of previous text property or overlay change.\n\
Scans characters backward from POSITION till it finds a change in some\n\
text property, or the beginning or end of an overlay, and returns the\n\
position of that.\n\
If none is found, the function returns (point-max).\n\
\n\
If the optional third argument LIMIT is non-nil, don't search\n\
past position LIMIT; return LIMIT if nothing is found before LIMIT.")
(position, limit)
Lisp_Object position, limit;
{
Lisp_Object temp;
temp = Fprevious_overlay_change (position);
if (! NILP (limit))
{
CHECK_NUMBER (limit, 2);
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,
"Return the position of next text property or overlay change for a specific property.\n\
Scans characters forward from POSITION till it finds\n\
a change in the PROP property, then returns the position of the change.\n\
The optional third argument OBJECT is the string or buffer to scan.\n\
The property values are compared with `eq'.\n\
If the property is constant all the way to the end of OBJECT, return the\n\
last valid position in OBJECT.\n\
If the optional fourth argument LIMIT is non-nil, don't search\n\
past position LIMIT; return LIMIT if nothing is found before LIMIT.")
(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 (XSTRING (object)->size);
else
position = limit;
}
}
else
{
Lisp_Object initial_value, value;
int count = specpdl_ptr - specpdl;
if (! NILP (object))
CHECK_BUFFER (object, 0);
if (BUFFERP (object) && current_buffer != XBUFFER (object))
{
record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
Fset_buffer (object);
}
initial_value = Fget_char_property (position, prop, object);
if (NILP (limit))
XSETFASTINT (limit, BUF_ZV (current_buffer));
else
CHECK_NUMBER_COERCE_MARKER (limit, 0);
for (;;)
{
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,
"Return the position of previous text property or overlay change for a specific property.\n\
Scans characters backward from POSITION till it finds\n\
a change in the PROP property, then returns the position of the change.\n\
The optional third argument OBJECT is the string or buffer to scan.\n\
The property values are compared with `eq'.\n\
If the property is constant all the way to the start of OBJECT, return the\n\
first valid position in OBJECT.\n\
If the optional fourth argument LIMIT is non-nil, don't search\n\
back past position LIMIT; return LIMIT if nothing is found before LIMIT.")
(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 (XSTRING (object)->size);
else
position = limit;
}
}
else
{
int count = specpdl_ptr - specpdl;
if (! NILP (object))
CHECK_BUFFER (object, 0);
if (BUFFERP (object) && current_buffer != XBUFFER (object))
{
record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
Fset_buffer (object);
}
if (NILP (limit))
XSETFASTINT (limit, BUF_BEGV (current_buffer));
else
CHECK_NUMBER_COERCE_MARKER (limit, 0);
if (XFASTINT (position) <= XFASTINT (limit))
position = limit;
else
{
Lisp_Object initial_value =
Fget_char_property (make_number (XFASTINT (position) - 1),
prop, object);
for (;;)
{
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,
"Return the position of next property change.\n\
Scans characters forward from POSITION in OBJECT till it finds\n\
a change in some text property, then returns the position of the change.\n\
The optional second argument OBJECT is the string or buffer to scan.\n\
Return nil if the property is constant all the way to the end of OBJECT.\n\
If the value is non-nil, it is a position greater than POSITION, never equal.\n\n\
If the optional third argument LIMIT is non-nil, don't search\n\
past position LIMIT; return LIMIT if nothing is found before LIMIT.")
(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, 0);
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)
? XSTRING (object)->size
: 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))
return limit;
if (! NILP (limit) && !(next->position < XFASTINT (limit)))
return limit;
XSETFASTINT (position, next->position);
return 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,
"Return the position of next property change for a specific property.\n\
Scans characters forward from POSITION till it finds\n\
a change in the PROP property, then returns the position of the change.\n\
The optional third argument OBJECT is the string or buffer to scan.\n\
The property values are compared with `eq'.\n\
Return nil if the property is constant all the way to the end of OBJECT.\n\
If the value is non-nil, it is a position greater than POSITION, never equal.\n\n\
If the optional fourth argument LIMIT is non-nil, don't search\n\
past position LIMIT; return LIMIT if nothing is found before LIMIT.")
(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, 0);
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))
return limit;
if (! NILP (limit) && !(next->position < XFASTINT (limit)))
return limit;
return make_number (next->position);
}
DEFUN ("previous-property-change", Fprevious_property_change,
Sprevious_property_change, 1, 3, 0,
"Return the position of previous property change.\n\
Scans characters backwards from POSITION in OBJECT till it finds\n\
a change in some text property, then returns the position of the change.\n\
The optional second argument OBJECT is the string or buffer to scan.\n\
Return nil if the property is constant all the way to the start of OBJECT.\n\
If the value is non-nil, it is a position less than POSITION, never equal.\n\n\
If the optional third argument LIMIT is non-nil, don't search\n\
back past position LIMIT; return LIMIT if nothing is found until LIMIT.")
(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, 0);
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))
return limit;
if (!NILP (limit)
&& !(previous->position + LENGTH (previous) > XFASTINT (limit)))
return limit;
return make_number (previous->position + LENGTH (previous));
}
DEFUN ("previous-single-property-change", Fprevious_single_property_change,
Sprevious_single_property_change, 2, 4, 0,
"Return the position of previous property change for a specific property.\n\
Scans characters backward from POSITION till it finds\n\
a change in the PROP property, then returns the position of the change.\n\
The optional third argument OBJECT is the string or buffer to scan.\n\
The property values are compared with `eq'.\n\
Return nil if the property is constant all the way to the start of OBJECT.\n\
If the value is non-nil, it is a position less than POSITION, never equal.\n\n\
If the optional fourth argument LIMIT is non-nil, don't search\n\
back past position LIMIT; return LIMIT if nothing is found until LIMIT.")
(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, 0);
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))
return limit;
if (!NILP (limit)
&& !(previous->position + LENGTH (previous) > XFASTINT (limit)))
return limit;
return make_number (previous->position + LENGTH (previous));
}
DEFUN ("add-text-properties", Fadd_text_properties,
Sadd_text_properties, 3, 4, 0,
"Add properties to the text from START to END.\n\
The third argument PROPERTIES is a property list\n\
specifying the property values to add.\n\
The optional fourth argument, OBJECT,\n\
is the string or buffer containing the text.\n\
Return t if any property value actually changed, nil otherwise.")
(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));
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,
"Set one property of the text from START to END.\n\
The third and fourth arguments PROPERTY and VALUE\n\
specify the property to add.\n\
The optional fifth argument, OBJECT,\n\
is the string or buffer containing the text.")
(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,
"Completely replace properties of text from START to END.\n\
The third argument PROPERTIES is the new property list.\n\
The optional fourth argument, OBJECT,\n\
is the string or buffer containing the text.\n\
If OBJECT is omitted or nil, it defaults to the current buffer.\n\
If PROPERTIES is nil, the effect is to remove all properties from\n\
the designated part of OBJECT.")
(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, unchanged;
register INTERVAL prev_changed = NULL_INTERVAL;
register int s, len;
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) == XSTRING (object)->size)
{
if (! XSTRING (object)->intervals)
return Qt;
XSTRING (object)->intervals = 0;
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;
}
s = XINT (start);
len = XINT (end) - s;
if (BUFFERP (object))
modify_region (XBUFFER (object), XINT (start), XINT (end));
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, object);
if (BUFFERP (object) && !NILP (signal_after_change_p))
signal_after_change (XINT (start), XINT (end) - XINT (start),
XINT (end) - XINT (start));
return Qt;
}
set_properties (properties, i, object);
if (LENGTH (i) == len)
{
if (BUFFERP (object) && !NILP (signal_after_change_p))
signal_after_change (XINT (start), XINT (end) - XINT (start),
XINT (end) - XINT (start));
return Qt;
}
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, object);
if (!NULL_INTERVAL_P (prev_changed))
merge_interval_left (i);
if (BUFFERP (object) && !NILP (signal_after_change_p))
signal_after_change (XINT (start), XINT (end) - XINT (start),
XINT (end) - XINT (start));
return Qt;
}
len -= LENGTH (i);
set_properties (properties, i, object);
if (NULL_INTERVAL_P (prev_changed))
prev_changed = i;
else
prev_changed = i = merge_interval_left (i);
i = next_interval (i);
}
if (BUFFERP (object) && !NILP (signal_after_change_p))
signal_after_change (XINT (start), XINT (end) - XINT (start),
XINT (end) - XINT (start));
return Qt;
}
DEFUN ("remove-text-properties", Fremove_text_properties,
Sremove_text_properties, 3, 4, 0,
"Remove some properties from text from START to END.\n\
The third argument PROPERTIES is a property list\n\
whose property names specify the properties to remove.\n\
\(The values stored in PROPERTIES are ignored.)\n\
The optional fourth argument, OBJECT,\n\
is the string or buffer containing the text.\n\
Return t if any property was actually removed, nil otherwise.")
(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));
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, 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, 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, i, object);
i = next_interval (i);
}
}
DEFUN ("text-property-any", Ftext_property_any,
Stext_property_any, 4, 5, 0,
"Check text from START to END for property PROPERTY equalling VALUE.\n\
If so, return the position of the first character whose property PROPERTY\n\
is `eq' to VALUE. Otherwise return nil.\n\
The optional fifth argument, OBJECT, is the string or buffer\n\
containing the text.")
(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,
"Check text from START to END for property PROPERTY not equalling VALUE.\n\
If so, return the position of the first character whose property PROPERTY\n\
is not `eq' to VALUE. Otherwise, return nil.\n\
The optional fifth argument, OBJECT, is the string or buffer\n\
containing the text.")
(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;
}
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, 0);
{
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))
XCAR (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 ();
}
}
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 ();
}
}
}
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 ();
tem = textget (prev->plist, Qrear_nonsticky);
if (! TMEM (Qread_only, tem)
&& (! NILP (Fplist_get (prev->plist, Qread_only))
|| ! TMEM (Qcategory, tem)))
text_read_only ();
}
}
}
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 ();
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,
"Property-list used as default values.\n\
The value of a property in this list is seen as the value for every\n\
character that does not have its own value for that property.");
Vdefault_text_properties = Qnil;
DEFVAR_LISP ("inhibit-point-motion-hooks", &Vinhibit_point_motion_hooks,
"If non-nil, don't run `point-left' and `point-entered' text properties.\n\
This also inhibits the use of the `intangible' text property.");
Vinhibit_point_motion_hooks = Qnil;
DEFVAR_LISP ("text-property-default-nonsticky",
&Vtext_property_default_nonsticky,
"Alist of properties vs the corresponding non-stickinesses.\n\
Each element has the form (PROPERTY . NONSTICKINESS).\n\
\n\
If a character in a buffer has PROPERTY, new text inserted adjacent to\n\
the character doesn't inherit PROPERTY if NONSTICKINESS is non-nil,\n\
inherits it if NONSTICKINESS is nil. The front-sticky and\n\
rear-nonsticky properties of the character overrides NONSTICKINESS.");
Vtext_property_default_nonsticky = 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 (&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 (&Stext_property_any);
defsubr (&Stext_property_not_all);
}