;; 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 <jwz@jwz.org>, for the LISPM Preservation Society.
;; Minimally merged with FSF 19.34 by Barry Warsaw <bwarsaw@python.org>
(symbol :tag "name"))
(radio :tag "Decoration"
(const :tag "default" nil)
- (const :tag "maximum" t)
+ (const :tag "maximum" t)
(integer :tag "level" 1)))))
:group 'font-lock)
;; #### barf gag retch. Horrid FSF lossage that we need to
;; keep around for compatibility with font-lock-keywords that
;; forget to properly quote their faces. I tried just let-binding
-;; them when we eval the face expression, but that failes because
+;; them when we eval the face expression, but that fails because
;; some files actually use the variables directly in their init code
;; without quoting them. --ben
(defvar font-lock-comment-face 'font-lock-comment-face
It is present only for horrid FSF compatibility reasons.
The corresponding face should be set using `edit-faces' or the
`set-face-*' functions.")
+;; GNU compatibility
+(define-compatible-variable-alias
+ 'font-lock-doc-face 'font-lock-doc-string-face)
(defvar font-lock-string-face 'font-lock-string-face
"This variable should not be set.
It is present only for horrid FSF compatibility reasons.
It is present only for horrid FSF compatibility reasons.
The corresponding face should be set using `edit-faces' or the
`set-face-*' functions.")
+(defvar font-lock-builtin-face 'font-lock-builtin-face
+ "This variable should not be set.
+It is present only for horrid FSF compatibility reasons.
+The corresponding face should be set using `edit-faces' or the
+`set-face-*' functions.")
(defvar font-lock-function-name-face 'font-lock-function-name-face
"This variable should not be set.
It is present only for horrid FSF compatibility reasons.
It is present only for horrid FSF compatibility reasons.
The corresponding face should be set using `edit-faces' or the
`set-face-*' functions.")
+(defvar font-lock-constant-face 'font-lock-constant-face
+ "This variable should not be set.
+It is present only for horrid FSF compatibility reasons.
+The corresponding face should be set using `edit-faces' or the
+`set-face-*' functions.")
(defvar font-lock-reference-face 'font-lock-reference-face
"This variable should not be set.
It is present only for horrid FSF compatibility reasons.
font-lock-string-face
font-lock-doc-string-face
font-lock-keyword-face
+ font-lock-builtin-face
font-lock-function-name-face
font-lock-variable-name-face
font-lock-type-face
+ font-lock-constant-face
font-lock-reference-face
font-lock-preprocessor-face
font-lock-warning-face))
"Font Lock mode face used to highlight keywords."
:group 'font-lock-faces)
+(defface font-lock-builtin-face
+ '((((class color) (background light)) (:foreground "Purple"))
+ (((class color) (background dark)) (:foreground "Cyan"))
+ (((class grayscale) (background light)) (:foreground "LightGray" :bold t))
+ (((class grayscale) (background dark)) (:foreground "DimGray" :bold t))
+ (t (:bold t)))
+ "Font Lock mode face used to highlight builtins."
+:group 'font-lock-faces)
+
(defface font-lock-function-name-face
'((((class color) (background dark)) (:foreground "aquamarine"))
;; brown4 is hardly different from black on windows.
"Font Lock mode face used to highlight types."
:group 'font-lock-faces)
+(defface font-lock-constant-face
+ '((((class color) (background light)) (:foreground "CadetBlue"))
+ (((class color) (background dark)) (:foreground "Aquamarine"))
+ (((class grayscale) (background light))
+ (:foreground "LightGray" :bold t :underline t))
+ (((class grayscale) (background dark))
+ (:foreground "Gray50" :bold t :underline t))
+ (t (:bold t :underline t)))
+ "Font Lock mode face used to highlight constants and labels."
+:group 'font-lock-faces)
+
(defface font-lock-reference-face
'((((class color) (background dark)) (:foreground "cadetblue2"))
(((class color) (background light)) (:foreground "red3"))
"Font Lock mode face used to highlight references."
:group 'font-lock-faces)
-;; #### FSF has font-lock-builtin-face.
-
(defface font-lock-preprocessor-face
'((((class color) (background dark)) (:foreground "steelblue1"))
(((class color) (background light)) (:foreground "blue3"))
"Font Lock Mode face used to highlight preprocessor conditionals."
:group 'font-lock-faces)
-;; #### Currently unused
(defface font-lock-warning-face
'((((class color) (background light)) (:foreground "Red" :bold t))
(((class color) (background dark)) (:foreground "Pink" :bold t))
font-lock-maximum-size
(cdr (or (assq major-mode font-lock-maximum-size)
(assq t font-lock-maximum-size))))))
- ;; Font-lock mode will refuse to turn itself on if in batch mode, or if
- ;; the current buffer is "invisible". The latter is because packages
- ;; sometimes put their temporary buffers into some particular major mode
- ;; to get syntax tables and variables and whatnot, but we don't want the
- ;; fact that the user has font-lock-mode on a mode hook to slow these
- ;; things down.
- (if (or noninteractive (eq (aref (buffer-name) 0) ?\ ))
- (setq on-p nil))
- (if (equal (buffer-name) " *Compiler Input*") ; hack for bytecomp...
+ ;; Font-lock mode will refuse to turn itself on if in batch mode
+ ;; to avoid potential (probably not actual, though) slowdown. We
+ ;; used to try to "be nice" by avoiding doing this in temporary
+ ;; buffers. But with the deferral code we don't need this, and it
+ ;; definitely screws some things up.
+ (if (noninteractive)
(setq on-p nil))
(cond (on-p
(make-local-hook 'after-change-functions)
next redisplay cycle, avoiding excessive fontification when many
buffer modifications are performed or a buffer is reverted.")
-(defvar font-lock-pending-extent-table (make-hash-table :weakness 'key))
+;; list of buffers in which there is a pending change.
+(defvar font-lock-pending-buffer-table (make-hash-table :weakness 'key))
+;; table used to keep track of ranges needing fontification.
(defvar font-lock-range-table (make-range-table))
(defun font-lock-pre-idle-hook ()
(condition-case font-lock-error
- (if (> (hash-table-count font-lock-pending-extent-table) 0)
+ (if (> (hash-table-count font-lock-pending-buffer-table) 0)
(font-lock-fontify-pending-extents))
(error (warn "Error caught in `font-lock-pre-idle-hook': %s"
font-lock-error))))
(defun font-lock-after-change-function (beg end old-len)
(when font-lock-mode
- (let ((ex (make-extent beg end)))
- (set-extent-property ex 'detachable nil)
- (set-extent-property ex 'end-open nil)
- (let ((exs (gethash (current-buffer) font-lock-pending-extent-table)))
- (push ex exs)
- (puthash (current-buffer) exs font-lock-pending-extent-table)))
+ ;; treat deletions as if the following character (or previous, if
+ ;; there is no following) were inserted. (also use the previous
+ ;; character at end of line. this avoids a problem when you
+ ;; insert a comment on the line before a line of code: if we use
+ ;; the following char, then when you hit backspace, the following
+ ;; line of code turns the comment color.) this is a bit of a hack
+ ;; but allows us to use text properties for everything.
+ (if (= beg end)
+ (cond ((not (save-excursion (goto-char end) (eolp)))
+ (setq end (1+ end)))
+ ((/= beg (point-min)) (setq beg (1- beg)))
+ (t nil)))
+ (put-text-property beg end 'font-lock-pending t)
+ (puthash (current-buffer) t font-lock-pending-buffer-table)
(if font-lock-always-fontify-immediately
(font-lock-fontify-pending-extents))))
;; only one buffer and one contiguous region!
(save-match-data
(maphash
- #'(lambda (buffer exs)
+ #'(lambda (buffer dummy)
;; remove first, to avoid infinite reprocessing if error
- (remhash buffer font-lock-pending-extent-table)
+ (remhash buffer font-lock-pending-buffer-table)
(when (buffer-live-p buffer)
(clear-range-table font-lock-range-table)
(with-current-buffer buffer
(save-excursion
(save-restriction
- ;; if we don't widen, then the C code will fail to
- ;; realize that we're inside a comment.
+ ;; if we don't widen, then the C code in
+ ;; syntactically-sectionize will fail to realize that
+ ;; we're inside a comment. #### We don't actually use
+ ;; syntactically-sectionize any more. Do we still
+ ;; need the widen?
(widen)
(let ((zmacs-region-stays
zmacs-region-stays)) ; protect from change!
- (mapc
- #'(lambda (ex)
- ;; paranoia.
- (when (and (extent-live-p ex)
- (not (extent-detached-p ex)))
- ;; first expand the ranges to full lines, because
- ;; that is what will be fontified; then use a
- ;; range table to merge the ranges.
- (let* ((beg (extent-start-position ex))
- (end (extent-end-position ex))
- (beg (progn (goto-char beg)
- (beginning-of-line)
- (point)))
- (end (progn (goto-char end)
- (forward-line 1)
- (point))))
- (detach-extent ex)
- (put-range-table beg end t
- font-lock-range-table))))
- exs)
+ (map-extents
+ #'(lambda (ex dummy-maparg)
+ ;; first expand the ranges to full lines,
+ ;; because that is what will be fontified;
+ ;; then use a range table to merge the
+ ;; ranges. (we could also do this simply using
+ ;; text properties. the range table code was
+ ;; here from a previous version of this code
+ ;; and works just as well.)
+ (let* ((beg (extent-start-position ex))
+ (end (extent-end-position ex))
+ (beg (progn (goto-char beg)
+ (beginning-of-line)
+ (point)))
+ (end (progn (goto-char end)
+ (forward-line 1)
+ (point))))
+ (put-range-table beg end t
+ font-lock-range-table)))
+ nil nil nil nil nil 'font-lock-pending t)
+ ;; clear all pending extents first in case of error below.
+ (put-text-property (point-min) (point-max)
+ 'font-lock-pending nil)
(map-range-table
#'(lambda (beg end val)
- ;; Maybe flush the internal cache used by
- ;; syntactically-sectionize. (It'd be nice if this
- ;; was more automatic.) Any deletions mean the
- ;; cache is invalid, and insertions at beginning or
- ;; end of line mean that the bol cache might be
- ;; invalid.
- ;; #### This code has been commented out for some time
- ;; now and is bit-rotting. Someone should look into
- ;; this.
-;; (if (or change-was-deletion (bobp)
-;; (= (preceding-char) ?\n))
-;; (buffer-syntactic-context-flush-cache))
- ;; #### This creates some unnecessary progress gauges.
+ ;; This creates some unnecessary progress gauges.
;; (if (and (= beg (point-min))
;; (= end (point-max)))
;; (font-lock-fontify-buffer)
;; (font-lock-fontify-region beg end)))
(font-lock-fontify-region beg end))
font-lock-range-table)))))))
- font-lock-pending-extent-table)))
+ font-lock-pending-buffer-table)))
\f
;; Syntactic fontification functions.
;; 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.
+;; 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
(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'."
+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))
(font-lock-apply-syntactic-highlight (car highlights))
(font-lock-fontify-syntactic-anchored-keywords (car highlights)
end))
- (setq highlights (cdr highlights)))
- )
+ (setq highlights (cdr highlights))))
(setq keywords (cdr keywords)))))
\f
;;; Regexp fontification functions.
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)
\f
;; Various functions.
-(defun font-lock-compile-keywords (&optional keywords)
- ;; Compile `font-lock-keywords' into the form (t KEYWORD ...) where KEYWORD
- ;; is the (MATCHER HIGHLIGHT ...) shown in the variable's doc string.
- (let ((keywords (or keywords font-lock-keywords)))
- (setq font-lock-keywords
- (if (eq (car-safe keywords) t)
- keywords
- (cons t (mapcar 'font-lock-compile-keyword keywords))))))
+(defun font-lock-compile-keywords (keywords)
+ "Compile KEYWORDS (a list) and return the list of compiled keywords.
+Each keyword has the form (MATCHER HIGHLIGHT ...). See `font-lock-keywords'."
+ (if (eq (car-safe keywords) t)
+ keywords
+ (cons t (mapcar 'font-lock-compile-keyword keywords))))
(defun font-lock-compile-keyword (keyword)
(cond ((nlistp keyword) ; Just MATCHER
keyword)))
(defun font-lock-eval-keywords (keywords)
- ;; Evalulate KEYWORDS if a function (funcall) or variable (eval) name.
+ "Evaluate KEYWORDS if a function (funcall) or variable (eval) name."
(if (listp keywords)
keywords
(font-lock-eval-keywords (if (fboundp keywords)
projects / chise / xemacs-chise.git.1 / blobdiff