Extract common code for adding text properties

* lisp/font-lock.el (font-lock--add-text-property):
New function.
(font-lock-prepend-text-property)
(font-lock-append-text-property): Use it.

(Bug#35476)

1 files changed, 20 insertions, 27 deletions

diff --git a/lisp/font-lock.el b/lisp/font-lock.el
index 95ca2f99c21..3991a4ee8ef 100644
--- a/lisp/font-lock.el
+++ b/lisp/font-lock.el
@@ -1387,11 +1387,13 @@ delimit the region to fontify."
 ;; 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)
-  "Prepend to one property of the text from START to END.
-Arguments PROP and VALUE specify the property and value to prepend to the value
-already in place.  The resulting property values are always lists.
-Optional argument OBJECT is the string or buffer containing the text."
+(defun font-lock--add-text-property (start end prop value object append)
+  "Add an element to a property of the text from START to END.
+Arguments PROP and VALUE specify the property and value to add to
+the value already in place.  The resulting property values are
+always lists.  Argument OBJECT is the string or buffer containing
+the text.  If argument APPEND is non-nil, VALUE will be appended,
+otherwise it will be prepended."
   (let ((val (if (and (listp value) (not (keywordp (car value))))
                  ;; Already a list of faces.
                  value
@@ -1407,35 +1409,26 @@ Optional argument OBJECT is the string or buffer containing the text."
            (or (keywordp (car prev))
                (memq (car prev) '(foreground-color background-color)))
            (setq prev (list prev)))
-      (put-text-property start next prop
-                         (append val (if (listp prev) prev (list prev)))
-                         object)
+      (let* ((list-prev (if (listp prev) prev (list prev)))
+             (new-value (if append
+                           (append list-prev val)
+                         (append val list-prev))))
+        (put-text-property start next prop new-value object))
       (setq start next))))
 
+(defun font-lock-prepend-text-property (start end prop value &optional object)
+  "Prepend to one property of the text from START to END.
+Arguments PROP and VALUE specify the property and value to prepend to the value
+already in place.  The resulting property values are always lists.
+Optional argument OBJECT is the string or buffer containing the text."
+  (font-lock--add-text-property start end prop value object nil))
+
 (defun font-lock-append-text-property (start end prop value &optional object)
   "Append to one property of the text from START to END.
 Arguments PROP and VALUE specify the property and value to append to the value
 already in place.  The resulting property values are always lists.
 Optional argument OBJECT is the string or buffer containing the text."
-  (let ((val (if (and (listp value) (not (keywordp (car value))))
-                 ;; Already a list of faces.
-                 value
-               ;; A single face (e.g. a plist of face properties).
-               (list value)))
-        next prev)
-    (while (/= start end)
-      (setq next (next-single-property-change start prop object end)
-            prev (get-text-property start prop object))
-      ;; Canonicalize old forms of face property.
-      (and (memq prop '(face font-lock-face))
-           (listp prev)
-           (or (keywordp (car prev))
-               (memq (car prev) '(foreground-color background-color)))
-           (setq prev (list prev)))
-      (put-text-property start next prop
-                         (append (if (listp prev) prev (list prev)) val)
-                         object)
-      (setq start next))))
+  (font-lock--add-text-property start end prop value object t))
 
 (defun font-lock-fillin-text-property (start end prop value &optional object)
   "Fill in one property of the text from START to END.