;; Copyright (C) 1992-1995, 1997 Free Software Foundation, Inc.
;; Copyright (C) 1995 Amdahl Corporation.
-;; Copyright (C) 1996 Ben Wing.
+;; Copyright (C) 1996, 2000, 2001 Ben Wing.
;; Author: Jamie Zawinski <jwz@jwz.org>, for the LISPM Preservation Society.
;; Minimally merged with FSF 19.34 by Barry Warsaw <bwarsaw@python.org>
(symbol :tag "name"))
(radio :tag "Decoration"
(const :tag "default" nil)
- (const :tag "maximum" t)
+ (const :tag "maximum" t)
(integer :tag "level" 1)))))
:group 'font-lock)
(integer :tag "size")))))
:group 'font-lock)
+;;;###autoload
+(defcustom font-lock-fontify-string-delimiters nil
+ "*If non-nil, apply font-lock-string-face to string delimiters as well as
+string text when fontifying."
+ :type 'boolean
+ :group 'font-lock)
\f
;; Fontification variables:
For example, an element of the first form highlights (if not already highlighted):
- \"\\\\<foo\\\\>\" Discrete occurrences of \"foo\" in the value
+ \"\\\\\\=<foo\\\\\\=>\" Discrete occurrences of \"foo\" in the value
of the variable `font-lock-keyword-face'.
(\"fu\\\\(bar\\\\)\" . 1) Substring \"bar\" within all occurrences of
`fubar-match' finds and matches in the value
of `fubar-face'.
- (\"\\\\<anchor\\\\>\" (0 anchor-face) (\"\\\\<item\\\\>\" nil nil (0 item-face)))
+ (\"\\\\\\=<anchor\\\\\\=>\" (0 anchor-face) (\"\\\\\\=<item\\\\\\=>\" nil nil (0 item-face)))
-------------- --------------- ------------ --- --- -------------
| | | | | |
MATCHER | ANCHOR-MATCHER | +------+ MATCH-HIGHLIGHT
;;;###autoload
(make-variable-buffer-local 'font-lock-keywords)
+;;;###autoload
+(defvar font-lock-syntactic-keywords nil
+ "A list of the syntactic keywords to highlight.
+Can be the list or the name of a function or variable whose value is the list.
+See `font-lock-keywords' for a description of the form of this list;
+the differences are listed below. MATCH-HIGHLIGHT should be of the form:
+
+ (MATCH SYNTAX OVERRIDE LAXMATCH)
+
+where SYNTAX can be of the form (SYNTAX-CODE . MATCHING-CHAR), the name of a
+syntax table, or an expression whose value is such a form or a syntax table.
+OVERRIDE cannot be `prepend' or `append'.
+
+For example, an element of the form highlights syntactically:
+
+ (\"\\\\$\\\\(#\\\\)\" 1 (1 . nil))
+
+ a hash character when following a dollar character, with a SYNTAX-CODE of
+ 1 (meaning punctuation syntax). Assuming that the buffer syntax table does
+ specify hash characters to have comment start syntax, the element will only
+ highlight hash characters that do not follow dollar characters as comments
+ syntactically.
+
+ (\"\\\\('\\\\).\\\\('\\\\)\"
+ (1 (7 . ?'))
+ (2 (7 . ?')))
+
+ both single quotes which surround a single character, with a SYNTAX-CODE of
+ 7 (meaning string quote syntax) and a MATCHING-CHAR of a single quote (meaning
+ a single quote matches a single quote). Assuming that the buffer syntax table
+ does not specify single quotes to have quote syntax, the element will only
+ highlight single quotes of the form 'c' as strings syntactically.
+ Other forms, such as foo'bar or 'fubar', will not be highlighted as strings.
+
+This is normally set via `font-lock-defaults'."
+)
+;;;###autoload
+(make-variable-buffer-local 'font-lock-syntactic-keywords)
+
(defvar font-lock-defaults nil
"The defaults font Font Lock mode for the current buffer.
Normally, do not set this directly. If you are writing a major mode,
This is normally set via `font-lock-defaults'.")
(make-variable-buffer-local 'font-lock-syntax-table)
-;; These are used in the FSF version in syntactic font-locking.
-;; We do this all in C.
-;;; These record the parse state at a particular position, always the
-;;; start of a line. Used to make
-;;; `font-lock-fontify-syntactically-region' faster.
-;(defvar font-lock-cache-position nil)
-;(defvar font-lock-cache-state nil)
-;(make-variable-buffer-local 'font-lock-cache-position)
-;(make-variable-buffer-local 'font-lock-cache-state)
+;; These record the parse state at a particular position, always the start of a
+;; line. Used to make `font-lock-fontify-syntactically-region' faster.
+;; Previously, `font-lock-cache-position' was just a buffer position. However,
+;; under certain situations, this occasionally resulted in mis-fontification.
+;; I think the "situations" were deletion with Lazy Lock mode's deferral. sm.
+(defvar font-lock-cache-state nil)
+(defvar font-lock-cache-position nil)
+(make-variable-buffer-local 'font-lock-cache-state)
+(make-variable-buffer-local 'font-lock-cache-position)
;; If this is nil, we only use the beginning of the buffer if we can't use
;; `font-lock-cache-position' and `font-lock-cache-state'.
;; #### barf gag retch. Horrid FSF lossage that we need to
;; keep around for compatibility with font-lock-keywords that
;; forget to properly quote their faces. I tried just let-binding
-;; them when we eval the face expression, but that failes because
+;; them when we eval the face expression, but that fails because
;; some files actually use the variables directly in their init code
;; without quoting them. --ben
(defvar font-lock-comment-face 'font-lock-comment-face
It is present only for horrid FSF compatibility reasons.
The corresponding face should be set using `edit-faces' or the
`set-face-*' functions.")
+;; GNU compatibility
+(define-compatible-variable-alias
+ 'font-lock-doc-face 'font-lock-doc-string-face)
(defvar font-lock-string-face 'font-lock-string-face
"This variable should not be set.
It is present only for horrid FSF compatibility reasons.
It is present only for horrid FSF compatibility reasons.
The corresponding face should be set using `edit-faces' or the
`set-face-*' functions.")
+(defvar font-lock-builtin-face 'font-lock-builtin-face
+ "This variable should not be set.
+It is present only for horrid FSF compatibility reasons.
+The corresponding face should be set using `edit-faces' or the
+`set-face-*' functions.")
(defvar font-lock-function-name-face 'font-lock-function-name-face
"This variable should not be set.
It is present only for horrid FSF compatibility reasons.
It is present only for horrid FSF compatibility reasons.
The corresponding face should be set using `edit-faces' or the
`set-face-*' functions.")
+(defvar font-lock-constant-face 'font-lock-constant-face
+ "This variable should not be set.
+It is present only for horrid FSF compatibility reasons.
+The corresponding face should be set using `edit-faces' or the
+`set-face-*' functions.")
(defvar font-lock-reference-face 'font-lock-reference-face
"This variable should not be set.
It is present only for horrid FSF compatibility reasons.
font-lock-string-face
font-lock-doc-string-face
font-lock-keyword-face
+ font-lock-builtin-face
font-lock-function-name-face
font-lock-variable-name-face
font-lock-type-face
+ font-lock-constant-face
font-lock-reference-face
font-lock-preprocessor-face
font-lock-warning-face))
"Font Lock mode face used to highlight keywords."
:group 'font-lock-faces)
+(defface font-lock-builtin-face
+ '((((class color) (background light)) (:foreground "Purple"))
+ (((class color) (background dark)) (:foreground "Cyan"))
+ (((class grayscale) (background light)) (:foreground "LightGray" :bold t))
+ (((class grayscale) (background dark)) (:foreground "DimGray" :bold t))
+ (t (:bold t)))
+ "Font Lock mode face used to highlight builtins."
+:group 'font-lock-faces)
+
(defface font-lock-function-name-face
'((((class color) (background dark)) (:foreground "aquamarine"))
;; brown4 is hardly different from black on windows.
"Font Lock mode face used to highlight types."
:group 'font-lock-faces)
+(defface font-lock-constant-face
+ '((((class color) (background light)) (:foreground "CadetBlue"))
+ (((class color) (background dark)) (:foreground "Aquamarine"))
+ (((class grayscale) (background light))
+ (:foreground "LightGray" :bold t :underline t))
+ (((class grayscale) (background dark))
+ (:foreground "Gray50" :bold t :underline t))
+ (t (:bold t :underline t)))
+ "Font Lock mode face used to highlight constants and labels."
+:group 'font-lock-faces)
+
(defface font-lock-reference-face
'((((class color) (background dark)) (:foreground "cadetblue2"))
(((class color) (background light)) (:foreground "red3"))
"Font Lock mode face used to highlight references."
:group 'font-lock-faces)
-;; #### FSF has font-lock-builtin-face.
-
(defface font-lock-preprocessor-face
'((((class color) (background dark)) (:foreground "steelblue1"))
(((class color) (background light)) (:foreground "blue3"))
"Font Lock Mode face used to highlight preprocessor conditionals."
:group 'font-lock-faces)
-;; #### Currently unused
(defface font-lock-warning-face
'((((class color) (background light)) (:foreground "Red" :bold t))
(((class color) (background dark)) (:foreground "Pink" :bold t))
font-lock-maximum-size
(cdr (or (assq major-mode font-lock-maximum-size)
(assq t font-lock-maximum-size))))))
- ;; Font-lock mode will refuse to turn itself on if in batch mode, or if
- ;; the current buffer is "invisible". The latter is because packages
- ;; sometimes put their temporary buffers into some particular major mode
- ;; to get syntax tables and variables and whatnot, but we don't want the
- ;; fact that the user has font-lock-mode on a mode hook to slow these
- ;; things down.
- (if (or noninteractive (eq (aref (buffer-name) 0) ?\ ))
- (setq on-p nil))
- (if (equal (buffer-name) " *Compiler Input*") ; hack for bytecomp...
+ ;; Font-lock mode will refuse to turn itself on if in batch mode
+ ;; to avoid potential (probably not actual, though) slowdown. We
+ ;; used to try to "be nice" by avoiding doing this in temporary
+ ;; buffers. But with the deferral code we don't need this, and it
+ ;; definitely screws some things up.
+ (if (noninteractive)
(setq on-p nil))
(cond (on-p
(make-local-hook 'after-change-functions)
((or (null maximum-size) (<= (buffer-size) maximum-size))
(font-lock-fontify-buffer))
(font-lock-verbose
- (lprogress-display 'font-lock
- "Fontifying %s... buffer too big." 'abort
- (buffer-name)))))
+ (progress-feedback-with-label
+ 'font-lock
+ "Fontifying %s... buffer too big." 'abort
+ (buffer-name)))))
(font-lock-fontified
(setq font-lock-fontified nil)
(font-lock-unfontify-region (point-min) (point-max))
;;;###autoload
(defun turn-on-font-lock ()
"Unconditionally turn on Font Lock mode."
+ (interactive)
(font-lock-mode 1))
;;;###autoload
(defun turn-off-font-lock ()
"Unconditionally turn off Font Lock mode."
+ (interactive)
(font-lock-mode 0))
;;; FSF has here:
(defsubst font-lock-remove-face (start end)
;; Remove any syntax highlighting on the characters in the range.
(put-nonduplicable-text-property start end 'face nil)
- (put-nonduplicable-text-property start end 'font-lock nil))
+ (put-nonduplicable-text-property start end 'font-lock nil)
+ (if lookup-syntax-properties
+ (put-nonduplicable-text-property start end 'syntax-table nil)))
+
+(defsubst font-lock-set-syntax (start end syntax)
+ ;; Set the face on the characters in the range.
+ (put-nonduplicable-text-property start end 'syntax-table syntax)
+ (put-nonduplicable-text-property start end 'font-lock t))
(defsubst font-lock-any-faces-p (start end)
;; Return non-nil if we've put any syntax highlighting on
(font-lock-mode 0)))
(set (make-local-variable 'font-lock-fontified) t)
(when (and aborted font-lock-verbose)
- (lprogress-display 'font-lock "Fontifying %s... aborted."
- 'abort (buffer-name))))
+ (progress-feedback-with-label 'font-lock "Fontifying %s... aborted."
+ 'abort (buffer-name))))
(run-hooks 'font-lock-after-fontify-buffer-hook)))
(defun font-lock-default-unfontify-buffer ()
;; Use the fontification syntax table, if any.
(if font-lock-syntax-table (set-syntax-table font-lock-syntax-table))
;; Now do the fontification.
- (if font-lock-keywords-only
- (font-lock-unfontify-region beg end)
+ (font-lock-unfontify-region beg end)
+ (when font-lock-syntactic-keywords
+ (font-lock-fontify-syntactic-keywords-region beg end))
+ (unless font-lock-keywords-only
(font-lock-fontify-syntactically-region beg end loudly))
(font-lock-fontify-keywords-region beg end loudly))
;; Clean up.
(defun font-lock-default-unfontify-region (beg end &optional maybe-loudly)
(when (and maybe-loudly font-lock-verbose
(>= (- end beg) font-lock-message-threshold))
- (lprogress-display 'font-lock "Fontifying %s..." 0 (buffer-name)))
+ (progress-feedback-with-label 'font-lock "Fontifying %s..." 0
+ (buffer-name)))
(let ((modified (buffer-modified-p))
(buffer-undo-list t) (inhibit-read-only t)
buffer-file-name buffer-file-truename)
next redisplay cycle, avoiding excessive fontification when many
buffer modifications are performed or a buffer is reverted.")
-(defvar font-lock-pending-extent-table (make-hash-table :weakness 'key))
+;; list of buffers in which there is a pending change.
+(defvar font-lock-pending-buffer-table (make-hash-table :weakness 'key))
+;; table used to keep track of ranges needing fontification.
(defvar font-lock-range-table (make-range-table))
(defun font-lock-pre-idle-hook ()
(condition-case font-lock-error
- (if (> (hash-table-count font-lock-pending-extent-table) 0)
+ (if (> (hash-table-count font-lock-pending-buffer-table) 0)
(font-lock-fontify-pending-extents))
(error (warn "Error caught in `font-lock-pre-idle-hook': %s"
font-lock-error))))
(defun font-lock-after-change-function (beg end old-len)
(when font-lock-mode
- (let ((ex (make-extent beg end)))
- (set-extent-property ex 'detachable nil)
- (set-extent-property ex 'end-open nil)
- (let ((exs (gethash (current-buffer) font-lock-pending-extent-table)))
- (push ex exs)
- (puthash (current-buffer) exs font-lock-pending-extent-table)))
+ ;; treat deletions as if the following character (or previous, if
+ ;; there is no following) were inserted. (also use the previous
+ ;; character at end of line. this avoids a problem when you
+ ;; insert a comment on the line before a line of code: if we use
+ ;; the following char, then when you hit backspace, the following
+ ;; line of code turns the comment color.) this is a bit of a hack
+ ;; but allows us to use text properties for everything.
+ (if (= beg end)
+ (cond ((not (save-excursion (goto-char end) (eolp)))
+ (setq end (1+ end)))
+ ((/= beg (point-min)) (setq beg (1- beg)))
+ (t nil)))
+ (put-text-property beg end 'font-lock-pending t)
+ (puthash (current-buffer) t font-lock-pending-buffer-table)
(if font-lock-always-fontify-immediately
(font-lock-fontify-pending-extents))))
;; only one buffer and one contiguous region!
(save-match-data
(maphash
- #'(lambda (buffer exs)
+ #'(lambda (buffer dummy)
;; remove first, to avoid infinite reprocessing if error
- (remhash buffer font-lock-pending-extent-table)
+ (remhash buffer font-lock-pending-buffer-table)
(when (buffer-live-p buffer)
(clear-range-table font-lock-range-table)
(with-current-buffer buffer
(save-excursion
(save-restriction
- ;; if we don't widen, then the C code will fail to
- ;; realize that we're inside a comment.
+ ;; if we don't widen, then the C code in
+ ;; syntactically-sectionize will fail to realize that
+ ;; we're inside a comment. #### We don't actually use
+ ;; syntactically-sectionize any more. Do we still
+ ;; need the widen?
(widen)
(let ((zmacs-region-stays
zmacs-region-stays)) ; protect from change!
- (mapc
- #'(lambda (ex)
- ;; paranoia.
- (when (and (extent-live-p ex)
- (not (extent-detached-p ex)))
- ;; first expand the ranges to full lines, because
- ;; that is what will be fontified; then use a
- ;; range table to merge the ranges.
- (let* ((beg (extent-start-position ex))
- (end (extent-end-position ex))
- (beg (progn (goto-char beg)
- (beginning-of-line)
- (point)))
- (end (progn (goto-char end)
- (forward-line 1)
- (point))))
- (detach-extent ex)
- (put-range-table beg end t
- font-lock-range-table))))
- exs)
+ (map-extents
+ #'(lambda (ex dummy-maparg)
+ ;; first expand the ranges to full lines,
+ ;; because that is what will be fontified;
+ ;; then use a range table to merge the
+ ;; ranges. (we could also do this simply using
+ ;; text properties. the range table code was
+ ;; here from a previous version of this code
+ ;; and works just as well.)
+ (let* ((beg (extent-start-position ex))
+ (end (extent-end-position ex))
+ (beg (progn (goto-char beg)
+ (beginning-of-line)
+ (point)))
+ (end (progn (goto-char end)
+ (forward-line 1)
+ (point))))
+ (put-range-table beg end t
+ font-lock-range-table)))
+ nil nil nil nil nil 'font-lock-pending t)
+ ;; clear all pending extents first in case of error below.
+ (put-text-property (point-min) (point-max)
+ 'font-lock-pending nil)
(map-range-table
#'(lambda (beg end val)
- ;; Maybe flush the internal cache used by
- ;; syntactically-sectionize. (It'd be nice if this
- ;; was more automatic.) Any deletions mean the
- ;; cache is invalid, and insertions at beginning or
- ;; end of line mean that the bol cache might be
- ;; invalid.
- ;; #### This code has been commented out for some time
- ;; now and is bit-rotting. Someone should look into
- ;; this.
-;; (if (or change-was-deletion (bobp)
-;; (= (preceding-char) ?\n))
-;; (buffer-syntactic-context-flush-cache))
- ;; #### This creates some unnecessary progress gauges.
+ ;; This creates some unnecessary progress gauges.
;; (if (and (= beg (point-min))
;; (= end (point-max)))
;; (font-lock-fontify-buffer)
;; (font-lock-fontify-region beg end)))
(font-lock-fontify-region beg end))
font-lock-range-table)))))))
- font-lock-pending-extent-table)))
+ font-lock-pending-buffer-table)))
\f
;; Syntactic fontification functions.
-;; Note: Here is the FSF version. Our version is much faster because
-;; of the C support we provide. This may be useful for reference,
-;; however, and perhaps there is something useful here that should
-;; be merged into our version.
-;;
-;(defun font-lock-fontify-syntactically-region (start end &optional loudly)
-; "Put proper face on each string and comment between START and END.
-;START should be at the beginning of a line."
-; (let ((synstart (if comment-start-skip
-; (concat "\\s\"\\|" comment-start-skip)
-; "\\s\""))
-; (comstart (if comment-start-skip
-; (concat "\\s<\\|" comment-start-skip)
-; "\\s<"))
-; state prev prevstate)
-; (if loudly (message "Fontifying %s... (syntactically...)" (buffer-name)))
-; (save-restriction
-; (widen)
-; (goto-char start)
-; ;;
-; ;; Find the state at the `beginning-of-line' before `start'.
-; (if (eq start font-lock-cache-position)
-; ;; Use the cache for the state of `start'.
-; (setq state font-lock-cache-state)
-; ;; Find the state of `start'.
-; (if (null font-lock-beginning-of-syntax-function)
-; ;; Use the state at the previous cache position, if any, or
-; ;; otherwise calculate from `point-min'.
-; (if (or (null font-lock-cache-position)
-; (< start font-lock-cache-position))
-; (setq state (parse-partial-sexp (point-min) start))
-; (setq state (parse-partial-sexp font-lock-cache-position start
-; nil nil font-lock-cache-state)))
-; ;; Call the function to move outside any syntactic block.
-; (funcall font-lock-beginning-of-syntax-function)
-; (setq state (parse-partial-sexp (point) start)))
-; ;; Cache the state and position of `start'.
-; (setq font-lock-cache-state state
-; font-lock-cache-position start))
-; ;;
-; ;; If the region starts inside a string, show the extent of it.
-; (if (nth 3 state)
-; (let ((beg (point)))
-; (while (and (re-search-forward "\\s\"" end 'move)
-; (nth 3 (parse-partial-sexp beg (point)
-; nil nil state))))
-; (put-text-property beg (point) 'face font-lock-string-face)
-; (setq state (parse-partial-sexp beg (point) nil nil state))))
-; ;;
-; ;; Likewise for a comment.
-; (if (or (nth 4 state) (nth 7 state))
-; (let ((beg (point)))
-; (save-restriction
-; (narrow-to-region (point-min) end)
-; (condition-case nil
-; (progn
-; (re-search-backward comstart (point-min) 'move)
-; (forward-comment 1)
-; ;; forward-comment skips all whitespace,
-; ;; so go back to the real end of the comment.
-; (skip-chars-backward " \t"))
-; (error (goto-char end))))
-; (put-text-property beg (point) 'face font-lock-comment-face)
-; (setq state (parse-partial-sexp beg (point) nil nil state))))
-; ;;
-; ;; Find each interesting place between here and `end'.
-; (while (and (< (point) end)
-; (setq prev (point) prevstate state)
-; (re-search-forward synstart end t)
-; (progn
-; ;; Clear out the fonts of what we skip over.
-; (remove-text-properties prev (point) '(face nil))
-; ;; Verify the state at that place
-; ;; so we don't get fooled by \" or \;.
-; (setq state (parse-partial-sexp prev (point)
-; nil nil state))))
-; (let ((here (point)))
-; (if (or (nth 4 state) (nth 7 state))
-; ;;
-; ;; We found a real comment start.
-; (let ((beg (match-beginning 0)))
-; (goto-char beg)
-; (save-restriction
-; (narrow-to-region (point-min) end)
-; (condition-case nil
-; (progn
-; (forward-comment 1)
-; ;; forward-comment skips all whitespace,
-; ;; so go back to the real end of the comment.
-; (skip-chars-backward " \t"))
-; (error (goto-char end))))
-; (put-text-property beg (point) 'face
-; font-lock-comment-face)
-; (setq state (parse-partial-sexp here (point) nil nil state)))
-; (if (nth 3 state)
-; ;;
-; ;; We found a real string start.
-; (let ((beg (match-beginning 0)))
-; (while (and (re-search-forward "\\s\"" end 'move)
-; (nth 3 (parse-partial-sexp here (point)
-; nil nil state))))
-; (put-text-property beg (point) 'face font-lock-string-face)
-; (setq state (parse-partial-sexp here (point)
-; nil nil state))))))
-; ;;
-; ;; Make sure `prev' is non-nil after the loop
-; ;; only if it was set on the very last iteration.
-; (setq prev nil)))
-; ;;
-; ;; Clean up.
-; (and prev (remove-text-properties prev end '(face nil)))))
-
(defun font-lock-lisp-like (mode)
;; Note: (or (get mode 'font-lock-lisp-like) (string-match ...)) is
;; not enough because the property needs to be able to specify a nil
;; in add-log, but I think this encompasses more modes.
(string-match "lisp\\|scheme" (symbol-name mode))))
+;; fontify-syntactically-region used to use syntactically-sectionize, which
+;; was supposedly much faster than the FSF version because it was written in
+;; C. However, the FSF version uses parse-partial-sexp, which is also
+;; written in C, and the benchmarking I did showed the
+;; syntactically-sectionize code to be slower overall. So here's the
+;; FSF version, modified to support font-lock-doc-string-face.
+;; -- mct 2000-12-29
+;; #### Andy conditionally reverted Matt's change when we were experimenting
+;; with making lookup-syntax-properties an optional feature. I don't see how
+;; this code relates to lookup-syntax-properties, though. I wonder if the
+;; bug is in our (?) version of parse-partial-sexp. Andy says no. Of course,
+;; Matt benchmarked ... WTF knows? sjt 2002-09-28
(defun font-lock-fontify-syntactically-region (start end &optional loudly)
"Put proper face on each string and comment between START and END.
-START should be at the beginning of a line."
+START should be at the beginning of a line. Optional argument LOUDLY
+is currently ignored."
(if font-lock-keywords-only
nil
+
+ ;; #### Shouldn't this just be using 'loudly??
(when (and font-lock-verbose
(>= (- end start) font-lock-message-threshold))
- (lprogress-display 'font-lock "Fontifying %s... (syntactically)" 5
- (buffer-name)))
- (font-lock-unfontify-region start end loudly)
+ (progress-feedback-with-label 'font-lock
+ "Fontifying %s... (syntactically)" 5
+ (buffer-name)))
(goto-char start)
- (if (> end (point-max)) (setq end (point-max)))
- (let ((lisp-like (font-lock-lisp-like major-mode)))
- (syntactically-sectionize
- #'(lambda (s e context depth)
- (let (face)
- (cond ((eq context 'string)
- (setq face
- ;; #### It would be nice if we handled
- ;; Python and other non-Lisp languages with
- ;; docstrings correctly.
- (if (and lisp-like (= depth 1))
- ;; really we should only use this if
- ;; in position 3 depth 1, but that's
- ;; too expensive to compute.
- 'font-lock-doc-string-face
- 'font-lock-string-face)))
- ((or (eq context 'comment)
- (eq context 'block-comment))
- (setq face 'font-lock-comment-face)
-; ;; Don't fontify whitespace at the beginning of lines;
-; ;; otherwise comment blocks may not line up with code.
-; ;; (This is sometimes a good idea, sometimes not; in any
-; ;; event it should be in C for speed --jwz)
-; (save-excursion
-; (goto-char s)
-; (while (prog1 (search-forward "\n" (1- e) 'move)
-; (setq face 'font-lock-comment-face)
-; (setq e (point)))
-; (skip-chars-forward " \t\n")
-; (setq s (point)))
- ))
- (font-lock-set-face s e face)))
- start end)
- )))
+
+ (let ((lisp-like (font-lock-lisp-like major-mode))
+ (cache (marker-position font-lock-cache-position))
+ state string beg depth)
+ ;;
+ ;; Find the state at the `beginning-of-line' before `start'.
+ (if (eq start cache)
+ ;; Use the cache for the state of `start'.
+ (setq state font-lock-cache-state)
+ ;; Find the state of `start'.
+ (if (null font-lock-beginning-of-syntax-function)
+ ;; Use the state at the previous cache position, if any, or
+ ;; otherwise calculate from `point-min'.
+ (if (or (null cache) (< start cache))
+ (setq state (parse-partial-sexp (point-min) start))
+ (setq state (parse-partial-sexp cache start nil nil
+ font-lock-cache-state)))
+ ;; Call the function to move outside any syntactic block.
+ (funcall font-lock-beginning-of-syntax-function)
+ (setq state (parse-partial-sexp (point) start)))
+ ;; Cache the state and position of `start'.
+ (setq font-lock-cache-state state)
+ (set-marker font-lock-cache-position start))
+ ;;
+ ;; If the region starts inside a string or comment, show the extent of it.
+ (when (or (nth 3 state) (nth 4 state))
+ (setq string (nth 3 state) beg (point))
+ (setq state (parse-partial-sexp (point) end nil nil state 'syntax-table))
+ (font-lock-set-face beg (point) (if string
+ font-lock-string-face
+ font-lock-comment-face)))
+ ;;
+ ;; Find each interesting place between here and `end'.
+ (while (and (< (point) end)
+ (progn
+ (setq state (parse-partial-sexp (point) end nil nil state
+ 'syntax-table))
+ (or (nth 3 state) (nth 4 state))))
+ (setq depth (nth 0 state) string (nth 3 state) beg (nth 8 state))
+ (setq state (parse-partial-sexp (point) end nil nil state 'syntax-table))
+ (if string
+ ;; #### It would be nice if we handled Python and other
+ ;; non-Lisp languages with docstrings correctly.
+ (let ((face (if (and lisp-like (= depth 1))
+ 'font-lock-doc-string-face
+ 'font-lock-string-face)))
+ (if font-lock-fontify-string-delimiters
+ (font-lock-set-face beg (point) face)
+ (font-lock-set-face (+ beg 1) (- (point) 1) face)))
+ (font-lock-set-face beg (point)
+ font-lock-comment-face))))))
\f
;;; Additional text property functions.
object)
(setq start next))))
\f
+;;; Syntactic regexp fontification functions (taken from FSF Emacs 20.7.1)
+
+;; These syntactic keyword pass functions are identical to those keyword pass
+;; functions below, with the following exceptions; (a) they operate on
+;; `font-lock-syntactic-keywords' of course, (b) they are all `defun' as speed
+;; is less of an issue, (c) eval of property value does not occur JIT as speed
+;; is less of an issue, (d) OVERRIDE cannot be `prepend' or `append' as it
+;; makes no sense for `syntax-table' property values, (e) they do not do it
+;; LOUDLY as it is not likely to be intensive.
+
+(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)))
+ (unless (numberp (car-safe value))
+ (setq value (eval value)))
+ (cond ((not start)
+ ;; No match but we might not signal an error.
+ (or (nth 3 highlight)
+ (error "No match %d in highlight %S" match highlight)))
+ ((not override)
+ ;; Cannot override existing fontification.
+ (or (map-extents 'extent-property (current-buffer)
+ start end 'syntax-table)
+ (font-lock-set-syntax start end value)))
+ ((eq override t)
+ ;; Override existing fontification.
+ (font-lock-set-syntax start end value))
+ ((eq override 'keep)
+ ;; Keep existing fontification.
+ (font-lock-fillin-text-property start end
+ 'syntax-table 'font-lock value)))))
+
+(defun font-lock-fontify-syntactic-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
+ ;; Evaluate PRE-MATCH-FORM.
+ (pre-match-value (eval (nth 1 keywords))))
+ ;; Set LIMIT to value of PRE-MATCH-FORM or the end of line.
+ (if (and (numberp pre-match-value) (> pre-match-value (point)))
+ (setq limit pre-match-value)
+ (save-excursion (end-of-line) (setq limit (point))))
+ (save-match-data
+ ;; Find an occurrence of `matcher' before `limit'.
+ (while (if (stringp matcher)
+ (re-search-forward matcher limit t)
+ (funcall matcher limit))
+ ;; Apply each highlight to this instance of `matcher'.
+ (setq highlights lowdarks)
+ (while highlights
+ (font-lock-apply-syntactic-highlight (car highlights))
+ (setq highlights (cdr highlights)))))
+ ;; Evaluate POST-MATCH-FORM.
+ (eval (nth 2 keywords))))
+
+(defun font-lock-fontify-syntactic-keywords-region (start end)
+ "Fontify according to `font-lock-syntactic-keywords' between START and END.
+START should be at the beginning of a line."
+;; ;; If `font-lock-syntactic-keywords' is a symbol, get the real keywords.
+ (when (symbolp font-lock-syntactic-keywords)
+ (setq font-lock-syntactic-keywords (font-lock-eval-keywords
+ font-lock-syntactic-keywords)))
+ ;; If `font-lock-syntactic-keywords' is not compiled, compile it.
+ (unless (eq (car font-lock-syntactic-keywords) t)
+ (setq font-lock-syntactic-keywords (font-lock-compile-keywords
+ font-lock-syntactic-keywords)))
+ ;; Get down to business.
+ (let ((case-fold-search font-lock-keywords-case-fold-search)
+ (keywords (cdr font-lock-syntactic-keywords))
+ keyword matcher highlights)
+ (while keywords
+ ;; Find an occurrence of `matcher' from `start' to `end'.
+ (setq keyword (car keywords) matcher (car keyword))
+ (goto-char start)
+ (while (if (stringp matcher)
+ (re-search-forward matcher end t)
+ (funcall matcher end))
+ ;; Apply each highlight to this instance of `matcher', which may be
+ ;; specific highlights or more keywords anchored to `matcher'.
+ (setq highlights (cdr keyword))
+ (while highlights
+ (if (numberp (car (car highlights)))
+ (font-lock-apply-syntactic-highlight (car highlights))
+ (font-lock-fontify-syntactic-anchored-keywords (car highlights)
+ end))
+ (setq highlights (cdr highlights))))
+ (setq keywords (cdr keywords)))))
+\f
;;; Regexp fontification functions.
(defsubst font-lock-apply-highlight (highlight)
START should be at the beginning of a line."
(let ((loudly (and font-lock-verbose
(>= (- end start) font-lock-message-threshold))))
+ (unless (eq (car-safe 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 (cdr (if (eq (car-safe font-lock-keywords) t)
- font-lock-keywords
- (font-lock-compile-keywords))))
+ (keywords (cdr font-lock-keywords))
(bufname (buffer-name))
(progress 5) (old-progress 5)
(iter 0)
(+ (/ (* (- (point) start) 95) (* (- end start) nkeywords))
(/ (* iter 95) nkeywords) 5))
(when (and loudly (> progress old-progress))
- (lprogress-display 'font-lock "Fontifying %s... (regexps)"
- progress bufname))
+ (progress-feedback-with-label 'font-lock
+ "Fontifying %s... (regexps)"
+ progress bufname))
(setq old-progress progress)
;; Apply each highlight to this instance of `matcher', which may be
;; specific highlights or more keywords anchored to `matcher'.
(setq highlights (cdr highlights))))
(setq iter (1+ iter))
(setq keywords (cdr keywords))))
- (if loudly (lprogress-display 'font-lock "Fontifying %s... " 100 (buffer-name)))))
+ (if loudly
+ (progress-feedback-with-label 'font-lock "Fontifying %s... " 100
+ (buffer-name)))))
\f
;; Various functions.
\f
;; Various functions.
-(defun font-lock-compile-keywords (&optional keywords)
- ;; Compile `font-lock-keywords' into the form (t KEYWORD ...) where KEYWORD
- ;; is the (MATCHER HIGHLIGHT ...) shown in the variable's doc string.
- (let ((keywords (or keywords font-lock-keywords)))
- (setq font-lock-keywords
- (if (eq (car-safe keywords) t)
- keywords
- (cons t (mapcar 'font-lock-compile-keyword keywords))))))
+(defun font-lock-compile-keywords (keywords)
+ "Compile KEYWORDS (a list) and return the list of compiled keywords.
+Each keyword has the form (MATCHER HIGHLIGHT ...). See `font-lock-keywords'."
+ (if (eq (car-safe keywords) t)
+ keywords
+ (cons t (mapcar 'font-lock-compile-keyword keywords))))
(defun font-lock-compile-keyword (keyword)
(cond ((nlistp keyword) ; Just MATCHER
(t ; Hopefully (MATCHER HIGHLIGHT ...)
keyword)))
+(defun font-lock-eval-keywords (keywords)
+ "Evaluate KEYWORDS if a function (funcall) or variable (eval) name."
+ (if (listp keywords)
+ keywords
+ (font-lock-eval-keywords (if (fboundp keywords)
+ (funcall keywords)
+ (eval keywords)))))
+
(defun font-lock-choose-keywords (keywords level)
;; Return LEVELth element of KEYWORDS. A LEVEL of nil is equal to a
;; LEVEL of 0, a LEVEL of t is equal to (1- (length KEYWORDS)).
(font-lock-find-font-lock-defaults major-mode)))
(keywords (font-lock-choose-keywords
(nth 0 defaults) font-lock-maximum-decoration)))
-
+
;; Keywords?
(setq font-lock-keywords (if (fboundp keywords)
(funcall keywords)
(setq font-lock-beginning-of-syntax-function
'beginning-of-defun)))))
+ (setq font-lock-cache-position (make-marker))
(setq font-lock-defaults-computed t)))
\f
;;
;; Control structures. ELisp and CLisp combined.
;;
- ;;(regexp-opt
- ;; '("cond" "if" "while" "let" "let*" "prog" "progn" "prog1"
- ;; "prog2" "progv" "catch" "throw" "save-restriction"
- ;; "save-excursion" "save-window-excursion"
- ;; "save-current-buffer" "with-current-buffer"
- ;; "with-temp-file" "with-temp-buffer" "with-output-to-string"
- ;; "with-string-as-buffer-contents"
- ;; "save-selected-window" "save-match-data" "unwind-protect"
- ;; "condition-case" "track-mouse" "autoload"
- ;; "eval-after-load" "eval-and-compile" "eval-when-compile"
- ;; "when" "unless" "do" "dolist" "dotimes" "flet" "labels"
- ;; "lambda" "return" "return-from"))
(cons
(concat
"(\\("
- "autoload\\|c\\(atch\\|ond\\(ition-case\\)?\\)\\|do\\(list\\|"
- "times\\)?\\|eval-\\(a\\(fter-load\\|nd-compile\\)\\|when-compile\\)\\|"
- "flet\\|if\\|l\\(a\\(bels\\|mbda\\)\\|et\\*?\\)\\|"
- "prog[nv12\\*]?\\|return\\(-from\\)?\\|save-\\(current-buffer\\|"
- "excursion\\|match-data\\|restriction\\|selected-window\\|"
- "window-excursion\\)\\|t\\(hrow\\|rack-mouse\\)\\|un\\(less\\|"
- "wind-protect\\)\\|w\\(h\\(en\\|ile\\)\\|ith-\\(current-buffer\\|"
- "output-to-string\\|string-as-buffer-contents\\|temp-\\(buffer\\|"
- "file\\)\\)\\)"
+ ;; beginning of generated stuff
+ ;; to regenerate, use the regexp-opt below, then delete the outermost
+ ;; grouping, then use the macro below to break up the string.
+ ;; (regexp-opt
+ ;; '("cond" "if" "while" "let" "let*" "prog" "progn" "prog1"
+ ;; "prog2" "progv" "catch" "throw" "save-restriction"
+ ;; "save-excursion" "save-window-excursion"
+ ;; "save-current-buffer" "with-current-buffer"
+ ;; "save-selected-window" "with-selected-window"
+ ;; "save-selected-frame" "with-selected-frame"
+ ;; "with-temp-file" "with-temp-buffer" "with-output-to-string"
+ ;; "with-string-as-buffer-contents"
+ ;; "save-match-data" "unwind-protect" "call-with-condition-handler"
+ ;; "condition-case" "track-mouse" "autoload"
+ ;; "eval-after-load" "eval-and-compile" "eval-when-compile"
+ ;; "when" "unless" "do" "dolist" "dotimes" "flet" "labels"
+ ;; "lambda" "block" "return" "return-from" "loop") t)
+ ;; (setq last-kbd-macro
+ ;; (read-kbd-macro "\" C-7 C-1 <right> C-r \\\\| 3*<right> \" RET"))
+ "autoload\\|block\\|c\\(?:a\\(?:ll-with-condition-handler\\|tch\\)\\|"
+ "ond\\(?:ition-case\\)?\\)\\|do\\(?:list\\|times\\)?\\|"
+ "eval-\\(?:a\\(?:fter-load\\|nd-compile\\)\\|when-compile\\)\\|flet\\|"
+ "if\\|l\\(?:a\\(?:bels\\|mbda\\)\\|et\\*?\\|oop\\)\\|prog[12nv]?\\|"
+ "return\\(?:-from\\)?\\|save-\\(?:current-buffer\\|excursion\\|"
+ "match-data\\|restriction\\|selected-\\(?:frame\\|window\\)\\|"
+ "window-excursion\\)\\|t\\(?:hrow\\|rack-mouse\\)\\|un\\(?:less\\|"
+ "wind-protect\\)\\|w\\(?:h\\(?:en\\|ile\\)\\|ith-\\(?:current-buffer\\|"
+ "output-to-string\\|s\\(?:elected-\\(?:frame\\|window\\)\\|"
+ "tring-as-buffer-contents\\)\\|temp-\\(?:buffer\\|file\\)\\)\\)"
+ ;; end of generated stuff
"\\)\\>") 1)
;;
;; Feature symbols as references.
(c++-keywords
; ("break" "continue" "do" "else" "for" "if" "return" "switch" "while"
; "asm" "catch" "delete" "new" "operator" "sizeof" "this" "throw" "try"
-; "protected" "private" "public")
- (concat "asm\\|break\\|c\\(atch\\|ontinue\\)\\|d\\(elete\\|o\\)\\|"
- "else\\|for\\|if\\|new\\|"
- "p\\(r\\(ivate\\|otected\\)\\|ublic\\)\\|return\\|"
- "s\\(izeof\\|witch\\)\\|t\\(h\\(is\\|row\\)\\|ry\\)\\|while"))
+; "protected" "private" "public" "const_cast" "dynamic_cast" "reinterpret_cast"
+; "static_cast" "and" "bitor" "or" "xor" "compl" "bitand" "and_eq"
+; "or_eq" "xor_eq" "not" "not_eq" "typeid" "false" "true")
+ (concat "a\\(nd\\(\\|_eq\\)\\|sm\\)\\|"
+ "b\\(it\\(or\\|and\\)\\|reak\\)\\|"
+ "c\\(atch\\|o\\(mpl\\|n\\(tinue\\|st_cast\\)\\)\\)\\|"
+ "d\\(elete\\|o\\|ynamic_cast\\)\\|"
+ "else\\|"
+ "f\\(alse\\|or\\)\\|if\\|"
+ "n\\(ew\\|ot\\(\\|_eq\\)\\)\\|"
+ "p\\(r\\(ivate\\|otected\\)\\|ublic\\)\\|"
+ "or\\(\\|_eq\\)\\|"
+ "re\\(interpret_cast\\|turn\\)\\|"
+ "s\\(izeof\\|tatic_cast\\|witch\\)\\|"
+ "t\\(h\\(is\\|row\\)\\|r\\(ue\\|y\\)\\|ypeid\\)\\|"
+ "xor\\(\\|_eq\\)\\|while"))
(c++-type-types
; ("auto" "extern" "register" "static" "typedef" "struct" "union" "enum"
; "signed" "unsigned" "short" "long" "int" "char" "float" "double"
; "void" "volatile" "const" "class" "inline" "friend" "bool"
-; "virtual" "complex" "template")
+; "virtual" "complex" "template" "explicit" "mutable" "export" "namespace"
+; "using" "typename" "wchar_t")
(concat "auto\\|bool\\|c\\(har\\|lass\\|o\\(mplex\\|nst\\)\\)\\|"
- "double\\|e\\(num\\|xtern\\)\\|f\\(loat\\|riend\\)\\|"
- "in\\(line\\|t\\)\\|long\\|register\\|"
+ "double\\|"
+ "e\\(num\\|x\\(p\\(licit\\|ort\\)\\|tern\\)\\)\\|"
+ "f\\(loat\\|riend\\)\\|"
+ "in\\(line\\|t\\)\\|long\\|mutable\\|namespace\\|register\\|"
"s\\(hort\\|igned\\|t\\(atic\\|ruct\\)\\)\\|"
- "t\\(emplate\\|ypedef\\)\\|un\\(ion\\|signed\\)\\|"
- "v\\(irtual\\|o\\(id\\|latile\\)\\)")) ; 11 ()s deep.
+ "t\\(emplate\\|ype\\(def\\|name\\)\\)\\|"
+ "u\\(\\(n\\(ion\\|signed\\)\\|sing\\)\\)\\|"
+ "v\\(irtual\\|o\\(id\\|latile\\)\\)\\|"
+ "wchar_t")) ; 11 ()s deep.
(ctoken "\\(\\sw\\|\\s_\\|[:~*&]\\)+")
)
(setq c-font-lock-keywords-1
"\\|long\\|short\\|void\\)\\>")
"Regexp which should match a primitive type.")
-(let ((capital-letter "A-Z\300-\326\330-\337")
- (letter "a-zA-Z_$\300-\326\330-\366\370-\377")
- (digit "0-9"))
(defvar java-font-lock-identifier-regexp
- (concat "\\<\\([" letter "][" letter digit "]*\\)\\>")
+ (let ((letter "a-zA-Z_$\300-\326\330-\366\370-\377")
+ (digit "0-9"))
+ (concat "\\<\\([" letter "][" letter digit "]*\\)\\>"))
"Regexp which should match all Java identifiers.")
(defvar java-font-lock-class-name-regexp
- (concat "\\<\\([" capital-letter "][" letter digit "]*\\)\\>")
+ (let ((capital-letter "A-Z\300-\326\330-\337")
+ (letter "a-zA-Z_$\300-\326\330-\366\370-\377")
+ (digit "0-9"))
+ (concat "\\<\\([" capital-letter "][" letter digit "]*\\)\\>"))
"Regexp which should match a class or an interface name.
The name is assumed to begin with a capital letter.")
-)
-
(let ((java-modifier-regexp
(concat "\\<\\(abstract\\|const\\|final\\|native\\|"
3 (if (match-beginning 2) 'bold 'italic) keep))
"Default expressions to highlight in TeX modes.")
-(defconst ksh-font-lock-keywords (purecopy
+(defconst ksh-font-lock-keywords
(list
'("\\(^\\|[^\$\\\]\\)#.*" . font-lock-comment-face)
'("\\<\\(if\\|then\\|else\\|elif\\|fi\\|case\\|esac\\|for\\|do\\|done\\|foreach\\|in\\|end\\|select\\|while\\|repeat\\|time\\|function\\|until\\|exec\\|command\\|coproc\\|noglob\\|nohup\\|nocorrect\\|source\\|autoload\\|alias\\|unalias\\|export\\|set\\|echo\\|eval\\|cd\\|log\\|compctl\\)\\>" . font-lock-keyword-face)
'("\\<\\[\\[.*\\]\\]\\>" . font-lock-type-face)
'("\$\(.*\)" . font-lock-type-face)
- ))
+ )
"Additional expressions to highlight in ksh-mode.")
-(defconst sh-font-lock-keywords (purecopy
+(defconst sh-font-lock-keywords
(list
'("\\(^\\|[^\$\\\]\\)#.*" . font-lock-comment-face)
'("\\<\\(if\\|then\\|else\\|elif\\|fi\\|case\\|esac\\|for\\|do\\|done\\|in\\|while\\|exec\\|export\\|set\\|echo\\|eval\\|cd\\)\\>" . font-lock-keyword-face)
'("\\[.*\\]" . font-lock-type-face)
'("`.*`" . font-lock-type-face)
- ))
+ )
"Additional expressions to highlight in sh-mode.")
\f
projects / chise / xemacs-chise.git.1 / blobdiff