xemacs-beta: lisp/font-lock.el comparison

comparison lisp/font-lock.el @ 412:697ef44129c6 r21-2-14

Import from CVS: tag r21-2-14

author	cvs
date	Mon, 13 Aug 2007 11:20:41 +0200
parents	de805c49cfc1
children	11054d720c21

comparison

equal deleted inserted replaced

-:12e008d41344
+:697ef44129c6
 ;; Copyright (C) 1992-1995, 1997 Free Software Foundation, Inc.
 ;; Copyright (C) 1995 Amdahl Corporation.
 ;; Copyright (C) 1996 Ben Wing.
-;; Author: Jamie Zawinski <jwz@jwz.org>, for the LISPM Preservation Society.
+;; Author: Jamie Zawinski <jwz@netscape.com>, for the LISPM Preservation Society.
 ;; Minimally merged with FSF 19.34 by Barry Warsaw <bwarsaw@python.org>
 ;; Then (partially) synched with FSF 19.30, leading to:
 ;; Next Author: RMS
 ;; Next Author: Simon Marshall <simon@gnu.ai.mit.edu>
 ;; Latest XEmacs Author: Ben Wing
 The size is measured in characters.  This affects `font-lock-fontify-region'
 but not `font-lock-fontify-buffer'. (In other words, when you first visit
 a file and it gets fontified, you will see status messages no matter what
 size the file is.  However, if you do something else like paste a
-chunk of text, you will see status messages only if the changed region is
+chunk of text or revert a buffer, you will see status messages only if the
-large enough.)
+changed region is large enough.)
 Note that setting `font-lock-verbose' to nil disables the status
 messages entirely."
 :type 'integer
 :group 'font-lock)
 ;; Fontification variables:
 ;;;###autoload
 (defvar font-lock-keywords nil
-"A list defining the keywords for `font-lock-mode' to highlight.
+"A list of the keywords to highlight.
+Each element should be of the form:
-FONT-LOCK-KEYWORDS := List of FONT-LOCK-FORM's.
+MATCHER
-FONT-LOCK-FORM     :== MATCHER
+(MATCHER . MATCH)
-| (MATCHER . MATCH)
+(MATCHER . FACENAME)
-| (MATCHER . FACE-FORM)
+(MATCHER . HIGHLIGHT)
-| (MATCHER . HIGHLIGHT)
+(MATCHER HIGHLIGHT ...)
-| (MATCHER HIGHLIGHT ...)
+(eval . FORM)
-| (eval . FORM)
+where HIGHLIGHT should be either MATCH-HIGHLIGHT or MATCH-ANCHORED.
-MATCHER            :== A string containing a regexp.
-| A variable containing a regexp to search for.
+FORM is an expression, whose value should be a keyword element,
-| A function to call to make the search.
+evaluated when the keyword is (first) used in a buffer.  This feature
-It is called with one arg, the limit of the search,
+can be used to provide a keyword that can only be generated when Font
-and should leave MATCH results in the XEmacs global
+Lock mode is actually turned on.
-match data.
-MATCH              :== An integer match subexpression number from MATCHER.
-FACE-FORM           :== The symbol naming a defined face.
-| Expression whos value is the face name to use.  If you
-want FACE-FORM to be a symbol that evaluates to a face,
-use a form like \"(progn sym)\".
-HIGHLIGHT          :== MATCH-HIGHLIGHT
-| MATCH-ANCHORED
-FORM               :== Expression returning a FONT-LOCK-FORM, evaluated when
-the FONT-LOCK-FORM is first used in a buffer.  This
-feature can be used to provide a FONT-LOCK-FORM that
-can only be generated when Font Lock mode is actually
-turned on.
-MATCH-HIGHLIGHT    :== (MATCH FACE-FORM OVERRIDE LAXMATCH)
-OVERRIDE           :== t        - overwrite existing fontification
-| 'keep    - only parts not already fontified are
-highlighted.
-| 'prepend - merge faces, this fontification has
-precedence over existing
-| 'append  - merge faces, existing fontification has
-precedence over
-this face.
-LAXMATCH           :== If non-nil, no error is signalled if there is no MATCH
-in MATCHER.
-MATCH-ANCHORED     :== (ANCHOR-MATCHER PRE-MATCH-FORM \\
-POST-MATCH-FORM MATCH-HIGHLIGHT ...)
-ANCHOR-MATCHER     :== Like a MATCHER, except that the limit of the search
-defaults to the end of the line after PRE-MATCH-FORM
-is evaluated.  However, if PRE-MATCH-FORM returns a
-position greater than the end of the line, that
-position is used as the limit of the search.  It is
-generally a bad idea to return a position greater than
-the end of the line, i.e., cause the ANCHOR-MATCHER
-search to span lines.
-PRE-MATCH-FORM     :== Evaluated before the ANCHOR-MATCHER is used, therefore
-can be used to initialize before, ANCHOR-MATCHER is
-used.  Typically, PRE-MATCH-FORM is used to move to
-some position relative to the original MATCHER, before
-starting with the ANCHOR-MATCHER.
-POST-MATCH-FORM    :== Like PRE-MATCH-FORM, but used to clean up after the
-ANCHOR-MATCHER.  It might be used to move, before
-resuming with MATCH-ANCHORED's parent's MATCHER.
-For example, an element of the first form highlights (if not already highlighted):
-\"\\\\<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\" in the value of
-`font-lock-keyword-face'.
-(\"fubar\" . fubar-face)         Occurrences of \"fubar\" in the value of
-`fubar-face'.
-(\"foo\\\\|bar\" 0 foo-bar-face t) Occurrences of either \"foo\" or \"bar\" in the
-value of `foo-bar-face', even if already
-highlighted.
-(fubar-match 1 fubar-face)     The first subexpression within all
-occurrences of whatever the function
-`fubar-match' finds and matches in the value
-of `fubar-face'.
-(\"\\\\<anchor\\\\>\" (0 anchor-face) (\"\\\\<item\\\\>\" nil nil (0 item-face)))
--------------- ---------------  ------------ --- --- -------------
-|            |               |            |   |          |
-MATCHER          |         ANCHOR-MATCHER     |   +------+ MATCH-HIGHLIGHT
-MATCH-HIGHLIGHT                 PRE-MATCH-FORM |
-POST-MATCH-FORM
-Discrete occurrences of \"anchor\" in the value of `anchor-face', and
-subsequent discrete occurrences of \"item\" (on the same line) in the value
-of `item-face'.  (Here PRE-MATCH-FORM and POST-MATCH-FORM are nil.
-Therefore \"item\" is initially searched for starting from the end of the
-match of \"anchor\", and searching for subsequent instance of \"anchor\"
-resumes from where searching for \"item\" concluded.)
 For highlighting single items, typically only MATCH-HIGHLIGHT is required.
-However, if an item or (typically) several items are to be highlighted
+However, if an item or (typically) items is to be highlighted following the
-following the instance of another item (the anchor) then MATCH-ANCHORED may be
+instance of another item (the anchor) then MATCH-ANCHORED may be required.
-required.
+MATCH-HIGHLIGHT should be of the form:
+(MATCH FACENAME OVERRIDE LAXMATCH)
+Where MATCHER can be either the regexp to search for, a variable
+containing the regexp to search for, or the function to call to make
+the search (called with one argument, the limit of the search).  MATCH
+is the subexpression of MATCHER to be highlighted.  FACENAME is either
+a symbol naming a face, or an expression whose value is the face name
+to use.  If you want FACENAME to be a symbol that evaluates to a face,
+use a form like \"(progn sym)\".
+OVERRIDE and LAXMATCH are flags.  If OVERRIDE is t, existing fontification may
+be overwritten.  If `keep', only parts not already fontified are highlighted.
+If `prepend' or `append', existing fontification is merged with the new, in
+which the new or existing fontification, respectively, takes precedence.
+If LAXMATCH is non-nil, no error is signalled if there is no MATCH in MATCHER.
+For example, an element of the form highlights (if not already highlighted):
+\"\\\\\\=<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\" in
+			the value of `font-lock-keyword-face'.
+(\"fubar\" . fubar-face)	Occurrences of \"fubar\" in the value of `fubar-face'.
+(\"foo\\\\|bar\" 0 foo-bar-face t)
+			Occurrences of either \"foo\" or \"bar\" in the value
+			of `foo-bar-face', even if already highlighted.
+MATCH-ANCHORED should be of the form:
+(MATCHER PRE-MATCH-FORM POST-MATCH-FORM MATCH-HIGHLIGHT ...)
+Where MATCHER is as for MATCH-HIGHLIGHT with one exception; see below.
+PRE-MATCH-FORM and POST-MATCH-FORM are evaluated before the first, and after
+the last, instance MATCH-ANCHORED's MATCHER is used.  Therefore they can be
+used to initialize before, and cleanup after, MATCHER is used.  Typically,
+PRE-MATCH-FORM is used to move to some position relative to the original
+MATCHER, before starting with MATCH-ANCHORED's MATCHER.  POST-MATCH-FORM might
+be used to move, before resuming with MATCH-ANCHORED's parent's MATCHER.
+For example, an element of the form highlights (if not already highlighted):
+(\"\\\\\\=<anchor\\\\\\=>\" (0 anchor-face) (\"\\\\\\=<item\\\\\\=>\" nil nil (0 item-face)))
+Discrete occurrences of \"anchor\" in the value of `anchor-face', and subsequent
+discrete occurrences of \"item\" (on the same line) in the value of `item-face'.
+(Here PRE-MATCH-FORM and POST-MATCH-FORM are nil.  Therefore \"item\" is
+initially searched for starting from the end of the match of \"anchor\", and
+searching for subsequent instance of \"anchor\" resumes from where searching
+for \"item\" concluded.)
+The above-mentioned exception is as follows.  The limit of the MATCHER search
+defaults to the end of the line after PRE-MATCH-FORM is evaluated.
+However, if PRE-MATCH-FORM returns a position greater than the position after
+PRE-MATCH-FORM is evaluated, that position is used as the limit of the search.
+It is generally a bad idea to return a position greater than the end of the
+line, i.e., cause the MATCHER search to span lines.
+Note that the MATCH-ANCHORED feature is experimental; in the future, we may
+replace it with other ways of providing this functionality.
 These regular expressions should not match text which spans lines.  While
-\\[font-lock-fontify-buffer] handles multi-line patterns correctly, updating when you
+\\[font-lock-fontify-buffer] handles multi-line patterns correctly, updating
-edit the buffer does not, since it considers text one line at a time.
+when you 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
+Be very careful composing regexps for this list;
-dramatically slow things down!
+the wrong pattern can dramatically slow things down!")
-")
 ;;;###autoload
 (make-variable-buffer-local 'font-lock-keywords)
 (defvar font-lock-defaults nil
 "The defaults font Font Lock mode for the current buffer.
 ;;; Initialization of faces.
 ;; #### 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
+;; forget to properly quote their faces.
-;; them when we eval the face expression, but that failes 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
-"This variable should not be set.
+"Don't even think of using this.")
-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-doc-string-face 'font-lock-doc-string-face
-"This variable should not be set.
+"Don't even think of using this.")
-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-string-face 'font-lock-string-face
-"This variable should not be set.
+"Don't even think of using this.")
-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-keyword-face 'font-lock-keyword-face
-"This variable should not be set.
+"Don't even think of using this.")
-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.
+"Don't even think of using this.")
-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-variable-name-face 'font-lock-variable-name-face
-"This variable should not be set.
+"Don't even think of using this.")
-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-type-face 'font-lock-type-face
-"This variable should not be set.
+"Don't even think of using this.")
-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.
+"Don't even think of using this.")
-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-preprocessor-face 'font-lock-preprocessor-face
-"This variable should not be set.
+"Don't even think of using this.")
-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-type-face
 font-lock-reference-face
 font-lock-preprocessor-face
 font-lock-warning-face))
+;; #### There should be an emulation for the old font-lock-use-*
+;; settings!
 (defface font-lock-comment-face
 '((((class color) (background dark)) (:foreground "gray80"))
-;; blue4 is hardly different from black on windows.
-(((class color) (background light) (type mswindows)) (:foreground "blue"))
 (((class color) (background light)) (:foreground "blue4"))
 (((class grayscale) (background light))
 (:foreground "DimGray" :bold t :italic t))
 (((class grayscale) (background dark))
 (:foreground "LightGray" :bold t :italic t))
 (defface font-lock-doc-string-face
 '((((class color) (background dark)) (:foreground "light coral"))
 (((class color) (background light)) (:foreground "green4"))
 (t (:bold t)))
-"Font Lock mode face used to highlight documentation strings.
+"Font Lock mode face used to highlight documentation strings."
-This is currently supported only in Lisp-like modes, which are those
-with \"lisp\" or \"scheme\" in their name.  You can explicitly make
-a mode Lisp-like by putting a non-nil `font-lock-lisp-like' property
-on the major mode's symbol."
 :group 'font-lock-faces)
 (defface font-lock-keyword-face
 '((((class color) (background dark)) (:foreground "cyan"))
-;; red4 is hardly different from black on windows.
-(((class color) (background light) (type mswindows)) (:foreground "red"))
 (((class color) (background light)) (:foreground "red4"))
 (((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 keywords."
 :group 'font-lock-faces)
 (defface font-lock-function-name-face
 '((((class color) (background dark)) (:foreground "aquamarine"))
-;; brown4 is hardly different from black on windows.
-;; I changed it to red because IMO it's pointless and ugly to
-;; use a million slightly different colors for niggly syntactic
-;; differences. --ben
-(((class color) (background light) (type mswindows)) (:foreground "red"))
 (((class color) (background light)) (:foreground "brown4"))
 (t (:bold t :underline t)))
 "Font Lock mode face used to highlight function names."
 :group 'font-lock-faces)
 	   ;; (remove-hook 'pre-idle-hook 'font-lock-pre-idle-hook)
 	   ))
 (set (make-local-variable 'font-lock-mode) on-p)
 (cond (on-p
 	   (font-lock-set-defaults-1)
+	   (make-local-hook 'before-revert-hook)
+	   (make-local-hook 'after-revert-hook)
+	   ;; If buffer is reverted, must clean up the state.
+	   (add-hook 'before-revert-hook 'font-lock-revert-setup nil t)
+	   (add-hook 'after-revert-hook 'font-lock-revert-cleanup nil t)
 	   (run-hooks 'font-lock-mode-hook)
 	   (cond (font-lock-fontified
 		  nil)
 		 ((or (null maximum-size) (<= (buffer-size) maximum-size))
 		  (font-lock-fontify-buffer))
 		 (font-lock-verbose
-		  (lprogress-display 'font-lock
+		  (lmessage 'command "Fontifying %s... buffer too big."
-			     "Fontifying %s... buffer too big." 'abort
+		    (buffer-name)))))
-			     (buffer-name)))))
 	  (font-lock-fontified
 	   (setq font-lock-fontified nil)
+	   (remove-hook 'before-revert-hook 'font-lock-revert-setup t)
+	   (remove-hook 'after-revert-hook 'font-lock-revert-cleanup t)
 	   (font-lock-unfontify-region (point-min) (point-max))
 	   (font-lock-thing-lock-cleanup))
 	  (t
+	   (remove-hook 'before-revert-hook 'font-lock-revert-setup t)
+	   (remove-hook 'after-revert-hook 'font-lock-revert-cleanup t)
 	   (font-lock-thing-lock-cleanup)))
 (redraw-modeline)))
 ;; For init-file hooks
 ;;;###autoload
 (funcall font-lock-fontify-region-function beg end loudly))
 (defun font-lock-unfontify-region (beg end &optional loudly)
 (funcall font-lock-unfontify-region-function beg end loudly))
+;; #### In these functions, the FSF is careful to do
+;; (save-restriction
+;;   (widen)
+;; before anything else.  Should we copy?
 (defun font-lock-default-fontify-buffer ()
 (interactive)
-;; if we don't widen, then the C code will fail to
+(let ((was-on font-lock-mode)
-;; realize that we're inside a comment.
+	(font-lock-verbose (or font-lock-verbose (interactive-p)))
-(save-restriction
+	(font-lock-message-threshold 0)
-(widen)
+	(aborted nil))
-(let ((was-on font-lock-mode)
+;; Turn it on to run hooks and get the right font-lock-keywords.
-	  (font-lock-verbose (or font-lock-verbose (interactive-p)))
+(or was-on (font-lock-mode 1))
-	  (font-lock-message-threshold 0)
+(font-lock-unfontify-region (point-min) (point-max) t)
-	  (aborted nil))
+;;    (buffer-syntactic-context-flush-cache)
-;; Turn it on to run hooks and get the right font-lock-keywords.
-(or was-on (font-lock-mode 1))
-(font-lock-unfontify-region (point-min) (point-max) t)
-;;    (buffer-syntactic-context-flush-cache)
 ;; If a ^G is typed during fontification, abort the fontification, but
 ;; return normally (do not signal.)  This is to make it easy to abort
 ;; fontification if it's taking a long time, without also causing the
 ;; buffer not to pop up.  If a real abort is desired, the user can ^G
 ;; again.
 ;;
 ;; Possibly this should happen down in font-lock-fontify-region instead
 ;; of here, but since that happens from the after-change-hook (meaning
 ;; much more frequently) I'm afraid of the bad consequences of stealing
 ;; the interrupt character at inopportune times.
 ;;
 (condition-case nil
-	  (save-excursion
+	(save-excursion
-	    (font-lock-fontify-region (point-min) (point-max)))
+	  (font-lock-fontify-region (point-min) (point-max)))
-	(t
+(quit
-	 (setq aborted t)))
+(setq aborted t)))
-(or was-on			; turn it off if it was off.
+(or was-on		; turn it off if it was off.
-	  (let ((font-lock-fontified nil)) ; kludge to prevent defontification
+	(let ((font-lock-fontified nil)) ; kludge to prevent defontification
-	    (font-lock-mode 0)))
+	  (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."
+	(lmessage 'command  "Fontifying %s... aborted." (buffer-name))))
-			   'abort (buffer-name))))
+(run-hooks 'font-lock-after-fontify-buffer-hook))
-(run-hooks 'font-lock-after-fontify-buffer-hook)))
 (defun font-lock-default-unfontify-buffer ()
 (font-lock-unfontify-region (point-min) (point-max))
 (set (make-local-variable 'font-lock-fontified) nil))
 ;	  (font-lock-fontify-keywords-region beg end))
 (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)))
+(lmessage 'progress "Fontifying %s..." (buffer-name)))
 (let ((modified (buffer-modified-p))
 	(buffer-undo-list t) (inhibit-read-only t)
 	buffer-file-name buffer-file-truename)
 (font-lock-remove-face beg end)
 (and (not modified) (buffer-modified-p) (set-buffer-modified-p nil))))
 ;; Following is the original FSF version (similar to our original
-;; version, before the deferred stuff was added).
+;; version, before all the crap I added below).
+;;
+;; Probably that crap should either be fixed up so it works better,
+;; or tossed away.
 ;;
 ;; I think that lazy-lock v2 tries to do something similar.
 ;; Those efforts should be merged.
 ;; Called when any modification is made to buffer text.
 ;      ;; Rescan between start of line from `beg' and start of line after `end'.
 ;      (font-lock-fontify-region
 ;	(progn (goto-char beg) (beginning-of-line) (point))
 ;	(progn (goto-char end) (forward-line 1) (point))))))
+(defvar font-lock-old-extent nil)
+(defvar font-lock-old-len 0)
+(defun font-lock-fontify-glumped-region ()
+;; even if something goes wrong in the fontification, mark the glumped
+;; region as fontified; otherwise, the same error might get signaled
+;; after every command.
+(unwind-protect
+;; buffer/extent may be deleted.
+(if (and (extent-live-p font-lock-old-extent)
+	       (buffer-live-p (extent-object font-lock-old-extent)))
+	  (save-excursion
+	    (set-buffer (extent-object font-lock-old-extent))
+	    (font-lock-after-change-function-1
+	     (extent-start-position font-lock-old-extent)
+	     (extent-end-position font-lock-old-extent)
+	     font-lock-old-len)))
+(detach-extent font-lock-old-extent)
+(setq font-lock-old-extent nil)))
+(defun font-lock-pre-idle-hook ()
+(condition-case nil
+(if font-lock-old-extent
+	  (font-lock-fontify-glumped-region))
+(error (warn "Error caught in `font-lock-pre-idle-hook'"))))
 (defvar font-lock-always-fontify-immediately nil
-"Set this to non-nil to disable font-lock deferral.
+"Set this to non-nil to disable font-lock deferral.")
-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))
-(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)
-	  (font-lock-fontify-pending-extents))
-(error (warn "Error caught in `font-lock-pre-idle-hook': %s"
-		 font-lock-error))))
 ;;; called when any modification is made to buffer text.  This function
-;;; remembers the changed ranges until the next redisplay, at which point
+;;; attempts to glump adjacent changes together so that excessive
-;;; the extents are merged and pruned, and the resulting ranges fontified.
+;;; fontification is avoided.  This function could easily be adapted
-;;; This function could easily be adapted to other after-change-functions.
+;;; to other after-change-functions.
 (defun font-lock-after-change-function (beg end old-len)
-(when font-lock-mode
+(let ((obeg (and font-lock-old-extent
-(let ((ex (make-extent beg end)))
+		   (extent-start-position font-lock-old-extent)))
-(set-extent-property ex 'detachable nil)
+	(oend (and font-lock-old-extent
-(set-extent-property ex 'end-open nil)
+		   (extent-end-position font-lock-old-extent)))
-(let ((exs (gethash (current-buffer) font-lock-pending-extent-table)))
+	(bc-end (+ beg old-len)))
-	(push ex exs)
-	(puthash (current-buffer) exs font-lock-pending-extent-table)))
+;; If this change can't be merged into the glumped one,
+;; we need to fontify the glumped one right now.
+(if (and font-lock-old-extent
+	     (or (not (eq (current-buffer)
+			  (extent-object font-lock-old-extent)))
+		 (< bc-end obeg)
+		 (> beg oend)))
+	(font-lock-fontify-glumped-region))
+(if font-lock-old-extent
+	;; Update glumped region.
+	(progn
+	  ;; Any characters in the before-change region that are
+	  ;; outside the glumped region go into the glumped
+	  ;; before-change region.
+	  (if (> bc-end oend)
+	      (setq font-lock-old-len (+ font-lock-old-len (- bc-end oend))))
+	  (if (> obeg beg)
+	      (setq font-lock-old-len (+ font-lock-old-len (- obeg beg))))
+	  ;; New glumped region is the union of the glumped region
+	  ;; and the new region.
+	  (set-extent-endpoints font-lock-old-extent
+				(min obeg beg)
+				(max oend end)))
+;; No glumped region, so create one.
+(setq font-lock-old-extent (make-extent beg end))
+(set-extent-property font-lock-old-extent 'detachable nil)
+(set-extent-property font-lock-old-extent 'end-open nil)
+(setq font-lock-old-len old-len))
 (if font-lock-always-fontify-immediately
-	(font-lock-fontify-pending-extents))))
+	(font-lock-fontify-glumped-region))))
-(defun font-lock-fontify-pending-extents ()
+(defun font-lock-after-change-function-1 (beg end old-len)
-;; ah, the beauty of mapping functions.
+(if (null font-lock-mode)
-;; this function is actually shorter than the old version, which handled
+nil
-;; only one buffer and one contiguous region!
+(save-excursion
-(save-match-data
+(save-restriction
-(maphash
+	;; if we don't widen, then fill-paragraph (and any command that
-#'(lambda (buffer exs)
+	;; operates on a narrowed region) confuses things, because the C
-	 ;; remove first, to avoid infinite reprocessing if error
+	;; code will fail to realize that we're inside a comment.
-	 (remhash buffer font-lock-pending-extent-table)
+	(widen)
-	 (when (buffer-live-p buffer)
+	(save-match-data
-	   (clear-range-table font-lock-range-table)
+	  (let ((zmacs-region-stays zmacs-region-stays)) ; protect from change!
-	   (with-current-buffer buffer
+	    (goto-char beg)
-	     (save-excursion
+	    ;; Maybe flush the internal cache used by syntactically-sectionize.
-	       (save-restriction
+	    ;; (It'd be nice if this was more automatic.)  Any deletions mean
-		 ;; if we don't widen, then the C code will fail to
+	    ;; the cache is invalid, and insertions at beginning or end of line
-		 ;; realize that we're inside a comment.
+	    ;; mean that the bol cache might be invalid.
-		 (widen)
+;;	    (if (or (> old-len 0) (bobp) (= (preceding-char) ?\n))
-		 (let ((zmacs-region-stays
+;;		(buffer-syntactic-context-flush-cache))
-			zmacs-region-stays)) ; protect from change!
-		   (mapc
+	    ;; Always recompute the whole line.
-		    #'(lambda (ex)
+	    (goto-char end)
-			;; paranoia.
+	    (forward-line 1)
-			(when (and (extent-live-p ex)
+	    (setq end (point))
-				   (not (extent-detached-p ex)))
+	    (goto-char beg)
-			  ;; first expand the ranges to full lines, because
+	    (beginning-of-line)
-			  ;; that is what will be fontified; then use a
+	    (setq beg (point))
-			  ;; range table to merge the ranges.
+	    ;; Rescan between start of line from `beg' and start of line after
-			  (let* ((beg (extent-start-position ex))
+	    ;; `end'.
-				 (end (extent-end-position ex))
+	    (font-lock-fontify-region beg end)))))))
-				 (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-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.
-;;			(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)))
 ;; 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,
 ;	 (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
-;; value.
-(if (plist-member (symbol-plist mode) 'font-lock-lisp-like)
-(get mode 'font-lock-lisp-like)
-;; If the property is not specified, guess.  Similar logic exists
-;; in add-log, but I think this encompasses more modes.
-(string-match "lisp\\|scheme" (symbol-name mode))))
 (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."
 (if font-lock-keywords-only
 nil
 (when (and font-lock-verbose
 	       (>= (- end start) font-lock-message-threshold))
-(lprogress-display 'font-lock "Fontifying %s... (syntactically)" 5
+(lmessage 'progress "Fontifying %s... (syntactically...)"
-		 (buffer-name)))
+	(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
-(syntactically-sectionize
+#'(lambda (s e context depth)
-#'(lambda (s e context depth)
+	  (let (face)
-	   (let (face)
+	    (cond ((eq context 'string)
-	     (cond ((eq context 'string)
+		   ;;#### Should only do this is Lisp-like modes!
-		    (setq face
+		   (setq face
-			  ;; #### It would be nice if we handled
+			 (if (= depth 1)
-			  ;; Python and other non-Lisp languages with
+			     ;; really we should only use this if
-			  ;; docstrings correctly.
+			     ;;  in position 3 depth 1, but that's
-			  (if (and lisp-like (= depth 1))
+			     ;;  too expensive to compute.
-			      ;; really we should only use this if
+			     'font-lock-doc-string-face
-			      ;;  in position 3 depth 1, but that's
+			   'font-lock-string-face)))
-			      ;;  too expensive to compute.
+		  ((or (eq context 'comment)
-			      'font-lock-doc-string-face
+		       (eq context 'block-comment))
-			    'font-lock-string-face)))
+		   (setq face 'font-lock-comment-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
 ;			      (setq face 'font-lock-comment-face)
 ;			      (setq e (point)))
 ;		       (skip-chars-forward " \t\n")
 ;		       (setq s (point)))
 		   ))
-	     (font-lock-set-face s e face)))
+	    (font-lock-set-face s e face)))
 start end)
-)))
+))
 ;;; Additional text property functions.
 ;; The following three text property functions are not generally available (and
 ;; it's not certain that they should be) so they are inlined for speed.
 (defun font-lock-fontify-keywords-region (start end &optional loudvar)
 "Fontify according to `font-lock-keywords' between START and END.
 START should be at the beginning of a line."
 (let ((loudly (and font-lock-verbose
 		     (>= (- end start) font-lock-message-threshold))))
-(let* ((case-fold-search font-lock-keywords-case-fold-search)
+(let ((case-fold-search font-lock-keywords-case-fold-search)
-	   (keywords (cdr (if (eq (car-safe font-lock-keywords) t)
+	  (keywords (cdr (if (eq (car-safe font-lock-keywords) t)
-			      font-lock-keywords
+			     font-lock-keywords
-			    (font-lock-compile-keywords))))
+			   (font-lock-compile-keywords))))
-	   (bufname (buffer-name))
+	  (bufname (buffer-name)) (count 0)
-	   (progress 5) (old-progress 5)
+	  keyword matcher highlights)
-	   (iter 0)
-	   (nkeywords (length keywords))
-	   keyword matcher highlights)
 ;;
 ;; Fontify each item in `font-lock-keywords' from `start' to `end'.
-;; In order to measure progress accurately we need to know how
-;; many keywords we have and how big the region is. Then progress
-;; is ((pos - start)/ (end - start) * nkeywords
-;; 	+ iteration / nkeywords) * 100
 (while keywords
+	(when loudly (lmessage 'progress "Fontifying %s... (regexps..%s)"
+		       bufname
+		       (make-string (setq count (1+ count)) ?.)))
 	;;
 	;; Find an occurrence of `matcher' from `start' to `end'.
 	(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)))
-	  ;; calculate progress
-	  (setq progress
-		(+ (/ (* (- (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))
-	  (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 keyword))
 	  (while highlights
 	    (if (numberp (car (car highlights)))
 		  ;; keyword so keywords can share bracketing
 		  ;; expressions.
 		  (and end (goto-char end)))
 	      (font-lock-fontify-anchored-keywords (car highlights) end))
 	    (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 (lmessage 'progress "Fontifying %s... done." (buffer-name)))))
 ;; Various functions.
 ;; Turn off other related packages if they're on.  I prefer a hook. --sm.
 (defun font-lock-after-fontify-buffer ()
 (cond ((and (boundp 'fast-lock-mode) fast-lock-mode)
 	 (fast-lock-after-fontify-buffer))
 	((and (boundp 'lazy-lock-mode) lazy-lock-mode)
 	 (lazy-lock-after-fontify-buffer))))
+;; If the buffer is about to be reverted, it won't be fontified afterward.
+(defun font-lock-revert-setup ()
+(setq font-lock-fontified nil))
+;; If the buffer has just been reverted, normally that turns off
+;; Font Lock mode.  So turn the mode back on if necessary.
+;; sb 1999-03-03 -- The above comment no longer appears to be operative as
+;; the first call to normal-mode *will* restore the font-lock state and
+;; this call forces a second font-locking to occur when reverting a buffer,
+;; which is wasteful at best.
+;(defalias 'font-lock-revert-cleanup 'turn-on-font-lock)
+(defun font-lock-revert-cleanup ())
 ;; Various functions.
 (defun font-lock-compile-keywords (&optional keywords)
 	 ;; Special constants:
 	 '("\\<\\(this\\|super\\)\\>" (1 font-lock-reference-face))
 	 '("\\<\\(false\\|null\\|true\\)\\>" (1 font-lock-keyword-face))
 	 ;; Class names:
-	 (list (concat "\\<\\(class\\|interface\\)\\>\\s *"
+	 (list (concat "\\<class\\>\\s *" java-font-lock-identifier-regexp)
-		       java-font-lock-identifier-regexp)
+	       1 'font-lock-function-name-face)
-	       2 'font-lock-function-name-face)
 	 ;; Package declarations:
 	 (list (concat "\\<\\(package\\|import\\)\\>\\s *"
 		       java-font-lock-identifier-regexp)
 	       '(2 font-lock-reference-face)
 		      '(0 nil))		; Workaround for bug in XEmacs.
 		'(font-lock-match-java-declarations
 		  (goto-char (match-end 1))
 		  (goto-char (match-end 0))
 		  (1 font-lock-variable-name-face))))))
 ;; Modifier keywords and Java doc tags
 (setq java-font-lock-keywords-3
 	(append
 	 '(
 	   ;; Feature scoping:
 	   ;; These must come first or the Modifiers from keywords-1 will
 	   ;; catch them.  We don't want to use override fontification here
 	   ;; because then these terms will be fontified within comments.
 	   ("\\<private\\>"   0 font-lock-string-face)
 	   ("\\<protected\\>" 0 font-lock-preprocessor-face)
 	   ("\\<public\\>"    0 font-lock-reference-face))
 	 java-font-lock-keywords-2
 	 (list
-	  ;; Javadoc tags
+	  ;; Java doc tags
-	  '("@\\(author\\|deprecated\\|exception\\|throws\\|param\\|return\\|see\\|since\\|version\\|serial\\|serialData\\|serialField\\)\\s "
+	  '("@\\(author\\|exception\\|param\\|return\\|see\\|version\\)\\s "
 	    0 font-lock-keyword-face t)
 	  ;; Doc tag - Parameter identifiers
 	  (list (concat "@param\\s +" java-font-lock-identifier-regexp)
 		1 'font-lock-variable-name-face t)
 	  ;; Doc tag - Exception types
-	  (list (concat "@\\(exception\\|throws\\)\\s +"
+	  (list (concat "@exception\\ s*"
 			java-font-lock-identifier-regexp)
-		'(2 (if (equal (char-after (match-end 0)) ?.)
+		'(1 (if (equal (char-after (match-end 0)) ?.)
 			font-lock-reference-face font-lock-type-face) t)
 		(list (concat "\\=\\." java-font-lock-identifier-regexp)
 		      '(goto-char (match-end 0)) nil
 		      '(1 (if (equal (char-after (match-end 0)) ?.)
 			      'font-lock-reference-face 'font-lock-type-face) t)))
 	  ;; Doc tag - Cross-references, usually to methods
 	  '("@see\\s +\\(\\S *[^][ \t\n\r\f(){},.;:]\\)"
 	    1 font-lock-function-name-face t)
-	  ;; Doc tag - docRoot (1.3)
-	  '("\\({ *@docRoot *}\\)"
-	    0 font-lock-keyword-face t)
-	  ;; Doc tag - beaninfo, unofficial but widely used, even by Sun
-	  '("\\(@beaninfo\\)"
-	    0 font-lock-keyword-face t)
-	  ;; Doc tag - Links
-	  '("{ *@link\\s +\\([^}]+\\)}"
-	    0 font-lock-keyword-face t)
-	  ;; Doc tag - Links
-	  '("{ *@link\\s +\\(\\(\\S +\\)\\|\\(\\S +\\s +\\S +\\)\\) *}"
-	    1 font-lock-function-name-face t)
 	  )))
 )
 (defvar java-font-lock-keywords java-font-lock-keywords-1
 "Additional expressions to highlight in Java mode.")

Mercurial > hg > xemacs-beta

comparison lisp/font-lock.el @ 412:697ef44129c6 r21-2-14