comparison src/textprop.c @ 17467:98c47e7857f3

Style of comments corrected. (interval_of): New function.

17466:c6ba5208968b

/* Interface code for dealing with text properties.
   Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc.

This file is part of GNU Emacs.

GNU Emacs is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by

  It is assumed that for any interval plist, a property appears
  only once on the list.  Although some code i.e., remove_properties,
  handles the more general case, the uniqueness of properties is
  necessary for the system to remain consistent.  This requirement
  is enforced by the subrs installing properties onto the intervals. */

/* The rest of the file is within this conditional */
#ifdef USE_TEXT_PROPERTIES

/* Types of hooks. */
Lisp_Object Qmouse_left;
Lisp_Object Qmouse_entered;
Lisp_Object Qpoint_left;
Lisp_Object Qpoint_entered;
Lisp_Object Qcategory;
Lisp_Object Qlocal_map;

/* Visual properties text (including strings) may have. */
Lisp_Object Qforeground, Qbackground, Qfont, Qunderline, Qstipple;
Lisp_Object Qinvisible, Qread_only, Qintangible;

/* Sticky properties */
Lisp_Object Qfront_sticky, Qrear_nonsticky;

  CHECK_STRING_OR_BUFFER (object, 0);
  CHECK_NUMBER_COERCE_MARKER (*begin, 0);
  CHECK_NUMBER_COERCE_MARKER (*end, 0);

  /* If we are asked for a point, but from a subr which operates
     on a range, then return nothing. */
  if (EQ (*begin, *end) && begin != end)
    return NULL_INTERVAL;

  if (XINT (*begin) > XINT (*end))
    {

      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 there's no text, there are no properties. */
      if (BUF_BEGV (b) == BUF_ZV (b))
	return NULL_INTERVAL;

      searchpos = XINT (*begin);
    }

  return find_interval (i, searchpos);
}

/* Validate LIST as a property list.  If LIST is not a list, then
   make one consisting of (LIST nil).  Otherwise, verify that LIST
   is even numbered and thus suitable as a plist. */

static Lisp_Object
validate_plist (list)
     Lisp_Object list;
{

  return Fcons (list, Fcons (Qnil, Qnil));
}

/* Return nonzero if interval I has all the properties,
   with the same values, of list PLIST. */

static int
interval_has_all_properties (plist, i)
     Lisp_Object plist;
     INTERVAL i;
{
  register Lisp_Object tail1, tail2, sym1, sym2;
  register int found;

  /* Go through each element of PLIST. */
  for (tail1 = plist; ! NILP (tail1); tail1 = Fcdr (Fcdr (tail1)))
    {
      sym1 = Fcar (tail1);
      found = 0;

      /* Go through I's plist, looking for sym1 */
      for (tail2 = i->plist; ! NILP (tail2); tail2 = Fcdr (Fcdr (tail2)))
	if (EQ (sym1, Fcar (tail2)))
	  {
	    /* Found the same property on both lists.  If the
	       values are unequal, return zero. */
	    if (! EQ (Fcar (Fcdr (tail1)), Fcar (Fcdr (tail2))))
	      return 0;

	    /* Property has same value on both lists;  go to next one. */
	    found = 1;
	    break;
	  }

      if (! found)

  return 1;
}

/* Return nonzero if the plist of interval I has any of the
   properties of PLIST, regardless of their values. */

static INLINE int
interval_has_some_properties (plist, i)
     Lisp_Object plist;
     INTERVAL i;
{
  register Lisp_Object tail1, tail2, sym;

  /* Go through each element of PLIST. */
  for (tail1 = plist; ! NILP (tail1); tail1 = Fcdr (Fcdr (tail1)))
    {
      sym = Fcar (tail1);

      /* Go through i's plist, looking for tail1 */

  /* No need to protect OBJECT, because we can GC only in the case
     where it is a buffer, and live buffers are always protected.
     I and its plist are also protected, via OBJECT.  */
  GCPRO3 (tail1, sym1, val1);

  /* Go through each element of PLIST. */
  for (tail1 = plist; ! NILP (tail1); tail1 = Fcdr (Fcdr (tail1)))
    {
      sym1 = Fcar (tail1);
      val1 = Fcar (Fcdr (tail1));
      found = 0;

	    /* No need to gcpro, because tail2 protects this
	       and it must be a cons cell (we get an error otherwise).  */
	    register Lisp_Object this_cdr;

	    this_cdr = Fcdr (tail2);
	    /* Found the property.  Now check its value. */
	    found = 1;

	    /* The properties have the same value on both lists.
	       Continue to the next property. */
	    if (EQ (val1, Fcar (this_cdr)))
	      break;

	    /* Record this change in the buffer, for undo purposes.  */
	    if (BUFFERP (object))

{
  register Lisp_Object tail1, tail2, sym, current_plist;
  register int changed = 0;

  current_plist = i->plist;
  /* Go through each element of plist. */
  for (tail1 = plist; ! NILP (tail1); tail1 = Fcdr (Fcdr (tail1)))
    {
      sym = Fcar (tail1);

      /* First, remove the symbol if its at the head of the list */

  return changed;
}

#if 0
/* Remove all properties from interval I.  Return non-zero
   if this changes the interval. */

static INLINE int
erase_properties (i)
     INTERVAL i;
{

  i->plist = Qnil;
  return 1;
}
#endif

DEFUN ("text-properties-at", Ftext_properties_at,
       Stext_properties_at, 1, 2, 0,
  "Return the list of properties held by the character at POSITION\n\
in optional argument OBJECT, a string or buffer.  If nil, OBJECT\n\

  /* No need to protect OBJECT, because we GC only if it's a buffer,
     and live buffers are always protected.  */
  GCPRO1 (properties);

  /* If we're not starting on an interval boundary, we have to
    split this interval. */
  if (i->position != s)
    {
      /* If this interval already has the properties, we can
         skip it. */
      if (interval_has_all_properties (properties, i))
	{
	  int got = (LENGTH (i) - (s - i->position));
	  if (got >= len)
	    RETURN_UNGCPRO (Qnil);

  len = XINT (end) - s;

  if (i->position != s)
    {
      /* No properties on this first interval -- return if
         it covers the entire region. */
      if (! interval_has_some_properties (properties, i))
	{
	  int got = (LENGTH (i) - (s - i->position));
	  if (got >= len)
	    return Qnil;

  if (i->position != s)
    {
      register int got;
      register INTERVAL unchanged = i;

      /* If there are properties here, then this text will be modified. */
      if (! NILP (i->plist))
	{
	  i = split_interval_right (unchanged, s - unchanged->position);
	  i->plist = Qnil;
	  modified++;

         LEN or more characters, then we may return without changing
	 anything.*/
      else if (LENGTH (i) - (s - i->position) <= len)
	return Qnil;
      /* The amount of text to change extends past I, so just note
	 how much we've gotten. */
      else
	got = LENGTH (i) - (s - i->position);

      len -= got;
      prev_changed = i;
      i = next_interval (i);
    }

  /* We are starting at the beginning of an interval, I. */
  while (len > 0)
    {
      if (LENGTH (i) >= len)
	{
	  /* If I has no properties, simply merge it if possible.  */

	  prev_changed = i;
	}
      else
	{
	  modified += ! NILP (i->plist);
	  /* Merging I will give it the properties of PREV_CHANGED. */
	  prev_changed = i = merge_interval_left (i);
	}

      i = next_interval (i);
    }

	    plist = Fcdr (Fcdr (plist));
	  }
      if (! NILP (plist))
	{
	  /* Must defer modifications to the interval tree in case src
	     and dest refer to the same string or buffer. */
	  stuff = Fcons (Fcons (make_number (p),
				Fcons (make_number (p + len),
				       Fcons (plist, Qnil))),
			stuff);
	}

      /* If Vinhibit_read_only is set and is not a list, we can
	 skip the read_only checks.  */
      if (NILP (Vinhibit_read_only) || CONSP (Vinhibit_read_only))
	{
	  /* If I and PREV differ we need to check for the read-only
	     property together with its stickiness. If either I or
	     PREV are 0, this check is all we need.
	     We have to take special care, since read-only may be
	     indirectly defined via the category property.  */
	  if (i != prev)
	    {

17467:98c47e7857f3

/* Interface code for dealing with text properties.
   Copyright (C) 1993, 1994, 1995, 1997 Free Software Foundation, Inc.

This file is part of GNU Emacs.

GNU Emacs is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by

  It is assumed that for any interval plist, a property appears
  only once on the list.  Although some code i.e., remove_properties,
  handles the more general case, the uniqueness of properties is
  necessary for the system to remain consistent.  This requirement
  is enforced by the subrs installing properties onto the intervals.  */

/* The rest of the file is within this conditional */
#ifdef USE_TEXT_PROPERTIES

/* Types of hooks.  */
Lisp_Object Qmouse_left;
Lisp_Object Qmouse_entered;
Lisp_Object Qpoint_left;
Lisp_Object Qpoint_entered;
Lisp_Object Qcategory;
Lisp_Object Qlocal_map;

/* Visual properties text (including strings) may have.  */
Lisp_Object Qforeground, Qbackground, Qfont, Qunderline, Qstipple;
Lisp_Object Qinvisible, Qread_only, Qintangible;

/* Sticky properties */
Lisp_Object Qfront_sticky, Qrear_nonsticky;

  CHECK_STRING_OR_BUFFER (object, 0);
  CHECK_NUMBER_COERCE_MARKER (*begin, 0);
  CHECK_NUMBER_COERCE_MARKER (*end, 0);

  /* If we are asked for a point, but from a subr which operates
     on a range, then return nothing.  */
  if (EQ (*begin, *end) && begin != end)
    return NULL_INTERVAL;

  if (XINT (*begin) > XINT (*end))
    {

      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 there's no text, there are no properties.  */
      if (BUF_BEGV (b) == BUF_ZV (b))
	return NULL_INTERVAL;

      searchpos = XINT (*begin);
    }

  return find_interval (i, searchpos);
}

/* Validate LIST as a property list.  If LIST is not a list, then
   make one consisting of (LIST nil).  Otherwise, verify that LIST
   is even numbered and thus suitable as a plist.  */

static Lisp_Object
validate_plist (list)
     Lisp_Object list;
{

  return Fcons (list, Fcons (Qnil, Qnil));
}

/* Return nonzero if interval I has all the properties,
   with the same values, of list PLIST.  */

static int
interval_has_all_properties (plist, i)
     Lisp_Object plist;
     INTERVAL i;
{
  register Lisp_Object tail1, tail2, sym1, sym2;
  register int found;

  /* Go through each element of PLIST.  */
  for (tail1 = plist; ! NILP (tail1); tail1 = Fcdr (Fcdr (tail1)))
    {
      sym1 = Fcar (tail1);
      found = 0;

      /* Go through I's plist, looking for sym1 */
      for (tail2 = i->plist; ! NILP (tail2); tail2 = Fcdr (Fcdr (tail2)))
	if (EQ (sym1, Fcar (tail2)))
	  {
	    /* Found the same property on both lists.  If the
	       values are unequal, return zero.  */
	    if (! EQ (Fcar (Fcdr (tail1)), Fcar (Fcdr (tail2))))
	      return 0;

	    /* Property has same value on both lists;  go to next one.  */
	    found = 1;
	    break;
	  }

      if (! found)

  return 1;
}

/* Return nonzero if the plist of interval I has any of the
   properties of PLIST, regardless of their values.  */

static INLINE int
interval_has_some_properties (plist, i)
     Lisp_Object plist;
     INTERVAL i;
{
  register Lisp_Object tail1, tail2, sym;

  /* Go through each element of PLIST.  */
  for (tail1 = plist; ! NILP (tail1); tail1 = Fcdr (Fcdr (tail1)))
    {
      sym = Fcar (tail1);

      /* Go through i's plist, looking for tail1 */

  /* No need to protect OBJECT, because we can GC only in the case
     where it is a buffer, and live buffers are always protected.
     I and its plist are also protected, via OBJECT.  */
  GCPRO3 (tail1, sym1, val1);

  /* Go through each element of PLIST.  */
  for (tail1 = plist; ! NILP (tail1); tail1 = Fcdr (Fcdr (tail1)))
    {
      sym1 = Fcar (tail1);
      val1 = Fcar (Fcdr (tail1));
      found = 0;

	    /* No need to gcpro, because tail2 protects this
	       and it must be a cons cell (we get an error otherwise).  */
	    register Lisp_Object this_cdr;

	    this_cdr = Fcdr (tail2);
	    /* Found the property.  Now check its value.  */
	    found = 1;

	    /* The properties have the same value on both lists.
	       Continue to the next property.  */
	    if (EQ (val1, Fcar (this_cdr)))
	      break;

	    /* Record this change in the buffer, for undo purposes.  */
	    if (BUFFERP (object))

{
  register Lisp_Object tail1, tail2, sym, current_plist;
  register int changed = 0;

  current_plist = i->plist;
  /* Go through each element of plist.  */
  for (tail1 = plist; ! NILP (tail1); tail1 = Fcdr (Fcdr (tail1)))
    {
      sym = Fcar (tail1);

      /* First, remove the symbol if its at the head of the list */

  return changed;
}

#if 0
/* Remove all properties from interval I.  Return non-zero
   if this changes the interval.  */

static INLINE int
erase_properties (i)
     INTERVAL i;
{

  i->plist = Qnil;
  return 1;
}
#endif

/* Returns the interval of the POSITION in OBJECT. 
   POSITION is BEG-based.  */

INTERVAL
interval_of (position, object)
     int position;
     Lisp_Object object;
{
  register INTERVAL i;
  int beg, end;

  if (NILP (object))
    XSETBUFFER (object, current_buffer);

  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);

      /* We expect position to be 1-based.  */
      beg = BEG;
      end = s->size + BEG;
      i = s->intervals;
    }

  if (!(beg <= position && position <= end))
    args_out_of_range (position, 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 held by the character at POSITION\n\
in optional argument OBJECT, a string or buffer.  If nil, OBJECT\n\

  /* No need to protect OBJECT, because we GC only if it's a buffer,
     and live buffers are always protected.  */
  GCPRO1 (properties);

  /* If we're not starting on an interval boundary, we have to
    split this interval.  */
  if (i->position != s)
    {
      /* If this interval already has the properties, we can
         skip it.  */
      if (interval_has_all_properties (properties, i))
	{
	  int got = (LENGTH (i) - (s - i->position));
	  if (got >= len)
	    RETURN_UNGCPRO (Qnil);

  len = XINT (end) - s;

  if (i->position != s)
    {
      /* No properties on this first interval -- return if
         it covers the entire region.  */
      if (! interval_has_some_properties (properties, i))
	{
	  int got = (LENGTH (i) - (s - i->position));
	  if (got >= len)
	    return Qnil;

  if (i->position != s)
    {
      register int got;
      register INTERVAL unchanged = i;

      /* If there are properties here, then this text will be modified.  */
      if (! NILP (i->plist))
	{
	  i = split_interval_right (unchanged, s - unchanged->position);
	  i->plist = Qnil;
	  modified++;

         LEN or more characters, then we may return without changing
	 anything.*/
      else if (LENGTH (i) - (s - i->position) <= len)
	return Qnil;
      /* The amount of text to change extends past I, so just note
	 how much we've gotten.  */
      else
	got = LENGTH (i) - (s - i->position);

      len -= got;
      prev_changed = i;
      i = next_interval (i);
    }

  /* We are starting at the beginning of an interval, I.  */
  while (len > 0)
    {
      if (LENGTH (i) >= len)
	{
	  /* If I has no properties, simply merge it if possible.  */

	  prev_changed = i;
	}
      else
	{
	  modified += ! NILP (i->plist);
	  /* Merging I will give it the properties of PREV_CHANGED.  */
	  prev_changed = i = merge_interval_left (i);
	}

      i = next_interval (i);
    }

	    plist = Fcdr (Fcdr (plist));
	  }
      if (! NILP (plist))
	{
	  /* Must defer modifications to the interval tree in case src
	     and dest refer to the same string or buffer.  */
	  stuff = Fcons (Fcons (make_number (p),
				Fcons (make_number (p + len),
				       Fcons (plist, Qnil))),
			stuff);
	}

      /* If Vinhibit_read_only is set and is not a list, we can
	 skip the read_only checks.  */
      if (NILP (Vinhibit_read_only) || CONSP (Vinhibit_read_only))
	{
	  /* If I and PREV differ we need to check for the read-only
	     property together with its stickiness.  If either I or
	     PREV are 0, this check is all we need.
	     We have to take special care, since read-only may be
	     indirectly defined via the category property.  */
	  if (i != prev)
	    {