home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / emacs-19.28-src.tgz / tar.out / fsf / emacs / lisp / paren.el < prev    next >
Lisp/Scheme  |  1996-09-28  |  5KB  |  143 lines
  1. ;;; paren.el --- highlight matching paren.
  2. ;; Copyright (C) 1993 Free Software Foundation, Inc.
  3.  
  4. ;; Author: rms@gnu.ai.mit.edu
  5. ;; Maintainer: FSF
  6. ;; Keywords: languages, faces
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23.  
  24. ;;; Commentary:
  25.  
  26. ;; Load this and it will display highlighting on whatever
  27. ;; paren matches the one before or after point.
  28.  
  29. ;;; Code:
  30.  
  31. ;; This is the overlay used to highlight the matching paren.
  32. (defvar show-paren-overlay nil)
  33. ;; This is the overlay used to highlight the closeparen
  34. ;; right before point.
  35. (defvar show-paren-overlay-1 nil)
  36.  
  37. (defvar show-paren-mismatch-face nil)
  38.  
  39. (defvar show-paren-face 'region
  40.   "*Name of face to use for showing the matching paren.")
  41.  
  42. ;; Find the place to show, if there is one,
  43. ;; and show it until input arrives.
  44. (defun show-paren-command-hook ()
  45.   ;; Do nothing if no window system to display results with.
  46.   ;; Do nothing if executing keyboard macro.
  47.   ;; Do nothing if input is pending.
  48.   (if (and window-system (not executing-kbd-macro) (sit-for 0 100))
  49.       (let (pos dir mismatch (oldpos (point))
  50.         (face show-paren-face))
  51.     (cond ((eq (char-syntax (preceding-char)) ?\))
  52.            (setq dir -1))
  53.           ((eq (char-syntax (following-char)) ?\()
  54.            (setq dir 1)))
  55.     (if dir
  56.         (save-excursion
  57.           (save-restriction
  58.         ;; Determine the range within which to look for a match.
  59.         (if blink-matching-paren-distance
  60.             (narrow-to-region (max (point-min)
  61.                        (- (point) blink-matching-paren-distance))
  62.                       (min (point-max)
  63.                        (+ (point) blink-matching-paren-distance))))
  64.         ;; Scan across one sexp within that range.
  65.         (condition-case ()
  66.             (setq pos (scan-sexps (point) dir))
  67.           (error nil))
  68.         ;; See if the "matching" paren is the right kind of paren
  69.         ;; to match the one we started at.
  70.         (if pos
  71.             (let ((beg (min pos oldpos)) (end (max pos oldpos)))
  72.               (and (/= (char-syntax (char-after beg)) ?\$)
  73.                (setq mismatch
  74.                  (not (eq (char-after (1- end))
  75.                       ;; This can give nil.
  76.                       (matching-paren (char-after beg))))))))
  77.         ;; If they don't properly match, use a different face,
  78.         ;; or print a message.
  79.         (if mismatch
  80.             (progn
  81.               (and (null show-paren-mismatch-face)
  82.                (x-display-color-p)
  83.                (or (internal-find-face 'paren-mismatch)
  84.                    (progn
  85.                  (make-face 'paren-mismatch)
  86.                  (set-face-background 'paren-mismatch
  87.                               "purple")
  88.                  (set-face-foreground 'paren-mismatch
  89.                               "white")))
  90.                (setq show-paren-mismatch-face 'paren-mismatch))
  91.               (if show-paren-mismatch-face
  92.               (setq face show-paren-mismatch-face)
  93.             (message "Paren mismatch"))))
  94.         )))
  95.     (cond (pos
  96.            (if (= dir -1)
  97.            ;; If matching backwards, highlight the closeparen
  98.            ;; before point as well as its matching open.
  99.            (progn
  100.              (if show-paren-overlay-1
  101.              (move-overlay show-paren-overlay-1
  102.                        (+ (point) dir) (point)
  103.                        (current-buffer))
  104.                (setq show-paren-overlay-1
  105.                  (make-overlay (- pos dir) pos)))
  106.              ;; Always set the overlay face, since it varies.
  107.              (overlay-put show-paren-overlay-1 'face face))
  108.          ;; Otherwise, turn off any such highlighting.
  109.          (and show-paren-overlay-1
  110.               (overlay-buffer show-paren-overlay-1)
  111.               (delete-overlay show-paren-overlay-1)))
  112.            ;; Turn on highlighting for the matching paren.
  113.            (if show-paren-overlay
  114.            (move-overlay show-paren-overlay (- pos dir) pos
  115.                  (current-buffer))
  116.          (setq show-paren-overlay
  117.                (make-overlay (- pos dir) pos)))
  118.            ;; Always set the overlay face, since it varies.
  119.            (overlay-put show-paren-overlay 'face face))
  120.           (t
  121.            ;; If not at a paren that has a match,
  122.            ;; turn off any previous paren highlighting.
  123.            (and show-paren-overlay (overlay-buffer show-paren-overlay)
  124.             (delete-overlay show-paren-overlay))
  125.            (and show-paren-overlay-1 (overlay-buffer show-paren-overlay-1)
  126.             (delete-overlay show-paren-overlay-1)))))))
  127.  
  128. (if window-system
  129.     (progn
  130.       (setq blink-paren-function nil)
  131.       (add-hook 'post-command-hook 'show-paren-command-hook)))
  132. ;;; This is in case paren.el is preloaded.
  133. (add-hook 'window-setup-hook
  134.       (function (lambda ()
  135.               (if window-system
  136.               (progn
  137.                 (setq blink-paren-function nil)
  138.                 (add-hook 'post-command-hook
  139.                       'show-paren-command-hook))))))
  140. (provide 'paren)
  141.  
  142. ;;; paren.el ends here
  143.