+;;; Additional text property functions.
+
+;; The following text property functions should be builtins. This means they
+;; should be written in C and put with all the other text property functions.
+;; In the meantime, those that are used by font-lock.el are defined in Lisp
+;; below and given a `font-lock-' prefix. Those that are not used are defined
+;; in Lisp below and commented out. sm.
+
+(defun font-lock-prepend-text-property (start end prop value &optional object)
+ "Prepend to one property of the text from START to END.
+Arguments PROP and VALUE specify the property and value to prepend to the value
+already in place. The resulting property values are always lists.
+Optional argument OBJECT is the string or buffer containing the text."
+ (let ((val (if (listp value) value (list value))) next prev)
+ (while (/= start end)
+ (setq next (next-single-property-change start prop object end)
+ prev (get-text-property start prop object))
+ (put-text-property start next prop
+ (append val (if (listp prev) prev (list prev)))
+ object)
+ (setq start next))))
+
+(defun font-lock-append-text-property (start end prop value &optional object)
+ "Append to one property of the text from START to END.
+Arguments PROP and VALUE specify the property and value to append to the value
+already in place. The resulting property values are always lists.
+Optional argument OBJECT is the string or buffer containing the text."
+ (let ((val (if (listp value) value (list value))) next prev)
+ (while (/= start end)
+ (setq next (next-single-property-change start prop object end)
+ prev (get-text-property start prop object))
+ (put-text-property start next prop
+ (append (if (listp prev) prev (list prev)) val)
+ object)
+ (setq start next))))
+
+(defun font-lock-fillin-text-property (start end prop value &optional object)
+ "Fill in one property of the text from START to END.
+Arguments PROP and VALUE specify the property and value to put where none are
+already in place. Therefore existing property values are not overwritten.
+Optional argument OBJECT is the string or buffer containing the text."
+ (let ((start (text-property-any start end prop nil object)) next)
+ (while start
+ (setq next (next-single-property-change start prop object end))
+ (put-text-property start next prop value object)
+ (setq start (text-property-any next end prop nil object)))))
+
+;; For completeness: this is to `remove-text-properties' as `put-text-property'
+;; is to `add-text-properties', etc.
+;(defun remove-text-property (start end property &optional object)
+; "Remove a property from text from START to END.
+;Argument PROPERTY is the property to remove.
+;Optional argument OBJECT is the string or buffer containing the text.
+;Return t if the property was actually removed, nil otherwise."
+; (remove-text-properties start end (list property) object))
+
+;; For consistency: maybe this should be called `remove-single-property' like
+;; `next-single-property-change' (not `next-single-text-property-change'), etc.
+;(defun remove-single-text-property (start end prop value &optional object)
+; "Remove a specific property value from text from START to END.
+;Arguments PROP and VALUE specify the property and value to remove. The
+;resulting property values are not equal to VALUE nor lists containing VALUE.
+;Optional argument OBJECT is the string or buffer containing the text."
+; (let ((start (text-property-not-all start end prop nil object)) next prev)
+; (while start
+; (setq next (next-single-property-change start prop object end)
+; prev (get-text-property start prop object))
+; (cond ((and (symbolp prev) (eq value prev))
+; (remove-text-property start next prop object))
+; ((and (listp prev) (memq value prev))
+; (let ((new (delq value prev)))
+; (cond ((null new)
+; (remove-text-property start next prop object))
+; ((= (length new) 1)
+; (put-text-property start next prop (car new) object))
+; (t
+; (put-text-property start next prop new object))))))
+; (setq start (text-property-not-all next end prop nil object)))))
+
+;;; End of Additional text property functions.
+\f
+;;; Syntactic regexp fontification functions.
+
+;; These syntactic keyword pass functions are identical to those keyword pass
+;; functions below, with the following exceptions; (a) they operate on
+;; `font-lock-syntactic-keywords' of course, (b) they are all `defun' as speed
+;; is less of an issue, (c) eval of property value does not occur JIT as speed
+;; is less of an issue, (d) OVERRIDE cannot be `prepend' or `append' as it
+;; makes no sense for `syntax-table' property values, (e) they do not do it
+;; LOUDLY as it is not likely to be intensive.
+
+(defun font-lock-apply-syntactic-highlight (highlight)
+ "Apply HIGHLIGHT following a match.
+HIGHLIGHT should be of the form MATCH-HIGHLIGHT,
+see `font-lock-syntactic-keywords'."
+ (let* ((match (nth 0 highlight))
+ (start (match-beginning match)) (end (match-end match))
+ (value (nth 1 highlight))
+ (override (nth 2 highlight)))
+ (unless (numberp (car-safe value))
+ (setq value (eval value)))
+ (cond ((not start)
+ ;; No match but we might not signal an error.
+ (or (nth 3 highlight)
+ (error "No match %d in highlight %S" match highlight)))
+ ((not override)
+ ;; Cannot override existing fontification.
+ (or (text-property-not-all start end 'syntax-table nil)
+ (put-text-property start end 'syntax-table value)))
+ ((eq override t)
+ ;; Override existing fontification.
+ (put-text-property start end 'syntax-table value))
+ ((eq override 'keep)
+ ;; Keep existing fontification.
+ (font-lock-fillin-text-property start end 'syntax-table value)))))
+
+(defun font-lock-fontify-syntactic-anchored-keywords (keywords limit)
+ "Fontify according to KEYWORDS until LIMIT.
+KEYWORDS should be of the form MATCH-ANCHORED, see `font-lock-keywords',
+LIMIT can be modified by the value of its PRE-MATCH-FORM."
+ (let ((matcher (nth 0 keywords)) (lowdarks (nthcdr 3 keywords)) highlights
+ ;; Evaluate PRE-MATCH-FORM.
+ (pre-match-value (eval (nth 1 keywords))))
+ ;; Set LIMIT to value of PRE-MATCH-FORM or the end of line.
+ (if (and (numberp pre-match-value) (> pre-match-value (point)))
+ (setq limit pre-match-value)
+ (save-excursion (end-of-line) (setq limit (point))))
+ (save-match-data
+ ;; Find an occurrence of `matcher' before `limit'.
+ (while (if (stringp matcher)
+ (re-search-forward matcher limit t)
+ (funcall matcher limit))
+ ;; Apply each highlight to this instance of `matcher'.
+ (setq highlights lowdarks)
+ (while highlights
+ (font-lock-apply-syntactic-highlight (car highlights))
+ (setq highlights (cdr highlights)))))
+ ;; Evaluate POST-MATCH-FORM.
+ (eval (nth 2 keywords))))
+
+(defun font-lock-fontify-syntactic-keywords-region (start end)
+ "Fontify according to `font-lock-syntactic-keywords' between START and END.
+START should be at the beginning of a line."
+ ;; If `font-lock-syntactic-keywords' is a symbol, get the real keywords.
+ (when (symbolp font-lock-syntactic-keywords)
+ (setq font-lock-syntactic-keywords (font-lock-eval-keywords
+ font-lock-syntactic-keywords)))
+ ;; If `font-lock-syntactic-keywords' is not compiled, compile it.
+ (unless (eq (car font-lock-syntactic-keywords) t)
+ (setq font-lock-syntactic-keywords (font-lock-compile-keywords
+ font-lock-syntactic-keywords)))
+ ;; Get down to business.
+ (let ((case-fold-search font-lock-keywords-case-fold-search)
+ (keywords (cdr font-lock-syntactic-keywords))
+ keyword matcher highlights)
+ (while keywords
+ ;; Find an occurrence of `matcher' from `start' to `end'.
+ (setq keyword (car keywords) matcher (car keyword))
+ (goto-char start)
+ (while (if (stringp matcher)
+ (re-search-forward matcher end t)
+ (funcall matcher end))
+ ;; Apply each highlight to this instance of `matcher', which may be
+ ;; specific highlights or more keywords anchored to `matcher'.
+ (setq highlights (cdr keyword))
+ (while highlights
+ (if (numberp (car (car highlights)))
+ (font-lock-apply-syntactic-highlight (car highlights))
+ (font-lock-fontify-syntactic-anchored-keywords (car highlights)
+ end))
+ (setq highlights (cdr highlights))))
+ (setq keywords (cdr keywords)))))
+
+;;; End of Syntactic regexp fontification functions.
+\f
+;;; Syntactic fontification functions.
+
+;; These record the parse state at a particular position, always the start of a
+;; line. Used to make `font-lock-fontify-syntactically-region' faster.
+;; Previously, `font-lock-cache-position' was just a buffer position. However,
+;; under certain situations, this occasionally resulted in mis-fontification.
+;; I think the "situations" were deletion with Lazy Lock mode's deferral. sm.
+(defvar font-lock-cache-state nil)
+(defvar font-lock-cache-position nil)
+
+(defun font-lock-fontify-syntactically-region (start end &optional loudly)
+ "Put proper face on each string and comment between START and END.
+START should be at the beginning of a line."
+ (let ((cache (marker-position font-lock-cache-position))
+ state string beg)
+ (if loudly (message "Fontifying %s... (syntactically...)" (buffer-name)))
+ (goto-char start)
+ ;;
+ ;; Find the state at the `beginning-of-line' before `start'.
+ (if (eq start cache)
+ ;; Use the cache for the state of `start'.
+ (setq state font-lock-cache-state)
+ ;; Find the state of `start'.
+ (if (null font-lock-beginning-of-syntax-function)
+ ;; Use the state at the previous cache position, if any, or
+ ;; otherwise calculate from `point-min'.
+ (if (or (null cache) (< start cache))
+ (setq state (parse-partial-sexp (point-min) start))
+ (setq state (parse-partial-sexp cache start nil nil
+ font-lock-cache-state)))
+ ;; Call the function to move outside any syntactic block.
+ (funcall font-lock-beginning-of-syntax-function)
+ (setq state (parse-partial-sexp (point) start)))
+ ;; Cache the state and position of `start'.
+ (setq font-lock-cache-state state)
+ (set-marker font-lock-cache-position start))
+ ;;
+ ;; If the region starts inside a string or comment, show the extent of it.
+ (when (or (nth 3 state) (nth 4 state))
+ (setq string (nth 3 state) beg (point))
+ (setq state (parse-partial-sexp (point) end nil nil state 'syntax-table))
+ (put-text-property beg (point) 'face
+ (if string
+ font-lock-string-face
+ font-lock-comment-face)))
+ ;;
+ ;; Find each interesting place between here and `end'.
+ (while (and (< (point) end)
+ (progn
+ (setq state (parse-partial-sexp (point) end nil nil state
+ 'syntax-table))
+ (or (nth 3 state) (nth 4 state))))
+ (setq string (nth 3 state) beg (nth 8 state))
+ (setq state (parse-partial-sexp (point) end nil nil state 'syntax-table))
+ (put-text-property beg (point) 'face
+ (if string
+ font-lock-string-face
+ font-lock-comment-face)))))
+
+;;; End of Syntactic fontification functions.
+\f
+;;; Keyword regexp fontification functions.
+
+(defsubst font-lock-apply-highlight (highlight)
+ "Apply HIGHLIGHT following a match.
+HIGHLIGHT should be of the form MATCH-HIGHLIGHT, see `font-lock-keywords'."
+ (let* ((match (nth 0 highlight))
+ (start (match-beginning match)) (end (match-end match))
+ (override (nth 2 highlight)))
+ (cond ((not start)
+ ;; No match but we might not signal an error.
+ (or (nth 3 highlight)
+ (error "No match %d in highlight %S" match highlight)))
+ ((not override)
+ ;; Cannot override existing fontification.
+ (or (text-property-not-all start end 'face nil)
+ (put-text-property start end 'face (eval (nth 1 highlight)))))
+ ((eq override t)
+ ;; Override existing fontification.
+ (put-text-property start end 'face (eval (nth 1 highlight))))
+ ((eq override 'prepend)
+ ;; Prepend to existing fontification.
+ (font-lock-prepend-text-property start end 'face (eval (nth 1 highlight))))
+ ((eq override 'append)
+ ;; Append to existing fontification.
+ (font-lock-append-text-property start end 'face (eval (nth 1 highlight))))
+ ((eq override 'keep)
+ ;; Keep existing fontification.
+ (font-lock-fillin-text-property start end 'face (eval (nth 1 highlight)))))))
+
+(defsubst font-lock-fontify-anchored-keywords (keywords limit)
+ "Fontify according to KEYWORDS until LIMIT.
+KEYWORDS should be of the form MATCH-ANCHORED, see `font-lock-keywords',
+LIMIT can be modified by the value of its PRE-MATCH-FORM."
+ (let ((matcher (nth 0 keywords)) (lowdarks (nthcdr 3 keywords)) highlights
+ (lead-start (match-beginning 0))
+ ;; Evaluate PRE-MATCH-FORM.
+ (pre-match-value (eval (nth 1 keywords))))
+ ;; Set LIMIT to value of PRE-MATCH-FORM or the end of line.
+ (if (not (and (numberp pre-match-value) (> pre-match-value (point))))
+ (save-excursion (end-of-line) (setq limit (point)))
+ (setq limit pre-match-value)
+ (when (>= pre-match-value (save-excursion (forward-line 1) (point)))
+ ;; this is a multiline anchored match
+ (put-text-property (point) limit 'font-lock-multiline t)))
+ (save-match-data
+ ;; Find an occurrence of `matcher' before `limit'.
+ (while (if (stringp matcher)
+ (re-search-forward matcher limit t)
+ (funcall matcher limit))
+ ;; Apply each highlight to this instance of `matcher'.
+ (setq highlights lowdarks)
+ (while highlights
+ (font-lock-apply-highlight (car highlights))
+ (setq highlights (cdr highlights)))))
+ ;; Evaluate POST-MATCH-FORM.
+ (eval (nth 2 keywords))))
+
+(defun font-lock-fontify-keywords-region (start end &optional loudly)
+ "Fontify according to `font-lock-keywords' between START and END.
+START should be at the beginning of a line."
+ (unless (eq (car 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 font-lock-keywords))
+ (bufname (buffer-name)) (count 0)
+ keyword matcher highlights)
+ ;;
+ ;; Fontify each item in `font-lock-keywords' from `start' to `end'.
+ (while keywords
+ (if loudly (message "Fontifying %s... (regexps..%s)" bufname
+ (make-string (incf 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)))
+ (when (and (match-beginning 0)
+ (>= (point)
+ (save-excursion (goto-char (match-beginning 0))
+ (forward-line 1) (point))))
+ ;; this is a multiline regexp match
+ (put-text-property (match-beginning 0) (point)
+ 'font-lock-multiline t))
+ ;; Apply each highlight to this instance of `matcher', which may be
+ ;; specific highlights or more keywords anchored to `matcher'.
+ (setq highlights (cdr keyword))
+ (while highlights
+ (if (numberp (car (car highlights)))
+ (font-lock-apply-highlight (car highlights))
+ (font-lock-fontify-anchored-keywords (car highlights) end))
+ (setq highlights (cdr highlights))))
+ (setq keywords (cdr keywords)))))
+
+;;; End of Keyword regexp fontification functions.
+\f
+;; Various functions.
+
+(defun font-lock-compile-keywords (keywords)
+ ;; Compile KEYWORDS into the form (t KEYWORD ...) where KEYWORD is of the
+ ;; form (MATCHER HIGHLIGHT ...) as shown in `font-lock-keywords' doc string.
+ (if (eq (car-safe keywords) t)
+ keywords
+ (cons t (mapcar 'font-lock-compile-keyword keywords))))
+
+(defun font-lock-compile-keyword (keyword)
+ (cond ((nlistp keyword) ; MATCHER
+ (list keyword '(0 font-lock-keyword-face)))
+ ((eq (car keyword) 'eval) ; (eval . FORM)
+ (font-lock-compile-keyword (eval (cdr keyword))))
+ ((eq (car-safe (cdr keyword)) 'quote) ; (MATCHER . 'FORM)
+ ;; If FORM is a FACENAME then quote it. Otherwise ignore the quote.
+ (if (symbolp (nth 2 keyword))
+ (list (car keyword) (list 0 (cdr keyword)))
+ (font-lock-compile-keyword (cons (car keyword) (nth 2 keyword)))))
+ ((numberp (cdr keyword)) ; (MATCHER . MATCH)
+ (list (car keyword) (list (cdr keyword) 'font-lock-keyword-face)))
+ ((symbolp (cdr keyword)) ; (MATCHER . FACENAME)
+ (list (car keyword) (list 0 (cdr keyword))))
+ ((nlistp (nth 1 keyword)) ; (MATCHER . HIGHLIGHT)
+ (list (car keyword) (cdr keyword)))
+ (t ; (MATCHER HIGHLIGHT ...)
+ keyword)))
+
+(defun font-lock-eval-keywords (keywords)
+ ;; Evalulate KEYWORDS if a function (funcall) or variable (eval) name.
+ (if (listp keywords)
+ keywords
+ (font-lock-eval-keywords (if (fboundp keywords)
+ (funcall keywords)
+ (eval keywords)))))
+
+(defun font-lock-value-in-major-mode (alist)
+ ;; Return value in ALIST for `major-mode', or ALIST if it is not an alist.
+ ;; Structure is ((MAJOR-MODE . VALUE) ...) where MAJOR-MODE may be t.
+ (if (consp alist)
+ (cdr (or (assq major-mode alist) (assq t alist)))
+ alist))
+
+(defun font-lock-choose-keywords (keywords level)
+ ;; Return LEVELth element of KEYWORDS. A LEVEL of nil is equal to a
+ ;; LEVEL of 0, a LEVEL of t is equal to (1- (length KEYWORDS)).
+ (cond ((symbolp keywords)
+ keywords)
+ ((numberp level)
+ (or (nth level keywords) (car (reverse keywords))))
+ ((eq level t)
+ (car (reverse keywords)))
+ (t
+ (car keywords))))
+
+(defvar font-lock-set-defaults nil) ; Whether we have set up defaults.
+
+(defun font-lock-set-defaults ()
+ "Set fontification defaults appropriately for this mode.
+Sets various variables using `font-lock-defaults' (or, if nil, using
+`font-lock-defaults-alist') and `font-lock-maximum-decoration'."
+ ;; Set fontification defaults.
+ (make-local-variable 'font-lock-fontified)
+ ;; Set iff not previously set.
+ (unless font-lock-set-defaults
+ (set (make-local-variable 'font-lock-set-defaults) t)
+ (set (make-local-variable 'font-lock-cache-state) nil)
+ (set (make-local-variable 'font-lock-cache-position) (make-marker))
+ (let* ((defaults (or font-lock-defaults
+ (cdr (assq major-mode font-lock-defaults-alist))))
+ (keywords
+ (font-lock-choose-keywords (nth 0 defaults)
+ (font-lock-value-in-major-mode font-lock-maximum-decoration)))
+ (local (cdr (assq major-mode font-lock-keywords-alist))))
+ ;; Regexp fontification?
+ (set (make-local-variable 'font-lock-keywords)
+ (font-lock-compile-keywords (font-lock-eval-keywords keywords)))
+ ;; Local fontification?
+ (while local
+ (font-lock-add-keywords nil (car (car local)) (cdr (car local)))
+ (setq local (cdr local)))
+ ;; Syntactic fontification?
+ (when (nth 1 defaults)
+ (set (make-local-variable 'font-lock-keywords-only) t))
+ ;; Case fold during regexp fontification?
+ (when (nth 2 defaults)
+ (set (make-local-variable 'font-lock-keywords-case-fold-search) t))
+ ;; Syntax table for regexp and syntactic fontification?
+ (when (nth 3 defaults)
+ (let ((slist (nth 3 defaults)))
+ (set (make-local-variable 'font-lock-syntax-table)
+ (copy-syntax-table (syntax-table)))
+ (while slist
+ ;; The character to modify may be a single CHAR or a STRING.
+ (let ((chars (if (numberp (car (car slist)))
+ (list (car (car slist)))
+ (mapcar 'identity (car (car slist)))))
+ (syntax (cdr (car slist))))
+ (while chars
+ (modify-syntax-entry (car chars) syntax font-lock-syntax-table)
+ (setq chars (cdr chars)))
+ (setq slist (cdr slist))))))
+ ;; Syntax function for syntactic fontification?
+ (when (nth 4 defaults)
+ (set (make-local-variable 'font-lock-beginning-of-syntax-function)
+ (nth 4 defaults)))
+ ;; Variable alist?
+ (let ((alist (nthcdr 5 defaults)))
+ (while alist
+ (let ((variable (car (car alist))) (value (cdr (car alist))))
+ (unless (boundp variable)
+ (set variable nil))
+ (set (make-local-variable variable) value)
+ (setq alist (cdr alist))))))))
+
+(defun font-lock-unset-defaults ()
+ "Unset fontification defaults. See `font-lock-set-defaults'."
+ (setq font-lock-set-defaults nil
+ font-lock-keywords nil
+ font-lock-keywords-only nil
+ font-lock-keywords-case-fold-search nil
+ font-lock-syntax-table nil
+ font-lock-beginning-of-syntax-function nil)
+ (let* ((defaults (or font-lock-defaults
+ (cdr (assq major-mode font-lock-defaults-alist))))
+ (alist (nthcdr 5 defaults)))
+ (while alist
+ (set (car (car alist)) (default-value (car (car alist))))
+ (setq alist (cdr alist)))))
+\f
+;;; Colour etc. support.
+
+;; Originally these variable values were face names such as `bold' etc.
+;; Now we create our own faces, but we keep these variables for compatibility
+;; and they give users another mechanism for changing face appearance.
+;; We now allow a FACENAME in `font-lock-keywords' to be any expression that
+;; returns a face. So the easiest thing is to continue using these variables,
+;; rather than sometimes evaling FACENAME and sometimes not. sm.
+(defvar font-lock-comment-face 'font-lock-comment-face
+ "Face name to use for comments.")
+
+(defvar font-lock-string-face 'font-lock-string-face
+ "Face name to use for strings.")
+
+(defvar font-lock-keyword-face 'font-lock-keyword-face
+ "Face name to use for keywords.")
+
+(defvar font-lock-builtin-face 'font-lock-builtin-face
+ "Face name to use for builtins.")
+
+(defvar font-lock-function-name-face 'font-lock-function-name-face
+ "Face name to use for function names.")
+
+(defvar font-lock-variable-name-face 'font-lock-variable-name-face
+ "Face name to use for variable names.")
+
+(defvar font-lock-type-face 'font-lock-type-face
+ "Face name to use for type and class names.")
+
+(defvar font-lock-constant-face 'font-lock-constant-face
+ "Face name to use for constant and label names.")
+
+(defvar font-lock-warning-face 'font-lock-warning-face
+ "Face name to use for things that should stand out.")
+
+(defvar font-lock-reference-face 'font-lock-constant-face
+ "This variable is obsolete. Use font-lock-constant-face.")
+
+;; Originally face attributes were specified via `font-lock-face-attributes'.
+;; Users then changed the default face attributes by setting that variable.
+;; However, we try and be back-compatible and respect its value if set except
+;; for faces where M-x customize has been used to save changes for the face.
+(when (boundp 'font-lock-face-attributes)
+ (let ((face-attributes font-lock-face-attributes))
+ (while face-attributes
+ (let* ((face-attribute (pop face-attributes))
+ (face (car face-attribute)))
+ ;; Rustle up a `defface' SPEC from a `font-lock-face-attributes' entry.
+ (unless (get face 'saved-face)
+ (let ((foreground (nth 1 face-attribute))
+ (background (nth 2 face-attribute))
+ (bold-p (nth 3 face-attribute))
+ (italic-p (nth 4 face-attribute))
+ (underline-p (nth 5 face-attribute))
+ face-spec)
+ (when foreground
+ (setq face-spec (cons ':foreground (cons foreground face-spec))))
+ (when background
+ (setq face-spec (cons ':background (cons background face-spec))))
+ (when bold-p
+ (setq face-spec (append '(:bold t) face-spec)))
+ (when italic-p
+ (setq face-spec (append '(:italic t) face-spec)))
+ (when underline-p
+ (setq face-spec (append '(:underline t) face-spec)))
+ (custom-declare-face face (list (list t face-spec)) nil)))))))
+
+;; But now we do it the custom way. Note that `defface' will not overwrite any
+;; faces declared above via `custom-declare-face'.
+(defface font-lock-comment-face
+ '((((type tty) (class color)) (:foreground "red"))
+ (((class grayscale) (background light))
+ (:foreground "DimGray" :bold t :italic t))
+ (((class grayscale) (background dark))
+ (:foreground "LightGray" :bold t :italic t))
+ (((class color) (background light)) (:foreground "Firebrick"))
+ (((class color) (background dark)) (:foreground "OrangeRed"))
+ (t (:bold t :italic t)))
+ "Font Lock mode face used to highlight comments."
+ :group 'font-lock-highlighting-faces)
+
+(defface font-lock-string-face
+ '((((type tty) (class color)) (:foreground "green"))
+ (((class grayscale) (background light)) (:foreground "DimGray" :italic t))
+ (((class grayscale) (background dark)) (:foreground "LightGray" :italic t))
+ (((class color) (background light)) (:foreground "RosyBrown"))
+ (((class color) (background dark)) (:foreground "LightSalmon"))
+ (t (:italic t)))
+ "Font Lock mode face used to highlight strings."
+ :group 'font-lock-highlighting-faces)
+
+(defface font-lock-keyword-face
+ '((((type tty) (class color)) (:foreground "cyan" :weight bold))
+ (((class grayscale) (background light)) (:foreground "LightGray" :bold t))
+ (((class grayscale) (background dark)) (:foreground "DimGray" :bold t))
+ (((class color) (background light)) (:foreground "Purple"))
+ (((class color) (background dark)) (:foreground "Cyan"))
+ (t (:bold t)))
+ "Font Lock mode face used to highlight keywords."
+ :group 'font-lock-highlighting-faces)
+
+(defface font-lock-builtin-face
+ '((((type tty) (class color)) (:foreground "blue" :weight light))
+ (((class grayscale) (background light)) (:foreground "LightGray" :bold t))
+ (((class grayscale) (background dark)) (:foreground "DimGray" :bold t))
+ (((class color) (background light)) (:foreground "Orchid"))
+ (((class color) (background dark)) (:foreground "LightSteelBlue"))
+ (t (:bold t)))
+ "Font Lock mode face used to highlight builtins."
+ :group 'font-lock-highlighting-faces)
+
+(defface font-lock-function-name-face
+ '((((type tty) (class color)) (:foreground "blue" :weight bold))
+ (((class color) (background light)) (:foreground "Blue"))
+ (((class color) (background dark)) (:foreground "LightSkyBlue"))
+ (t (:inverse-video t :bold t)))
+ "Font Lock mode face used to highlight function names."
+ :group 'font-lock-highlighting-faces)
+
+(defface font-lock-variable-name-face
+ '((((type tty) (class color)) (:foreground "yellow" :weight light))
+ (((class grayscale) (background light))
+ (:foreground "Gray90" :bold t :italic t))
+ (((class grayscale) (background dark))
+ (:foreground "DimGray" :bold t :italic t))
+ (((class color) (background light)) (:foreground "DarkGoldenrod"))
+ (((class color) (background dark)) (:foreground "LightGoldenrod"))
+ (t (:bold t :italic t)))
+ "Font Lock mode face used to highlight variable names."
+ :group 'font-lock-highlighting-faces)
+
+(defface font-lock-type-face
+ '((((type tty) (class color)) (:foreground "green"))
+ (((class grayscale) (background light)) (:foreground "Gray90" :bold t))
+ (((class grayscale) (background dark)) (:foreground "DimGray" :bold t))
+ (((class color) (background light)) (:foreground "ForestGreen"))
+ (((class color) (background dark)) (:foreground "PaleGreen"))
+ (t (:bold t :underline t)))
+ "Font Lock mode face used to highlight type and classes."
+ :group 'font-lock-highlighting-faces)
+
+(defface font-lock-constant-face
+ '((((type tty) (class color)) (:foreground "magenta"))
+ (((class grayscale) (background light))
+ (:foreground "LightGray" :bold t :underline t))
+ (((class grayscale) (background dark))
+ (:foreground "Gray50" :bold t :underline t))
+ (((class color) (background light)) (:foreground "CadetBlue"))
+ (((class color) (background dark)) (:foreground "Aquamarine"))
+ (t (:bold t :underline t)))
+ "Font Lock mode face used to highlight constants and labels."
+ :group 'font-lock-highlighting-faces)
+
+(defface font-lock-warning-face
+ '((((type tty) (class color)) (:foreground "red"))
+ (((class color) (background light)) (:foreground "Red" :bold t))
+ (((class color) (background dark)) (:foreground "Pink" :bold t))
+ (t (:inverse-video t :bold t)))
+ "Font Lock mode face used to highlight warnings."
+ :group 'font-lock-highlighting-faces)
+
+;;; End of Colour etc. support.
+\f
+;;; Menu support.
+
+;; This section of code is commented out because Emacs does not have real menu
+;; buttons. (We can mimic them by putting "( ) " or "(X) " at the beginning of
+;; the menu entry text, but with Xt it looks both ugly and embarrassingly
+;; amateur.) If/When Emacs gets real menus buttons, put in menu-bar.el after
+;; the entry for "Text Properties" something like:
+;;
+;; (define-key menu-bar-edit-menu [font-lock]
+;; (cons "Syntax Highlighting" font-lock-menu))
+;;
+;; and remove a single ";" from the beginning of each line in the rest of this
+;; section. Probably the mechanism for telling the menu code what are menu
+;; buttons and when they are on or off needs tweaking. I have assumed that the
+;; mechanism is via `menu-toggle' and `menu-selected' symbol properties. sm.
+
+;;;;###autoload
+;(progn
+; ;; Make the Font Lock menu.
+; (defvar font-lock-menu (make-sparse-keymap "Syntax Highlighting"))
+; ;; Add the menu items in reverse order.
+; (define-key font-lock-menu [fontify-less]
+; '("Less In Current Buffer" . font-lock-fontify-less))
+; (define-key font-lock-menu [fontify-more]
+; '("More In Current Buffer" . font-lock-fontify-more))
+; (define-key font-lock-menu [font-lock-sep]
+; '("--"))
+; (define-key font-lock-menu [font-lock-mode]
+; '("In Current Buffer" . font-lock-mode))
+; (define-key font-lock-menu [global-font-lock-mode]
+; '("In All Buffers" . global-font-lock-mode)))
+;
+;;;;###autoload
+;(progn
+; ;; We put the appropriate `menu-enable' etc. symbol property values on when
+; ;; font-lock.el is loaded, so we don't need to autoload the three variables.
+; (put 'global-font-lock-mode 'menu-toggle t)
+; (put 'font-lock-mode 'menu-toggle t)
+; (put 'font-lock-fontify-more 'menu-enable '(identity))
+; (put 'font-lock-fontify-less 'menu-enable '(identity)))
+;
+;;; Put the appropriate symbol property values on now. See above.
+;(put 'global-font-lock-mode 'menu-selected 'global-font-lock-mode)
+;(put 'font-lock-mode 'menu-selected 'font-lock-mode)
+;(put 'font-lock-fontify-more 'menu-enable '(nth 2 font-lock-fontify-level))
+;(put 'font-lock-fontify-less 'menu-enable '(nth 1 font-lock-fontify-level))
+;
+;(defvar font-lock-fontify-level nil) ; For less/more fontification.
+;
+;(defun font-lock-fontify-level (level)
+; (let ((font-lock-maximum-decoration level))
+; (when font-lock-mode
+; (font-lock-mode))
+; (font-lock-mode)
+; (when font-lock-verbose
+; (message "Fontifying %s... level %d" (buffer-name) level))))
+;
+;(defun font-lock-fontify-less ()
+; "Fontify the current buffer with less decoration.
+;See `font-lock-maximum-decoration'."
+; (interactive)
+; ;; Check in case we get called interactively.
+; (if (nth 1 font-lock-fontify-level)
+; (font-lock-fontify-level (1- (car font-lock-fontify-level)))
+; (error "No less decoration")))
+;
+;(defun font-lock-fontify-more ()
+; "Fontify the current buffer with more decoration.
+;See `font-lock-maximum-decoration'."
+; (interactive)
+; ;; Check in case we get called interactively.
+; (if (nth 2 font-lock-fontify-level)
+; (font-lock-fontify-level (1+ (car font-lock-fontify-level)))
+; (error "No more decoration")))
+;
+;;; This should be called by `font-lock-set-defaults'.
+;(defun font-lock-set-menu ()
+; ;; Activate less/more fontification entries if there are multiple levels for
+; ;; the current buffer. Sets `font-lock-fontify-level' to be of the form
+; ;; (CURRENT-LEVEL IS-LOWER-LEVEL-P IS-HIGHER-LEVEL-P) for menu activation.
+; (let ((keywords (or (nth 0 font-lock-defaults)
+; (nth 1 (assq major-mode font-lock-defaults-alist))))
+; (level (font-lock-value-in-major-mode font-lock-maximum-decoration)))
+; (make-local-variable 'font-lock-fontify-level)
+; (if (or (symbolp keywords) (= (length keywords) 1))
+; (font-lock-unset-menu)
+; (cond ((eq level t)
+; (setq level (1- (length keywords))))
+; ((or (null level) (zerop level))
+; ;; The default level is usually, but not necessarily, level 1.
+; (setq level (- (length keywords)
+; (length (member (eval (car keywords))
+; (mapcar 'eval (cdr keywords))))))))
+; (setq font-lock-fontify-level (list level (> level 1)
+; (< level (1- (length keywords))))))))
+;
+;;; This should be called by `font-lock-unset-defaults'.
+;(defun font-lock-unset-menu ()
+; ;; Deactivate less/more fontification entries.
+; (setq font-lock-fontify-level nil))
+
+;;; End of Menu support.
+\f
+;;; Various regexp information shared by several modes.