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

comparison lisp/font-lock.el @ 442:abe6d1db359e r21-2-36

Import from CVS: tag r21-2-36

author	cvs
date	Mon, 13 Aug 2007 11:35:02 +0200
parents	3a7e78e1142d
children	576fb035e263

comparison

equal deleted inserted replaced

-:72a7cfa4a488
+:abe6d1db359e
 ;;; font-lock.el --- decorating source files with fonts/colors based on syntax
 ;; Copyright (C) 1992-1995, 1997 Free Software Foundation, Inc.
 ;; Copyright (C) 1995 Amdahl Corporation.
-;; Copyright (C) 1996 Ben Wing.
+;; Copyright (C) 1996, 2000 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>
 ;; Then (partially) synched with FSF 19.30, leading to:
 ;; Next Author: RMS
 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 or revert a buffer, you will see status messages only if the
+chunk of text, you will see status messages only if the changed region is
-changed region is large enough.)
+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 of the keywords to highlight.
+"A list defining the keywords for `font-lock-mode' to highlight.
-Each element should be of the form:
+FONT-LOCK-KEYWORDS := List of FONT-LOCK-FORM's.
-MATCHER
-(MATCHER . MATCH)
+FONT-LOCK-FORM     :== MATCHER
-(MATCHER . FACENAME)
+| (MATCHER . MATCH)
-(MATCHER . HIGHLIGHT)
+| (MATCHER . FACE-FORM)
-(MATCHER HIGHLIGHT ...)
+| (MATCHER . HIGHLIGHT)
-(eval . FORM)
+| (MATCHER HIGHLIGHT ...)
+| (eval . FORM)
-where HIGHLIGHT should be either MATCH-HIGHLIGHT or MATCH-ANCHORED.
+MATCHER            :== A string containing a regexp.
-FORM is an expression, whose value should be a keyword element,
+| A variable containing a regexp to search for.
-evaluated when the keyword is (first) used in a buffer.  This feature
+| A function to call to make the search.
-can be used to provide a keyword that can only be generated when Font
+It is called with one arg, the limit of the search,
-Lock mode is actually turned on.
+and should leave MATCH results in the XEmacs global
+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) items is to be highlighted following the
+However, if an item or (typically) several items are to be highlighted
-instance of another item (the anchor) then MATCH-ANCHORED may be required.
+following the instance of another item (the anchor) then MATCH-ANCHORED may be
+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
+\\[font-lock-fontify-buffer] handles multi-line patterns correctly, updating when you
-when you edit the buffer does not, since it considers text one line at a time.
+edit the buffer does not, since it considers text one line at a time.
-Be very careful composing regexps for this list;
+Be very careful composing regexps for this list; the wrong pattern can
-the wrong pattern can dramatically slow things down!")
+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.
+;; forget to properly quote their faces.  I tried just let-binding
+;; 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
-"Don't even think of using this.")
+"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-doc-string-face 'font-lock-doc-string-face
-"Don't even think of using this.")
+"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-string-face 'font-lock-string-face
-"Don't even think of using this.")
+"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-keyword-face 'font-lock-keyword-face
-"Don't even think of using this.")
+"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
-"Don't even think of using this.")
+"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-variable-name-face 'font-lock-variable-name-face
-"Don't even think of using this.")
+"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-type-face 'font-lock-type-face
-"Don't even think of using this.")
+"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
-"Don't even think of using this.")
+"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-preprocessor-face 'font-lock-preprocessor-face
-"Don't even think of using this.")
+"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-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))
 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
-		  (lmessage 'command "Fontifying %s... buffer too big."
+		  (progress-feedback-with-label
-		    (buffer-name)))))
+		   'font-lock
+		   "Fontifying %s... buffer too big." 'abort
+		   (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)
-(let ((was-on font-lock-mode)
+;; if we don't widen, then the C code will fail to
-	(font-lock-verbose (or font-lock-verbose (interactive-p)))
+;; realize that we're inside a comment.
-	(font-lock-message-threshold 0)
+(save-restriction
-	(aborted nil))
+(widen)
-;; Turn it on to run hooks and get the right font-lock-keywords.
+(let ((was-on font-lock-mode)
-(or was-on (font-lock-mode 1))
+	  (font-lock-verbose (or font-lock-verbose (interactive-p)))
-(font-lock-unfontify-region (point-min) (point-max) t)
+	  (font-lock-message-threshold 0)
-;;    (buffer-syntactic-context-flush-cache)
+	  (aborted nil))
+;; 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)))
-(quit
+	(t
-(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)
-	(lmessage 'command  "Fontifying %s... aborted." (buffer-name))))
+	(progress-feedback-with-label 'font-lock "Fontifying %s... aborted."
-(run-hooks 'font-lock-after-fontify-buffer-hook))
+				      'abort (buffer-name))))
+(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))
-(lmessage 'progress "Fontifying %s..." (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)
 (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 all the crap I added below).
+;; version, before the deferred stuff was added).
-;;
-;; 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-always-fontify-immediately nil
-(defvar font-lock-old-len 0)
+"Set this to non-nil to disable font-lock deferral.
+Otherwise, changes to existing text will not be processed until the
-(defun font-lock-fontify-glumped-region ()
+next redisplay cycle, avoiding excessive fontification when many
-;; even if something goes wrong in the fontification, mark the glumped
+buffer modifications are performed or a buffer is reverted.")
-;; region as fontified; otherwise, the same error might get signaled
-;; after every command.
+(defvar font-lock-pending-extent-table (make-hash-table :weakness 'key))
-(unwind-protect
+(defvar font-lock-range-table (make-range-table))
-;; 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
+(condition-case font-lock-error
-(if font-lock-old-extent
+(if (> (hash-table-count font-lock-pending-extent-table) 0)
-	  (font-lock-fontify-glumped-region))
+	  (font-lock-fontify-pending-extents))
-(error (warn "Error caught in `font-lock-pre-idle-hook'"))))
+(error (warn "Error caught in `font-lock-pre-idle-hook': %s"
+		 font-lock-error))))
-(defvar font-lock-always-fontify-immediately nil
-"Set this to non-nil to disable font-lock deferral.")
 ;;; called when any modification is made to buffer text.  This function
-;;; attempts to glump adjacent changes together so that excessive
+;;; remembers the changed ranges until the next redisplay, at which point
-;;; fontification is avoided.  This function could easily be adapted
+;;; the extents are merged and pruned, and the resulting ranges fontified.
-;;; to other after-change-functions.
+;;; This function could easily be adapted to other after-change-functions.
 (defun font-lock-after-change-function (beg end old-len)
-(let ((obeg (and font-lock-old-extent
+(when font-lock-mode
-		   (extent-start-position font-lock-old-extent)))
+(let ((ex (make-extent beg end)))
-	(oend (and font-lock-old-extent
+(set-extent-property ex 'detachable nil)
-		   (extent-end-position font-lock-old-extent)))
+(set-extent-property ex 'end-open nil)
-	(bc-end (+ beg old-len)))
+(let ((exs (gethash (current-buffer) font-lock-pending-extent-table)))
+	(push ex exs)
-;; If this change can't be merged into the glumped one,
+	(puthash (current-buffer) exs font-lock-pending-extent-table)))
-;; 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-glumped-region))))
+	(font-lock-fontify-pending-extents))))
-(defun font-lock-after-change-function-1 (beg end old-len)
+(defun font-lock-fontify-pending-extents ()
-(if (null font-lock-mode)
+;; ah, the beauty of mapping functions.
-nil
+;; this function is actually shorter than the old version, which handled
-(save-excursion
+;; only one buffer and one contiguous region!
-(save-restriction
+(save-match-data
-	;; if we don't widen, then fill-paragraph (and any command that
+(maphash
-	;; operates on a narrowed region) confuses things, because the C
+#'(lambda (buffer exs)
-	;; code will fail to realize that we're inside a comment.
+	 ;; remove first, to avoid infinite reprocessing if error
-	(widen)
+	 (remhash buffer font-lock-pending-extent-table)
-	(save-match-data
+	 (when (buffer-live-p buffer)
-	  (let ((zmacs-region-stays zmacs-region-stays)) ; protect from change!
+	   (clear-range-table font-lock-range-table)
-	    (goto-char beg)
+	   (with-current-buffer buffer
-	    ;; Maybe flush the internal cache used by syntactically-sectionize.
+	     (save-excursion
-	    ;; (It'd be nice if this was more automatic.)  Any deletions mean
+	       (save-restriction
-	    ;; the cache is invalid, and insertions at beginning or end of line
+		 ;; if we don't widen, then the C code will fail to
-	    ;; mean that the bol cache might be invalid.
+		 ;; realize that we're inside a comment.
-;;	    (if (or (> old-len 0) (bobp) (= (preceding-char) ?\n))
+		 (widen)
-;;		(buffer-syntactic-context-flush-cache))
+		 (let ((zmacs-region-stays
+			zmacs-region-stays)) ; protect from change!
-	    ;; Always recompute the whole line.
+		   (mapc
-	    (goto-char end)
+		    #'(lambda (ex)
-	    (forward-line 1)
+			;; paranoia.
-	    (setq end (point))
+			(when (and (extent-live-p ex)
-	    (goto-char beg)
+				   (not (extent-detached-p ex)))
-	    (beginning-of-line)
+			  ;; first expand the ranges to full lines, because
-	    (setq beg (point))
+			  ;; that is what will be fontified; then use a
-	    ;; Rescan between start of line from `beg' and start of line after
+			  ;; range table to merge the ranges.
-	    ;; `end'.
+			  (let* ((beg (extent-start-position ex))
-	    (font-lock-fontify-region beg end)))))))
+				 (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-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,
 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))
-(lmessage 'progress "Fontifying %s... (syntactically...)"
+(progress-feedback-with-label 'font-lock
-	(buffer-name)))
+				    "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
 (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)) (count 0)
+	   (bufname (buffer-name))
-	  keyword matcher highlights)
+	   (progress 5) (old-progress 5)
+	   (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))
+	    (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 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 (lmessage 'progress "Fontifying %s... done." (buffer-name)))))
+(if loudly
+	(progress-feedback-with-label 'font-lock "Fontifying %s... " 100
+				      (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)
 (append lisp-font-lock-keywords-1
 (list
 ;;
 ;; 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\\|"
+;; beginning of generated stuff
-"times\\)?\\|eval-\\(a\\(fter-load\\|nd-compile\\)\\|when-compile\\)\\|"
+;; to regenerate, use the regexp-opt below, then delete the outermost
-"flet\\|if\\|l\\(a\\(bels\\|mbda\\)\\|et\\*?\\)\\|"
+;; grouping, then use the macro below to break up the string.
-"prog[nv12\\*]?\\|return\\(-from\\)?\\|save-\\(current-buffer\\|"
+;; (regexp-opt
-"excursion\\|match-data\\|restriction\\|selected-window\\|"
+;;   '("cond" "if" "while" "let" "let*" "prog" "progn" "prog1"
-"window-excursion\\)\\|t\\(hrow\\|rack-mouse\\)\\|un\\(less\\|"
+;;     "prog2" "progv" "catch" "throw" "save-restriction"
-"wind-protect\\)\\|w\\(h\\(en\\|ile\\)\\|ith-\\(current-buffer\\|"
+;;     "save-excursion" "save-window-excursion"
-"output-to-string\\|string-as-buffer-contents\\|temp-\\(buffer\\|"
+;;     "save-current-buffer" "with-current-buffer"
-"file\\)\\)\\)"
+;;     "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.
 '("(\\(featurep\\|provide\\|require\\)\\>[ \t']*\\(\\sw+\\)?"
 (1 font-lock-keyword-face) (2 font-lock-reference-face nil t))
 (defvar java-font-lock-type-regexp
 (concat "\\<\\(boolean\\|byte\\|char\\|double\\|float\\|int"
 "\\|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\\|"
 	       "private\\|protected\\|public\\|"
 	       "static\\|synchronized\\|transient\\|volatile\\)\\>")))
 	 ;; Special constants:
 	 '("\\<\\(this\\|super\\)\\>" (1 font-lock-reference-face))
 	 '("\\<\\(false\\|null\\|true\\)\\>" (1 font-lock-keyword-face))
 	 ;; Class names:
-	 (list (concat "\\<class\\>\\s *" java-font-lock-identifier-regexp)
+	 (list (concat "\\<\\(class\\|interface\\)\\>\\s *"
-	       1 'font-lock-function-name-face)
+		       java-font-lock-identifier-regexp)
+	       2 'font-lock-function-name-face)
 	 ;; Package declarations:
 	 (list (concat "\\<\\(package\\|import\\)\\>\\s *"
 		       java-font-lock-identifier-regexp)
 	       '(2 font-lock-reference-face)
 	   ("\\<public\\>"    0 font-lock-reference-face))
 	 java-font-lock-keywords-2
 	 (list
-	  ;; Java doc tags
+	  ;; Javadoc tags
-	  '("@\\(author\\|exception\\|throws\\|deprecated\\|param\\|return\\|see\\|since\\|version\\)\\s "
+	  '("@\\(author\\|deprecated\\|exception\\|throws\\|param\\|return\\|see\\|since\\|version\\|serial\\|serialData\\|serialField\\)\\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\\s +"
+	  (list (concat "@\\(exception\\|throws\\)\\s +"
 			java-font-lock-identifier-regexp)
-		'(1 (if (equal (char-after (match-end 0)) ?.)
+		'(2 (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 - Exception types
-	  (list (concat "@exception\\s +"
-			java-font-lock-identifier-regexp)
-		'(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 - Links
+	  ;; Doc tag - docRoot (1.3)
-	  '("{@link\\s +\\([^}]*\\)}"
+	  '("\\({ *@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 +\\(\\S +\\s +\\S +\\)}"
+	  '("{ *@link\\s +\\([^}]+\\)}"
+	    0 font-lock-keyword-face t)
+	  ;; Doc tag - Links
+	  '("{ *@link\\s +\\(\\(\\S +\\)\\|\\(\\S +\\s +\\S +\\)\\) *}"
 	    1 font-lock-function-name-face t)
 	  )))
 )

Mercurial > hg > xemacs-beta

comparison lisp/font-lock.el @ 442:abe6d1db359e r21-2-36