X-Git-Url: http://git.chise.org/gitweb/?p=chise%2Fxemacs-chise.git.1;a=blobdiff_plain;f=lisp%2Ffont-lock.el;h=d72aeebfc9e6cddd4f666d25564d0b393e294946;hp=edc59641a97b02aab5b4a0794b9b799156481154;hb=b0360c4503dfc01c7b7e75e6170c32aa7d267291;hpb=14144012929ab5944f367d5d1b323ab8268abb05 diff --git a/lisp/font-lock.el b/lisp/font-lock.el index edc5964..d72aeeb 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -2,7 +2,7 @@ ;; Copyright (C) 1992-1995, 1997 Free Software Foundation, Inc. ;; Copyright (C) 1995 Amdahl Corporation. -;; Copyright (C) 1996, 2000 Ben Wing. +;; Copyright (C) 1996, 2000, 2001 Ben Wing. ;; Author: Jamie Zawinski , for the LISPM Preservation Society. ;; Minimally merged with FSF 19.34 by Barry Warsaw @@ -282,7 +282,7 @@ available for buffers in `c-mode', and level 1 decoration otherwise." (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) @@ -313,6 +313,12 @@ megabyte for buffers in `rmail-mode', and size is irrelevant otherwise." (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) ;; Fontification variables: @@ -435,9 +441,74 @@ edit the buffer does not, since it considers text one line at a time. Be very careful composing regexps for this list; the wrong pattern can dramatically slow things down! ") + +(defvar font-lock-keywords-alist nil + "Alist of additional `font-lock-keywords' elements for major modes. + +Each element has the form (MODE KEYWORDS . HOW). +`font-lock-set-defaults' adds the elements in the list KEYWORDS to +`font-lock-keywords' when Font Lock is turned on in major mode MODE. + +If HOW is nil, KEYWORDS are added at the beginning of +`font-lock-keywords'. If it is `set', they are used to replace the +value of `font-lock-keywords'. If HOW is any other non-nil value, +they are added at the end. + +This is normally set via `font-lock-add-keywords' and +`font-lock-remove-keywords'.") + +(defvar font-lock-removed-keywords-alist nil + "Alist of `font-lock-keywords' elements to be removed for major modes. + +Each element has the form (MODE . KEYWORDS). `font-lock-set-defaults' +removes the elements in the list KEYWORDS from `font-lock-keywords' +when Font Lock is turned on in major mode MODE. + +This is normally set via `font-lock-add-keywords' and +`font-lock-remove-keywords'.") + ;;;###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, @@ -511,15 +582,15 @@ If this is nil, the major mode's syntax table is used. 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'. @@ -581,7 +652,7 @@ This is normally set via `font-lock-defaults'.") ;; #### 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 @@ -594,6 +665,9 @@ The corresponding face should be set using `edit-faces' or the 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. @@ -604,6 +678,11 @@ The corresponding face should be set using `edit-faces' or the 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. @@ -619,6 +698,11 @@ The corresponding face should be set using `edit-faces' or the 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. @@ -629,15 +713,22 @@ The corresponding face should be set using `edit-faces' or the 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-warning-face 'font-lock-warning-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.") (defconst font-lock-face-list '(font-lock-comment-face 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)) @@ -686,6 +777,15 @@ on the major mode's symbol." "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. @@ -718,6 +818,17 @@ on the major mode's symbol." "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")) @@ -728,8 +839,6 @@ on the major mode's symbol." "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")) @@ -737,7 +846,6 @@ on the major mode's symbol." "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)) @@ -783,6 +891,188 @@ on the major mode's symbol." (setq font-lock-maximum-decoration t) (font-lock-recompute-variables))) +(defun font-lock-add-keywords (mode keywords &optional how) + "Add highlighting KEYWORDS for MODE. + +MODE should be a symbol, the major mode command name, such as `c-mode' +or nil. If nil, highlighting keywords are added for the current buffer. +KEYWORDS should be a list; see the variable `font-lock-keywords'. +By default they are added at the beginning of the current highlighting list. +If optional argument HOW is `set', they are used to replace the current +highlighting list. If HOW is any other non-nil value, they are added at the +end of the current highlighting list. + +For example: + + (font-lock-add-keywords 'c-mode + '((\"\\\\\\=<\\\\(FIXME\\\\):\" 1 font-lock-warning-face prepend) + (\"\\\\\\=<\\\\(and\\\\|or\\\\|not\\\\)\\\\\\=>\" . font-lock-keyword-face))) + +adds two fontification patterns for C mode, to fontify `FIXME:' words, even in +comments, and to fontify `and', `or' and `not' words as keywords. + +The above procedure will only add the keywords for C mode, not +for modes derived from C mode. To add them for derived modes too, +pass nil for MODE and add the call to c-mode-hook. + +For example: + + (add-hook 'c-mode-hook + (lambda () + (font-lock-add-keywords nil + '((\"\\\\\\=<\\\\(FIXME\\\\):\" 1 font-lock-warning-face prepend) + (\"\\\\\\=<\\\\(and\\\\|or\\\\|not\\\\)\\\\\\=>\" . + font-lock-keyword-face))))) + +The above procedure may fail to add keywords to derived modes if +some involved major mode does not follow the standard conventions. +File a bug report if this happens, so the major mode can be corrected. + +Note that some modes have specialized support for additional patterns, e.g., +see the variables `c-font-lock-extra-types', `c++-font-lock-extra-types', +`objc-font-lock-extra-types' and `java-font-lock-extra-types'." + (cond (mode + ;; If MODE is non-nil, add the KEYWORDS and HOW spec to + ;; `font-lock-keywords-alist' so `font-lock-set-defaults' uses them. + (let ((spec (cons keywords how)) cell) + (if (setq cell (assq mode font-lock-keywords-alist)) + (if (eq how 'set) + (setcdr cell (list spec)) + (setcdr cell (append (cdr cell) (list spec)))) + (push (list mode spec) font-lock-keywords-alist))) + ;; Make sure that `font-lock-removed-keywords-alist' does not + ;; contain the new keywords. + (font-lock-update-removed-keyword-alist mode keywords how)) + (t + ;; Otherwise set or add the keywords now. + ;; This is a no-op if it has been done already in this buffer + ;; for the correct major mode. + (font-lock-set-defaults) + (let ((was-compiled (eq (car font-lock-keywords) t))) + ;; Bring back the user-level (uncompiled) keywords. + (if was-compiled + (setq font-lock-keywords (cadr font-lock-keywords))) + ;; Now modify or replace them. + (if (eq how 'set) + (setq font-lock-keywords keywords) + (font-lock-remove-keywords nil keywords) ;to avoid duplicates + (let ((old (if (eq (car-safe font-lock-keywords) t) + (cdr font-lock-keywords) + font-lock-keywords))) + (setq font-lock-keywords (if how + (append old keywords) + (append keywords old))))) + ;; If the keywords were compiled before, compile them again. + (if was-compiled + (setq font-lock-keywords + (font-lock-compile-keywords font-lock-keywords))))))) + +(defun font-lock-update-removed-keyword-alist (mode keywords how) + "Update `font-lock-removed-keywords-alist' when adding new KEYWORDS to MODE." + ;; When font-lock is enabled first all keywords in the list + ;; `font-lock-keywords-alist' are added, then all keywords in the + ;; list `font-lock-removed-keywords-alist' are removed. If a + ;; keyword was once added, removed, and then added again it must be + ;; removed from the removed-keywords list. Otherwise the second add + ;; will not take effect. + (let ((cell (assq mode font-lock-removed-keywords-alist))) + (if cell + (if (eq how 'set) + ;; A new set of keywords is defined. Forget all about + ;; our old keywords that should be removed. + (setq font-lock-removed-keywords-alist + (delq cell font-lock-removed-keywords-alist)) + ;; Delete all previously removed keywords. + (dolist (kword keywords) + (setcdr cell (delete kword (cdr cell)))) + ;; Delete the mode cell if empty. + (if (null (cdr cell)) + (setq font-lock-removed-keywords-alist + (delq cell font-lock-removed-keywords-alist))))))) + +;; Written by Anders Lindgren . +;; +;; Case study: +;; (I) The keywords are removed from a major mode. +;; In this case the keyword could be local (i.e. added earlier by +;; `font-lock-add-keywords'), global, or both. +;; +;; (a) In the local case we remove the keywords from the variable +;; `font-lock-keywords-alist'. +;; +;; (b) The actual global keywords are not known at this time. +;; All keywords are added to `font-lock-removed-keywords-alist', +;; when font-lock is enabled those keywords are removed. +;; +;; Note that added keywords are taken out of the list of removed +;; keywords. This ensure correct operation when the same keyword +;; is added and removed several times. +;; +;; (II) The keywords are removed from the current buffer. +(defun font-lock-remove-keywords (mode keywords) + "Remove highlighting KEYWORDS for MODE. + +MODE should be a symbol, the major mode command name, such as `c-mode' +or nil. If nil, highlighting keywords are removed for the current buffer. + +To make the removal apply to modes derived from MODE as well, +pass nil for MODE and add the call to MODE-hook. This may fail +for some derived modes if some involved major mode does not +follow the standard conventions. File a bug report if this +happens, so the major mode can be corrected." + (cond (mode + ;; Remove one keyword at the time. + (dolist (keyword keywords) + (let ((top-cell (assq mode font-lock-keywords-alist))) + ;; If MODE is non-nil, remove the KEYWORD from + ;; `font-lock-keywords-alist'. + (when top-cell + (dolist (keyword-list-how-pair (cdr top-cell)) + ;; `keywords-list-how-pair' is a cons with a list of + ;; keywords in the car top-cell and the original how + ;; argument in the cdr top-cell. + (setcar keyword-list-how-pair + (delete keyword (car keyword-list-how-pair)))) + ;; Remove keyword list/how pair when the keyword list + ;; is empty and how doesn't specify `set'. (If it + ;; should be deleted then previously deleted keywords + ;; would appear again.) + (let ((cell top-cell)) + (while (cdr cell) + (if (and (null (car (car (cdr cell)))) + (not (eq (cdr (car (cdr cell))) 'set))) + (setcdr cell (cdr (cdr cell))) + (setq cell (cdr cell))))) + ;; Final cleanup, remove major mode cell if last keyword + ;; was deleted. + (if (null (cdr top-cell)) + (setq font-lock-keywords-alist + (delq top-cell font-lock-keywords-alist)))) + ;; Remember the keyword in case it is not local. + (let ((cell (assq mode font-lock-removed-keywords-alist))) + (if cell + (unless (member keyword (cdr cell)) + (nconc cell (list keyword))) + (push (cons mode (list keyword)) + font-lock-removed-keywords-alist)))))) + (t + ;; Otherwise remove it immediately. + (font-lock-set-defaults) + (let ((was-compiled (eq (car font-lock-keywords) t))) + ;; Bring back the user-level (uncompiled) keywords. + (if was-compiled + (setq font-lock-keywords (cadr font-lock-keywords))) + + ;; Edit them. + (setq font-lock-keywords (copy-sequence font-lock-keywords)) + (dolist (keyword keywords) + (setq font-lock-keywords + (delete keyword font-lock-keywords))) + + ;; If the keywords were compiled before, compile them again. + (if was-compiled + (setq font-lock-keywords + (font-lock-compile-keywords font-lock-keywords))))))) ;;;;;;;;;;;;;;;;;;;;;; actual code ;;;;;;;;;;;;;;;;;;;;;; @@ -859,15 +1149,12 @@ See the variable `font-lock-keywords' for customization." 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) @@ -944,7 +1231,14 @@ See the variable `font-lock-keywords' for customization." (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 @@ -1084,8 +1378,10 @@ This can take a while for large buffers." ;; 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. @@ -1132,12 +1428,14 @@ Otherwise, changes to existing text will not be processed until the 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)))) @@ -1149,12 +1447,20 @@ buffer modifications are performed or a buffer is reverted.") (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)))) @@ -1164,176 +1470,58 @@ buffer modifications are performed or a buffer is reverted.") ;; 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))) ;; 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 @@ -1344,52 +1532,83 @@ buffer modifications are performed or a buffer is reverted.") ;; 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)) (progress-feedback-with-label 'font-lock "Fontifying %s... (syntactically)" 5 (buffer-name))) - (font-lock-unfontify-region start end loudly) (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)))))) ;;; Additional text property functions. @@ -1473,6 +1692,100 @@ Optional argument OBJECT is the string or buffer containing the text." object) (setq start next)))) +;;; 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))))) + ;;; Regexp fontification functions. (defsubst font-lock-apply-highlight (highlight) @@ -1536,10 +1849,11 @@ LIMIT can be modified by the value of its PRE-MATCH-FORM." 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) @@ -1613,14 +1927,12 @@ START should be at the beginning of a line." ;; 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 @@ -1636,6 +1948,14 @@ START should be at the beginning of a line." (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)). @@ -1713,7 +2033,7 @@ START should be at the beginning of a line." (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) @@ -1779,6 +2099,7 @@ START should be at the beginning of a line." (setq font-lock-beginning-of-syntax-function 'beginning-of-defun))))) + (setq font-lock-cache-position (make-marker)) (setq font-lock-defaults-computed t))) @@ -1874,7 +2195,7 @@ START should be at the beginning of a line." "\\)\\)\\>" ;; Any whitespace and declared object. "[ \t'\(]*" - "\\([^ \t\n\)]+\\)?") + "\\([^ \t\n\(\)]+\\)?") '(1 font-lock-keyword-face) '(8 (cond ((match-beginning 3) 'font-lock-variable-name-face) ((match-beginning 6) 'font-lock-type-face) @@ -2395,9 +2716,10 @@ The name is assumed to begin with a capital letter.") (list (concat "\\<\\(" + "assert\\|" "break\\|byvalue\\|" "case\\|cast\\|catch\\|class\\|continue\\|" - "do\\|else\\|extends\\|" + "do\\|else\\|enum\\|extends\\|" "finally\\|for\\|future\\|" "generic\\|goto\\|" "if\\|implements\\|import\\|" @@ -2583,10 +2905,10 @@ The name is assumed to begin with a capital letter.") '("\\(@beaninfo\\)" 0 font-lock-keyword-face t) ;; Doc tag - Links - '("{ *@link\\s +\\([^}]+\\)}" + '("{ *@link\\(?:plain\\)?\\s +\\([^}]+\\)}" 0 font-lock-keyword-face t) ;; Doc tag - Links - '("{ *@link\\s +\\(\\(\\S +\\)\\|\\(\\S +\\s +\\S +\\)\\) *}" + '("{ *@link\\(?:plain\\)?\\s +\\(\\(\\S +\\)\\|\\(\\S +\\s +\\S +\\)\\) *}" 1 font-lock-function-name-face t) ))) @@ -2602,32 +2924,34 @@ The name is assumed to begin with a capital letter.") ;; the cursor to fontify more identifiers. (defun font-lock-match-java-declarations (limit) "Match and skip over variable definitions." - (if (looking-at "\\s *\\(\\[\\s *\\]\\s *\\)*") - (goto-char (match-end 0))) - (and - (looking-at java-font-lock-identifier-regexp) - (save-match-data - (not (string-match java-font-lock-type-regexp - (buffer-substring (match-beginning 1) - (match-end 1))))) - (save-match-data - (save-excursion - (goto-char (match-beginning 1)) - (not (looking-at - (concat java-font-lock-class-name-regexp - "\\s *\\(\\[\\s *\\]\\s *\\)*\\<"))))) - (save-match-data - (condition-case nil - (save-restriction - (narrow-to-region (point-min) limit) - (goto-char (match-end 0)) - ;; Note: Both `scan-sexps' and the second goto-char can - ;; generate an error which is caught by the - ;; `condition-case' expression. - (while (not (looking-at "\\s *\\(\\(,\\)\\|;\\|$\\)")) - (goto-char (or (scan-sexps (point) 1) (point-max)))) - (goto-char (match-end 2))) ; non-nil - (error t))))) + (save-restriction + (narrow-to-region (point-min) limit) + + (if (looking-at "\\s *\\(\\[\\s *\\]\\s *\\)*") + (goto-char (match-end 0))) + (and + (looking-at java-font-lock-identifier-regexp) + (save-match-data + (not (string-match java-font-lock-type-regexp + (buffer-substring (match-beginning 1) + (match-end 1))))) + (save-match-data + (save-excursion + (goto-char (match-beginning 1)) + (not (looking-at + (concat java-font-lock-class-name-regexp + "\\s *\\(\\[\\s *\\]\\s *\\)*\\<"))))) + (save-match-data + (condition-case nil + (progn + (goto-char (match-end 0)) + ;; Note: Both `scan-sexps' and the second goto-char can + ;; generate an error which is caught by the + ;; `condition-case' expression. + (while (not (looking-at "\\s *\\(\\(,\\)\\|;\\|$\\)")) + (goto-char (or (scan-sexps (point) 1) (point-max)))) + (goto-char (match-end 2))) ; non-nil + (error t)))))) (defvar tex-font-lock-keywords