home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1992 #19 / NN_1992_19.iso / spool / alt / lucidem / help / 365 < prev    next >
Encoding:
Text File  |  1992-08-31  |  17.5 KB  |  479 lines
  1. x-gateway: rodan.UU.NET from help-lucid-emacs to alt.lucid-emacs.help; Tue, 1 Sep 1992 00:52:02 EDT
  2. Date: Mon, 31 Aug 1992 21:50:25 PDT
  3. Message-ID: <9209010450.AA24434@thalidomide.lucid>
  4. X-Windows: The joke that kills.
  5. From: jwz@lucid.com (Jamie Zawinski)
  6. Sender: jwz%thalidomide@lucid.com
  7. Subject: electric font lock mode
  8. Newsgroups: alt.lucid-emacs.help
  9. Path: sparky!uunet!wendy-fate.uu.net!help-lucid-emacs
  10. Lines: 467
  11.  
  12. Here's a little something I hacked up last night.  It's really way too slow
  13. to use, but if most of it were ported to C, it would probably be acceptably
  14. fast.  (Imagine using an emacs-lisp implementation of forward-sexp...)
  15.  
  16. Doing M-x font-lock-fontify-buffer on a 35k file of C code takes about a
  17. minute on a Sparc2.  Do M-x electric-font-lock-mode to make it auto-fontify
  18. what you type.  This can *almost* keep up with my typing, but not quite.
  19.  
  20. Also I think that the fontification of keywords that it does by default is
  21. really gaudy, but I wanted to see how fast that would be.
  22.  
  23.     -- Jamie
  24.  
  25. ---------- slice 'n' dice --------------------------------- file: font-lock.el
  26. ;; Electric Font Lock Mode.  Yow.
  27. ;; Copyright (C) 1992 Free Software Foundation, Inc.
  28.  
  29. ;; This file is part of GNU Emacs.
  30.  
  31. ;; GNU Emacs is free software; you can redistribute it and/or modify
  32. ;; it under the terms of the GNU General Public License as published by
  33. ;; the Free Software Foundation; either version 2, or (at your option)
  34. ;; any later version.
  35.  
  36. ;; GNU Emacs is distributed in the hope that it will be useful,
  37. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  38. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  39. ;; GNU General Public License for more details.
  40.  
  41. ;; You should have received a copy of the GNU General Public License
  42. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  43. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  44.  
  45. ;; Electric-font-lock-mode is a minor mode that causes your comments to
  46. ;; be displayed in one font, strings in another, reserved words in another,
  47. ;; etc.  Actually, it works with any display attributes, not just fonts, 
  48. ;; but the name is what it is for historical continuity...
  49.  
  50. ;; Comments will be displayed in `font-lock-comment-face'.
  51. ;; Strings will be displayed in `font-lock-string-face'.
  52. ;; Function and variable names in their defining forms will be displayed
  53. ;;  in `font-lock-function-name-face'.
  54. ;; Reserved words will be displayed in `font-lock-keyword-face'.
  55. ;;
  56. ;; To initially fontify the buffer, use M-x font-lock-fontify-buffer.
  57. ;; The fonts of the current line will be updated with every insertion or
  58. ;; deletion.
  59. ;;
  60. ;; To make the text you type be fontified, use M-x electric-font-lock-mode.
  61. ;;
  62. ;; To define new reserved words or other patterns to highlight, use the
  63. ;; `font-lock-keywords' variable.
  64.  
  65. (or (find-face 'font-lock-comment-face)
  66.     (make-face 'font-lock-comment-face))
  67. (or (face-differs-from-default-p 'font-lock-comment-face)
  68.     (copy-face 'italic 'font-lock-comment-face))
  69.  
  70. (or (find-face 'font-lock-string-face)
  71.     (make-face 'font-lock-string-face))
  72. (or (face-differs-from-default-p 'font-lock-string-face)
  73.     (copy-face 'italic 'font-lock-string-face))
  74.  
  75. (or (find-face 'font-lock-doc-string-face)
  76.     (make-face 'font-lock-doc-string-face))
  77. (or (face-differs-from-default-p 'font-lock-doc-string-face)
  78.     (copy-face 'bold-italic 'font-lock-doc-string-face))
  79.  
  80. (or (find-face 'font-lock-function-name-face)
  81.     (make-face 'font-lock-function-name-face))
  82. (or (face-differs-from-default-p 'font-lock-function-name-face)
  83.     (copy-face 'bold-italic 'font-lock-function-name-face))
  84.  
  85. (or (find-face 'font-lock-keyword-face)
  86.     (make-face 'font-lock-keyword-face))
  87. (or (face-differs-from-default-p 'font-lock-keyword-face)
  88.     (copy-face 'bold 'font-lock-keyword-face))
  89.  
  90.  
  91. (defvar font-lock-keywords nil
  92.   "*The keywords to highlight.
  93. If this is a list, then elements may be of the forms:
  94.   \"string\"             ; a regexp to highlight in the 
  95.                  ;  `font-lock-keyword-face'.
  96.   (\"string\" . integer)     ; match N of the regexp will be highlighted
  97.   (\"string\" . face-name)     ; use the named face
  98.   (\"string\" integer face-name) ; both of the above")
  99.  
  100. (defvar font-lock-keywords-case-fold-search nil
  101.   "*Whether the strings in `font-lock-keywords' should be case-folded.")
  102.  
  103.  
  104. ;;; These variables are the cache (and outputs) of font-lock-find-context.
  105. ;;; The last point computed is held in the cache, as well as the last
  106. ;;; point at the beginning of a line that was computed.  This makes there
  107. ;;; be little penalty for moving left-to-right on a line a character at a 
  108. ;;; time; makes starting over on a line be cheap; and makes random-accessing
  109. ;;; within a line relatively cheap.  
  110. ;;;
  111. ;;; When we move to a different line farther down in the file (but within the
  112. ;;; current top-level form) we simply continue computing forward.  If we move
  113. ;;; backward more than a line, or move beyond the end of the current tlf, or
  114. ;;; do a deletion, then we call `beginning-of-defun' and start over from there.
  115. ;;;
  116. ;;; To fontify the whole buffer, we just go through it a character at a time,
  117. ;;; and create new extents when necessary (the extents we create span lines.)
  118. ;;;
  119. ;;; Each time a modification happens to a line, we remove all of the extents
  120. ;;; on that line (splitting line-spanning extents as necessary) and recompute
  121. ;;; the contexts for every character on the line.  This means that, as the
  122. ;;; user types, we repeatedly go back to the begnning of the line, doing more
  123. ;;; work the longer the line gets.  
  124. ;;;
  125. ;;; We redo the whole line because that's a lot easier than dealing with the
  126. ;;; hair of modifying possibly-overlapping extents, and extents whose 
  127. ;;; endpoints were moved by the insertion we are reacting to.
  128. ;;;
  129. ;;; Extents as they now exist are not a good fit for this project, because
  130. ;;; extents talk about properties of *regions*, when what we want to talk
  131. ;;; about here are properties of *characters*.  
  132. ;;;
  133. ;;; This is way too slow, but is a decent prototype; if this were 
  134. ;;; reimplemented in C, I think it could be usably fast.
  135.  
  136. (defvar font-lock-context nil)
  137. (defvar font-lock-context-start-marker nil)
  138. (defvar font-lock-context-end nil)
  139. (defvar font-lock-context-depth nil)
  140. (defvar font-lock-backslash-p nil)
  141. (defvar font-lock-comment-context nil)
  142. (defvar font-lock-string-context nil)
  143.  
  144. (defvar font-lock-bol-context nil)
  145. (defvar font-lock-bol-context-start-marker nil)
  146. (defvar font-lock-bol-context-end nil)
  147. (defvar font-lock-bol-context-depth nil)
  148. (defvar font-lock-bol-backslash-p nil)
  149. (defvar font-lock-bol-comment-context nil)
  150. (defvar font-lock-bol-string-context nil)
  151.  
  152. (defun font-lock-flush-cache ()
  153.   (if font-lock-context-start-marker
  154.       (progn
  155.     (set-marker font-lock-context-start-marker nil)
  156.     (set-marker font-lock-bol-context-start-marker nil)
  157.     (setq font-lock-context-start-marker nil
  158.           font-lock-bol-context-start-marker nil))))
  159.  
  160.  
  161. (defsubst font-lock-char-syntax-code (char)
  162.   (ash (aref (syntax-table) char) -16))
  163. (defsubst font-lock-comment-start1-p (code) (/= 0 (logand 1 code)))
  164. (defsubst font-lock-comment-start2-p (code) (/= 0 (logand 2 code)))
  165. (defsubst font-lock-comment-end1-p (code) (/= 0 (logand 4 code)))
  166. (defsubst font-lock-comment-end2-p (code) (/= 0 (logand 8 code)))
  167.  
  168. (defun font-lock-find-context ()
  169.   (let ((target (point))
  170.     (do-bod (or (null font-lock-context-start-marker)
  171.             (> (point) font-lock-context-end)
  172.             (not (eq (current-buffer)
  173.                  (marker-buffer
  174.                   font-lock-context-start-marker)))))
  175.     syntax)
  176.     (if (or do-bod (< (point) font-lock-context-start-marker))
  177.     (if (or do-bod (< (point) font-lock-bol-context-start-marker))
  178.         ;; we need to start over at the current defun.
  179.         (progn
  180.           (beginning-of-defun)
  181.           (if font-lock-context-start-marker
  182.           (move-marker font-lock-context-start-marker (point))
  183.         (setq font-lock-context-start-marker (point-marker)
  184.               font-lock-bol-context-start-marker (point-marker)
  185.               ))
  186.           (setq font-lock-context-end (save-excursion
  187.                         (re-search-forward "\n\\s("
  188.                                    nil 'move)
  189.                         (point))
  190.             font-lock-context nil
  191.             font-lock-context-depth 0
  192.             font-lock-backslash-p
  193.               (= (char-syntax (preceding-char)) ?\\)
  194.               font-lock-comment-context nil
  195.               font-lock-string-context nil
  196.             ))
  197.       ;; we can restart at the cached beginning-of-line
  198.       (setq font-lock-context font-lock-bol-context
  199.         font-lock-context-end font-lock-bol-context-end
  200.         font-lock-context-depth font-lock-bol-context-depth
  201.         font-lock-backslash-p font-lock-bol-backslash-p
  202.         font-lock-comment-context font-lock-bol-comment-context
  203.         font-lock-string-context font-lock-bol-string-context)
  204.       (move-marker font-lock-context-start-marker
  205.                font-lock-bol-context-start-marker)))
  206.     (goto-char font-lock-context-start-marker)
  207.     (while (< (point) target)
  208.       (setq syntax (char-syntax (following-char)))
  209.       (cond (font-lock-backslash-p
  210.          (setq font-lock-backslash-p nil))
  211.         ((= syntax ?\\)
  212.          (or font-lock-backslash-p (setq font-lock-backslash-p t)))
  213.         ((= syntax ?\()
  214.          (or font-lock-context
  215.          (setq font-lock-context-depth
  216.                (1+ font-lock-context-depth))))
  217.         ((= syntax ?\))
  218.          (or font-lock-context
  219.          (setq font-lock-context-depth
  220.                (1- font-lock-context-depth))))
  221.         ((= syntax ?\<)
  222.          (or font-lock-context
  223.          (setq font-lock-context 'comment)))
  224.         ((= syntax ?\>)
  225.          (if (and (eq font-lock-context 'comment)
  226.               (not font-lock-comment-context))
  227.          (setq font-lock-context nil)))
  228.         ((= syntax ?\")
  229.          (cond ((and (eq font-lock-context 'string)
  230.              (eq font-lock-string-context (following-char)))
  231.             (setq font-lock-context nil
  232.               font-lock-string-context nil))
  233.            ((null font-lock-context)
  234.             (setq font-lock-context 'string
  235.               font-lock-string-context (following-char)))))
  236.         ;;
  237.         ;; Check for multi-char comment characters.
  238.         ;; We do this last because `char-syntax' is byte-coded.
  239.         ;;
  240.         ((= syntax ?.) ; not necessarily correct, but fast.
  241.          (let ((code (font-lock-char-syntax-code (following-char))))
  242.            (cond ((and (font-lock-comment-start1-p code)
  243.                (or (null font-lock-comment-context)
  244.                    (eq font-lock-comment-context 'start1)))
  245.               (setq font-lock-comment-context 'start1))
  246.              ((and (font-lock-comment-start2-p code)
  247.                (eq font-lock-comment-context 'start1))
  248.               (setq font-lock-comment-context 'start2))
  249.              ((and (font-lock-comment-end1-p code)
  250.                (or (eq font-lock-comment-context 'start2)
  251.                    (eq font-lock-comment-context 'end1)))
  252.               (setq font-lock-comment-context 'end1))
  253.              ((and (font-lock-comment-end2-p code)
  254.                (eq font-lock-comment-context 'end1))
  255.               (setq font-lock-comment-context 'end2)))))
  256.         )
  257.       (cond ((and font-lock-context
  258.           (not (eq font-lock-context 'comment2)))
  259.          (setq font-lock-comment-context nil))
  260.         ((eq font-lock-comment-context 'start2)
  261.          (setq font-lock-context 'comment2))
  262.         ((eq font-lock-comment-context 'end2)
  263.          (setq font-lock-context nil
  264.            font-lock-comment-context nil)))
  265.       (if (= (preceding-char) ?\n)
  266.       (progn
  267.         (setq font-lock-bol-context font-lock-context
  268.           font-lock-bol-context-end font-lock-context-end
  269.           font-lock-bol-context-depth font-lock-context-depth
  270.           font-lock-bol-backslash-p font-lock-backslash-p
  271.           font-lock-bol-comment-context font-lock-comment-context
  272.           font-lock-bol-string-context font-lock-string-context)
  273.         (move-marker font-lock-bol-context-start-marker
  274.              font-lock-context-start-marker)))
  275.       (forward-char 1))
  276.     (move-marker font-lock-context-start-marker (point)))
  277.   font-lock-context)
  278.  
  279.  
  280. (defsubst font-lock-context-face ()
  281.   (cond ((eq font-lock-context 'comment) 'font-lock-comment-face)
  282.     ((eq font-lock-context 'comment2) 'font-lock-comment-face)
  283.     ((eq font-lock-context 'string)
  284.      (if (= font-lock-context-depth 1)
  285.          ;; rally we should only use this if in position 3 depth 1, but
  286.          ;; that's too expensive to compute.
  287.          'font-lock-doc-string-face
  288.        'font-lock-string-face))
  289.     (t nil)))
  290.  
  291.  
  292. (defsubst font-lock-any-extents-p (start end)
  293.   (let ((result nil))
  294.     (map-extents (function (lambda (ignore ignore) (setq result t)))
  295.          (current-buffer) start end nil)
  296.     result))
  297.  
  298. (defun font-lock-hack-keywords (start end)
  299.   (goto-char start)
  300.   (let ((case-fold-search font-lock-keywords-case-fold-search)
  301.     (rest font-lock-keywords)
  302.     str match face s e)
  303.     (while rest
  304.       (goto-char start)
  305.       (cond ((consp (car rest))
  306.          (setq str (car (car rest)))
  307.          (cond ((consp (cdr (car rest)))
  308.             (setq match (car (cdr (car rest)))
  309.               face (car (cdr (cdr (car rest))))))
  310.            ((symbolp (cdr (car rest)))
  311.             (setq match 0 face (cdr (car rest))))
  312.            (t
  313.             (setq match (cdr (car rest))
  314.               face 'font-lock-keyword-face))))
  315.         (t
  316.          (setq str (car rest)
  317.            match 0
  318.            face 'font-lock-keyword-face)))
  319.       (while (re-search-forward str end t)
  320.     (setq s (match-beginning match)
  321.           e (match-end match))
  322.     ;; don't fontify this keyword if we're already in some other context.
  323.     (or (font-lock-any-extents-p s e)
  324.         (set-extent-face (make-extent s e) face)))
  325.       (setq rest (cdr rest)))))
  326.  
  327.  
  328. (defun font-lock-fontify-buffer ()
  329.   "Fontify the current buffer the way electric-font-lock-mode would."
  330.   (interactive)
  331.   (map-extents (function (lambda (x y) (delete-extent x)))
  332.            (current-buffer) (point-min) (point-max) nil)
  333.   (font-lock-flush-cache)
  334.   (save-excursion
  335.     (goto-char (point-min))
  336.     (let ((face nil)
  337.       (last-face nil)
  338.       (extent nil))
  339.       (while (not (eobp))
  340.     (setq last-face face)
  341.     (font-lock-find-context)
  342.     (setq face (font-lock-context-face))
  343.     (cond ((null face)
  344.            (setq extent nil))
  345.           ((eq face last-face)
  346.            (if extent
  347.            (set-extent-endpoints
  348.             extent (extent-start-position extent) (point))))
  349.           (t
  350.            (setq extent (make-extent (point) (point)))
  351.            (set-extent-face extent face)))
  352.     (forward-char 1)))
  353.     (font-lock-hack-keywords (point-min) (point-max))
  354.     ))
  355.  
  356.  
  357.  
  358. (defun font-lock-refontify-line ()
  359.   (let (bol eol s e)
  360.     (save-excursion
  361.       (end-of-line)
  362.       (setq eol (point))
  363.       (beginning-of-line)
  364.       (setq bol (point))
  365.       ;;
  366.       ;; First delete all extents on this line.
  367.       ;; If extents span the line, divide them first so that
  368.       ;; previous and following lines are unaffected.
  369.       (map-extents (function
  370.             (lambda (extent ignore)
  371.               (setq s (extent-start-position extent)
  372.                 e (extent-end-position extent))
  373.               (cond ((< s bol)    ; starts before line
  374.                  (set-extent-endpoints extent s (1- bol))
  375.                  (if (> e (1+ eol)) ; ...and ends after line
  376.                  (set-extent-face
  377.                   (make-extent (1+ eol) e)
  378.                   (extent-face extent))))
  379.                 ((> e (1+ eol))    ; starts on line and ends after
  380.                  (set-extent-endpoints extent (1+ eol) e))
  381.                 (t        ; contained on line
  382.                  (delete-extent extent)))))
  383.            (current-buffer) bol eol nil)
  384.       ;;
  385.       ;; Now fontify this line.
  386.       ;;
  387.       (let (extent face new-face
  388.         e-start)
  389.     (while (<= (point) eol)
  390.       (font-lock-find-context)
  391.       (setq new-face (font-lock-context-face))
  392.       (cond ((and face (eq face new-face))
  393.          (set-extent-endpoints extent e-start (1+ (point))))
  394.         (new-face
  395.          (setq extent (make-extent (setq e-start (point))
  396.                        (1+ (point))))
  397.          (set-extent-face extent new-face)))
  398.       (setq face new-face)
  399.       (forward-char 1)))
  400.       )))
  401.  
  402.  
  403. (defun font-lock-after-change-function (beg end old-len)
  404.   (if (> old-len 0) ; deletions mean the cache is invalid
  405.       (font-lock-flush-cache))
  406.   (save-excursion
  407.     (goto-char beg)
  408.     (beginning-of-line)
  409.     (setq beg (point))
  410.     (while (<= (point) end)
  411.       (font-lock-refontify-line)
  412.       (forward-line 1))
  413.     (font-lock-hack-keywords beg (point))))
  414.  
  415.  
  416. (defvar electric-font-lock-mode-hook nil
  417.   "*Function or functions to run on entry to electric-font-lock-mode.")
  418.  
  419. (defun electric-font-lock-mode (&optional arg)
  420.   "Toggle Electric Font Lock Mode.
  421. With arg, turn font-lock mode on if and only if arg is positive.
  422. In font-lock mode, text is fontified as you type it."
  423.   (interactive "P")
  424.   (set (make-local-variable 'after-change-function)
  425.        (if (if (null arg)
  426.            (not after-change-function)
  427.          (> (prefix-numeric-value arg) 0))
  428.        'font-lock-after-change-function
  429.      nil))
  430.   (if (interactive-p)
  431.       (message "Electric Font Lock Mode is now %s."
  432.            (if after-change-function "on" "off")))
  433.   (if after-change-function
  434.       (run-hooks 'electric-font-lock-mode-hook)))
  435.  
  436.  
  437. ;;; Lisp and C mode interface
  438.  
  439. (defvar lisp-font-lock-keywords
  440.  '(("^(def[-a-z]+\\s +\\(\\S +\\)" 1 font-lock-function-name-face)
  441.    ("(\\(cond\\|if\\|when\\|unless\\|[ec]?\\(type\\)?case\\)[ \t\n]" . 1)
  442.    ("(\\(while\\|do\\|let*?\\|flet\\|labels\\|prog[nv12*]?\\)[ \t\n]" . 1)
  443.    ("\\s :\\(\\sw\\|\\s_\\)+\\>" . 1)
  444.    ))
  445.  
  446. (defconst c-font-lock-keywords
  447.   (let ((storage "auto\\|extern\\|register\\|static\\|volatile")
  448.     (prefixes "unsigned\\|short\\|long")
  449.     (types (concat "int\\|char\\|float\\|double\\|void\\|struct\\|"
  450.                "union\\|enum\\|typedef")))
  451.     (list storage
  452.       (list (concat "\\(" storage "\\)?\\s *"
  453.             "\\(" prefixes "\\)?\\s *"
  454.             "\\(" types "\\)\\s +"
  455.             "\\(\\(\\sw\\|\\s_\\|[*&]\\)+\\)")
  456.         4 'font-lock-function-name-face)
  457.       (cons (concat
  458.          "[ \t]\\("
  459.          "for\\|while\\|do\\|return\\|goto\\|switch\\|case\\|break"
  460.          "\\)[ \t\n(){};,]")
  461.         1)
  462.       "\\(\\sw\\|\\s_\\)+:"
  463.       '("^#[ \t]*[a-z]+" . font-lock-comment-face)
  464.       '("^#[ \t]*include[ \t]+<\\([^>\n]+\\)>" 1 font-lock-string-face)
  465.       )))
  466.  
  467.  
  468. (defun dummy-electric-font-lock-mode-hook ()
  469.   (cond ((memq major-mode '(lisp-mode emacs-lisp-mode))
  470.      (set (make-local-variable 'font-lock-keywords)
  471.           lisp-font-lock-keywords))
  472.     ((memq major-mode '(c-mode c++-mode))
  473.      (set (make-local-variable 'font-lock-keywords)
  474.           c-font-lock-keywords))
  475.     ))
  476.  
  477. (add-hook 'electric-font-lock-mode-hook
  478.       'dummy-electric-font-lock-mode-hook)
  479.