;;; font-lock.el --- decorating source files with fonts/colors based on syntax
;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
;; Copyright (C) 1995 Amdahl Corporation.

;; Author: Jamie Zawinski <jwz@lucid.com>, for the LISPM Preservation Society.
;; Modified by: Ben Wing <wing@spg.amdahl.com>
;;	made configuration easier, added some code to delay fontification
;;	of adjacent pieces of inserted text until the post-command-hook
;;	is called
;; Keywords: languages, faces

;; This file is part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Synched up with: Not synched with FSF.

;;; Commentary:

;; Font-lock-mode is a minor mode that causes your comments to be
;; displayed in one face, strings in another, reserved words in another,
;; documentation strings in another, and so on.
;;
;; Comments will be displayed in `font-lock-comment-face'.
;; Strings will be displayed in `font-lock-string-face'.
;; Doc strings will be displayed in `font-lock-doc-string-face'.
;; Function and variable names (in their defining forms) will be
;;  displayed in `font-lock-function-name-face'.
;; Reserved words will be displayed in `font-lock-keyword-face'.
;;
;; Don't let the name fool you: you can highlight things using different
;; colors or background stipples instead of fonts, though that is not the
;; default.  See the variables `font-lock-use-colors' and
;; `font-lock-use-fonts' for broad control over this, or see the
;; documentation on faces and how to change their attributes for
;; fine-grained control.
;;
;; To make the text you type be fontified, use M-x font-lock-mode.  When
;; this minor mode is on, the fonts of the current line will be updated
;; with every insertion or deletion.
;;
;; By default, font-lock will automatically put newly loaded files
;; into font-lock-mode if it knows about the file's mode.  See the
;; variables `font-lock-auto-fontify', `font-lock-mode-enable-list',
;; and `font-lock-mode-disable-list' for control over this.
;;
;; The `font-lock-keywords' variable defines other patterns to highlight.
;; The default font-lock-mode-hook sets it to the value of the variables
;; lisp-font-lock-keywords, c-font-lock-keywords, etc, as appropriate.
;; The easiest way to change the highlighting patterns is to change the
;; values of c-font-lock-keywords and related variables.  See the doc
;; string of the variable `font-lock-keywords' for the appropriate syntax.
;;
;; The default value for `lisp-font-lock-keywords' is the value of the variable
;; `lisp-font-lock-keywords-1'.  You may like `lisp-font-lock-keywords-2' 
;; better; it highlights many more words, but is slower and makes your buffers
;; be very visually noisy.
;;
;; The same is true of `c-font-lock-keywords-1' and `c-font-lock-keywords-2';
;; the former is subdued, the latter is loud.
;;
;; You can make font-lock default to the gaudier variety of keyword
;; highlighting by setting the variable `font-lock-use-maximal-decoration'
;; before loading font-lock, or by calling the functions
;; `font-lock-use-default-maximal-decoration' or
;; `font-lock-use-default-minimal-decoration'.
;;
;; On a Sparc10, the initial fontification takes about 6 seconds for a typical
;; 140k file of C code, using the default configuration.  The actual speed
;; depends heavily on the type of code in the file, and how many non-syntactic
;; patterns match; for example, Xlib.h takes 23 seconds for 101k, because many
;; patterns match in it.  You can speed this up substantially by removing some
;; of the patterns that are highlighted by default.  Fontifying lisp code is
;; significantly faster, because lisp has a more regular syntax than C, so the
;; regular expressions don't have to be as complicated.
;;
;; It's called font-lock-mode here because on the Lispms it was called
;; "Electric Font Lock Mode."  It was called that because there was an older
;; mode called "Electric Caps Lock Mode" which had the function of causing all
;; of your source code to be in upper case except for strings and comments,
;; without you having to blip the caps lock key by hand all the time (thus the
;; "electric", as in `electric-c-brace'.)

;; See also the related packages `fast-lock' and `lazy-lock'.  Both
;; attempt to speed up the initial fontification.  `fast-lock' saves
;; the fontification info when you exit Emacs and reloads it next time
;; you load the file, so that the file doesn't have to be fontified
;; again.  `lazy-lock' does "lazy" fontification -- i.e. it only
;; fontifies the text as it becomes visible rather than fontifying
;; the whole file when it's first loaded in.

;;; Code:

(require 'text-props)

;;;;;;;;;;;;;;;;;;;;;;      user variables       ;;;;;;;;;;;;;;;;;;;;;;

;;;###autoload
(make-variable-buffer-local 'font-lock-keywords)
;;;###autoload
(defvar font-lock-keywords nil
  "*The keywords to highlight.
If this is a list, then elements may be of the forms:

  \"string\"			  ; a regexp to highlight in the 
				  ;  `font-lock-keyword-face'.
  (\"string\" . integer)  	  ; match N of the regexp will be highlighted
  (\"string\" . face-name)	  ; use the named face
  (\"string\" integer face-name)    ; both of the above
  (\"string\" integer face-name t)  ; this allows highlighting to overlap
				  ;  with already-highlighted regions.

These regular expressions should not match text which spans lines.  Multi-line
patterns will be correctly fontified when \\[font-lock-fontify-buffer] is used,
but will not be matched by the auto-fontification that font-lock-mode does,
since it looks at only one line at a time.

Be careful composing regexps for this list; the wrong pattern can dramatically
slow things down!")

(defvar font-lock-keywords-case-fold-search nil
  "*Whether the strings in `font-lock-keywords' should be case-folded.
This variable is automatically buffer-local, as the correct value depends
on the language in use.")
(make-variable-buffer-local 'font-lock-keywords-case-fold-search)

(defvar font-lock-verbose t
  "*Whether `font-lock-fontify-buffer' should print status messages.
See also `font-lock-message-threshold'.")

(defvar font-lock-message-threshold 6000
  "*Minimum size of region being fontified for status messages to appear.

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
changed region is large enough.)

Note that setting `font-lock-verbose' to nil disables the status
messages entirely.")

(defvar font-lock-mode-hook nil
  "Function or functions to run on entry to font-lock-mode.")

(defvar font-lock-after-fontify-buffer-hook nil
  "Function or functions to run after completion of font-lock-fontify-buffer.")

(defvar font-lock-use-syntax-tables t
  "Whether font-lock should bother doing syntactic fontification.
This should be true for all ``language'' modes, but other modes, like
dired, do not have anything useful in the syntax tables (no comment
or string delimiters, etc) and so there is no need to use them.
You should not set this variable; its value is automatically computed
by examining the syntax table.")

;;;###autoload
(defvar font-lock-auto-fontify t
  "*Whether font-lock should automatically fontify files as they're loaded.
This will only happen if font-lock has fontifying keywords for the major
mode of the file.  You can get finer-grained control over auto-fontification
by using this variable in combination with `font-lock-mode-enable-list' or
`font-lock-mode-disable-list'.")

;;;###autoload
(defvar font-lock-mode-enable-list nil
  "*List of modes to auto-fontify, if `font-lock-auto-fontify' is nil.")

;;;###autoload
(defvar font-lock-mode-disable-list nil
  "*List of modes not to auto-fontify, if `font-lock-auto-fontify' is t.")

;;;###autoload
(defvar font-lock-use-colors nil
  "*If true, font-lock will by default use colors to fontify text.
Set this *before* loading font-lock (e.g. in your init file).  You can
also explicitly reset the font-lock faces to these colors at any time by
calling the function `font-lock-use-default-colors'.

See also `font-lock-use-fonts'.  If you want more control over the faces
used for fontification, see the documentation of `font-lock-mode' for
how to do it.  In such a case, you might want to consider setting both
`font-lock-use-colors' and `font-lock-use-fonts' to nil to prevent
font-lock from initializing the faces.")

;;;###autoload
(defvar font-lock-use-fonts t
  "*If true, font-lock will by default use different fonts to fontify text.
Set this *before* loading font-lock (e.g. in your init file).  You can
also explicitly reset the font-lock faces to these fonts at any time by
calling the function `font-lock-use-default-fonts'.

See also `font-lock-use-colors'.  If you want more control over the faces
used for fontification, see the documentation of `font-lock-mode' for
how to do it.  In such a case, you might want to consider setting both
`font-lock-use-colors' and `font-lock-use-fonts' to nil to prevent
font-lock from initializing the faces.")

;;;###autoload
(defvar font-lock-use-maximal-decoration nil
  "*If true, font-lock will use a larger set of decorations than normal.
Set this *before* loading font-lock (e.g. in your init file).  This
typically results in keywords being fontified as well as comments
and strings and such; however, fontification will take longer.  If you
want to change this when font-lock is already loaded, use the functions
`font-lock-use-default-minimal-decoration' or
`font-lock-use-default-maximal-decoration'.")


;;;;;;;;;;;;;;;;;;;;;;        actual code        ;;;;;;;;;;;;;;;;;;;;;;

;;; To fontify the whole buffer by language syntax, we go through it a
;;; character at a time, creating extents on the boundary of each syntactic
;;; unit (that is, one extent for each block comment, one for each line
;;; comment, one for each string, etc.)  This is done with the C function
;;; syntactically-sectionize.  It's in C for speed (the speed of lisp function
;;; calls was a real bottleneck for this task since it involves examining each
;;; character in turn.)
;;;
;;; Then we make a second pass, to fontify the buffer based on other patterns
;;; specified by regexp.  When we find a match for a region of text, we need
;;; to change the fonts on those characters.  This is done with the
;;; put-text-property function, which knows how to efficiently share extents.
;;; Conceptually, we are attaching some particular face to each of the
;;; characters in a range, but the implementation of this involves creating
;;; extents, or resizing existing ones.
;;;
;;; Each time a modification happens to a line, we re-fontify the entire line.
;;; We do this by first removing the extents (text properties) on the line,
;;; and then doing the syntactic and keyword passes again on that line.  (More
;;; generally, each modified region is extended to include the preceeding and
;;; following BOL or EOL.)
;;;
;;; This means that, as the user types, we repeatedly go back to the beginning
;;; of the line, doing more work the longer the line gets.  This doesn't cost
;;; much in practice, and if we don't, then we incorrectly fontify things when,
;;; for example, inserting spaces into `intfoo () {}'.
;;;

(defsubst font-lock-set-face (start end face)
  ;; Set the face on the characters in the range.
  (put-nonduplicable-text-property start end 'face face)
  (put-nonduplicable-text-property start end 'font-lock t))

(defsubst font-lock-unfontify-region (start end &optional maybe-loudly)
  (if (and maybe-loudly font-lock-verbose
	   (>= (- end start) font-lock-message-threshold))
      (message "Fontifying %s..." (buffer-name)))
  ;; Clear all font-lock data on the characters in the range.
  (put-nonduplicable-text-property start end 'face nil)
  (put-nonduplicable-text-property start end 'font-lock nil))

(defsubst font-lock-any-extents-p (start end)
  ;; used to look for 'text-prop property, but this has problems
  ;; if you put any other text properties in the vicinity.
  ;; Simon Marshall suggested looking for the 'face property,
  ;; but that's equally bogus.  Only reliable way is for font-lock
  ;; to specially mark its extents.
  (map-extents 'extent-property (current-buffer) start end 'font-lock))

(defun font-lock-fontify-region (start end)
  (if (not font-lock-use-syntax-tables)
      nil
    (if (and font-lock-verbose
	     (>= (- end start) font-lock-message-threshold))
	(message "Fontifying %s... (syntactically...)" (buffer-name)))
    (goto-char start)
    (if (> end (point-max)) (setq end (point-max)))
    (syntactically-sectionize
      #'(lambda (s e context depth)
	  (let (face)
	    (cond ((eq context 'string)
		   ;;#### Should only do this is Lisp-like modes!
		   (setq face
			 (if (= depth 1)
			     ;; really we should only use this if
			     ;;  in position 3 depth 1, but that's
			     ;;  too expensive to compute.
			     'font-lock-doc-string-face
			   'font-lock-string-face)))
		  ((or (eq context 'comment)
		       (eq context 'block-comment))
		   (setq face 'font-lock-comment-face)
;		 ;; Don't fontify whitespace at the beginning of lines;
;		 ;;  otherwise comment blocks may not line up with code.
;		 ;; (This is sometimes a good idea, sometimes not; in any
;		 ;; event it should be in C for speed --jwz)
;		 (save-excursion
;		     (goto-char s)
;		     (while (prog1 (search-forward "\n" (1- e) 'move)
;			      (setq face 'font-lock-comment-face)
;			      (setq e (point)))
;		       (skip-chars-forward " \t\n")
;		       (setq s (point)))
		   ))
	    (font-lock-set-face s e face)))
      start end)
    ))

(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 may be deleted.
      (if (buffer-live-p (extent-buffer font-lock-old-extent))
	  (save-excursion
	    (set-buffer (extent-buffer 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)))

(defvar font-lock-executing-command-p nil)

(defun font-lock-pre-command-hook ()
  (setq font-lock-executing-command-p t))
  
(defun font-lock-post-command-hook ()
  (setq font-lock-executing-command-p nil)
  (if (and font-lock-old-extent
	   (not (input-pending-p)))
      (font-lock-fontify-glumped-region)))

;; Setting this to true disables the attempts that font-lock would otherwise
;; make to delay after-change fontifying until the post-command-hook is
;; called.  We set this to true because this stuff doesn't quite work yet.

(defvar font-lock-always-fontify-immediately t)

;;; called when any modification is made to buffer text.  This function
;;; attempts to glump adjacent changes together so that excessive
;;; fontification is avoided.  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
		   (extent-start-position font-lock-old-extent)))
	(oend (and font-lock-old-extent
		   (extent-end-position font-lock-old-extent)))
	(bc-end (+ beg old-len)))

    ;; 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-buffer 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 (or font-lock-always-fontify-immediately
	    (not font-lock-executing-command-p))
	(font-lock-fontify-glumped-region))))

(defun font-lock-after-change-function-1 (beg end old-len)
  (if (null font-lock-mode)
      nil
    (save-excursion
      (save-restriction
	;; if we don't widen, then fill-paragraph (and any command that
	;; operates on a narrowed region) confuses things, because the C
	;; code will fail to realize that we're inside a comment.
	(widen)
	(save-match-data
	  (let ((zmacs-region-stays zmacs-region-stays)) ; protect from change!
	    (goto-char beg)
	    ;; 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.
;;	    (if (or (> old-len 0) (bobp) (= (preceding-char) ?\n))
;;		(buffer-syntactic-context-flush-cache))

	    ;; Always recompute the whole line.
	    (goto-char end)
	    (forward-line 1)
	    (setq end (point))
	    (goto-char beg)
	    (beginning-of-line)
	    (setq beg (point))
	    (font-lock-unfontify-region beg end t)
	    (font-lock-fontify-region beg end)
	    (font-lock-hack-keywords beg end)))))))


;;; Fontifying arbitrary patterns

(defun font-lock-hack-keywords (start end)
  (let ((loudly (and font-lock-verbose
		     (>= (- end start) font-lock-message-threshold))))
    (if loudly (message "Fontifying %s... (regexps...)" (buffer-name)))
    (goto-char start)
    (let ((case-fold-search font-lock-keywords-case-fold-search)
	  (rest font-lock-keywords)
	  (count 0)
	  first str match face s e allow-overlap-p)
      (while rest
	(setq first (car rest))
	(goto-char start)
	(cond ((consp first)
	       (setq str (car first))
	       (cond ((consp (cdr first))
		      (setq match (nth 1 first)
			    face (nth 2 first)
			    allow-overlap-p (nth 3 first)))
		     ((symbolp (cdr first))
		      (setq match 0 allow-overlap-p nil
			    face (cdr first)))
		     (t
		      (setq match (cdr first)
			    allow-overlap-p nil
			    face 'font-lock-keyword-face))))
	      (t
	       (setq str first
		     match 0
		     allow-overlap-p nil
		     face 'font-lock-keyword-face)))
	(while (re-search-forward str end t)
	  (setq s (match-beginning match)
		e (match-end match))
	  (goto-char e) ;; tlp00 hack to allow for back to back fonts
	  (or s (error "expression did not match subexpression %d" match))
	  ;; don't fontify this keyword if we're already in some other context.
	  (or (= s e)
	      (if allow-overlap-p nil (font-lock-any-extents-p s (1- e)))
	      (font-lock-set-face s e face)))
	(if loudly (message "Fontifying %s... (regexps...%s)"
			    (buffer-name)
			    (make-string (setq count (1+ count)) ?.)))
	(setq rest (cdr rest))))
    (if loudly (message "Fontifying %s... done." (buffer-name)))))


;; The user level functions

;;;###autoload
(defvar font-lock-mode nil) ; for modeline
(add-minor-mode 'font-lock-mode " FLock" nil)

(defvar font-lock-fontified nil) ; whether we have hacked this buffer
(put 'font-lock-fontified 'permanent-local t)

;;;###autoload
(defun font-lock-mode (&optional arg)
  "Toggle Font Lock Mode.
With arg, turn font-lock mode on if and only if arg is positive.
In the font-lock minor mode, text is fontified as you type it:

 - comments are displayed in font-lock-comment-face;
 - strings are displayed in font-lock-string-face;
 - documentation strings are displayed in font-lock-doc-string-face;
 - function and variable names in their defining forms are displayed
   in font-lock-function-name-face;
 - and certain other expressions are displayed in other faces
   according to the value of the variable `font-lock-keywords'.

When font-lock mode is turned on/off, the buffer is fontified/defontified.
To fontify a buffer without having newly typed text become fontified, you
can use \\[font-lock-fontify-buffer].

See the variable `font-lock-keywords' for customization."
  (interactive "P")
  (let ((on-p (if (null arg)
		  (not font-lock-mode)
		(> (prefix-numeric-value arg) 0))))
    ;; 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))
    (cond (on-p
	   ;; make it all local so as not to clutter up all the buffers
	   (add-hook (make-local-variable 'after-change-functions)
		     'font-lock-after-change-function)
	   (add-hook 'local-pre-command-hook 'font-lock-pre-command-hook)
	   (add-hook 'local-post-command-hook 'font-lock-post-command-hook))
	  (t
	   (remove-hook 'after-change-functions
			'font-lock-after-change-function)
	   (remove-hook 'local-pre-command-hook 'font-lock-pre-command-hook)
	   (remove-hook 'local-post-command-hook 'font-lock-post-command-hook)
	   ))
    (set (make-local-variable 'font-lock-mode) on-p)
    (cond (on-p
	   (font-lock-examine-syntax-table)
	   (font-lock-set-defaults)
	   (run-hooks 'font-lock-mode-hook)
	   (or font-lock-fontified (font-lock-fontify-buffer)))
	  (font-lock-fontified
	   (setq font-lock-fontified nil)
	   (font-lock-unfontify-region (point-min) (point-max))))
    (redraw-modeline)))


;; For init-file hooks
;;;###autoload
(defun turn-on-font-lock ()
  "Unconditionally turn on Font Lock mode."
  (font-lock-mode 1))

;;;###autoload
(defun font-lock-fontify-buffer ()
  "Fontify the current buffer the way `font-lock-mode' would:

 - comments are displayed in font-lock-comment-face;
 - strings are displayed in font-lock-string-face;
 - documentation strings are displayed in font-lock-doc-string-face;
 - function and variable names in their defining forms are displayed
   in font-lock-function-name-face;
 - and certain other expressions are displayed in other faces
   according to the value of the variable `font-lock-keywords'.

This can take a while for large buffers."
  (interactive)
  (let ((was-on font-lock-mode)
	(font-lock-verbose (or font-lock-verbose (interactive-p)))
	(font-lock-message-threshold 0)
	(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
	  (font-lock-fontify-region (point-min) (point-max))
	  (font-lock-hack-keywords (point-min) (point-max)))
      (quit
       (setq aborted t)))

    (or was-on		; turn it off if it was off.
	(let ((font-lock-fontified nil)) ; kludge to prevent defontification
	  (font-lock-mode 0)))
    (set (make-local-variable 'font-lock-fontified) t)
    (if (and aborted font-lock-verbose)
	(message "Fontifying %s... aborted." (buffer-name)))
    )
  (run-hooks 'font-lock-after-fontify-buffer-hook))

(defun font-lock-examine-syntax-table ()
  "Computes the value of font-lock-use-syntax-tables for this buffer."
  (let ((i (1- (length (syntax-table))))
	(got-one nil))
    (if (eq (syntax-table) (standard-syntax-table))
	;; Assume that modes which haven't bothered to install their own
	;; syntax table don't do anything syntactically interesting.
	;; Really, the standard-syntax-table shouldn't have comments and
	;; strings in it, but changing that now might break things.
	nil
      ;; else map over the syntax table looking for strings or comments.
      (while (>= i 0)
	(if (memq (char-syntax i) '(?\" ?\< ?\> ?\$))
	    (setq got-one t i 0))
	(setq i (1- i))))
    (set (make-local-variable 'font-lock-use-syntax-tables) got-one)))

(defun font-lock-find-file-hook ()
  "Find-file hook for the font-lock package.
See the variable `font-lock-auto-fontify'."
  (if font-lock-mode
      nil		; don't do anything if font-lock is already active
    (font-lock-set-defaults) ; determine if we have keywords for this mode
    (if (and font-lock-keywords
	     (or (and font-lock-auto-fontify
		      (not (memq major-mode font-lock-mode-disable-list)))
		 (and (not font-lock-auto-fontify)
		      (memq major-mode font-lock-mode-enable-list))))
	(turn-on-font-lock))))


;;; Cruftiness for the Options menu

(defun font-lock-reset-face (face)
  "Reset FACE its default state (from the X resource database).
Returns whether it is indistinguishable from the default face."
  (reset-face face)
  (init-face-from-resources face)
  (face-differs-from-default-p face))

(defun font-lock-copy-face (from to)
  (if (font-lock-reset-face to)
      ;; warnings disabled because it's reasonable to do this on purpose
      '(warn "X resources override default for %s" to)
    (copy-face from to)))

(defun font-lock-set-foreground (color to)
  (if (font-lock-reset-face to)
      '(warn "X resources override default for %s" to)
    (set-face-foreground to color)))

(defun font-lock-use-default-fonts ()
  "Reset the font-lock faces to a default set of fonts."
  (interactive)
  (font-lock-copy-face 'italic 'font-lock-comment-face)
  ;; Underling comments looks terrible on tty's
  (set-face-underline-p 'font-lock-comment-face nil 'global 'tty)
  (set-face-highlight-p 'font-lock-comment-face t 'global 'tty)
  (font-lock-copy-face 'font-lock-comment-face 'font-lock-string-face)
  (font-lock-copy-face 'font-lock-string-face 'font-lock-doc-string-face)
  (font-lock-copy-face 'bold-italic 'font-lock-function-name-face)
  (font-lock-copy-face 'bold 'font-lock-keyword-face)
  (font-lock-copy-face 'bold 'font-lock-preprocessor-face)
  (font-lock-copy-face 'italic 'font-lock-type-face)
  ;; is this necessary?
  (remove-hook 'font-lock-mode-hook 'font-lock-use-default-fonts)
  nil)

(defun font-lock-use-default-colors ()
  "Reset the font-lock faces to a default set of colors."
  (interactive)
  (font-lock-copy-face 'default 'font-lock-comment-face)
  (font-lock-set-foreground "#6920ac" 'font-lock-comment-face)
  (font-lock-copy-face 'default 'font-lock-string-face)
  (font-lock-set-foreground "green4" 'font-lock-string-face)
  (font-lock-copy-face 'default 'font-lock-doc-string-face)
  (font-lock-set-foreground "green4" 'font-lock-doc-string-face)
  (font-lock-copy-face 'default 'font-lock-function-name-face)
  (font-lock-set-foreground "red3" 'font-lock-function-name-face)
  (font-lock-copy-face 'default 'font-lock-keyword-face)
  (font-lock-set-foreground "blue3" 'font-lock-keyword-face)
  (font-lock-copy-face 'default 'font-lock-preprocessor-face)
  (font-lock-set-foreground "blue3" 'font-lock-preprocessor-face)
  (font-lock-copy-face 'default 'font-lock-type-face)
  (font-lock-set-foreground "blue3" 'font-lock-type-face)
  ;; is this necessary?
  (remove-hook 'font-lock-mode-hook 'font-lock-use-default-colors)
  nil)

(defun font-lock-use-default-minimal-decoration ()
  "Reset the font-lock patterns to a fast, minimal set of decorations."
  (setq lisp-font-lock-keywords lisp-font-lock-keywords-1)
  (setq c-font-lock-keywords c-font-lock-keywords-1)
  (setq c++-font-lock-keywords c++-font-lock-keywords-1)
  (setq fortran-font-lock-keywords fortran-font-lock-keywords-1)
  ;; is this necessary?
  (remove-hook 'font-lock-mode-hook
	       'font-lock-use-default-minimal-decoration)
  nil)

(defun font-lock-use-default-maximal-decoration ()
  "Reset the font-lock patterns to a larger set of decorations."
  (setq lisp-font-lock-keywords lisp-font-lock-keywords-2)
  (setq c-font-lock-keywords c-font-lock-keywords-2)
  (setq c++-font-lock-keywords c++-font-lock-keywords-2)
  (setq fortran-font-lock-keywords fortran-font-lock-keywords-2)
  ;; is this necessary?
  (remove-hook 'font-lock-mode-hook
	       'font-lock-use-default-maximal-decoration)
  nil)


;;; Determining which set of font-lock keywords to use.

(defun font-lock-set-defaults ()
  ;; Tries to set font-lock-keywords to something appropriate for this mode.
  (let ((major (symbol-name major-mode))
        (try #'(lambda (n)
                 (if (stringp n) (setq n (intern-soft n)))
                 (if (and n
                          (boundp n))
                     n
                     nil))))
    (setq font-lock-keywords 
          (symbol-value
           (or (funcall try (get major-mode 'font-lock-keywords))
               (funcall try (concat major "-font-lock-keywords"))
               (funcall try (and (string-match "-mode\\'" major)
                                 (concat (substring 
                                          major 0 (match-beginning 0))
                                         "-font-lock-keywords")))
               'font-lock-keywords)))
    (setq font-lock-keywords-case-fold-search ; buffer-local
	  (get major-mode 'font-lock-keywords-case-fold-search))
    ))


;;;;;;;;;;;;;;;;;;;;;;         keywords         ;;;;;;;;;;;;;;;;;;;;;;

;;; Various major-mode interfaces.
;;; Probably these should go in with the source of the respective major modes.


;; These are the modes where the font-lock keywords are not trivially
;; deducible from the mode name (that is, modes where `FOO-mode' does
;; not use `FOO-font-lock-keywords'.)
;;
(put 'emacs-lisp-mode	'font-lock-keywords 'lisp-font-lock-keywords)
(put 'c++-c-mode	'font-lock-keywords 'c-font-lock-keywords)
;; the nine billion names of TeX mode...
(put 'plain-tex-mode	'font-lock-keywords 'tex-font-lock-keywords)
(put 'slitex-tex-mode	'font-lock-keywords 'tex-font-lock-keywords)
(put 'latex-tex-mode	'font-lock-keywords 'tex-font-lock-keywords)
(put 'LaTex-tex-mode	'font-lock-keywords 'tex-font-lock-keywords)
(put 'latex-mode        'font-lock-keywords 'tex-font-lock-keywords)
(put 'LaTeX-mode        'font-lock-keywords 'tex-font-lock-keywords)
(put 'japanese-LaTeX-mode 'font-lock-keywords 'text-font-lock-keywords)
(put 'japanese-SliTeX-mode 'font-lock-keywords 'text-font-lock-keywords)
(put 'SliTeX-mode	'font-lock-keywords 'text-font-lock-keywords)
(put 'FoilTeX-mode	'font-lock-keywords 'text-font-lock-keywords)

(defconst lisp-font-lock-keywords-1 (purecopy
 '(;;
   ;; highlight defining forms.  This doesn't work too nicely for
   ;; (defun (setf foo) ...) but it does work for (defvar foo) which
   ;; is more important.
   ("^(def[-a-z]+\\s +\\([^ \t\n\)]+\\)" 1 font-lock-function-name-face)
   ;;
   ;; highlight CL keywords (three clauses seems faster than one)
   ("\\s :\\(\\(\\sw\\|\\s_\\)+\\)\\>" . 1)
   ("(:\\(\\(\\sw\\|\\s_\\)+\\)\\>" . 1)
   ("':\\(\\(\\sw\\|\\s_\\)+\\)\\>" . 1)
   ;;
   ;; this is highlights things like (def* (setf foo) (bar baz)), but may
   ;; be slower (I haven't really thought about it)
;   ("^(def[-a-z]+\\s +\\(\\s(\\S)*\\s)\\|\\S(\\S *\\)"
;    1 font-lock-function-name-face)
   ))
 "For consideration as a value of `lisp-font-lock-keywords'.
This does fairly subdued highlighting.")

(defconst lisp-font-lock-keywords-2 (purecopy
  (append
   lisp-font-lock-keywords-1
   '(;;
     ;; Highlight control structures
     ("(\\(cond\\|if\\|when\\|unless\\|[ec]?\\(type\\)?case\\)[ \t\n]" . 1)
     ("(\\(while\\|do\\|let\\*?\\|flet\\|labels\\|prog[nv12*]?\\)[ \t\n]" . 1)
     ("(\\(do\\*\\|dotimes\\|dolist\\|loop\\)[ \t\n]" . 1)
     ("(\\(catch\\|\\throw\\|block\\|return\\|return-from\\)[ \t\n]" . 1)
     ("(\\(save-restriction\\|save-window-restriction\\)[ \t\n]" . 1)
     ("(\\(save-excursion\\|unwind-protect\\|condition-case\\)[ \t\n]" . 1)
     ;;
     ;; highlight function names in emacs-lisp docstrings (in the syntax
     ;; that substitute-command-keys understands.)
     ("\\\\\\\\\\[\\([^]\\\n]+\\)]" 1 font-lock-keyword-face t)
     ;;
     ;; highlight words inside `' which tend to be function names
     ("`\\([-a-zA-Z0-9_][-a-zA-Z0-9_][-a-zA-Z0-9_.]+\\)'"
      1 font-lock-keyword-face t)
     )))
 "For consideration as a value of `lisp-font-lock-keywords'.
This does a lot more highlighting.")

;; default to the gaudier variety?
;(defconst lisp-font-lock-keywords lisp-font-lock-keywords-2
;  "Additional expressions to highlight in lisp modes.")
(defconst lisp-font-lock-keywords lisp-font-lock-keywords-1
  "Additional expressions to highlight in lisp modes.")


(defconst c-font-lock-keywords-1 nil
 "For consideration as a value of `c-font-lock-keywords'.
This does fairly subdued highlighting.")

(defconst c-font-lock-keywords-2 nil
 "For consideration as a value of `c-font-lock-keywords'.
This does a lot more highlighting.")

(let ((storage "auto\\|extern\\|register\\|static\\|volatile")
      (prefixes "unsigned\\|short\\|long\\|const")
      (types (concat "int\\|long\\|char\\|float\\|double\\|void\\|struct\\|"
		     "union\\|enum\\|typedef"))
      (ctoken "\\(\\sw\\|\\s_\\|[:~*&]\\)+")
      )
  (setq c-font-lock-keywords-1 (purecopy
   (list
    ;; fontify preprocessor directives.
    '("^#[ \t]*[a-z]+" . font-lock-preprocessor-face)
    ;;
    ;; fontify names being defined.
    '("^#[ \t]*\\(define\\|undef\\)[ \t]+\\(\\(\\sw\\|\\s_\\)+\\)" 2
      font-lock-function-name-face)
    ;;
    ;; fontify other preprocessor lines.
    '("^#[ \t]*\\(if\\|ifn?def\\|elif\\)[ \t]+\\([^\n]+\\)"
      2 font-lock-function-name-face t)
    ;;
    ;; fontify the filename in #include <...>
    ;; don't need to do this for #include "..." because those were
    ;; already fontified as strings by the syntactic pass.
    ;; (Changed to not include the <> in the face, since "" aren't.)
    '("^#[ \t]*include[ \t]+<\\([^>\"\n]+\\)>" 1 font-lock-string-face)
    ;;
    ;; fontify the names of functions being defined.
    ;; I think this should be fast because it's anchored at bol, but it's not.
    (list (concat
	   "^\\(" ctoken "[ \t]+\\)?"	; type specs; there can be no
	   "\\(" ctoken "[ \t]+\\)?"	; more than 3 tokens, right?
	   "\\(" ctoken "[ \t]+\\)?"
	   "\\([*&]+[ \t]*\\)?"		; pointer
	   "\\(" ctoken "\\)[ \t]*(")	; name
	  8 'font-lock-function-name-face)
    ;;
    ;; This is faster but not by much.  I don't see why not.
;    (list (concat "^\\(" ctoken "\\)[ \t]*(") 1 'font-lock-function-name-face)
    ;;
    ;; Fontify structure names (in structure definition form).
    (list (concat "^\\(typedef[ \t]+struct\\|struct\\|static[ \t]+struct\\)"
		  "[ \t]+\\(" ctoken "\\)[ \t]*\\(\{\\|$\\)")
	  2 'font-lock-function-name-face)
    ;;
    ;; Fontify case clauses.  This is fast because its anchored on the left.
    '("case[ \t]+\\(\\(\\sw\\|\\s_\\)+\\):". 1)
    '("\\<\\(default\\):". 1)
    )))

  (setq c-font-lock-keywords-2 (purecopy
   (append c-font-lock-keywords-1
    (list
     ;;
     ;; fontify all storage classes and type specifiers
     ;; types should be surrounded by non alphanumerics (Raymond Toy)
     (cons (concat "\\<\\(" storage "\\)\\>") 'font-lock-type-face)
     (list (concat "\\([^a-zA-Z0-9_]\\|^\\)\\("
		   types
		   "\\)\\([^a-zA-Z0-9_]\\|$\\)")
	   2 'font-lock-type-face)
     ;; fontify the prefixes now.  The types should have been fontified
     ;; previously.
     (list (concat "\\<\\(" prefixes "\\)[ \t]+\\(" types "\\)\\>")
	   1 'font-lock-type-face)
     ;;
     ;; fontify all builtin tokens
     (cons (concat
	    "[ \t]\\("
	    (mapconcat 'identity
	     '("for" "while" "do" "return" "goto" "case" "break" "switch"
	       "if" "then" "else if" "else" "return" "continue" "default"
	       )
	     "\\|")
	    "\\)[ \t\n(){};,]")
	   1)
     ;;
     ;; fontify case targets and goto-tags.  This is slow because the
     ;; expression is anchored on the right.
     "\\(\\(\\sw\\|\\s_\\)+\\):"
     ;;
     ;; Fontify variables declared with structures, or typedef names.
     '("}[ \t*]*\\(\\(\\sw\\|\\s_\\)+\\)[ \t]*[,;]"
       1 font-lock-function-name-face)
     ;;
     ;; Fontify global variables without a type.
;     '("^\\([_a-zA-Z0-9:~*]+\\)[ \t]*[[;={]" 1 font-lock-function-name-face)

     ))))
  )


;; default to the gaudier variety?
;(defconst c-font-lock-keywords c-font-lock-keywords-2
;  "Additional expressions to highlight in C mode.")
(defconst c-font-lock-keywords c-font-lock-keywords-1
  "Additional expressions to highlight in C mode.")

(defconst c++-font-lock-keywords-1 nil
 "For consideration as a value of `c++-font-lock-keywords'.
This does fairly subdued highlighting.")

(defconst c++-font-lock-keywords-2 nil
 "For consideration as a value of `c++-font-lock-keywords'.
This does a lot more highlighting.")

(let ((ctoken "\\(\\sw\\|\\s_\\|[:~*&]\\)+")
      (c++-types (concat "complex\\|public\\|private\\|protected\\|virtual\\|"
			 "friend\\|inline"))
      c++-font-lock-keywords-internal-1
      c++-font-lock-keywords-internal-2
      )
  (setq c++-font-lock-keywords-internal-1 (purecopy
   (list
    ;;
    ;; fontify friend operator functions
    '("^\\(operator[^(]*\\)(" 1 font-lock-function-name-face)
    '("^\\(operator[ \\t]*([ \\t]*)[^(]*\\)(" 1 font-lock-function-name-face)

    ;; fontify the class names only in the definition
    (list (concat "^class[ \t]+" ctoken "[ \t\n{: ;]") 1
	  'font-lock-function-name-face)

    (list (concat
	   "^\\(" ctoken "[ \t]+\\)?" ; type specs; there can be no
	   "\\(" ctoken "[ \t]+\\)?" ; more than 3 tokens, right?
	   "\\(" ctoken "[ \t]+\\)?"
	   "\\(\\*+[ \t]*\\)?"	; pointer
	   "\\(" ctoken "\\(::\\)?~?\\(\\(operator[ \t]*[^ \ta-zA-Z]+\\)\\|"
	   ctoken "\\)\\)[ \t]*(") ; name
	  8 'font-lock-function-name-face t)
    )))

  (setq c++-font-lock-keywords-internal-2 (purecopy
   (list
    ;; fontify extra c++ storage classes and type specifiers
    (cons (concat "\\<\\(" c++-types "\\)\\>") 'font-lock-type-face)

    ;;special check for class
    '("^\\(\\<\\|template[ \t]+<[ \t]*\\)\\(class\\)[ \t\n]+" 2
      font-lock-type-face)

    ;; special handling of template
    "^\\(template\\)\\>"
    ;; fontify extra c++ builtin tokens
    (cons (concat
	   "[ \t]\\("
	   (mapconcat 'identity
		      '("asm" "catch" "throw" "try" "delete" "new" "operator"
			"sizeof" "this"
			)
		      "\\|")
	   "\\)[ \t\n(){};,]")
	  1)
    )))

  (setq c++-font-lock-keywords-1 (purecopy
   (append c-font-lock-keywords-1 c++-font-lock-keywords-internal-1)))

  (setq c++-font-lock-keywords-2 (purecopy
   (append c-font-lock-keywords-2 c++-font-lock-keywords-internal-1
	   c++-font-lock-keywords-internal-2)))
  )

(defconst c++-font-lock-keywords c++-font-lock-keywords-1
  "Additional expressions to highlight in C++ mode.")


;; Added by Bob Weiner, Motorola, Inc., 2/16/94.
;; Lots of embedded developers still program in assembler and this
;; works well for a number of assemblers.  Comments are handled by the
;; syntax tables.
(defconst asm-font-lock-keywords (purecopy
 '(
   ("^\\(\\sw\\|\\s_\\)+" 0 font-lock-function-name-face)
   ("^\\(\\sw\\|\\s_\\)+:?\\s +\\(\\sw+\\)" 2 font-lock-keyword-face)
   ("^\\s +\\(\\(\\sw\\|\\s_\\)+\\)" 1 font-lock-keyword-face)
   ))
 "Additional expressions to highlight in assembler mode.")

(defconst perl-font-lock-keywords (purecopy
  (list
   (cons (concat "[ \n\t{]*\\("
		 (mapconcat 'identity
			    '("if" "until" "while" "elsif" "else" "unless"
			      "for" "foreach" "continue" "exit" "die" "last"
			      "goto" "next" "redo" "return" "local" "exec")
			    "\\|")
		 "\\)[ \n\t;(]")
	 1)
        (mapconcat 'identity
                   '("#endif" "#else" "#ifdef" "#ifndef" "#if" "#include"
                     "#define" "#undef")
                   "\\|")
        '("^[ \n\t]*sub[ \t]+\\([^ \t{]+\\)[ \n\t]*\\{"
          1 font-lock-function-name-face)
        '("[ \n\t{]*\\(eval\\)[ \n\t(;]" 
          1 font-lock-function-name-face)
        ;; '("\\(--- .* ---\\|=== .* ===\\)" 1 font-lock-doc-string-face)
        ))
  "Additional expressions to highlight in Perl mode.")

(defconst tex-font-lock-keywords (purecopy
  (list
   ;; Lionel Mallet: Thu Oct 14 09:41:38 1993
   ;; I've added an exit condition to the regexp below, and the other
   ;; regexps for the second part.
   ;; What would be useful here is something like:
   ;; ("\\(\\\\\\w+\\)\\({\\(\\w+\\)}\\)+" 1 font-lock-keyword-face t 3
   ;;  font-lock-function-name-face t)
   '("\\(\\\\\\w+\\)\\W" 1 font-lock-keyword-face t)
   '("\\(\\\\\\w+\\){\\([^}\n]+\\)}" 2 font-lock-function-name-face t)
   '("\\(\\\\\\w+\\){\\(\\w+\\)}{\\(\\w+\\)}" 3
     font-lock-function-name-face t)
   '("\\(\\\\\\w+\\){\\(\\w+\\)}{\\(\\w+\\)}{\\(\\w+\\)}" 4
     font-lock-function-name-face t)
   '("{\\\\em\\([^}]+\\)}" 1 font-lock-comment-face t)
   '("{\\\\bf\\([^}]+\\)}" 1 font-lock-keyword-face t)
   '("^[ \t\n]*\\\\def[\\\\@]\\(\\w+\\)\\W" 1 font-lock-function-name-face t)
   ;; Lionel Mallet: Thu Oct 14 09:40:10 1993
   ;; the regexp below is useless as it is now covered by the first 2 regexps
   ;;   '("\\\\\\(begin\\|end\\){\\([a-zA-Z0-9\\*]+\\)}"
   ;;     2 font-lock-function-name-face t)
   '("[^\\\\]\\$\\([^$]*\\)\\$" 1 font-lock-string-face t)
;   '("\\$\\([^$]*\\)\\$" 1 font-lock-string-face t)
   ))
  "Additional expressions to highlight in TeX mode.")

(defconst texinfo-font-lock-keywords (purecopy
  (list
   "@\\(@\\|[^}\t \n{]+\\)"					;commands
   '("^\\(@c\\|@comment\\)[ \t].*$" 0 font-lock-comment-face t)	;comments
   '("^\\(*.*\\)[\t ]*$" 1 font-lock-function-name-face t)	;menu items
   '("@\\(emph\\|strong\\|b\\|i\\){\\([^}]+\\)" 2 font-lock-comment-face t)
   '("@\\(file\\|kbd\\|key\\){\\([^}]+\\)" 2 font-lock-string-face t)
   '("@\\(samp\\|code\\|var\\){\\([^}]+\\)" 2 font-lock-function-name-face t)
   '("@\\(xref\\|pxref\\){\\([^}]+\\)" 2 font-lock-keyword-face t)
   '("@end *\\([a-zA-Z0-9]+\\)[ \t]*$" 1 font-lock-function-name-face t)
   '("@item \\(.*\\)$" 1 font-lock-function-name-face t)
   '("\\$\\([^$]*\\)\\$" 1 font-lock-string-face t)
   ))
  "Additional expressions to highlight in TeXinfo mode.")

(defconst postscript-font-lock-keywords (purecopy
   (list
    ;; Proper rule for Postscript strings
    '("(\\([^)]\\|\\\\.\\|\\\\\n\\)*)" . font-lock-string-face)
    ;; Make any line beginning with a / be a ``keyword''
    '("^/[^\n%]*" . font-lock-keyword-face)
    ;; Make brackets of all forms be keywords
    '("[][<>{}]+" . font-lock-keyword-face)
    ;; Keywords
    (list (concat 
	   "[][ \t\f\n\r()<>{}/%]"	;delimiter
	   "\\("
	   (mapconcat 'identity
		      '("begin" "end" 
			"save" "restore" "gsave" "grestore"
			;; Any delimited name ending in 'def'
			"[a-zA-Z0-9-._]*def"
			"[Dd]efine[a-zA-Z0-9-._]*")
		      "\\|")
	   "\\)"
	   "\\([][ \t\f\n\r()<>{}/%]\\|$\\)" ;delimiter
	   )
	  1 'font-lock-keyword-face)))
   "Expressions to highlight in Postscript buffers.")

(defconst scheme-font-lock-keywords (purecopy
 '(("(define[ \t]+(?\\([^ \t\n\)]+\\)" 1 font-lock-function-name-face)
   ("(\\(cond\\|lambda\\|begin\\|if\\|else\\|case\\|do\\)[ \t\n]" . 1)
   ("(\\(\\|letrec\\|let\\*?\\|set!\\|and\\|or\\)[ \t\n]" . 1)
   ("(\\(quote\\|unquote\\|quasiquote\\|unquote-splicing\\)[ \t\n]" . 1)
   ("(\\(syntax\\|syntax-rules\\|define-syntax\\|let-syntax\\|letrec-syntax\\)[ \t\n]" . 1)))
  "Expressions to highlight in Scheme buffers.")

(defconst dired-font-lock-keywords (purecopy
  (let ((bn (concat "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|"
		    "Aug\\|Sep\\|Oct\\|Nov\\|Dec\\) +[0-9]+ +[0-9:]+")))
    (list
     '("^  [/~].*:$" . bold-italic)				   ; Header
     (list (concat "^\\(\\([^ ].*\\)" bn "\\) \\(.*\\)$") 1 'bold) ; Marked
     (list (concat "^. +d.*" bn " \\(.*\\)$") 2 'bold)		   ; Subdirs
     (list (concat "^. +l.*" bn " \\(.*\\)$") 2 'italic)	   ; Links
     (cons (concat "^. +-..[xsS]......\\|"	; Regular files with executable
		   "^. +-.....[xsS]...\\|"	; or setuid/setgid bits set
		   "^. +-........[xsS]")
	   'bold)
     ;; Possibly we should highlight more types of files differently:
     ;; backups; autosaves; core files?  Those with ignored-extensions?
     )))
  "Expressions to highlight in Dired buffers.")

(defconst ada-font-lock-keywords (purecopy
  (let ((ident  "\\(\\(\\sw\\|\\s_\\)+\\)") ; indent is 2nd capture
	(decl-1 "\\(procedure\\|function\\|package\\)[ \t]+") ; 1 ()
	(decl-2 "\\(task\\|package\\)[ \t]+body[ \t]+")	; 1()
	(kwords-1			; "normal" keywords
	 '("abort" "abs" "accept" "access" "array" "begin" "body" "case"
	   "constant" "declare" "delay" "delta" "digits" "else" "elsif"
	   "entry" "exception" "exit" "function"  "generic" "goto" "if"
	   "others" "limited" "loop" "mod" "new" "null" "out" "subtype"
	   "package" "pragma" "private" "procedure" "raise" "range" "record"
	   "rem" "renames" "return" "reverse" "select" "separate" "task"
	   "terminate" "then" "type" "when" "while" "with" "xor"))
	(kwords-2	; keywords that may appear at the end of a word AND
			; may also be preceeded by a non-space.
	 '("and" "at" "do" "end" "for" "in" "is" "not" "of" "or" "use"))
	)
    (list
     ;;'("\\(--.*\\)" 1 font-lock-comment-face t) ; syntax table should do this
     (list (concat "^[ \t]*" decl-2 ident) 3 'font-lock-function-name-face)
     (list (concat "^[ \t]*" decl-1 ident) 3 'font-lock-function-name-face)
     (cons (concat "\\(" (mapconcat 'identity kwords-1 "\\|") "\\)[ \n\t;(]")
	   1)
     (cons (concat "[ \t+=*/---]\\(" (mapconcat 'identity kwords-2 "\\|")
		   "\\)[ \n\t;(]")
	   1)
     (cons "^\\(end\\)[ \n\t;(]" 1)
     (cons "\\.\\(all\\)" 1)
     )))
  "Expressions to highlight in Ada buffers.")

(defconst ksh-font-lock-keywords (purecopy
  (list
   '("\\(^\\|[^\$\\\]\\)#.*" . font-lock-comment-face)
   '("\\<\\(if\\|then\\|else\\|elif\\|fi\\|case\\|esac\\|for\\|do\\|done\\|foreach\\|in\\|end\\|select\\|while\\|repeat\\|time\\|function\\|until\\|exec\\|command\\|coproc\\|noglob\\|nohup\\|nocorrect\\|source\\|autoload\\|alias\\|unalias\\|export\\|set\\|echo\\|eval\\|cd\\|log\\|compctl\\)\\>" . font-lock-keyword-face)
   '("\\<\\[\\[.*\\]\\]\\>" . font-lock-type-face)
   '("\$\(.*\)" . font-lock-type-face)
   ))
  "Additional expressions to highlight in ksh-mode.")

(defconst sh-font-lock-keywords (purecopy
  (list
   '("\\(^\\|[^\$\\\]\\)#.*" . font-lock-comment-face)
   '("\\<\\(if\\|then\\|else\\|elif\\|fi\\|case\\|esac\\|for\\|do\\|done\\|in\\|while\\|exec\\|export\\|set\\|echo\\|eval\\|cd\\)\\>" . font-lock-keyword-face)
   '("\\[.*\\]" . font-lock-type-face)
   '("`.*`" . font-lock-type-face)
   ))
  "Additional expressions to highlight in sh-mode.")

(defconst pascal-font-lock-keywords (purecopy
  (list
   '("^[ \t]*\\(function\\|pro\\(cedure\\|gram\\)\\)\\>[ \t]*\\(\\sw+\\)?"
     1 font-lock-keyword-face)
   '("^[ \t]*\\(function\\|pro\\(cedure\\|gram\\)\\)\\>[ \t]*\\(\\sw+\\)?"
     3 font-lock-function-name-face t)
;   ("type" "const" "real" "integer" "char" "boolean" "var"
;    "record" "array" "file")
   (cons (concat "\\<\\(array\\|boolean\\|c\\(har\\|onst\\)\\|file\\|"
		 "integer\\|re\\(al\\|cord\\)\\|type\\|var\\)\\>")
	 'font-lock-type-face)
   '("\\<\\(label\\|external\\|forward\\)\\>" . font-lock-reference-face)
   '("\\<\\([0-9]+\\)[ \t]*:" 1 font-lock-reference-face)
;   ("of" "to" "for" "if" "then" "else" "case" "while"
;    "do" "until" "and" "or" "not" "in" "with" "repeat" "begin" "end")
   (concat "\\<\\("
	   "and\\|begin\\|case\\|do\\|e\\(lse\\|nd\\)\\|for\\|i[fn]\\|"
	   "not\\|o[fr]\\|repeat\\|t\\(hen\\|o\\)\\|until\\|w\\(hile\\|ith\\)"
	   "\\)\\>")
   '("\\<\\(goto\\)\\>[ \t]*\\([0-9]+\\)?"
     1 font-lock-keyword-face)
   '("\\<\\(goto\\)\\>[ \t]*\\([0-9]+\\)?"
     2 font-lock-reference-face t)))
  "Additional expressions to highlight in Pascal mode.")

(defconst python-font-lock-keywords
  (purecopy
   (list
    (cons (concat "\\b\\("
                  (mapconcat 'identity
                             '("access"     "del"        "from"
                               "lambda"     "return"     "and"
                               "elif"       "global"     "not"
                               "try:"       "break "     "else:"
                               "if"         "or"         "while"
                               "except"     "except:"    "import"
                               "pass"       "continue"   "finally:"
                               "in"         "print"      "for"
                               "is"         "raise")
                             "\\|")
                  "\\)[ \n\t(]")
          1)
    '("\\bclass[ \t]+\\([a-zA-Z_]+[a-zA-Z0-9_]*\\)"
      1 font-lock-type-face)
    '("\\bdef[ \t]+\\([a-zA-Z_]+[a-zA-Z0-9_]*\\)"
      1 font-lock-function-name-face)
    ))
  "Additional expressions to highlight in Python mode.")

(defconst compilation-font-lock-keywords (purecopy
  (list
   '("^[-_.\"A-Za-z0-9/+]+\\(:\\|, line \\)[0-9]+: \\([wW]arning:\\).*$" .
     font-lock-keyword-face)
   '("^[-_.\"A-Za-z0-9/+]+\\(: *\\|, line \\)[0-9]+:.*$" . font-lock-function-name-face)
   '("^[^:\n]+-[a-zA-Z][^:\n]+$" . font-lock-doc-string-face)
   '("\\(^[-_.\"A-Za-z0-9/+]+\\)\\(: *\\|, line \\)[0-9]+" 1 font-lock-string-face t)
   '("^[-_.\"A-Za-z0-9/+]+\\(: *[0-9]+\\|, line [0-9]+\\)" 1 bold t)
   ))
  "Additional expressions to highlight in compilation buffers.")

(defconst makefile-font-lock-keywords (purecopy
  (list
   '("^#.*$" . font-lock-comment-face)
   '("[^$]#.*$" . font-lock-comment-face)
   ;; rules
   '("^\\([^ \t\n]*%?[^ \t\n]*[ \t]*::?\\)[ \t]" 1 font-lock-type-face t)
   '("^\\(\\.[A-Za-z][A-Za-z]?\\..[ \t]*::?\\)" 1 font-lock-type-face t)
   '("^[^ \t\n]+[ \t]*:;?\\(.*\\)$" 1 font-lock-doc-string-face t)
   ;; variable definition
   '("^[_A-Za-z0-9]+[ \t]*\+?=" . font-lock-function-name-face)
   '("\\( \\|:=\\)[_A-Za-z0-9]+[ \t]*\\+=" . font-lock-function-name-face)
   ;; variable references
   '("\\(\\$\\$?\\([^ \t\n{(]\\|[{(][^ \t\n)}]+[)}]\\)\\)" 
     1 font-lock-keyword-face t)
   '("^include " . font-lock-string-face)
   ))
  "Additional expressions to highlight in makefiles")

(defconst rexx-font-lock-keywords
  (purecopy
   (list
    (cons (concat "\\<\\("
     (mapconcat 'identity
     '("address" "arg" "break" "call" "do" "drop" "echo" "else" "end"
      "exit" "if" "interpret" "iterate" "leave" "nop" "numeric"
      "options" "otherwise" "parse" "procedure" "pull" "push" "queue"
      "return" "say" "select" "shell" "signal" "then" "trace" "upper"
      "when" "value" "to" "by" "for" "forever" "while" "until" "form"
      "digits" "fuzz" "scientific" "engineering" "failat" "prompt"
      "results" "upper" "external" "source" "with" "command"
      "function" "var" "version" "expose" "on" "off")
     "\\|") "\\)\\>") 'font-lock-keyword-face)
   '("\\(\\sw+\\):" 1 font-lock-function-name-face)))
  "Additional expressions to highlight in Rexx mode.")

(defconst fortran-font-lock-keywords-1
  (purecopy
   (list
    ;; fontify comments
    '("^[cC*].*$" . font-lock-comment-face)
    ;;
    ;; fontify preprocessor directives.
    '("^#[ \t]*[a-z]+" . font-lock-preprocessor-face)
    ;;
    ;; fontify names being defined.
    '("^#[ \t]*\\(define\\|undef\\)[ \t]+\\(\\(\\sw\\|\\s_\\)+\\)" 2
      font-lock-function-name-face)
    ;;
    ;; fontify other preprocessor lines.
    '("^#[ \t]*\\(if\\|ifn?def\\|elif\\)[ \t]+\\([^\n]+\\)"
      2 font-lock-function-name-face t)

    ;; Subroutine and function declarations
    '("^[ \t]*subroutine.*$" . font-lock-function-name-face)
    '("^[ \t].*function.*$" . font-lock-function-name-face)
    '("^[ \t].*program.*$" . font-lock-function-name-face)
    '("^[ \t].*entry.*$" . font-lock-function-name-face)
    ))
  "For consideration as a value of `fortran-font-lock-keywords'.
This does fairly subdued highlighting of comments and function names.")

(defconst fortran-font-lock-keywords-2
  (purecopy
   (append fortran-font-lock-keywords-1
    (list
     ;; Variable declarations
     '("^[ \t]*\\(\\(integer\\|logical\\|real\\|complex\\|double[ \t]*precision\\|character\\|parameter\\)[^ \t]*\\)" 
       1 font-lock-keyword-face)
     ;; Common blocks, external, etc
     '("^[ \t]*\\(common\\|save\\|external\\|intrinsic\\|data\\)" 1 font-lock-keyword-face)
     ;; Other keywords
     '("^[ \t]*[0-9]*[ \t]*\\(if\\)[ \t]*("
       1 font-lock-keyword-face)

     ;; Then
     ;; '("^\\(\\([ \t]*[0-9]*[ \t]*\\)\\|\\(      [^ ]\\)\\).*[ \t]*\\(then\\)[ \t]*"
     ;;   4 font-lock-keyword-face)
     '("\\(then\\)[ \t]*$" 1 font-lock-keyword-face)

     ;; '("^[ \t]*[0-9]*[ \t]*\\(end[ \t]*if\\)[ \t]*$"
     '("\\(end[ \t]*if\\)[ \t]*$"
       1 font-lock-keyword-face)      
     ;; '("\\(else[ \t]*\\(if\\)?\\)"
     ;; the below works better <mdb@cdc.noaa.gov>
     '("^[ \t]*[0-9]*[ \t]*\\(else[ \t]*\\(if\\)?\\)"
       1 font-lock-keyword-face)
     '("^[ \t]*[0-9]*[ \t]*\\(do\\)[ \t]*[0-9]+"
       1 font-lock-keyword-face)
     '("^[ \t]*[0-9]*[ \t]*\\(do\\)[ \t]*[a-z0-9_$]+[ \t]*="
       1 font-lock-keyword-face)
     '("^[ \t]*[0-9]*[ \t]*\\(end[ \t]*do\\)"
       1 font-lock-keyword-face)
     '("^[ \t]*[0-9]+[ \t]*\\(continue\\)" 1 font-lock-keyword-face)
     '("^[ \t]*[0-9]*[ \t]*\\(call\\)" 1 font-lock-keyword-face)
     '("^[ \t]*[0-9]*[ \t]*\\(go[ \t]*to\\)" 1 font-lock-keyword-face)

     '("^[ \t]*[0-9]*[ \t]*\\(open\\|close\\|read\\|write\\|format\\)[ \t]*("
       1 font-lock-keyword-face)
     '("^[ \t]*[0-9]*[ \t]*\\(print\\)[ \t]*[*'0-9]+" 1 font-lock-keyword-face)

     '("^[ \t]*[0-9]*[ \t]*\\(end\\|return\\)[ \t]*$" 1 font-lock-keyword-face)

     '("^[ \t]*[0-9]*[ \t]*\\(stop\\)[ \t]*['0-9]*" 1 font-lock-keyword-face)

     ;; Boolean and relational operations, logical true and false
     '("\\.\\(and\\|or\\|not\\|lt\\|le\\|eq\\|ge\\|gt\\|ne\\|true\\|false\\)\\."
       . font-lock-keyword-face)
     )))
  "For consideration as a value of `fortran-font-lock-keywords'.
This highlights variable types, \"keywords,\" etc.")

;; The keywords in the preceding lists assume case-insensitivity.
(put 'fortran-mode 'font-lock-keywords-case-fold-search t)
(put 'ada-mode 'font-lock-keywords-case-fold-search t)

(defconst fortran-font-lock-keywords fortran-font-lock-keywords-1
  "Additional expressions to highlight in Fortran mode.")


;;;;;;;;;;;;;;;;;;;;;;      initialization       ;;;;;;;;;;;;;;;;;;;;;;

(add-hook 'find-file-hooks 'font-lock-find-file-hook t)

(make-face 'font-lock-comment-face)
(make-face 'font-lock-doc-string-face)
(make-face 'font-lock-string-face)
(make-face 'font-lock-function-name-face)
(make-face 'font-lock-keyword-face)
(make-face 'font-lock-preprocessor-face)
(make-face 'font-lock-type-face)

(cond (font-lock-use-colors (font-lock-use-default-colors))
      (font-lock-use-fonts (font-lock-use-default-fonts)))

(if font-lock-use-maximal-decoration
    (font-lock-use-default-maximal-decoration))


(provide 'font-lock)

;;; font-lock.el ends here
