`add-face'

`add-face'

[Lars Ingebrigtsen]

Wolfgang Jenkner has just made me aware that `face' text properties are
combining!  That is, you can have lists of them and they work like
overlays.

I've always disliked working with overlays, because they are so fiddly.
Just look (or don't!) at the code in shr.el, but I thought I had to,
since text properties didn't combine.

However, the Emacs functions for working with combining text property
faces are kinda...  weak.  You basically have to check yourself, so you
end up with code like this:

(defun gnus-combine-text-property (beg end prop val)
  "Combine PROP with text properties between BEG and END.
This combines attributes if PROP is `face' otherwise this is just
like `put-text-property', more or less.
Beware: Proof-of-concept."
  (let ((b beg))
    (while (< b end)
      (let ((oldval (get-text-property b prop)))
	(gnus-put-text-property
	 b (setq b (next-single-property-change b prop nil end))
	 prop (cond ((or (not (eq prop 'face))
			 (null oldval))
		     val)
		    ((and (consp oldval)
			  (not (keywordp (car oldval))))
		     (cons val oldval))
		    (t
		     (list val oldval))))))))

So here's my suggestion for exposing this rather nice functionality in a
more convenient form.

Add a function `add-face', that will do what you think it does.  Or
perhaps `add-face-region'?  Or `add-text-property-face'?

Anyway, this will call `add-text-properties' with a new optional
parameter NOREPLACE, that will tell `add-text-properties' to add to the
list of properties instead of replacing.  This, in turn, will then call
add_properties with a new parameter, and it will do the trivial list
manipulation stuff instead of just

	    Fsetcar (this_cdr, val1);

If this sounds like a good idea, I can implement this right away.  And
then change shr.el to use the new function, which should speed table
rendering up a bit, as well as getting rid of some uglee code.

-- 
(domestic pets only, the antidote for overdose, milk.)
  http://lars.ingebrigtsen.no  *  Lars Magne Ingebrigtsen

Re: `add-face'

[Chong Yidong]

Lars Ingebrigtsen <larsi@gnus.org> writes:

> So here's my suggestion for exposing this rather nice functionality in
> a more convenient form.
>
> Add a function `add-face', that will do what you think it does.  Or
> perhaps `add-face-region'?  Or `add-text-property-face'?
>
> Anyway, this will call `add-text-properties' with a new optional
> parameter NOREPLACE, that will tell `add-text-properties' to add to the
> list of properties instead of replacing.  This, in turn, will then call
> add_properties with a new parameter, and it will do the trivial list
> manipulation stuff instead of just
>
> 	    Fsetcar (this_cdr, val1);
>
> If this sounds like a good idea, I can implement this right away.  And
> then change shr.el to use the new function, which should speed table
> rendering up a bit, as well as getting rid of some uglee code.

I guess you already added this to upstream Gnus, with an add-face
function defined in gnus-compat.el.  This broke Gnus in trunk when it
got merged into trunk, so I reverted it.

As for the idea, it sounds good in principle.  I think either
`add-face-text-property' or `face-add-text-property' would be a better
name.

Is it really necessary to modify `add-text-properties' to get this work,
though?  It seems to me that next-single-property-change gives you
enough information to do the job without changing the internals.

Someone should also check if this mechanism plays well with M-x
highlight-regexp.

Re: `add-face'

[Lars Ingebrigtsen]

Chong Yidong <cyd@gnu.org> writes:

> As for the idea, it sounds good in principle.  I think either
> `add-face-text-property' or `face-add-text-property' would be a better
> name.

Yeah, `add-face-text-property' sounds nice.

> Is it really necessary to modify `add-text-properties' to get this work,
> though?  It seems to me that next-single-property-change gives you
> enough information to do the job without changing the internals.

I was mainly thinking about speed.  shr.el, for instance, adds a lot of
faces, and it needs all the help it can get to speed stuff up.  For
larger HTML documents it's too slow now, and this more complex way of
adding faces won't help.

And the changes are pretty minimal, and may be generally useful.

-- 
(domestic pets only, the antidote for overdose, milk.)
  http://lars.ingebrigtsen.no  *  Lars Magne Ingebrigtsen

Re: `add-face'

[Chong Yidong]

Lars Ingebrigtsen <larsi@gnus.org> writes:

>> Is it really necessary to modify `add-text-properties' to get this work,
>> though?  It seems to me that next-single-property-change gives you
>> enough information to do the job without changing the internals.
>
> I was mainly thinking about speed.  shr.el, for instance, adds a lot of
> faces, and it needs all the help it can get to speed stuff up.  For
> larger HTML documents it's too slow now, and this more complex way of
> adding faces won't help.
>
> And the changes are pretty minimal, and may be generally useful.

My main concern is that modifying list values of text properties in this
way seems a bit too high-level for add-text-properties.  It's mostly the
`face' property that needs this kind of list management, and the details
of the needed list management work (e.g. you'll probably want to use
`add-to-list' to avoid adding duplicate faces) are pretty specific to
the `face' property.  So bolting this onto add-text-properties seems
wrong.

If speed is really an issue, we could make add-face-text-property a
primitive instead of modifying add-text-properties.

First, though, I'd suggest trying to use next-single-property-change
with a Lisp implementation, and checking if it really isn't fast enough.
You might be surprised.  (After all, even if you are doing it in C, you
will probably still be using Fnext_single_property_change.)

Re: `add-face'

[Lars Ingebrigtsen]

Chong Yidong <cyd@gnu.org> writes:

> First, though, I'd suggest trying to use next-single-property-change
> with a Lisp implementation, and checking if it really isn't fast enough.
> You might be surprised.  (After all, even if you are doing it in C, you
> will probably still be using Fnext_single_property_change.)

My current implementation just alters add_properties from

	    /* I's property has a different value -- change it */
	    Fsetcar (this_cdr, val1);

to
            
	    /* I's property has a different value -- change it */
	    if (replace)
	      Fsetcar (this_cdr, val1);
	    else
	      Fsetcar (this_cdr, Fcons (val1, Fcar (this_cdr)));

so it's kinda trivial, and entails no searching for properties.  (Well,
beyond what `add-text-properties' does when looking through the buffer.
But it looks pretty efficient to me.)

I'm not sure I totally follow the logic of `add-text-properties' in
detail, though.

But I'll do some benchmarking with the native and
`next-single-property-change' versions.

-- 
(domestic pets only, the antidote for overdose, milk.)
  http://lars.ingebrigtsen.no  *  Lars Magne Ingebrigtsen

Re: `add-face'

[Lars Ingebrigtsen]

I've now done some simple benchmarking with the native function and the
next-property-change version, included below.

Setting a thousand face properties on a biggish web page isn't unusual.

With a hundred repetitions, the native version takes 12 seconds.  The
non-native one takes 91 seconds.  So on a realistic shr.el rendering,
fontifying with the native version takes 0.12 seconds, while the
non-native ones takes 0.91 seconds, so this seems worthwhile to me.
Especially with such a small change to the C code.

Shall I just check the code in, and then we can fiddle with it further?

(defun add-props-native ()
  (with-temp-buffer
    (dotimes (i 1000)
      (insert "this is a line of text and stuff\n"))
    (dotimes (i 1000)
      (let* ((start (1+ (random (1- (buffer-size)))))
	     (length (random (- (buffer-size) start))))
	(add-face-text-property start (+ start length)
				(if (zerop (mod length 2))
				    'bold 'italic))))))

(defun add-props-non-native ()
  (with-temp-buffer
    (dotimes (i 1000)
      (insert "this is a line of text and stuff\n"))
    (dotimes (i 1000)
      (let* ((start (1+ (random (1- (buffer-size)))))
	     (length (random (- (buffer-size) start))))
	(add-face start (+ start length)
		  (if (zerop (mod length 2))
		      'bold 'italic))))))


-- 
(domestic pets only, the antidote for overdose, milk.)
  http://lars.ingebrigtsen.no  *  Lars Magne Ingebrigtsen

Re: `add-face'

[Johan Bockgård]

Chong Yidong <cyd@gnu.org> writes:

> As for the idea, it sounds good in principle.  I think either
> `add-face-text-property' or `face-add-text-property' would be a better
> name.

BTW, there is already similar functionality in font-lock.el:

;;; Additional text property functions.

;; The following text property functions should be builtins.  This means they
;; should be written in C and put with all the other text property functions.
;; In the meantime, those that are used by font-lock.el are defined in Lisp
;; below and given a `font-lock-' prefix.  Those that are not used are defined
;; in Lisp below and commented out.  sm.

(defun font-lock-prepend-text-property (start end prop value &optional object)
[...]
(defun font-lock-append-text-property (start end prop value &optional object)
[...]
(defun font-lock-fillin-text-property (start end prop value &optional object)
[...]

Re: `add-face'

[Chong Yidong]

Lars Ingebrigtsen <larsi@gnus.org> writes:

> My current implementation just alters add_properties from
>
> 	    /* I's property has a different value -- change it */
> 	    Fsetcar (this_cdr, val1);
>
> to
>             
> 	    /* I's property has a different value -- change it */
> 	    if (replace)
> 	      Fsetcar (this_cdr, val1);
> 	    else
> 	      Fsetcar (this_cdr, Fcons (val1, Fcar (this_cdr)));
>
> so it's kinda trivial, and entails no searching for properties.

Could you please post the proposed docstring for the amended
add-text-properties?  Thanks.

Re: `add-face'

[Lars Ingebrigtsen]

Chong Yidong <cyd@gnu.org> writes:

> Could you please post the proposed docstring for the amended
> add-text-properties?  Thanks.

  DEFUN ("add-text-properties", Fadd_text_properties,
!        Sadd_text_properties, 3, 5, 0,
         doc: /* Add properties to the text from START to END.
  The third argument PROPERTIES is a property list
  specifying the property values to add.  If the optional fourth argument
  OBJECT is a buffer (or nil, which means the current buffer),
  START and END are buffer positions (integers or markers).
  If OBJECT is a string, START and END are 0-based indices into it.
+ If NOREPLACE, add the text properties instead of replacing any
+ existing ones.  This is mainly useful for faces.
  Return t if any property value actually changed, nil otherwise.  */)
!   (Lisp_Object start, Lisp_Object end, Lisp_Object properties,
!    Lisp_Object object, Lisp_Object noreplace)


-- 
(domestic pets only, the antidote for overdose, milk.)
  http://lars.ingebrigtsen.no  *  Lars Magne Ingebrigtsen

Re: `add-face'

[Chong Yidong]

Lars Ingebrigtsen <larsi@gnus.org> writes:

>   DEFUN ("add-text-properties", Fadd_text_properties,
> !        Sadd_text_properties, 3, 5, 0,
>          doc: /* Add properties to the text from START to END.
>   The third argument PROPERTIES is a property list
>   specifying the property values to add.  If the optional fourth argument
>   OBJECT is a buffer (or nil, which means the current buffer),
>   START and END are buffer positions (integers or markers).
>   If OBJECT is a string, START and END are 0-based indices into it.
> + If NOREPLACE, add the text properties instead of replacing any
> + existing ones.  This is mainly useful for faces.
>   Return t if any property value actually changed, nil otherwise.  */)
> !   (Lisp_Object start, Lisp_Object end, Lisp_Object properties,
> !    Lisp_Object object, Lisp_Object noreplace)

This is too vague.  What does "add the text properties" mean?  If the
current value of a property is nil, and the argument to
add-text-properties specifies a value `foo', does the new value become
`foo' or `(foo)'?  If the current value is `1', does the new value
become `(foo 1)' or something else?

And, specifically for face properties, what if the current value is a
list specifying an anonymous face, like `(:foreground "black")'?

Re: `add-face'

[Stefan Monnier]

> This is too vague.  What does "add the text properties" mean?  If the
> current value of a property is nil, and the argument to
> add-text-properties specifies a value `foo', does the new value become
> `foo' or `(foo)'?  If the current value is `1', does the new value
> become `(foo 1)' or something else?
> And, specifically for face properties, what if the current value is a
> list specifying an anonymous face, like `(:foreground "black")'?

Yup, it's much better to provide a dedicated add-face-text-property.


        Stefan

Re: `add-face'

[Lars Magne Ingebrigtsen]

Chong Yidong <cyd@gnu.org> writes:

>> + If NOREPLACE, add the text properties instead of replacing any
>> + existing ones.  This is mainly useful for faces.

[...]

> This is too vague.  What does "add the text properties" mean?  If the
> current value of a property is nil, and the argument to
> add-text-properties specifies a value `foo', does the new value become
> `foo' or `(foo)'?

The former, but it probably doesn't matter?

> If the current value is `1', does the new value become `(foo 1)' or
> something else?

`(foo 1)' is, I think, the only reasonable way to interpret "add".

> And, specifically for face properties, what if the current value is a
> list specifying an anonymous face, like `(:foreground "black")'?

Oh, it doesn't.  Hm.  That's a problem...  is there any reliable way to
distinguish `(:foreground "black")' from `(bold italic)'?

-- 
(domestic pets only, the antidote for overdose, milk.)
  bloggy blog http://lars.ingebrigtsen.no/

Re: `add-face'

[Lars Magne Ingebrigtsen]

Stefan Monnier <monnier@iro.umontreal.ca> writes:

> Yup, it's much better to provide a dedicated add-face-text-property.

Yeah, that probably true.  I only put it in `add-text-properties'
because that's the work horse that does a fair bit of the property
mangling.  But perhaps it would make sense to leave
`add-text-properties' the way it is, and factor out the body of the
function, so that `add-face-text-property' could reuse it.

-- 
(domestic pets only, the antidote for overdose, milk.)
  bloggy blog http://lars.ingebrigtsen.no/

Re: `add-face'

[Lars Magne Ingebrigtsen]

[-- Attachment #1: Type: text/plain, Size: 1510 bytes --]

Stefan Monnier <monnier@iro.umontreal.ca> writes:

>> This is too vague.  What does "add the text properties" mean?  If the
>> current value of a property is nil, and the argument to
>> add-text-properties specifies a value `foo', does the new value become
>> `foo' or `(foo)'?  If the current value is `1', does the new value
>> become `(foo 1)' or something else?
>> And, specifically for face properties, what if the current value is a
>> list specifying an anonymous face, like `(:foreground "black")'?
>
> Yup, it's much better to provide a dedicated add-face-text-property.

I totally dropped the ball on this one, but was reminded when I
re-discovered that most of the time spent in shr.el when rendering
Wikipedia pages is doing manual face/overlay stuff.

I looked for the code for quite a while until I remembered that it was
on a laptop.  I've now re-spun the code, and there is a dedicated
`add-face-text-property' function and anonymous face properties are
handled correctly.

But I'd still like to have the extended `add-text-properties' function,
because then shr.el can say

(add-text-properties start end
 '(face underline shr-data :foo widget-stuff :blah)
 nil t)

instead of splitting stuff up.  For some reason or other, that speeds
stuff up by 20%...

But if the `add-text-properties' extension is a no-no, I can re-spin the
patch to not include that, but it'll entail a bit more code-change,
since the body of `add-text-properties' will have to be split up for
reuse.

Here's the patch:


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: prop2.patch --]
[-- Type: text/x-diff, Size: 7174 bytes --]

=== modified file 'src/editfns.c'
--- src/editfns.c	2013-05-18 05:32:17 +0000
+++ src/editfns.c	2013-06-17 07:15:47 +0000
@@ -3563,7 +3563,7 @@
 
   Fadd_text_properties (make_number (0),
 			make_number (SCHARS (string)),
-			properties, string);
+			properties, string, Qnil);
   RETURN_UNGCPRO (string);
 }
 

=== modified file 'src/minibuf.c'
--- src/minibuf.c	2013-05-04 19:27:41 +0000
+++ src/minibuf.c	2013-06-17 07:15:47 +0000
@@ -649,7 +649,7 @@
 	Fput_text_property (make_number (BEG), make_number (PT),
 			    Qfield, Qt, Qnil);
 	Fadd_text_properties (make_number (BEG), make_number (PT),
-			      Vminibuffer_prompt_properties, Qnil);
+			      Vminibuffer_prompt_properties, Qnil, Qnil);
       }
     unbind_to (count1, Qnil);
   }

=== modified file 'src/textprop.c'
--- src/textprop.c	2013-06-17 06:03:19 +0000
+++ src/textprop.c	2013-06-17 07:43:38 +0000
@@ -370,7 +370,8 @@
    are actually added to I's plist) */
 
 static bool
-add_properties (Lisp_Object plist, INTERVAL i, Lisp_Object object)
+add_properties (Lisp_Object plist, INTERVAL i, Lisp_Object object,
+		bool replace)
 {
   Lisp_Object tail1, tail2, sym1, val1;
   bool changed = 0;
@@ -416,7 +417,17 @@
 	      }
 
 	    /* I's property has a different value -- change it */
-	    Fsetcar (this_cdr, val1);
+	    if (replace)
+	      Fsetcar (this_cdr, val1);
+	    else {
+	      if (CONSP (Fcar (this_cdr)) &&
+		  /* Special-case anonymous face properties. */
+		  (! EQ (sym1, Qface) ||
+		   NILP (Fkeywordp (Fcar (Fcar (this_cdr))))))
+		Fsetcar (this_cdr, Fcons (val1, Fcar (this_cdr)));
+	      else
+		Fsetcar (this_cdr, Fcons (val1, Fcons (Fcar (this_cdr), Qnil)));
+	    }
 	    changed = 1;
 	    break;
 	  }
@@ -1127,20 +1138,24 @@
 /* Callers note, this can GC when OBJECT is a buffer (or nil).  */
 
 DEFUN ("add-text-properties", Fadd_text_properties,
-       Sadd_text_properties, 3, 4, 0,
+       Sadd_text_properties, 3, 5, 0,
        doc: /* Add properties to the text from START to END.
 The third argument PROPERTIES is a property list
 specifying the property values to add.  If the optional fourth argument
 OBJECT is a buffer (or nil, which means the current buffer),
 START and END are buffer positions (integers or markers).
 If OBJECT is a string, START and END are 0-based indices into it.
+If NOREPLACE, add the text properties instead of replacing any
+existing ones.  This is mainly useful for faces.
 Return t if any property value actually changed, nil otherwise.  */)
-  (Lisp_Object start, Lisp_Object end, Lisp_Object properties, Lisp_Object object)
+  (Lisp_Object start, Lisp_Object end, Lisp_Object properties,
+   Lisp_Object object, Lisp_Object noreplace)
 {
   INTERVAL i, unchanged;
   ptrdiff_t s, len;
   bool modified = 0;
   struct gcpro gcpro1;
+  bool replace = NILP (noreplace);
   bool first_time = 1;
 
   properties = validate_plist (properties);
@@ -1230,7 +1245,7 @@
 
 	  if (LENGTH (i) == len)
 	    {
-	      add_properties (properties, i, object);
+	      add_properties (properties, i, object, replace);
 	      if (BUFFERP (object))
 		signal_after_change (XINT (start), XINT (end) - XINT (start),
 				     XINT (end) - XINT (start));
@@ -1241,7 +1256,7 @@
 	  unchanged = i;
 	  i = split_interval_left (unchanged, len);
 	  copy_properties (unchanged, i);
-	  add_properties (properties, i, object);
+	  add_properties (properties, i, object, replace);
 	  if (BUFFERP (object))
 	    signal_after_change (XINT (start), XINT (end) - XINT (start),
 				 XINT (end) - XINT (start));
@@ -1249,7 +1264,7 @@
 	}
 
       len -= LENGTH (i);
-      modified |= add_properties (properties, i, object);
+      modified |= add_properties (properties, i, object, replace);
       i = next_interval (i);
     }
 }
@@ -1268,7 +1283,7 @@
 {
   Fadd_text_properties (start, end,
 			Fcons (property, Fcons (value, Qnil)),
-			object);
+			object, Qnil);
   return Qnil;
 }
 
@@ -1287,6 +1302,23 @@
 }
 
 
+DEFUN ("add-face-text-property", Fadd_face_text_property,
+       Sadd_face_text_property, 3, 4, 0,
+       doc: /* Add the face property to the text from START to END.
+The third argument FACE specifies the face to add.
+If any text in the region already has any face properties, this new
+face property will be added to the front of the face property list.
+If the optional fourth argument OBJECT is a buffer (or nil, which means
+the current buffer), START and END are buffer positions (integers or
+markers).  If OBJECT is a string, START and END are 0-based indices into it.  */)
+  (Lisp_Object start, Lisp_Object end, Lisp_Object face, Lisp_Object object)
+{
+  Fadd_text_properties (start, end,
+			Fcons (Qface, Fcons (face, Qnil)),
+			object, Qt);
+  return Qnil;
+}
+ 
 /* Replace properties of text from START to END with new list of
    properties PROPERTIES.  OBJECT is the buffer or string containing
    the text.  OBJECT nil means use the current buffer.
@@ -1893,7 +1925,7 @@
     {
       res = Fcar (stuff);
       res = Fadd_text_properties (Fcar (res), Fcar (Fcdr (res)),
-				  Fcar (Fcdr (Fcdr (res))), dest);
+				  Fcar (Fcdr (Fcdr (res))), dest, Qnil);
       if (! NILP (res))
 	modified = 1;
       stuff = Fcdr (stuff);
@@ -1984,7 +2016,7 @@
       end = make_number (XINT (XCAR (XCDR (item))) + XINT (delta));
       plist = XCAR (XCDR (XCDR (item)));
 
-      Fadd_text_properties (start, end, plist, object);
+      Fadd_text_properties (start, end, plist, object, Qnil);
     }
 
   UNGCPRO;
@@ -2292,6 +2324,7 @@
   DEFSYM (Qforeground, "foreground");
   DEFSYM (Qbackground, "background");
   DEFSYM (Qfont, "font");
+  DEFSYM (Qface, "face");
   DEFSYM (Qstipple, "stipple");
   DEFSYM (Qunderline, "underline");
   DEFSYM (Qread_only, "read-only");
@@ -2326,6 +2359,7 @@
   defsubr (&Sadd_text_properties);
   defsubr (&Sput_text_property);
   defsubr (&Sset_text_properties);
+  defsubr (&Sadd_face_text_property);
   defsubr (&Sremove_text_properties);
   defsubr (&Sremove_list_of_text_properties);
   defsubr (&Stext_property_any);

=== modified file 'src/xdisp.c'
--- src/xdisp.c	2013-06-15 09:34:20 +0000
+++ src/xdisp.c	2013-06-17 07:15:47 +0000
@@ -11692,7 +11692,7 @@
       else
 	end = i + 1;
       Fadd_text_properties (make_number (i), make_number (end),
-			    props, f->desired_tool_bar_string);
+			    props, f->desired_tool_bar_string, Qnil);
 #undef PROP
     }
 
@@ -20886,7 +20886,7 @@
 	  props = Fplist_put (props, Qface, face);
 	}
       Fadd_text_properties (make_number (0), make_number (len),
-			    props, lisp_string);
+			    props, lisp_string, Qnil);
     }
   else
     {
@@ -20913,7 +20913,7 @@
 	}
       if (!NILP (props))
 	Fadd_text_properties (make_number (0), make_number (len),
-			      props, lisp_string);
+			      props, lisp_string, Qnil);
     }
 
   if (len > 0)
@@ -20928,7 +20928,7 @@
       lisp_string = Fmake_string (make_number (field_width), make_number (' '));
       if (!NILP (props))
 	Fadd_text_properties (make_number (0), make_number (field_width),
-			      props, lisp_string);
+			      props, lisp_string, Qnil);
       mode_line_string_list = Fcons (lisp_string, mode_line_string_list);
       n += field_width;
     }


[-- Attachment #3: Type: text/plain, Size: 103 bytes --]


-- 
(domestic pets only, the antidote for overdose, milk.)
  bloggy blog http://lars.ingebrigtsen.no/

Re: `add-face'

[Lars Magne Ingebrigtsen]

Lars Magne Ingebrigtsen <larsi@gnus.org> writes:

> But if the `add-text-properties' extension is a no-no, I can re-spin the
> patch to not include that, but it'll entail a bit more code-change,
> since the body of `add-text-properties' will have to be split up for
> reuse.

Actually, that turned out to not be very useful when I, er, tried to use
it, so I'm rewriting the code to not alter `add-text-properties'.

-- 
(domestic pets only, the antidote for overdose, milk.)
  bloggy blog http://lars.ingebrigtsen.no/

Re: `add-face'

[Lars Magne Ingebrigtsen]

[-- Attachment #1: Type: text/plain, Size: 25 bytes --]

Here's the new version:


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: props3.patch --]
[-- Type: text/x-diff, Size: 6438 bytes --]

=== modified file 'src/textprop.c'
--- src/textprop.c	2013-06-17 06:03:19 +0000
+++ src/textprop.c	2013-06-17 09:49:56 +0000
@@ -60,6 +60,13 @@
 static Lisp_Object Qread_only;
 Lisp_Object Qminibuffer_prompt;
 
+enum property_set_type
+{
+  TEXT_PROPERTY_REPLACE,
+  TEXT_PROPERTY_PREPEND,
+  TEXT_PROPERTY_APPEND
+};
+
 /* Sticky properties.  */
 Lisp_Object Qfront_sticky, Qrear_nonsticky;
 
@@ -370,7 +377,8 @@
    are actually added to I's plist) */
 
 static bool
-add_properties (Lisp_Object plist, INTERVAL i, Lisp_Object object)
+add_properties (Lisp_Object plist, INTERVAL i, Lisp_Object object,
+		enum property_set_type set_type)
 {
   Lisp_Object tail1, tail2, sym1, val1;
   bool changed = 0;
@@ -416,7 +424,30 @@
 	      }
 
 	    /* I's property has a different value -- change it */
-	    Fsetcar (this_cdr, val1);
+	    if (set_type == TEXT_PROPERTY_REPLACE)
+	      Fsetcar (this_cdr, val1);
+	    else {
+	      if (CONSP (Fcar (this_cdr)) &&
+		  /* Special-case anonymous face properties. */
+		  (! EQ (sym1, Qface) ||
+		   NILP (Fkeywordp (Fcar (Fcar (this_cdr))))))
+		/* The previous value is a list, so prepend (or
+		   append) the new value to this list. */
+		if (set_type == TEXT_PROPERTY_PREPEND)
+		  Fsetcar (this_cdr, Fcons (val1, Fcar (this_cdr)));
+		else
+		  nconc2 (Fcar (this_cdr), Fcons (val1, Qnil));
+	      else {
+		/* The previous value is a single value, so make it
+		   into a list. */
+		if (set_type == TEXT_PROPERTY_PREPEND)
+		  Fsetcar (this_cdr,
+			   Fcons (val1, Fcons (Fcar (this_cdr), Qnil)));
+		else
+		  Fsetcar (this_cdr,
+			   Fcons (Fcar (this_cdr), Fcons (val1, Qnil)));
+	      }
+	    }
 	    changed = 1;
 	    break;
 	  }
@@ -1124,19 +1155,12 @@
     return make_number (previous->position + LENGTH (previous));
 }
 \f
-/* Callers note, this can GC when OBJECT is a buffer (or nil).  */
+/* Used by add-text-properties and add-face-text-property. */
 
-DEFUN ("add-text-properties", Fadd_text_properties,
-       Sadd_text_properties, 3, 4, 0,
-       doc: /* Add properties to the text from START to END.
-The third argument PROPERTIES is a property list
-specifying the property values to add.  If the optional fourth argument
-OBJECT is a buffer (or nil, which means the current buffer),
-START and END are buffer positions (integers or markers).
-If OBJECT is a string, START and END are 0-based indices into it.
-Return t if any property value actually changed, nil otherwise.  */)
-  (Lisp_Object start, Lisp_Object end, Lisp_Object properties, Lisp_Object object)
-{
+static Lisp_Object
+add_text_properties_1 (Lisp_Object start, Lisp_Object end,
+		       Lisp_Object properties, Lisp_Object object,
+		       enum property_set_type set_type) {
   INTERVAL i, unchanged;
   ptrdiff_t s, len;
   bool modified = 0;
@@ -1230,7 +1254,7 @@
 
 	  if (LENGTH (i) == len)
 	    {
-	      add_properties (properties, i, object);
+	      add_properties (properties, i, object, set_type);
 	      if (BUFFERP (object))
 		signal_after_change (XINT (start), XINT (end) - XINT (start),
 				     XINT (end) - XINT (start));
@@ -1241,7 +1265,7 @@
 	  unchanged = i;
 	  i = split_interval_left (unchanged, len);
 	  copy_properties (unchanged, i);
-	  add_properties (properties, i, object);
+	  add_properties (properties, i, object, set_type);
 	  if (BUFFERP (object))
 	    signal_after_change (XINT (start), XINT (end) - XINT (start),
 				 XINT (end) - XINT (start));
@@ -1249,13 +1273,31 @@
 	}
 
       len -= LENGTH (i);
-      modified |= add_properties (properties, i, object);
+      modified |= add_properties (properties, i, object, set_type);
       i = next_interval (i);
     }
 }
 
 /* Callers note, this can GC when OBJECT is a buffer (or nil).  */
 
+DEFUN ("add-text-properties", Fadd_text_properties,
+       Sadd_text_properties, 3, 4, 0,
+       doc: /* Add properties to the text from START to END.
+The third argument PROPERTIES is a property list
+specifying the property values to add.  If the optional fourth argument
+OBJECT is a buffer (or nil, which means the current buffer),
+START and END are buffer positions (integers or markers).
+If OBJECT is a string, START and END are 0-based indices into it.
+Return t if any property value actually changed, nil otherwise.  */)
+  (Lisp_Object start, Lisp_Object end, Lisp_Object properties,
+   Lisp_Object object)
+{
+  return add_text_properties_1 (start, end, properties, object,
+				TEXT_PROPERTY_REPLACE);
+}
+
+/* Callers note, this can GC when OBJECT is a buffer (or nil).  */
+
 DEFUN ("put-text-property", Fput_text_property,
        Sput_text_property, 4, 5, 0,
        doc: /* Set one property of the text from START to END.
@@ -1287,6 +1329,29 @@
 }
 
 
+DEFUN ("add-face-text-property", Fadd_face_text_property,
+       Sadd_face_text_property, 3, 5, 0,
+       doc: /* Add the face property to the text from START to END.
+The third argument FACE specifies the face to add.
+If any text in the region already has any face properties, this new
+face property will be added to the front of the face property list.
+If the optional fourth argument APPENDP is non-nil, append to the end
+of the face property list instead.
+If the optional fifth argument OBJECT is a buffer (or nil, which means
+the current buffer), START and END are buffer positions (integers or
+markers).  If OBJECT is a string, START and END are 0-based indices
+into it.  */)
+  (Lisp_Object start, Lisp_Object end, Lisp_Object face,
+   Lisp_Object appendp, Lisp_Object object)
+{
+  add_text_properties_1 (start, end,
+			 Fcons (Qface, Fcons (face, Qnil)),
+			 object,
+			 NILP (appendp)? TEXT_PROPERTY_PREPEND:
+			 TEXT_PROPERTY_APPEND);
+  return Qnil;
+}
+ 
 /* Replace properties of text from START to END with new list of
    properties PROPERTIES.  OBJECT is the buffer or string containing
    the text.  OBJECT nil means use the current buffer.
@@ -2292,6 +2357,7 @@
   DEFSYM (Qforeground, "foreground");
   DEFSYM (Qbackground, "background");
   DEFSYM (Qfont, "font");
+  DEFSYM (Qface, "face");
   DEFSYM (Qstipple, "stipple");
   DEFSYM (Qunderline, "underline");
   DEFSYM (Qread_only, "read-only");
@@ -2326,6 +2392,7 @@
   defsubr (&Sadd_text_properties);
   defsubr (&Sput_text_property);
   defsubr (&Sset_text_properties);
+  defsubr (&Sadd_face_text_property);
   defsubr (&Sremove_text_properties);
   defsubr (&Sremove_list_of_text_properties);
   defsubr (&Stext_property_any);


[-- Attachment #3: Type: text/plain, Size: 103 bytes --]


-- 
(domestic pets only, the antidote for overdose, milk.)
  bloggy blog http://lars.ingebrigtsen.no/

Re: `add-face'

[Stefan Monnier]

> Here's the new version:

Looks OK.  Please include a NEWS entry, of course.


        Stefan

Re: `add-face'

[Lars Magne Ingebrigtsen]

Stefan Monnier <monnier@iro.umontreal.ca> writes:

> Looks OK.

Great!

> Please include a NEWS entry, of course.

Yup.  And I added a lispref entry.  Perhaps it should be
cross-referenced from somewhere for easier discoverability...

-- 
(domestic pets only, the antidote for overdose, milk.)
  bloggy blog http://lars.ingebrigtsen.no/