Download
(require 'font-lock)
(defun put-text-property-unless-ignore (start end property value &optional object)
"`put-text-property', but ignore text with property `font-lock-ignore'."
(let ((here (min start end))
(end1 (max start end)))
(while (< here end1)
(unless (get-text-property here 'font-lock-ignore object)
(put-text-property here (1+ here) property value object))
(setq here (1+ here)))))
(defun font-lock-default-unfontify-region (beg end)
"Unfontify from BEG to END, unless text with property `font-lock-ignore'."
(let ((here (min beg end))
(end1 (max beg end)))
(while (< here end1)
(unless (get-text-property here 'font-lock-ignore)
(remove-list-of-text-properties
here (1+ here) (append font-lock-extra-managed-props
(if font-lock-syntactic-keywords
'(syntax-table face font-lock-multiline)
'(face font-lock-multiline)))))
(setq here (1+ here)))))
(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."
(let ((val (if (listp value) value (list value))) next prev)
(while (/= start end)
(setq next (next-single-property-change start prop object end)
prev (get-text-property start prop object))
(put-text-property-unless-ignore start next prop
(append val (if (listp prev) prev (list prev)))
object)
(setq start next))))
(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 (listp value) value (list value))) next prev)
(while (/= start end)
(setq next (next-single-property-change start prop object end)
prev (get-text-property start prop object))
(put-text-property-unless-ignore start next prop
(append (if (listp prev) prev (list prev)) val)
object)
(setq start next))))
(defun font-lock-fillin-text-property (start end prop value &optional object)
"Fill in one property of the text from START to END.
Arguments PROP and VALUE specify the property and value to put where none are
already in place. Therefore existing property values are not overwritten.
Optional argument OBJECT is the string or buffer containing the text."
(let ((start (text-property-any start end prop nil object)) next)
(while start
(setq next (next-single-property-change start prop object end))
(put-text-property-unless-ignore start next prop value object)
(setq start (text-property-any next end prop nil object)))))
(defun font-lock-apply-syntactic-highlight (highlight)
"Apply HIGHLIGHT following a match.
HIGHLIGHT should be of the form MATCH-HIGHLIGHT,
see `font-lock-syntactic-keywords'."
(let* ((match (nth 0 highlight))
(start (match-beginning match)) (end (match-end match))
(value (nth 1 highlight))
(override (nth 2 highlight)))
(if (not start)
(or (nth 3 highlight)
(error "No match %d in highlight %S" match highlight))
(when (and (consp value) (not (numberp (car value))))
(setq value (eval value)))
(when (stringp value) (setq value (string-to-syntax value)))
(syntax-ppss-after-change-function start)
(cond
((not override)
(or (text-property-not-all start end 'syntax-table nil)
(put-text-property-unless-ignore start end 'syntax-table value)))
((eq override t)
(put-text-property-unless-ignore start end 'syntax-table value))
((eq override 'keep)
(font-lock-fillin-text-property start end 'syntax-table value))))))
(defun font-lock-fontify-syntactically-region (start end &optional loudly ppss)
"Put proper face on each string and comment between START and END.
START should be at the beginning of a line."
(let ((comment-end-regexp
(or font-lock-comment-end-skip
(regexp-quote
(replace-regexp-in-string "^ *" "" comment-end))))
state face beg)
(if loudly (message "Fontifying %s... (syntactically...)" (buffer-name)))
(goto-char start)
(setq state (or ppss (syntax-ppss start)))
(while
(progn
(when (or (nth 3 state) (nth 4 state))
(setq face (funcall font-lock-syntactic-face-function state))
(setq beg (max (nth 8 state) start))
(setq state (parse-partial-sexp (point) end nil nil state
'syntax-table))
(when face (put-text-property-unless-ignore beg (point) 'face face))
(when (and (eq face 'font-lock-comment-face)
(or font-lock-comment-start-skip
comment-start-skip))
(save-excursion
(goto-char beg)
(if (looking-at (or font-lock-comment-start-skip
comment-start-skip))
(put-text-property-unless-ignore beg (match-end 0) 'face
font-lock-comment-delimiter-face)))
(if (looking-back comment-end-regexp (point-at-bol) t)
(put-text-property-unless-ignore (match-beginning 0) (point) 'face
font-lock-comment-delimiter-face))))
(< (point) end))
(setq state (parse-partial-sexp (point) end nil nil state
'syntax-table)))))
(defun font-lock-apply-highlight (highlight)
"Apply HIGHLIGHT following a match.
HIGHLIGHT should be of the form MATCH-HIGHLIGHT, see `font-lock-keywords'."
(let* ((match (nth 0 highlight))
(start (match-beginning match)) (end (match-end match))
(override (nth 2 highlight)))
(if (not start)
(or (nth 3 highlight)
(error "No match %d in highlight %S" match highlight))
(let ((val (eval (nth 1 highlight))))
(when (eq (car-safe val) 'face)
(add-text-properties start end (cddr val))
(setq val (cadr val)))
(cond
((not (or val (eq override t)))
nil)
((not override)
(or (text-property-not-all start end 'face nil)
(put-text-property-unless-ignore start end 'face val)))
((eq override t)
(put-text-property-unless-ignore start end 'face val))
((eq override 'prepend)
(font-lock-prepend-text-property start end 'face val))
((eq override 'append)
(font-lock-append-text-property start end 'face val))
((eq override 'keep)
(font-lock-fillin-text-property start end 'face val)))))))
(defun font-lock-fontify-anchored-keywords (keywords limit)
"Fontify according to KEYWORDS until LIMIT.
KEYWORDS should be of the form MATCH-ANCHORED, see `font-lock-keywords',
LIMIT can be modified by the value of its PRE-MATCH-FORM."
(let ((matcher (nth 0 keywords)) (lowdarks (nthcdr 3 keywords)) highlights
(lead-start (match-beginning 0))
(pre-match-value (eval (nth 1 keywords))))
(if (not (and (numberp pre-match-value) (> pre-match-value (point))))
(setq limit (line-end-position))
(setq limit pre-match-value)
(when (and font-lock-multiline (>= limit (line-beginning-position 2)))
(put-text-property-unless-ignore (if (= limit (line-beginning-position 2))
(1- limit)
(min lead-start (point)))
limit
'font-lock-multiline t)))
(save-match-data
(while (and (< (point) limit)
(if (stringp matcher)
(re-search-forward matcher limit t)
(funcall matcher limit)))
(setq highlights lowdarks)
(while highlights
(font-lock-apply-highlight (car highlights))
(setq highlights (cdr highlights)))))
(eval (nth 2 keywords))))
(defun font-lock-fontify-keywords-region (start end &optional loudly)
"Fontify according to `font-lock-keywords' between START and END.
START should be at the beginning of a line.
LOUDLY, if non-nil, allows progress-meter bar."
(unless (eq (car font-lock-keywords) t)
(setq font-lock-keywords
(font-lock-compile-keywords font-lock-keywords)))
(let ((case-fold-search font-lock-keywords-case-fold-search)
(keywords (cddr font-lock-keywords))
(bufname (buffer-name)) (count 0)
(pos (make-marker))
keyword matcher highlights)
(while keywords
(if loudly (message "Fontifying %s... (regexps..%s)" bufname
(make-string (incf count) ?.)))
(setq keyword (car keywords) matcher (car keyword))
(goto-char start)
(while (and (< (point) end)
(if (stringp matcher)
(re-search-forward matcher end t)
(funcall matcher end))
(or (> (point) (match-beginning 0))
(progn (forward-char 1) t)))
(when (and font-lock-multiline
(>= (point)
(save-excursion (goto-char (match-beginning 0))
(forward-line 1) (point))))
(put-text-property-unless-ignore (if (= (point)
(save-excursion
(goto-char (match-beginning 0))
(forward-line 1) (point)))
(1- (point))
(match-beginning 0))
(point)
'font-lock-multiline t))
(setq highlights (cdr keyword))
(while highlights
(if (numberp (car (car highlights)))
(font-lock-apply-highlight (car highlights))
(set-marker pos (point))
(font-lock-fontify-anchored-keywords (car highlights) end)
(if (< (point) pos) (goto-char pos)))
(setq highlights (cdr highlights))))
(setq keywords (cdr keywords)))
(set-marker pos nil)))
(provide 'font-lock+)