home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / epoch / tek-epoch-stuff / tek-src-hilite.el < prev    next >
Encoding:
Text File  |  1991-11-20  |  7.8 KB  |  221 lines
  1. ;*****************************************************************************
  2. ;
  3. ; Filename:    tek-src-hilite.el
  4. ;
  5. ; Copyright (C) 1991  Ken Wood
  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 1, or (at your option)
  10. ; 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. ; Author:        Ken Wood, <kwood@austek.oz.au>
  22. ; Organisation:        Austek Microsystems Pty Ltd, Australia.
  23. ; Released with permission from Austek Microsystems.
  24. ;
  25. ; Description:    Highlight comments in source code buffers. Highlighting is
  26. ;        updated on find-file and save-buffer.
  27. ;
  28. ;        Button styles may be customised by means of X11 resources.
  29. ;        The resource name to use is "src-comment".
  30. ;        See the file tek-style-utils.el for details.
  31. ;
  32. ;        You may need to modify the variable
  33. ;        tek-highlight-merge-comments if you change the highlighting
  34. ;        style away from the default. See the documentation for this
  35. ;        variable for further details.
  36. ;
  37. ;        See the INSTALL file that comes with this package for
  38. ;        installation details.
  39. ;
  40. ;*****************************************************************************
  41.  
  42. ; $Id: tek-src-hilite.el,v 1.5 1991/11/21 02:58:53 kwood Exp $
  43.  
  44. (provide 'tek-src-hilite)
  45. (require 'epoch-running)
  46.  
  47. ; Put the whole thing inside a test to get it to compile under emacs.
  48. (if running-epoch
  49.     (progn
  50.       
  51.       (require 'tek-style-utils)
  52.  
  53.       (defvar tek-src-comment-foreground "blue3"
  54.     "\
  55. Foreground color used to highlight comments if no value is defined in
  56. the X11 resources and the display device supports color. On monochrome
  57. screens a different font is used in place of the different color.")
  58.       
  59.       (defvar tek-src-comment-styleorattribute
  60.     ; If the display supports multiple colors and a default color
  61.     ; is specified, define the style to use a different color.
  62.     (if (and (> (number-of-colors) 2) tek-src-comment-foreground)
  63.         (tek-build-style "src-comment"
  64.                  nil nil
  65.                  tek-src-comment-foreground (background)
  66.                  (background) (foreground))
  67.       ; Otherwise, define the style to use a different font.
  68.       (tek-build-style "src-comment" nil (or tek-italic-bold-fixed-font
  69.                          tek-bold-fixed-font
  70.                          tek-italic-fixed-font)
  71.                (foreground) (background)
  72.                (background) (foreground)))
  73.     "\
  74. Style or attribute used to display characters in source code comments.")
  75.  
  76.  
  77.       ; Select V3 or V4 button behaviour
  78.       (if tek-highlight-use-attributes
  79.       (progn
  80.         ; Do things the old way - using attributes.
  81.       
  82.         (defvar tek-src-comment-style tek-src-comment-styleorattribute
  83.           "\
  84. Style used for displaying comments in source code when attributes are
  85. used to mark buttons.")
  86.  
  87.         ; Modify the variable used with add-button to be an attribute
  88.         (setq tek-src-comment-styleorattribute (reserve-attribute))
  89.       
  90.         ;Bind the comment style to the comment attribute
  91.         (set-attribute-style tek-src-comment-styleorattribute
  92.                  tek-src-comment-style)
  93.         ))
  94.  
  95.  
  96.       (defvar tek-highlight-done-this-buffer nil
  97.     "\
  98. Buffer-local variable indicating whether any comments have been
  99. highlighted in this buffer or not.")
  100.  
  101.       (defvar tek-highlight-comment-continue-regexp nil
  102.     "\
  103. Buffer-local variable used to decide when adjacent comments may be
  104. considered a single block. A search string which allows only
  105. whitespace between comments.")
  106.  
  107.       (make-variable-buffer-local 'tek-highlight-done-this-buffer)
  108.       (make-variable-buffer-local 'tek-highlight-comment-continue-regexp)
  109.  
  110.  
  111.       (defvar tek-highlight-merge-comments t
  112.     "\
  113. *If non-nil then adjacent comments which are separated only by
  114. whitespace may be merged, i.e. highlighted by a single button which
  115. runs from the start of the first comment to the end of the last
  116. comment. This variable is t by default, as this results in a
  117. significant speedup in syntaxes which have newline-terminated
  118. comments. It should be set to nil if the comment highlighting style
  119. makes whitespace visible. Underlining and changing the background
  120. color are two things that do this.")
  121.  
  122.  
  123.       ;
  124.       ; Function which does the actual highlighting
  125.       ;
  126.       (defun tek-highlight-comments ()
  127.     "\
  128. Actual source code highlighting function. Called by
  129. tek-highlight-comments-on-find and tek-highlight-comments-on-write."
  130.     ; Silently do nothing if there are no regexps to search with.
  131.     (if (and syndecode-comment-start-regexp
  132.          syndecode-comment-end-regexp)
  133.         (let ((starting-point (point-min))
  134.           comment-start-begin
  135.           comment-start-end
  136.           comment-end-end)
  137.           (save-excursion
  138.         (goto-char (point-min))
  139.         ; Algorithm is: search for start of a comment,
  140.         ; make sure it really is a comment; then highlight
  141.         ; from there to the end of the comment.
  142.         ;
  143.         ; First, find a comment-start sequence.
  144.         (while (re-search-forward syndecode-comment-start-regexp
  145.                       nil t)
  146.           (progn
  147.             (setq comment-start-begin (match-beginning 0))
  148.             (setq comment-start-end (match-end 0))
  149.             ; Check that the comment start sequence really does
  150.             ; indicate the start of a comment, and that it's not
  151.             ; inside a string etc.
  152.             (setq state (parse-partial-sexp
  153.                  starting-point comment-start-end))
  154.             (if (nth 4 state)
  155.             ; Yes, this is really the start of a comment
  156.             (progn
  157.               (goto-char comment-start-end)
  158.               ; Find the end of the comment by searching
  159.               ; for a comment terminating sequence
  160.               (re-search-forward syndecode-comment-end-regexp
  161.                          nil t)
  162.               (setq comment-end-end (point))
  163.               ; Now, searches are faster than adding buttons,
  164.               ; so see if we can extend this button to cover any
  165.               ; following comments.
  166.               (while (and tek-highlight-merge-comments
  167.                       (looking-at
  168.                        tek-highlight-comment-continue-regexp))
  169.                 (progn (re-search-forward
  170.                     tek-highlight-comment-continue-regexp
  171.                     nil t)
  172.                    (re-search-forward
  173.                     syndecode-comment-end-regexp
  174.                     nil t)
  175.                    (setq comment-end-end (point))))
  176.               ; Highlight the comment
  177.               (add-button comment-start-begin comment-end-end
  178.                       tek-src-comment-styleorattribute)
  179.               ; Start the next syntax parse at the end of the
  180.               ; comment just processed.
  181.               (setq starting-point comment-end-end)
  182.               )))))
  183.           ; Set a flag to indicate there are highlighted comments in
  184.           ; this buffer.
  185.           (setq tek-highlight-done-this-buffer t)
  186.           ))) ; end of defun
  187.  
  188.  
  189.       ; Function to be called by find-file-hooks.
  190.       (defun tek-highlight-comments-on-find ()
  191.     "\
  192. Function to highlight all the comments in the current buffer. Intended
  193. to be called by find-file-hooks."
  194.     ; Extract comment details from the current syntax table. This will
  195.     ; do nothing if this function has already been run in this buffer.
  196.     (decode-syntax-table)
  197.     (if syndecode-comment-start-regexp
  198.         (setq tek-highlight-comment-continue-regexp
  199.           (concat "[ \t\n]*\\(" syndecode-comment-start-regexp
  200.               "\\)")))
  201.     (tek-highlight-comments))
  202.  
  203.  
  204.       ; Function to be called by write-file-hooks.
  205.       (defun tek-highlight-comments-on-write ()
  206.     "\
  207. Function to highlight all the comments in the current buffer. Intended
  208. to be called by write-file-hooks."
  209.     ; Check to see if there is any highlighting currently in effect
  210.     (if tek-highlight-done-this-buffer
  211.         ; If so, remove & redo highlighting.
  212.         (progn
  213.           ; Clean up first - saves memory
  214.           (clear-buttons)
  215.           (tek-highlight-comments)))
  216.     ; Have to return nil or write-file-hooks will get stuffed up.
  217.     nil)
  218.  
  219.  
  220.       )) ; end: running-epoch test
  221.