code.delx.au - gnu-emacs/blob - lisp/hilit19.el

   1 ;; hilit19.el (Release 2.7) -- customizable highlighting for Emacs19.
   2 ;; Copyright (c) 1993 Free Software Foundation, Inc.
   3 ;;
   4 ;; Author:   Jonathan Stigelman <Stig@netcom.com>
   5 ;; Keywords: faces
   6 ;;
   7 ;; This program is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation; either version 2 of the License, or
  10 ;; (at your option) any later version.
  11 ;;
  12 ;; This program is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16 ;;
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with this program; if not, write to the Free Software
  19 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20 ;;
  21
  22 ;;; Commentary:
  23
  24 ;; Hilit19.el is a customizable highlighting package for Emacs19.  It supports
  25 ;; not only source code highlighting, but also Info, RMAIL, VM, gnus...
  26 ;; Hilit19 knows (or thinks it knows) how to highlight emacs buffers in
  27 ;; about 25 different modes.
  28 ;;
  29 ;; WHERE TO GET THE LATEST VERSIONS OF HILIT19.EL (beta and release),
  30 ;; PLUS LOTS OF OTHER *WAY COOL* STUFF VIA ANONYMOUS FTP:
  31 ;;
  32 ;;      netcom.com:/pub/stig/src/{Beta,Release}/hilit19.el.gz
  33 ;;
  34 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  35 ;;
  36 ;; TO SUBMIT BUG REPORTS (or feedback of any sort)...
  37 ;;
  38 ;;    M-x hilit-submit-feedback RET
  39 ;;
  40 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41 ;;
  42 ;; hilit19.el,v 2.7 1993/07/30 02:43:01 stig Release
  43 ;;
  44 ;; LCD Archive Entry:
  45 ;; hilit19|Jonathan Stigelman|Stig@netcom.com|
  46 ;; Comprehensive (and comparatively fast) regex-based highlighting for Emacs 19|
  47 ;; 1993/07/30 02:43:01|Release 2.7|~/packages/hilit19.el.Z|
  48 ;;
  49 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  50 ;;
  51 ;; GENERAL OVERVIEW
  52 ;;
  53 ;;      This package installs numerous hooks to colorfully highlight your
  54 ;;      source code buffers as well as mail and news buffers.  Most
  55 ;;      programming languages have predefined highlighting patterns.
  56 ;;      Just load hilit19 and files will be automatically highlighted as
  57 ;;      they're loaded.
  58 ;;
  59 ;;      Rehighlight a buffer by typing C-S-l (control-shift-lowercase-L).
  60 ;;
  61 ;;      If, when you edit the buffer, the coloring gets messed up, just
  62 ;;      redraw and the coloring will be adjusted.  If automatic highlighting
  63 ;;      in the current buffer has been turned off, then typing C-u C-S-l will
  64 ;;      force a rehighlight of the entire buffer.
  65 ;;
  66 ;;      Hilit19 can build faces by examining the names that you give to them
  67 ;;      For example, green/black-bold-italic-underline would be created as
  68 ;;      a face with a green foreground, and a black background, using a
  69 ;;      bold-italic font...with underlining for good measure.
  70 ;;
  71 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  72 ;;
  73 ;; SETUP -- In your .emacs:
  74 ;;
  75 ;;
  76 ;; (cond (window-system
  77 ;;        (setq hilit-mode-enable-list  '(not text-mode)
  78 ;;              hilit-background-mode   'light
  79 ;;              hilit-inhibit-hooks     nil
  80 ;;              hilit-inhibit-rebinding nil)
  81 ;;
  82 ;;        (require 'hilit19)
  83 ;;        ))
  84 ;;
  85 ;; If you like font-lock-mode and want to use both packages, then you can
  86 ;; disable hilit for the modes in which you want to use font-lock by listing
  87 ;; said modes in hilit-mode-enable-list.
  88 ;;
  89 ;;      (hilit-translate type     'RoyalBlue   ; enable highlighting in C/C++
  90 ;;                       string   nil)         ; disable string highlighting
  91 ;;
  92 ;; To get 100% of the utility of hilit19, you may also have to apply the
  93 ;; patches below for info.el and vm5.33L_19/vm-summary.el
  94 ;;
  95 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  96 ;;
  97 ;; SETUP -- Are you using the right font for Emacs?
  98 ;;
  99 ;; Emacs cannot properly find bold and italic fonts unless you specify a
 100 ;; verbose X11 font name.  Here's a good font menu:
 101 ;;
 102 ;; (setq
 103 ;;  x-fixed-font-alist
 104 ;;  '("Font Menu"
 105 ;;    ("Fonts"
 106 ;;     ("6x12" "-misc-fixed-medium-r-semicondensed--12-110-75-75-c-60-*-1")
 107 ;;     ("6x13" "-misc-fixed-medium-r-semicondensed--13-120-75-75-c-60-*-1")
 108 ;;     ("lucida 13"
 109 ;;      "-b&h-lucidatypewriter-medium-r-normal-sans-0-0-0-0-m-0-*-1")
 110 ;;     ("7x13" "-misc-fixed-medium-r-normal--13-120-75-75-c-70-*-1")
 111 ;;     ("7x14" "-misc-fixed-medium-r-normal--14-130-75-75-c-70-*-1")
 112 ;;     ("9x15" "-misc-fixed-medium-r-normal--15-140-*-*-c-*-*-1")
 113 ;;     ("")
 114 ;;     ("clean 8x8" "-schumacher-clean-medium-r-normal--*-80-*-*-c-*-*-1")
 115 ;;     ("clean 8x14" "-schumacher-clean-medium-r-normal--*-140-*-*-c-*-*-1")
 116 ;;     ("clean 8x10" "-schumacher-clean-medium-r-normal--*-100-*-*-c-*-*-1")
 117 ;;     ("clean 8x16" "-schumacher-clean-medium-r-normal--*-160-*-*-c-*-*-1")
 118 ;;     ("")
 119 ;;     ("sony 8x16" "-sony-fixed-medium-r-normal--16-120-100-100-c-80-*-1")
 120 ;;     ("")
 121 ;;     ("-- Courier --")
 122 ;;     ("Courier 10" "-adobe-courier-medium-r-normal--*-100-*-*-m-*-*-1")
 123 ;;     ("Courier 12" "-adobe-courier-medium-r-normal--*-120-*-*-m-*-*-1")
 124 ;;     ("Courier 14" "-adobe-courier-medium-r-normal--*-140-*-*-m-*-*-1")
 125 ;;     ("Courier 18" "-adobe-courier-medium-r-normal--*-180-*-*-m-*-*-1")
 126 ;;     ("Courier 18-b" "-adobe-courier-bold-r-normal--*-180-*-*-m-*-*-1")
 127 ;;     )))
 128 ;;
 129 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 130 ;;
 131 ;; KNOWN BUGS/TO DO LIST/HELP WANTED/APPLY WITHIN
 132 ;;
 133 ;; * When more than one size of font is used in different frames, only one
 134 ;;   font size can have bold & italic properties.
 135 ;;
 136 ;; * When identifiers such as remove_switch_entry, ar highlighted in C/C++,
 137 ;;   imbedded keywords--"switch" in this case--are highlighted.  I don't
 138 ;;   personally see this problem because I modify the syntax for C/C++ so that
 139 ;;   ?_ is a word character "w".  This also means that forward-word skips over
 140 ;;   entire variables.  This will be fixed when I generalize the highlighting
 141 ;;   patterns.
 142 ;;
 143 ;; * unbalanced, unescaped double quote characters can confuse hilit19.
 144 ;;   This will be fixed, so don't bug me about it.
 145 ;;
 146 ;; * ALTHOUGH HILIT19 IS FASTER THAN FONT-LOCK-MODE...
 147 ;;   For various reasons, the speed of the package could still stand to be
 148 ;;   improved.  If you care to do a little profiling and make things tighter...
 149 ;;
 150 ;; * hilit-toggle-highlight is flaky when auto-rehighlight is neither t nor nil.
 151 ;;   Does anyone actually USE this?  I think I might just remove it.
 152 ;;
 153 ;; PROJECTS THAT YOU CAN TAKE OVER BECAUSE I DON'T MUCH CARE ABOUT THEM...
 154 ;;
 155 ;; * Moved hilit-wysiwyg-replace here from my version of man.el, this is not
 156 ;;   a bug.  The bug is that I don't have a reverse operation yet...just a
 157 ;;   stub Wysiwyg-anything really belongs in a package of it's own.
 158 ;;
 159 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 160 ;;
 161 ;; Thanks to the following people for their input:
 162 ;;    ebert@enpc.enpc.fr (Rolf EBERT), ada, LaTeX & bibtex highlights
 163 ;;    Vivek Khera <khera@cs.duke.edu>, gnus hooks + random advice & patches
 164 ;;    brian@athe.WUstl.EDU (Brian Dunford-Shore), prolog highlights
 165 ;;    John Ladwig <jladwig@soils.umn.edu>, 1st pass nroff highlights
 166 ;;    campo@sunthpi3.difi.unipi.it (Massimo Campostrini), fortran highlights
 167 ;;    jayb@laplace.MATH.ColoState.EDU (Jay Bourland), 1st pass dired
 168 ;;    Yoshio Turner <yoshio@CS.UCLA.EDU>, modula 2 highlights
 169 ;;    Fritz Knabe <knabe@ecrc.de>, advice & patches
 170 ;;    Alon Albert <alon@milcse.rtsg.mot.com>, advice & patches
 171 ;;    dana@thumper.bellcore.com (Dana A. Chee), working on the multi-frame bug
 172 ;;    derway@ndc.com (Don Erway), for breaking it...
 173 ;;
 174 ;; With suggestions and minor regex patches from numerous others...
 175 ;;
 176 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 177 ;;
 178 ;; hilit19.el,v
 179 ;; Revision 2.7  1993/07/30  02:43:01  stig
 180 ;; added const to the list of modifiers for C/C++ types
 181 ;;
 182 ;; Revision 2.6  1993/07/30  00:30:54  stig
 183 ;; now permit selection of arbitrary subexpressions for highlighting...
 184 ;; fixed keyword patterns for C/C++ using this technique.
 185 ;;
 186 ;; Revision 2.5  1993/07/28  05:02:56  stig
 187 ;; improvements to makefile regular expressions
 188 ;; removed about 130 lines just by compacting the big defconst for
 189 ;;   hilit-face-translation-table into a mapcar and defining a separate table
 190 ;;   of default faces.
 191 ;;
 192 ;; Revision 2.4  1993/07/27  14:09:05  stig
 193 ;; documented another "known problem" to "head off gripe mail at the pass."
 194 ;;
 195 ;; Revision 2.3  1993/07/27  02:15:49  stig
 196 ;; (hilit-lookup-face-create) incorporated patch which improves it's behavior
 197 ;; with more than one frame...  Still can't have bold on the same face in two
 198 ;; differrent fonts sizes at the same time...
 199 ;;
 200 ;; Revision 2.2  1993/07/27  02:02:59  stig
 201 ;; vastly improved the makefile patterns
 202 ;; added hook for mh-show-mode
 203 ;;
 204 ;; Revision 2.1  1993/07/24  17:46:21  stig
 205 ;; Phasing out Info-select-hook...  Version 19.18 will use Info-selection-hook.
 206 ;;
 207 ;; Revision 2.0  1993/07/24  13:50:10  stig
 208 ;; better documentation and added the function hilit-submit-feedback.
 209 ;; C-S-l (control shift l) repaints the buffer.  Other bindings are optional.
 210 ;; multi-line highlights no longer cause problems when
 211 ;;   hilit-auto-rehighlight is 'visible
 212 ;; added hilit-predefined-face-list...
 213 ;; changed name of hilit-mode-alist to hilit-patterns-alist
 214 ;; added hilit-message-quietly to mail-setup-hook
 215 ;; added hilit-parser-alist which can be used to apply different patterns to
 216 ;;   different parts of a buffer.  This could be integrated in a far more
 217 ;;   elegant manner, but it presently serves the purpose of not applying
 218 ;;   message header patterns to message bodies in mail-mode and it's kin.
 219 ;; hilit-set-mode-patterns now takes a list of modes and an optional parse-fn
 220 ;;
 221
 222 ;;;;;; AND THIS CAN BE APPLIED TO VM 5.33L_19
 223 ;;
 224 ;; *** ../site/vm5.33L_19/vm-summary.el    Fri Jun  4 22:17:11 1993
 225 ;; --- ./vm-summary.el     Tue Jun 22 16:39:30 1993
 226 ;; ***************
 227 ;; *** 152,158 ****
 228 ;;                   (insert "->")
 229 ;;                   (delete-char 2)
 230 ;;                   (forward-char -2)
 231 ;; !                 (and w vm-auto-center-summary (vm-auto-center-summary))))
 232 ;;             (and old-window (select-window old-window)))))))
 233 ;;
 234 ;;   (defun vm-mark-for-display-update (message)
 235 ;; --- 152,159 ----
 236 ;;                   (insert "->")
 237 ;;                   (delete-char 2)
 238 ;;                   (forward-char -2)
 239 ;; !                 (and w vm-auto-center-summary (vm-auto-center-summary))
 240 ;; !                 (run-hooks 'vm-summary-pointer-hook)))
 241 ;;             (and old-window (select-window old-window)))))))
 242 ;;
 243 ;;   (defun vm-mark-for-display-update (message)
 244 ;;
 245 ;;;;;;
 246 \f
 247 ;;; Code:
 248
 249 ;; User Options:
 250
 251 (defvar hilit-quietly nil
 252   "* If non-nil, this inhibits progress indicators during highlighting")
 253
 254 (defvar hilit-auto-highlight t
 255   "* T if we should highlight all buffers as we find 'em, nil to disable
 256   automatic highlighting by the find-file hook.")
 257
 258 (defvar hilit-auto-highlight-maxout 57000
 259   "* auto-highlight is disabled in buffers larger than this")
 260
 261 (defvar hilit-auto-rehighlight t
 262   "* If this is non-nil, then hilit-redraw and hilit-recenter will also
 263   rehighlight part or all of the current buffer.  T will rehighlight the
 264   whole buffer, a NUMBER will rehighlight that many lines before and after
 265   the cursor, and the symbol 'visible' will rehighlight only the visible
 266   portion of the current buffer.  This variable is buffer-local.")
 267
 268 (make-variable-buffer-local 'hilit-auto-rehighlight)
 269
 270 (defvar hilit-auto-rehighlight-fallback '(20000 . 100)
 271   "* Cons of the form (THRESHOLD . FALLBACK), where FALLBACK is assigned to
 272   hilit-auto-rehighlight if the size of a newly opened buffer is larger than
 273   THRESHOLD.")
 274
 275 (defvar hilit-face-check t
 276   "* T slows down highlighting but permits the user to change fonts without
 277   losing bold and italic faces...  T causes hilit-lookup-face-create to dig
 278   through the frame parameters for the current window every time it's called.
 279   If you never change fonts in emacs, set this to NIL.")
 280
 281 ;; Variables which must be set before loading hilit19.
 282
 283 (defvar hilit-inhibit-rebinding nil
 284   "If non-nil, this inhibits replacement of recenter, yank, and yank-pop.")
 285
 286 (defvar hilit-inhibit-hooks nil
 287   "If non-nil, this inhibits installation of hooks for Info, gnus, & vm.")
 288
 289 (defvar hilit-background-mode 'light
 290   "'mono inhibits color, 'dark or 'light indicate the background brightness.")
 291
 292 (defvar hilit-mode-enable-list nil
 293   "If a list of modes to exclusively enable or specifically disable.
 294 The sense of the list is negated if it begins with the symbol 'not'.
 295 Set this variable before you load hilit19.
 296
 297 Ex:  (perl-mode jargon-mode c-mode)     ; just perl, C, and jargon modes
 298      (not text-mode)                    ; all modes except text mode")
 299
 300 ;; Variables that are not generally modified directly
 301
 302 (defvar hilit-parser-alist nil
 303   "alist of major-mode values and parsers called by hilit-rehighlight-buffer.
 304
 305 Parsers for a given mode are IGNORED for partial rehighlights...maybe you'd
 306 like to make this more universal?")
 307
 308 (defvar hilit-patterns-alist nil
 309   "alist of major-mode values and default highlighting patterns
 310
 311 A hilighting pattern is a list of the form (start end face), where
 312 start is a regex, end is a regex (or nil if it's not needed) and face
 313 is the name of an entry in hilit-face-translation-table, the name of a face,
 314 or nil (which disables the pattern).
 315
 316 See the hilit-lookup-face-create documentation for valid face names.")
 317
 318 (defvar hilit-predefined-face-list (face-list)
 319   "List of faces with which hilit-lookup-face-create will NOT tamper.
 320
 321 If hilit19 is dumped into emacs at your site, you may have to set this in
 322 your init file.")
 323
 324 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 325 ;; Use this to report bugs:
 326
 327 (eval-when-compile (require 'reporter)) ; no compilation gripes
 328
 329 (defun hilit-submit-feeback ()
 330   "Submit feedback on hilit19 to the author: Stig@netcom.com"
 331   (interactive)
 332   (require 'reporter)
 333   (and (y-or-n-p "Do you really want to submit a report on hilit19? ")
 334        (reporter-submit-bug-report
 335         "Jonathan Stigelman <Stig@netcom.com>"
 336         "hilit19.el (Release 2.7)"
 337         (and (y-or-n-p "Do you need to include a dump hilit variables? ")
 338              (append
 339               '(
 340                 hilit-quietly                   hilit-inhibit-hooks
 341                 hilit-background-mode           hilit-mode-enable-list
 342                 hilit-auto-highlight            hilit-auto-highlight-maxout
 343                 hilit-auto-rehighlight          hilit-auto-rehighlight-fallback
 344                 hilit-face-check
 345                 )
 346               (and (y-or-n-p "Have you modified the standard patterns? ")
 347                    (yes-or-no-p "Are your patterns *REALLY* relevant? ")
 348                    '(hilit-parser-alist
 349                      hilit-patterns-alist
 350                      hilit-predefined-face-list
 351                      ))))
 352          (function
 353           (lambda ()
 354             (and (y-or-n-p "Is this a problem with font display? ")
 355                  (insert "\nFrame Configuration:\n====================\n"
 356                          (prin1-to-string (frame-configuration-to-register ?F))
 357                          "\n"
 358                          ))))
 359          nil
 360          (concat
 361           "This is (check all that apply, and delete what's irrelevant):\n"
 362           "  [ ] a _MASSIVE_THANK_YOU_ for writing hilit19.el\n"
 363           "  [ ] An invitation to attend the next Hackers Conference\n"
 364           "  [ ] my DONATION to your vacation fund (prototype digital cash)\n"
 365           "  [ ] You're a RIGHTEOUS HACKER, what are your rates?\n"
 366           "  [ ] I've used the force and read the source, but I'M CONFUSED\n"
 367           "  [ ] a PATCH (diff -cw oldversion newversion) to fix a problem\n"
 368           "  [ ] a REPRODUCABLE BUG that I do not believe to be an EMACS bug\n"
 369           "     - I *swear* that it's not already mentioned in the KNOWN BUGS\n"
 370           "     - Also, I have checked netcom.com:/pub/stig/src/hilit19.el.gz\n"
 371           "       for a newer release that fixes the problem.\n"
 372           "  [ ] ADVICE -- or an unfulfilled desire that I suspect you share\n"
 373           "\n"
 374           "Hey Stig, I *know* you're busy but...\n"))))
 375
 376 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 377 ;;
 378 ;; These faces are either a valid face name, or nil
 379 ;; if you want to change them, you must do so AFTER hilit19 is loaded
 380
 381 (defconst hilit-default-face-table
 382   '(
 383     ;; used for C/C++ and elisp and perl
 384     (comment    firebrick-italic    moccasin           italic)
 385     (include    purple              Plum1              default-bold-italic)
 386     (define     ForestGreen-bold    green              bold)
 387     (defun      blue-bold           cyan-bold          default-bold-italic)
 388     (decl       RoyalBlue           cyan               bold)
 389     (type       nil                 yellow             nil)
 390     (keyword    RoyalBlue           cyan               default-bold-italic)
 391     (label      red-bold            orange-underlined  underline)
 392     (string     grey40              orange             underline)
 393
 394     ;; some further faces for Ada
 395     (struct       black-bold        white-bold         bold)
 396     (glob-struct  magenta           Plum1              default-bold-underline)
 397     (named-param  DarkGoldenrod     Goldenrod          underline)
 398
 399     ;; and anotherone for LaTeX
 400     (crossref     DarkGoldenrod     Goldenrod          underline)
 401
 402     ;; compilation buffers
 403     (active-error default/pink-bold  default/DeepPink-bold  bold-underline)
 404     (error        red-bold           yellow                 bold)
 405     (warning      blue-italic        green                  italic)
 406
 407     ;; Makefiles (some faces borrowed from C/C++ too)
 408     (rule         blue-bold-underline cyan-underline   bold-underline)
 409
 410     ;; VM, GNUS and Text mode
 411     (msg-subject    blue-bold       yellow             bold)
 412     (msg-from       purple-bold     SeaGreen           bold)
 413     (msg-header     firebrick-bold  cyan               italic)
 414     (msg-separator  black/tan-bold  lightblue          nil)
 415     (msg-quote      ForestGreen     green              italic)
 416
 417     (summary-seen     grey40        white              nil)
 418     (summary-killed   grey50        white              nil)
 419     (summary-Xed      OliveDrab2    green              nil)
 420     (summary-deleted  firebrick     white              italic)
 421     (summary-unread   RoyalBlue     yellow             bold)
 422     (summary-new      blue-bold     yellow-bold        default-bold-italic)
 423     (summary-current  default/skyblue-bold green/LightGrey-bold reverse-default)
 424
 425     (gnus-group-unsubscribed grey50             white       nil)
 426     (gnus-group-empty        nil                yellow      nil)
 427     (gnus-group-full         ForestGreen        green       italic)
 428     (gnus-group-overflowing  firebrick          orange      default-bold-italic)
 429
 430     ;; dired mode
 431     (dired-directory blue-bold         cyan            bold)
 432     (dired-link      firebrick-italic  green           italic)
 433     (dired-ignored   ForestGreen       moccasin        nil)
 434     (dired-deleted   red-bold-italic   orange          default-bold-italic)
 435     (dired-marked    purple            Plum1           nil)
 436
 437     ;; Info-mode, and jargon-mode.el and prep.ai.mit.edu:/pub/gnu/jargon*
 438     (jargon-entry    blue-bold         cyan            bold)
 439     (jargon-xref     purple-bold       Plum1           italic)
 440     (jargon-keyword  firebrick-underline yellow        underline)
 441     )
 442   "alist of default faces (face . (light-default dark-default mono-default))")
 443
 444 (defconst hilit-face-translation-table
 445   (let ((index (or (cdr (assq hilit-background-mode
 446                               '((light . 1) (dark . 2))))
 447                    3)))
 448     (mapcar (function (lambda (x) (cons (car x) (nth index x))))
 449             hilit-default-face-table))
 450   "alist that maps symbolic face-names to real face names")
 451
 452 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 453 ;; To translate one face to another...
 454 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 455
 456 (defmacro hilit-translate (&rest args)
 457   "(hilit-translate FROM TO FROM TO ...): translate each face FROM to the
 458 value of its TO face.  This is like setq for faces.
 459
 460 The function hilit-lookup-face-create will repeatedly translate until no more
 461 translations for the face exist in the translation table.
 462
 463 See the documentation for hilit-lookup-face-create for names of valid faces."
 464   (or (zerop (% (length args) 2))
 465       (error "wrong number of args"))
 466   (let (cmdl from to)
 467     (while args
 468       (setq from (car args) to (nth 1 args) args (nthcdr 2 args)
 469             cmdl (cons (list 'hilit-associate ''hilit-face-translation-table
 470                              (list 'quote from) to)
 471                        cmdl)))
 472     (cons 'progn cmdl)))
 473
 474 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 475 ;; This function actually translates and then creates the faces...
 476 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 477
 478 (defun hilit-lookup-face-create (face &optional force)
 479   "Get a FACE, or create it if it doesn't exist.  In order for it to
 480 properly create the face, the followwing naming convention must be used:
 481     [reverse-](fgcolor[/bgcolor])[-bold][-italic][-underline]
 482 Example: (hilit-lookup-face-create 'comment-face) might create and return 'red
 483
 484 Each color is either the name of an X color (see .../X11/lib/X11/rgb.txt),
 485 a hexadecimal specification of the form \"hex-[0-9A-Fa-f]+\", or \"default\".
 486
 487 An optional argument, FORCE, will cause the face to be recopied from the
 488 default...which is probably of use only if you've changed fonts.
 489
 490 See the documentation for hilit-translate and hilit-face-translation-table."
 491
 492 ;; translate the face ...
 493   (let ((trec t) visited)
 494     (while trec
 495       (cond ((memq face visited) (error "face translation loop: %S" visited))
 496             (t (setq visited (cons face visited)
 497                      trec (assq face hilit-face-translation-table))
 498                (and trec (setq face (cdr trec)))))))
 499
 500   ;; make the face if we need to...
 501   (let* ((fn (symbol-name face))
 502          (frame (selected-frame))
 503          (basefont (cdr (assq 'font (frame-parameters frame))))
 504          error fgcolor bgcolor)
 505     (cond
 506      ((or (null face)
 507           (memq face hilit-predefined-face-list))
 508       ;; do nothing if the face is nil or if it's predefined.
 509       )
 510      ((or force
 511           (not (memq face (face-list)))
 512           (and hilit-face-check
 513                (not (string= (get face 'basefont) basefont))))
 514       (copy-face 'default 'scratch-face)
 515       (if (string-match "^reverse-?" fn)
 516           (progn (invert-face 'scratch-face)
 517                  (setq fn (substring fn (match-end 0)))))
 518
 519       ;; parse foreground color
 520       (if (string-match "^\\(hex-\\)?\\([A-Za-z0-9]+\\)" fn)
 521           (setq fgcolor (concat
 522                          (if (match-beginning 1) "#")
 523                          (substring fn (match-beginning 2) (match-end 2)))
 524                 fn (substring fn (match-end 0)))
 525         (error "bad face name %S" face))
 526
 527       ;; parse background color
 528       (if (string-match "^/\\(hex-\\)?\\([A-Za-z0-9]+\\)" fn)
 529           (setq bgcolor (concat
 530                          (and (match-beginning 1) "#")
 531                          (substring fn (match-beginning 2) (match-end 2)))
 532                 fn (substring fn (match-end 0))))
 533
 534       (and (string= "default" fgcolor) (setq fgcolor nil))
 535       (and (string= "default" bgcolor) (setq bgcolor nil))
 536
 537       ;; catch errors if we can't allocate the color(s)
 538       (condition-case nil
 539           (progn (set-face-foreground 'scratch-face fgcolor)
 540                  (set-face-background 'scratch-face bgcolor)
 541                  (copy-face 'scratch-face face)
 542                  (put face 'basefont basefont))
 543         (error (message "couldn't allocate color for '%s'"
 544                         (symbol-name face))
 545                (setq face 'default)
 546                (setq error t)))
 547       (or error
 548           ;; don't bother w/ bold or italic if we didn't get the color
 549           ;; we wanted, but ignore errors making the face bold or italic
 550           ;; if the font isn't available, there's nothing to do about it...
 551           (progn
 552             (set-face-font face nil frame)
 553             (set-face-underline-p face (string-match "underline" fn))
 554             (if (string-match ".*bold" fn)
 555                 (progn
 556                   ;; first, fix up this frame's face
 557                   (make-face-bold face frame  'noerr)
 558                   ;; now, fix up the face from the global list
 559                   (set-face-font face (face-font face frame) t)))
 560             (if (string-match ".*italic" fn)
 561                 (progn
 562                   ;; first, fix up this frame's face
 563                   (make-face-italic face frame 'noerr)
 564                   ;; now, fix up the face from the global list
 565                   (set-face-font face (face-font face frame) t)))
 566             ))
 567       )))
 568   face)
 569
 570 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 571 ;; Region Highlight/Unhighlight code (Both overlay and text-property versions)
 572 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 573
 574 (defsubst hilit-region-set-face (start end face-name &optional prio prop)
 575   "Highlight region from START to END using FACE and, optionally, PRIO.
 576 The optional 5th arg, PROP is a property to set instead of 'hilit."
 577   (let ((overlay (make-overlay start end)))
 578     (overlay-put overlay 'face face-name)
 579     (overlay-put overlay (or prop 'hilit) t)
 580     (and prio (overlay-put overlay 'priority prio))))
 581
 582 (defun hilit-unhighlight-region (start end &optional quietly)
 583   "Unhighlights the region from START to END, optionally in a QUIET way"
 584   (interactive "r")
 585   (or quietly hilit-quietly (message "Unhighlighting"))
 586   (while (< start end)
 587     (mapcar (function (lambda (ovr)
 588                         (and (overlay-get ovr 'hilit) (delete-overlay ovr))))
 589             (overlays-at start))
 590     (setq start (next-overlay-change start)))
 591   (or quietly hilit-quietly (message "Done unhighlighting")))
 592
 593 ;;;; These functions use text properties instead of overlays.  Text properties
 594 ;;;; are copied through kill and yank...which might be convenient, but is not
 595 ;;;; terribly efficient as of 19.12, ERGO it's been disabled
 596 ;;
 597 ;;(defsubst hilit-region-set-face (start end face-name &optional prio prop)
 598 ;;  "Highlight region from START to END using FACE and, optionally, PRIO.
 599 ;;The optional 5th arg, PROP is a property to set instead of 'hilit."
 600 ;;    (put-text-property start end 'face face-name)
 601 ;;    )
 602 ;;
 603 ;;(defun hilit-unhighlight-region (start end &optional quietly)
 604 ;;  "Unhighlights the region from START to END, optionally in a QUIET way"
 605 ;;  (interactive "r")
 606 ;;  (let ((buffer-read-only nil)
 607 ;;      (bm (buffer-modified-p)))
 608 ;;    (remove-text-properties start end '(face))
 609 ;;    (set-buffer-modified-p bm)))
 610 ;;;;
 611
 612 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 613 ;; Pattern Application code and user functions
 614 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 615
 616 (defun hilit-highlight-region (start end &optional patterns quietly)
 617   "Highlights the area of the buffer between START and END (the region when
 618 interactive).  Without the optional PATTERNS argument, the pattern for
 619 major-mode is used.  If PATTERNS is a symbol, then the patterns associated
 620 with that symbol are used.  QUIETLY suppresses progress messages if
 621 non-nil."
 622   (interactive "r")
 623   (cond ((null patterns)
 624          (setq patterns (cdr (assq major-mode hilit-patterns-alist))))
 625         ((symbolp patterns)
 626          (setq patterns (cdr (assq patterns hilit-patterns-alist)))))
 627   ;; txt prop: (setq patterns (reverse patterns))
 628   (let ((prio (length patterns))
 629         (case-fold-search nil)
 630         ;; txt prop: (buffer-read-only nil)
 631         ;; txt prop: (bm (buffer-modified-p))
 632         p pstart pend face mstart)
 633     ;; txt prop: (unwind-protect
 634     (save-excursion
 635       (save-restriction
 636         (narrow-to-region start end)
 637         (while patterns
 638           (setq p (car patterns))
 639           (setq pstart (car p)
 640                 pend (nth 1 p)
 641                 face (hilit-lookup-face-create (nth 2 p)))
 642           (if (not face)                ; skipped if nil
 643               nil
 644             (or quietly hilit-quietly
 645                 (message "highlighting %d: %s%s" prio pstart
 646                          (if pend (concat " ... " pend) "")))
 647             (goto-char (point-min))
 648             (condition-case nil
 649                 (cond
 650                       ((symbolp pstart)
 651                        ;; inner loop -- special function to find pattern
 652                        (let (region)
 653                          (while (setq region (funcall pstart pend))
 654                            (hilit-region-set-face (car region) (cdr region)
 655                                                   face prio))))
 656                       ((stringp pend)
 657                        ;; inner loop -- regex-start ... regex-end
 658                        (while (re-search-forward pstart nil t nil)
 659                          (goto-char (setq mstart (match-beginning 0)))
 660                          (if (re-search-forward pend nil t nil)
 661                              (hilit-region-set-face mstart (match-end 0)
 662                                                     face prio)
 663                            (forward-char 1))))
 664                       (t
 665                        (or (numberp pend) (setq pend 0))
 666                        ;; inner loop -- just one regex to match whole pattern
 667                        (while (re-search-forward pstart nil t nil)
 668                          (hilit-region-set-face  (match-beginning pend)
 669                                                  (match-end pend) face prio))))
 670               (error (message "Unbalanced delimiters?  Barfed on '%s'"
 671                               pstart)
 672                      (ding) (sit-for 4))))
 673           (setq prio (1- prio)
 674                 patterns (cdr patterns)))
 675         ))
 676     (or quietly hilit-quietly (message "")) ; "Done highlighting"
 677     ;; txt prop: (set-buffer-modified-p bm)) ; unwind protection
 678     ))
 679
 680 (defun hilit-rehighlight-region (start end &optional quietly)
 681   "Re-highlights the region, optionally in a QUIET way"
 682   (interactive "r")
 683   (setq start (apply 'min start (mapcar 'overlay-start (overlays-at start)))
 684         end (apply 'max end (mapcar 'overlay-end (overlays-at end))))
 685   (hilit-unhighlight-region start end quietly)
 686   (hilit-highlight-region   start end nil quietly))
 687
 688 (defun hilit-rehighlight-buffer (&optional quietly)
 689   "Re-highlights the buffer, optionally in a QUIET way"
 690   (interactive "")
 691   (let ((parse-fn (cdr (assq major-mode hilit-parser-alist))))
 692     (if parse-fn
 693         (funcall parse-fn quietly)
 694       (hilit-rehighlight-region (point-min) (point-max) quietly)))
 695   nil)
 696
 697 (defun hilit-rehighlight-buffer-quietly ()
 698   (hilit-rehighlight-buffer t))
 699
 700 (defun hilit-rehighlight-message (quietly)
 701   "Highlight a buffer containing a news article or mail message."
 702   (save-excursion
 703     (goto-char (point-min))
 704     (re-search-forward "^$" nil 'noerr)
 705     (hilit-unhighlight-region (point-min) (point-max) quietly)
 706     (hilit-highlight-region (point-min) (point) 'msg-header quietly)
 707     (hilit-highlight-region (point) (point-max) 'msg-body quietly)))
 708
 709 (defalias 'hilit-highlight-buffer 'hilit-rehighlight-buffer)
 710
 711 (defun hilit-toggle-highlight (arg)
 712   "Locally toggle highlighting.  With arg, forces highlighting off."
 713   (interactive "P")
 714   ;; FIXME -- this loses numeric information in hilit-auto-rehighlight
 715   (setq hilit-auto-rehighlight
 716         (and (not arg) (not hilit-auto-rehighlight)))
 717   (if hilit-auto-rehighlight
 718       (hilit-rehighlight-buffer)
 719     (hilit-unhighlight-region (point-min) (point-max)))
 720   (message "Rehighlighting is set to %s" hilit-auto-rehighlight))
 721
 722 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 723 ;; HOOKS
 724 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 725
 726 (defun hilit-find-file-hook ()
 727   "Find-file hook for hilit package.  See the variable hilit-auto-highlight."
 728   (cond ((and hilit-auto-highlight
 729               (assq major-mode hilit-patterns-alist))
 730          (if (> buffer-saved-size (car hilit-auto-rehighlight-fallback))
 731              (setq hilit-auto-rehighlight
 732                    (cdr hilit-auto-rehighlight-fallback)))
 733          (if (> buffer-saved-size hilit-auto-highlight-maxout) nil
 734            (hilit-rehighlight-buffer)
 735            (set-buffer-modified-p nil)))))
 736
 737 (defun hilit-repaint-command (arg)
 738   "Rehighlights according to the value of hilit-auto-rehighlight, or the
 739 prefix argument if that is specified.
 740 \t\\[hilit-repaint-command]\t\trepaint according to hilit-auto-rehighlight
 741 \t^U \\[hilit-repaint-command]\trepaint entire buffer
 742 \t^U - \\[hilit-repaint-command]\trepaint visible portion of buffer
 743 \t^U n \\[hilit-repaint-command]\trepaint n lines to either side of point"
 744   (interactive "P")
 745   (let (st en quietly)
 746     (or arg (setq arg hilit-auto-rehighlight))
 747     (cond ((or (eq  arg 'visible) (eq arg '-))
 748            (setq st (window-start) en (window-end) quietly t))
 749           ((numberp arg)
 750            (setq st (save-excursion (forward-line (- arg)) (point))
 751                  en (save-excursion (forward-line arg) (point))))
 752           (arg
 753            (hilit-rehighlight-buffer)))
 754     (if st
 755           (hilit-rehighlight-region st en quietly))))
 756
 757 ;; (defun hilit-rehighlight-yank-region ()
 758 ;;   "Rehighlights from the beginning of the line where the region starts to
 759 ;; the end of the line where the region ends.  This could flake out on
 760 ;; multi-line highlights (like C comments and lisp strings.)"
 761 ;;   (if hilit-auto-rehighlight
 762 ;;       (hilit-rehighlight-region
 763 ;;        (save-excursion (goto-char (region-beginning))
 764 ;;                     (beginning-of-line) (point))
 765 ;;        (save-excursion (goto-char (region-end))
 766 ;;                     (end-of-line) (point))
 767 ;;        t)))
 768
 769 (defun hilit-recenter (arg)
 770   "Recenter, then rehighlight according to hilit-auto-rehighlight.  If called
 771 with an unspecified prefix argument (^U but no number), then a rehighlight of
 772 the entire buffer is forced."
 773   (interactive "P")
 774   (recenter arg)
 775   ;; force display update
 776   (sit-for 0)
 777   (hilit-repaint-command (consp arg)))
 778
 779 ;; (defun hilit-redraw-display (arg)
 780 ;;   "Rehighlights according to the value of hilit-auto-rehighlight, a prefix
 781 ;; arg forces a rehighlight of the whole buffer.  Otherwise just like
 782 ;; redraw-display."
 783 ;;   (interactive "P")
 784 ;;   (hilit-redraw-internal arg)
 785 ;;   (redraw-display))
 786
 787 (defun hilit-yank (arg)
 788   "Yank with rehighlighting"
 789   (interactive "*P")
 790   (let ((transient-mark-mode nil))
 791     (yank arg)
 792     (and hilit-auto-rehighlight
 793          (hilit-rehighlight-region (region-beginning) (region-end) t))
 794     (setq this-command 'yank)))
 795
 796 (defun hilit-yank-pop (arg)
 797   "Yank-pop with rehighlighting"
 798   (interactive "*p")
 799   (let ((transient-mark-mode nil))
 800     (yank-pop arg)
 801     (and hilit-auto-rehighlight
 802          (hilit-rehighlight-region (region-beginning) (region-end) t))
 803     (setq this-command 'yank)))
 804
 805 ;;; this line highlighting stuff is untested.  play with it only if you feel
 806 ;;; adventurous...don't ask me to fix it...though you're welcome to.  -- Stig
 807 ;;
 808 ;; (defun hilit-rehighlight-line-quietly (&rest args)
 809 ;;   "Quietly rehighlight just this line.
 810 ;; Useful as an after change hook in VM/gnus summary buffers and dired buffers.
 811 ;; If only there were an after-change-function, that is..."
 812 ;;   (save-excursion
 813 ;;     (push-mark nil t)
 814 ;;     (hilit-rehighlight-yank-region)
 815 ;;     (and orig-achange-function (apply orig-achange-function args))))
 816 ;;
 817 ;; (defun hilit-install-line-hooks ()
 818 ;;   (make-variable-buffer-local 'after-change-function)
 819 ;;   (make-local-variable 'orig-achange-function)
 820 ;;   (setq orig-achange-function after-change-function)
 821 ;;   (setq after-change-function 'hilit-rehighlight-line-quietly))
 822
 823 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 824 ;; Wysiwyg Stuff...  take it away and build a whole package around it!
 825 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 826 ;;
 827 ;; ; For the Jargon-impaired, WYSIWYG === What You See Is What You Get
 828 ;; ; Sure, it sucks to type.  Oh, well.
 829 ;; (defun hilit-wysiwyg-replace ()
 830 ;;   "Replace overstruck text with normal text that's been overlayed with the
 831 ;; appropriate text attribute.  Suitable for a find-file hook."
 832 ;;   (save-excursion
 833 ;;     (goto-char (point-min))
 834 ;;     (let ((wysb (hilit-lookup-face-create 'wysiwyg-bold))
 835 ;;        (wysu (hilit-lookup-face-create 'wysiwyg-underline))
 836 ;;        (bmod (buffer-modified-p)))
 837 ;;       (while (re-search-forward "\\(.\b.\\)+" nil t)
 838 ;;      (let ((st (match-beginning 0)) (en (match-end 0)))
 839 ;;        (goto-char st)
 840 ;;        (if (looking-at "_")
 841 ;;            (hilit-region-set-face st en wysu 100 'wysiwyg)
 842 ;;          (hilit-region-set-face st en wysb 100 'wysiwyg))
 843 ;;        (while (and (< (point) en) (looking-at ".\b"))
 844 ;;          (replace-match "") (forward-char))
 845 ;;        ))
 846 ;;       (set-buffer-modified-p bmod))))
 847 ;;
 848 ;; ; is this more appropriate as a write-file-hook or a write-contents-hook?
 849 ;; (defun hilit-wysiwyg-write-repair ()
 850 ;;   "Replace wysiwyg overlays with overstrike text."
 851 ;;   (message "*sigh* hilit-wysiwyg-write-repair not implemented yet")
 852 ;;
 853 ;; For efficiency, this hook should copy the current buffer to a scratch
 854 ;; buffer and do it's overstriking there.  Overlays are not copied, so it'll
 855 ;; be necessary to hop back and forth.  This is OK since you're not fiddling
 856 ;; with--making or deleting--any overlays.  THEN write the new buffer,
 857 ;; delete it, and RETURN T. << important
 858 ;;
 859 ;; Just so you know...there is already an emacs function called
 860 ;; underline-region that does underlining.  I think that the thing to do is
 861 ;; extend that to do overstriking as well.
 862 ;;
 863 ;;  (while (< start end)
 864 ;;    (mapcar (function (lambda (ovr)
 865 ;;                        (and (overlay-get ovr 'hilit) (delete-overlay ovr))))
 866 ;;          (overlays-at start))
 867 ;;    (setq start (next-overlay-change start)))
 868 ;;  nil)
 869
 870 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 871 ;; Initialization.
 872 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 873
 874 (and (not hilit-inhibit-rebinding)
 875      window-system
 876      (progn
 877        (substitute-key-definition 'yank     'hilit-yank
 878                                   (current-global-map))
 879        (substitute-key-definition 'yank-pop 'hilit-yank-pop
 880                                   (current-global-map))
 881        (substitute-key-definition 'recenter 'hilit-recenter
 882                                   (current-global-map))))
 883
 884 (global-set-key [?\C-\S-l] 'hilit-repaint-command)
 885
 886 (and window-system
 887      (add-hook 'find-file-hooks 'hilit-find-file-hook t))
 888
 889 (eval-when-compile (require 'gnus))     ; no compilation gripes
 890
 891 (and (not hilit-inhibit-hooks)
 892      window-system
 893      (condition-case c
 894          (progn
 895
 896            ;; BUFFER highlights...
 897            (mapcar (function
 898                     (lambda (hook)
 899                       (add-hook hook 'hilit-rehighlight-buffer-quietly)))
 900                    '(
 901                      compilation-parse-hook
 902
 903                      Info-select-hook   ; FIXME -- phase this out later
 904                      Info-selection-hook
 905
 906                      vm-summary-mode-hooks
 907                      vm-summary-pointer-hook
 908                      vm-preview-message-hook
 909                      vm-show-message-hook
 910
 911                      gnus-article-prepare-hook
 912                      gnus-summary-prepare-hook
 913                      gnus-group-prepare-hook
 914
 915                      rmail-show-message-hook
 916                      mail-setup-hook
 917                      mh-show-mode-hook
 918                      ))
 919
 920            ;; rehilight only the visible part of the summary buffer for speed.
 921            (add-hook 'gnus-mark-article-hook
 922                      (function
 923                       (lambda ()
 924                         (or (memq gnus-current-article gnus-newsgroup-marked)
 925                             (gnus-summary-mark-as-read gnus-current-article))
 926                         (gnus-summary-set-current-mark)
 927                         (save-excursion
 928                           (set-buffer gnus-summary-buffer)
 929                           (hilit-rehighlight-region (window-start)
 930                                                     (window-end) t)
 931                           ))))
 932            ;; only need prepare article hook
 933            ;;
 934            ;;   (add-hook 'gnus-select-article-hook
 935            ;;             '(lambda () (save-excursion
 936            ;;                           (set-buffer gnus-article-buffer)
 937            ;;                           (hilit-rehighlight-buffer))))
 938            )
 939        (error (message "Error loading highlight hooks: %s" c)
 940               (ding) (sit-for 1))))
 941
 942 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 943 ;; Default patterns for various modes.
 944 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 945
 946 ;;; do I need this?  I changed the defconst to a defvar because defconst is
 947 ;;; inappropriate, but I don't know why I wanted hilit-patterns-alist to be
 948 ;;; reset on every reload...
 949
 950 (setq hilit-patterns-alist nil)
 951
 952 (defun hilit-associate (alist key val)
 953   "creates, or destructively replaces, the pair (key . val) in alist"
 954   (let ((oldentry (assq key (eval alist))))
 955     (if oldentry
 956         (setcdr oldentry val)
 957       (set alist (cons (cons key val) (eval alist))))))
 958
 959 (defun hilit-set-mode-patterns (modelist patterns &optional parse-fn)
 960   "Sets the default highlighting patterns for MODE to PATTERNS.
 961 See the variable hilit-mode-enable-list."
 962   (or (consp modelist) (setq modelist (list modelist)))
 963   (let (ok (flip (eq (car hilit-mode-enable-list) 'not)))
 964     (mapcar (function
 965              (lambda (m)
 966                (setq ok (or (null hilit-mode-enable-list)
 967                             (memq m hilit-mode-enable-list)))
 968                (and flip (setq ok (not ok)))
 969                (and ok
 970                    (progn
 971                      (and parse-fn
 972                           (hilit-associate 'hilit-parser-alist m parse-fn))
 973                      (hilit-associate 'hilit-patterns-alist m patterns)))))
 974             modelist)))
 975
 976 (defun hilit-string-find (qchar)
 977   "looks for a string and returns (start . end) or NIL.  The argument QCHAR
 978 is the character that would precede a character constant double quote.
 979 Finds  [^QCHAR]\" ... [^\\]\""
 980   (let (st en)
 981     (while (and (search-forward "\"" nil t)
 982                 (eq qchar (char-after (1- (setq st (match-beginning 0)))))))
 983     (while (and (search-forward "\"" nil t)
 984                 (eq ?\\ (char-after (- (setq en (point)) 2)))))
 985     (and en (cons st en))))
 986
 987 (hilit-set-mode-patterns
 988  '(c-mode c++-c-mode elec-c-mode)
 989  '(("/\\*" "\\*/" comment)
 990                                         ;       ("\"" "[^\\]\"" string)
 991    (hilit-string-find ?' string)
 992    ;; declaration
 993    ("^#[ \t]*\\(undef\\|define\\).*$" nil define)
 994    ("^#.*$" nil include)
 995    ;; function decls are expected to have types on the previous line
 996    ("^\\(\\w\\|[$_]\\)+\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun)
 997    ("^\\(typedef\\|struct\\|union\\|enum\\).*$" nil decl)
 998    ;; datatype -- black magic regular expression
 999    ("[ \n\t({]\\(\\(const\\|register\\|volatile\\|unsigned\\|extern\\|static\\)\\s +\\)*\\(\\(\\w\\|[$_]\\)+_t\\|float\\|double\\|void\\|char\\|short\\|int\\|long\\|FILE\\|\\(\\(struct\\|union\\|enum\\)\\([ \t]+\\(\\w\\|[$_]\\)*\\)\\)\\)\\(\\s +\\*+)?\\|[ \n\t;()]\\)" nil type)
1000    ;; key words
1001    ("[^_]\\<\\(return\\|goto\\|if\\|else\\|case\\|default\\|switch\\|break\\|continue\\|while\\|do\\|for\\)\\>[^_]" 1 keyword)
1002    ))
1003
1004 (hilit-set-mode-patterns
1005  'c++-mode
1006  '(("/\\*" "\\*/" comment)
1007    ("//.*$" nil comment)
1008    ("^/.*$" nil comment)
1009 ;   ("\"" "[^\\]\"" string)
1010    (hilit-string-find ?' string)
1011    ;; declaration
1012    ("^#[ \t]*\\(undef\\|define\\).*$" nil define)
1013    ("^#.*$" nil include)
1014    ;; function decls are expected to have types on the previous line
1015    ("^\\(\\(\\w\\|[$_]\\)+::\\)?\\(\\w\\|[$_]\\)+\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun)
1016    ("^\\(\\(\\w\\|[$_]\\)+[ \t]*::[ \t]*\\)?\\(\\(\\w\\|[$_]\\)+\\|operator.*\\)\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun)
1017    ("^\\(template\\|typedef\\|struct\\|union\\|class\\|enum\\|public\\|private\\|protected\\).*$" nil decl)
1018    ;; datatype -- black magic regular expression
1019    ("[ \n\t({]\\(\\(const\\|register\\|volatile\\|unsigned\\|extern\\|static\\)\\s +\\)*\\(\\(\\w\\|[$_]\\)+_t\\|float\\|double\\|void\\|char\\|short\\|int\\|long\\|FILE\\|\\(\\(struct\\|union\\|enum\\|class\\)\\([ \t]+\\(\\w\\|[$_]\\)*\\)\\)\\)\\(\\s +\\*+)?\\|[ \n\t;()]\\)" nil type)
1020    ;; key words
1021    ("[^_]\\<\\(return\\|goto\\|if\\|else\\|case\\|default\\|switch\\|break\\|continue\\|while\\|do\\|for\\|public\\|protected\\|private\\|delete\\|new\\)\\>[^_]"
1022     1 keyword)))
1023
1024 (hilit-set-mode-patterns
1025  'perl-mode
1026  '(("\\s #.*$" nil comment)
1027    ("^#.*$" nil comment)
1028    ("\"[^\\\"]*\\(\\\\\\(.\\|\n\\)[^\\\"]*\\)*\"" nil string)
1029    ("^\\(__....?__\\|\\s *\\sw+:\\)" nil label)
1030    ("^require.*$" nil include)
1031    ("^package.*$" nil decl)
1032    ("^\\s *sub\\s +\\(\\w\\|[_']\\)+" nil defun)
1033    ("\\b\\(do\\|if\\|unless\\|while\\|until\\|else\\|elsif\\|for\\|foreach\\|continue\\|next\\|redo\\|last\\|goto\\|return\\|die\\|exit\\)\\b" nil keyword)))
1034
1035 (hilit-set-mode-patterns
1036  'ada-mode
1037  '(;; comments
1038    ("--.*$" nil comment)
1039    ;; main structure
1040    ("[ \t\n]procedure[ \t]" "\\([ \t]\\(is\\|renames\\)\\|);\\)" glob-struct)
1041    ("[ \t\n]task[ \t]" "[ \t]is" glob-struct)
1042    ("[ \t\n]function[ \t]" "return[ \t]+[A-Za-z_0-9]+[ \t]*\\(is\\|;\\|renames\\)" glob-struct)
1043    ("[ \t\n]package[ \t]" "[ \t]\\(is\\|renames\\)" glob-struct)
1044    ;; if there is nothing before "private", it is part of the structure
1045    ("^[ \t]*private[ \t\n]" nil glob-struct)
1046    ;; if there is no indentation before the "end", then it is most
1047    ;; probably the end of the package
1048    ("^end.*$" ";" glob-struct)
1049    ;; program structure -- "null", "delay" and "terminate" omitted
1050    ("[ \n\t]\\(in\\|out\\|select\\|if\\|else\\|case\\|when\\|and\\|or\\|not\\|accept\\|loop\\|do\\|then\\|elsif\\|else\\|for\\|while\\|exit\\)[ \n\t;]" nil struct)
1051    ;; block structure
1052    ("[ \n\t]\\(begin\\|end\\|declare\\|exception\\|generic\\|raise\\|return\\|package\\|body\\)[ \n\t;]" nil struct)
1053    ;; type declaration
1054    ("^[ \t]*\\(type\\|subtype\\).*$" ";" decl)
1055    ("[ \t]+is record.*$" "end record;" decl)
1056    ;; "pragma", "with", and "use" are close to C cpp directives
1057    ("^[ \t]*\\(with\\|pragma\\|use\\)" ";" include)
1058    ;; nice for named parameters, but not so beautiful in case statements
1059    ("[A-Za-z_0-9.]+[ \t]*=>"   nil named-param)
1060    ;; string constants probably not everybody likes this one
1061    ("\"" ".*\"" string)))
1062
1063 (hilit-set-mode-patterns
1064  'fortran-mode
1065  '(("^[*Cc].*$" nil comment)
1066    ("[ \t]\\(call\\|program\\|subroutine\\|function\\|stop\\|return\\|end\\|include\\)[ \t\n]" nil include)
1067    ("\\(^[ \t]*[0-9]+\\|[ \t]continue[ \t\n]\\|format\\)" nil define)
1068    ("[ \t]\\(do\\|do[ \t]*[0-9]+\\|go[ \t]*to[ \t]*[0-9]+\\|end[ \t]*do\\|if\\|else[ \t]*if\\|then\\|else\\|end[ \t]*if\\)[ \t\n(]" nil define)
1069    ("[ \t]\\(parameter[\t\n ]*([^)]*)\\|data\\|save\\|common[ \t\n]*/[^/]*/\\)"
1070     nil decl)
1071    ("^     ." nil type)
1072    ("implicit[ \t]*none" nil decl)
1073    ("\\([ \t]\\|implicit[ \t]*\\)\\(dimension\\|integer\\|real\\|double[ \t]*precision\\|character\\|logical\\|complex\\|double[ \t]*complex\\)\\([*][0-9]*\\|[ \t\n]\\)" nil keyword)
1074    ("'[^'\n]*'" nil string)
1075    ))
1076
1077 (hilit-set-mode-patterns
1078  '(m2-mode modula-2-mode)
1079  '(("(\\*" "\\*)" comment)
1080    (hilit-string-find ?\\ string)
1081    ("^[ \t]*PROCEDURE[ \t]+\\w+[^ \t(;]*" nil defun)
1082    ("\\<\\(RECORD\\|ARRAY\\|OF\\|POINTER\\|TO\\|BEGIN\\|END\\|FOR\\|IF\\|THEN\\|ELSE\\|ELSIF\\|CASE\\|WHILE\\|DO\\|MODULE\\|FROM\\|RETURN\\|IMPORT\\|EXPORT\\|VAR\\|LOOP\\|UNTIL\\|\\DEFINITION\\|IMPLEMENTATION\\|AND\\|OR\\|NOT\\|CONST\\|TYPE\\|QUALIFIED\\)\\>" nil keyword)
1083    ))
1084
1085 (hilit-set-mode-patterns 'prolog-mode
1086  '(("/\\*" "\\*/" comment)
1087    ("%.*$" nil comment)
1088    (":-" nil defun)
1089    ("!" nil label)
1090    ("\"[^\\\"]*\\(\\\\\\(.\\|\n\\)[^\\\"]*\\)*\"" nil string)
1091    ("\\b\\(is\\|mod\\)\\b" nil keyword)
1092    ("\\(->\\|-->\\|;\\|==\\|\\\\==\\|=<\\|>=\\|<\\|>\\|=\\|\\\\=\\|=:=\\|=\\\.\\\.\\|\\\\\\\+\\)" nil decl)
1093    ("\\(\\\[\\||\\|\\\]\\)" nil include)))
1094
1095 (hilit-set-mode-patterns
1096  '(
1097    LaTeX-mode japanese-LaTeX-mode SliTeX-mode
1098    japanese-SliTeX-mode FoilTeX-mode latex-mode
1099    )
1100  '(
1101    ;; comments
1102    ("[^\\]%.*$" nil comment)
1103
1104    ;; the following two match \foo[xx]{xx} or \foo*{xx} or \foo{xx}
1105    ("\\\\\\(sub\\)*\\(paragraph\\|section\\)\\(\*\\|\\[.*\\]\\)?{" "}"
1106     keyword)
1107    ("\\\\\\(chapter\\|part\\)\\(\*\\|\\[.*\\]\\)?{" "}" keyword)
1108    ("\\\\footnote\\(mark\\|text\\)?{" "}" keyword)
1109    ("\\\\[a-z]+box" nil keyword)
1110    ("\\\\\\(v\\|h\\)space\\(\*\\)?{" "}" keyword)
1111
1112    ;; (re-)define new commands/environments/counters
1113    ("\\\\\\(re\\)?new\\(environment\\|command\\){" "}" defun)
1114    ("\\\\new\\(length\\|theorem\\|counter\\){" "}" defun)
1115
1116    ;; various declarations/definitions
1117    ("\\\\\\(setlength\\|settowidth\\|addtolength\\|setcounter\\|addtocounter\\)" nil define)
1118    ("\\\\\\(\\|title\\|author\\|date\\|thanks\\){" "}" define)
1119
1120    ("\\\\documentstyle\\(\\[.*\\]\\)?{" "}" decl)
1121    ("\\\\\\(begin\\|end\\|nofiles\\|includeonly\\){" "}" decl)
1122    ("\\\\\\(raggedright\\|makeindex\\|makeglossary\\|maketitle\\)\\b" nil
1123     decl)
1124    ("\\\\\\(pagestyle\\|thispagestyle\\|pagenumbering\\){" "}" decl)
1125    ("\\\\\\(normalsize\\|small\\|footnotesize\\|scriptsize\\|tiny\\|large\\|Large\\|LARGE\\|huge\\|Huge\\)\\b" nil decl)
1126    ("\\\\\\(appendix\\|tableofcontents\\|listoffigures\\|listoftables\\)\\b"
1127     nil decl)
1128    ("\\\\\\(bf\\|em\\|it\\|rm\\|sf\\|sl\\|ss\\|tt\\)\\b" nil decl)
1129
1130    ;; label-like things
1131    ("\\\\item\\[" "\\]" label)
1132    ("\\\\item\\b" nil label)
1133    ("\\\\caption\\(\\[.*\\]\\)?{" "}" label)
1134
1135    ;; things that bring in external files
1136    ("\\\\\\(include\\|input\\|bibliography\\){" "}" include)
1137
1138    ;; "wysiwyg" emphasis -- these don't work with nested expressions
1139    ;; ("{\\\\\\(em\\|it\\|sl\\)" "}" italic)
1140    ;; ("{\\\\bf" "}" bold)
1141
1142    ("``" "''" string)
1143
1144    ;; things that do some sort of cross-reference
1145    ("\\\\\\(\\(no\\)?cite\\|\\(page\\)?ref\\|label\\|index\\|glossary\\){" "}" crossref)
1146    ))
1147
1148 (hilit-set-mode-patterns
1149  'bibtex-mode
1150  '(;;(";.*$"                    nil     comment)
1151    ("%.*$"                      nil     comment)
1152    ("@[a-zA-Z]+"                nil     keyword)
1153    ("{[ \t]*[-a-z:_A-Z0-9]+,"   nil     label) ; is wrong sometimes
1154    ("^[ \t]*[a-zA-Z]+[ \t]*="   nil     define)))
1155
1156 (hilit-set-mode-patterns
1157  'compilation-mode
1158  '(
1159    ("^[-_.\"A-Za-z0-9]+\\(:\\|, line \\)[0-9]+: warning:.*$" nil warning)
1160    ("^[-_.\"A-Za-z0-9]+\\(:\\|, line \\)[0-9]+:.*$" nil error)
1161    ))
1162
1163 (hilit-set-mode-patterns
1164  'makefile-mode
1165  '(("^#.*$" nil comment)
1166    ("[^$]#.*$" nil comment)
1167    ;; rules
1168    ("^[^ \t\n]*%[^ \t\n]*[ \t]*::?[ \t]*[^ \t\n]*[ \t]*\\(#.*\\)?$" nil rule)
1169    ("^[.][A-Za-z][A-Za-z]?\..*$" nil rule)
1170    ;; variable definition
1171    ("^[_A-Za-z0-9]+[ \t]*\+?=" nil define)
1172    ("\\( \\|:=\\)[_A-Za-z0-9]+[ \t]*\\+=" nil define)
1173    ;; variable references
1174    ("\\$\\([^ \t\n{(]\\|[{(]@?[_A-Za-z0-9:.,%/=]+[)}]\\)" nil keyword)
1175    ("^[A-Za-z0-9.,/_-]+[ \t]*:.*$" nil defun)
1176    ("^include " nil include)))
1177
1178 (let* ((header-patterns '(("^Subject:.*$" nil msg-subject)
1179                           ("^From:.*$" nil msg-from)
1180                           ("^--text follows this line--$" nil msg-separator)
1181                           ("^[A-Za-z][A-Za-z0-9-]+:" nil msg-header)))
1182        (body-patterns '(("^\\(In article\\|[ \t]*\\w*[]<>}|]\\).*$"
1183                          nil msg-quote)))
1184        (message-patterns (append header-patterns body-patterns)))
1185   (hilit-set-mode-patterns 'msg-header header-patterns)
1186   (hilit-set-mode-patterns 'msg-body body-patterns)
1187   (hilit-set-mode-patterns '(vm-mode text-mode mail-mode rmail-mode
1188                              gnus-article-mode news-reply-mode mh-show-mode)
1189                            message-patterns
1190                            'hilit-rehighlight-message))
1191
1192 (hilit-set-mode-patterns
1193  'gnus-group-mode
1194  '(("^U.*$" nil gnus-group-unsubscribed)
1195    ("^ +[01]?[0-9]:.*$" nil gnus-group-empty)
1196    ("^ +[2-9][0-9]:.*$" nil gnus-group-full)
1197    ("^ +[0-9][0-9][0-9]+:.*$" nil gnus-group-overflowing)))
1198
1199 (hilit-set-mode-patterns
1200  'gnus-summary-mode
1201  '(("^D +[0-9]+: \\[.*$" nil summary-seen)
1202    ("^K +[0-9]+: \\[.*$" nil summary-killed)
1203    ("^X +[0-9]+: \\[.*$" nil summary-Xed)
1204    ("^- +[0-9]+: \\[.*$" nil summary-unread)
1205    ("^. +[0-9]+:\\+\\[.*$" nil summary-current)
1206    ("^  +[0-9]+: \\[.*$" nil summary-new)
1207    ))
1208
1209 (hilit-set-mode-patterns
1210  'vm-summary-mode
1211  '(("^   .*$" nil summary-seen)
1212    ("^->.*$" nil  summary-current)
1213    ("^  D.*$" nil summary-deleted)
1214    ("^  U.*$" nil summary-unread)
1215    ("^  N.*$" nil summary-new)))
1216
1217
1218 (hilit-set-mode-patterns
1219  '(emacs-lisp-mode lisp-mode)
1220  '(
1221    (";.*" nil comment)
1222 ;;;      ("^;.*$" nil comment)
1223 ;;;      ("\\s ;+[ ;].*$" nil comment)
1224    (hilit-string-find ?\\ string)
1225    ("^\\s *(def\\(un\\|macro\\|advice\\|subst\\)\\s " "\\()\\|nil\\)" defun)
1226    ("^\\s *(defvar\\s +\\S +" nil decl)
1227    ("^\\s *(defconst\\s +\\S +" nil define)
1228    ("^\\s *(\\(provide\\|require\\|\\(auto\\)?load\\).*$" nil include)
1229    ))
1230
1231
1232 (hilit-set-mode-patterns
1233  'plain-tex-mode
1234  '(("^%%.*$" nil comment)
1235    ("{\\\\em\\([^}]+\\)}" nil comment)
1236    ("\\(\\\\\\w+\\)" nil keyword)
1237    ("{\\\\bf\\([^}]+\\)}" nil keyword)
1238    ("^[ \t\n]*\\\\def[\\\\@]\\(\\w+\\)" nil defun)
1239    ("\\\\\\(begin\\|end\\){\\([A-Za-z0-9\\*]+\\)}" nil defun)
1240 ;   ("[^\\\\]\\$\\([^$]*\\)\\$" nil string)
1241    ("\\$\\([^$]*\\)\\$" nil string)
1242    ))
1243
1244 ;; Reasonable extensions would include smarter parameter handling for such
1245 ;; things as the .IX and .I macros, which alternate the handling of following
1246 ;; arguments.
1247
1248 (hilit-set-mode-patterns
1249  'nroff-mode
1250  '(("^\\.[\\\][\\\"].*$" nil comment)
1251    ("^\\.so .*$" nil include)
1252    ("^\\.[ST]H.*$" nil defun)
1253 ;;   ("^[^\\.].*\"[^\\\"]*\\(\\\\\\(.\\)[^\\\"]*\\)*\"" nil string)
1254    ("\"" "[^\\]\"" string)
1255    ("^\\.[A-Za-z12\\\\].*$" nil define)
1256    ("\\([\\\][^ ]*\\)" nil keyword)
1257    ("^\\.[a-zA-Z].*$" nil keyword)))
1258
1259 (hilit-set-mode-patterns
1260  'texinfo-mode
1261  '(("^\\(@c\\|@comment\\)\\>.*$" nil comment)
1262    ("@\\(emph\\|strong\\|b\\|i\\){[^}]+}" nil comment)
1263 ; seems broken
1264 ;   ("\\$[^$]*\\$" nil string)
1265    ("@\\(file\\|kbd\\|key\\){[^}]+}" nil string)
1266    ("^\\*.*$" nil defun)
1267    ("@\\(if\\w+\\|format\\|item\\)\\b.*$" nil defun)
1268    ("@end +[A-Za-z0-9]+[ \t]*$" nil defun)
1269    ("@\\(samp\\|code\\|var\\){[^}]+}" nil defun)
1270    ("@\\w+\\({[^}]+}\\)?" nil keyword)
1271    ))
1272
1273 (hilit-set-mode-patterns
1274  'dired-mode
1275  (append
1276   '(("^D.*$"  nil dired-deleted)
1277    ("^\\*.*$" nil dired-marked)
1278    ("^  d.*$" nil dired-directory)
1279    ("^  l.*$" nil dired-link)
1280    ("^  -.*#.*#$" nil dired-ignored))
1281   (list (cons
1282          (concat "^  .*\\("
1283                  (mapconcat 'regexp-quote completion-ignored-extensions "\\|")
1284                  "\\)$")
1285          '(nil dired-ignored)))))
1286
1287 (hilit-set-mode-patterns
1288  'jargon-mode
1289  '(("^:[^:]*:" nil jargon-entry)
1290    ("{[^}]*}+" nil jargon-xref)))
1291
1292 (hilit-set-mode-patterns
1293  'Info-mode
1294  '(("^\\* [^:]+:+" nil jargon-entry)
1295    ("\\*[Nn]ote\\b[^:]+:+" nil jargon-xref)
1296    ("  \\(Next\\|Prev\\|Up\\):" nil jargon-xref)
1297    ("- \\(Variable\\|Function\\|Macro\\|Command\\|Special Form\\|User Option\\):.*$"
1298     nil jargon-keyword)))       ; lisp manual
1299
1300 (provide 'hilit19)
1301
1302 ;;; hilit19 ends here.