/[cmucl]/src/hemlock/highlight.lisp
ViewVC logotype

Contents of /src/hemlock/highlight.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Mon Sep 23 09:27:29 1991 UTC (22 years, 6 months ago) by wlott
Branch: MAIN
Changes since 1.2: +9 -14 lines
Allow active region highlighting on the tty.
1 ;;; -*- Log: hemlock.log; Package: Hemlock -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/highlight.lisp,v 1.3 1991/09/23 09:27:29 wlott Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; Highlighting paren and some other good stuff.
15 ;;;
16 ;;; Written by Bill Chiles and Jim Healy.
17 ;;;
18
19 (in-package "HEMLOCK")
20
21
22
23 ;;;; Open parens.
24
25 (defhvar "Highlight Open Parens"
26 "When non-nil, causes open parens to be displayed in a different font when
27 the cursor is directly to the right of the corresponding close paren."
28 :value nil)
29
30 (defhvar "Open Paren Highlighting Font"
31 "The string name of the font to be used for highlighting open parens.
32 The font is loaded when initializing Hemlock."
33 :value nil)
34
35
36 (defvar *open-paren-font-marks* nil
37 "The pair of font-marks surrounding the currently highlighted open-
38 paren or nil if there isn't one.")
39
40 (defvar *open-paren-highlight-font* 2
41 "The index into the font-map for the open paren highlighting font.")
42
43
44 ;;; MAYBE-HIGHLIGHT-OPEN-PARENS is a redisplay hook that matches parens by
45 ;;; highlighting the corresponding open-paren after a close-paren is
46 ;;; typed.
47 ;;;
48 (defun maybe-highlight-open-parens (window)
49 (declare (ignore window))
50 (when (value highlight-open-parens)
51 (with-mark ((mark (current-point)))
52 (cond ((and (value highlight-active-region) (region-active-p))
53 (kill-open-paren-font-marks))
54 ((eq (character-attribute :lisp-syntax (previous-character mark))
55 :close-paren)
56 (pre-command-parse-check mark)
57 (cond ((not (and (valid-spot mark nil) (list-offset mark -1)))
58 (kill-open-paren-font-marks))
59 ((not *open-paren-font-marks*)
60 (set-open-paren-font-marks mark))
61 ((mark= (region-start *open-paren-font-marks*) mark))
62 (t (reset-open-paren-font-marks mark))))
63 (t (kill-open-paren-font-marks))))))
64 ;;;
65 (add-hook redisplay-hook 'maybe-highlight-open-parens)
66
67 (defun set-open-paren-font-marks (mark)
68 (let ((line (mark-line mark)))
69 (setf *open-paren-font-marks*
70 (region
71 (font-mark line (mark-charpos mark) *open-paren-highlight-font*)
72 (font-mark line (mark-charpos (mark-after mark)) 0)))))
73
74 (defun reset-open-paren-font-marks (mark)
75 (move-font-mark (region-start *open-paren-font-marks*) mark)
76 (move-font-mark (region-end *open-paren-font-marks*)
77 (mark-after mark)))
78
79 (defun kill-open-paren-font-marks ()
80 (when *open-paren-font-marks*
81 (delete-font-mark (region-start *open-paren-font-marks*))
82 (delete-font-mark (region-end *open-paren-font-marks*))
83 (setf *open-paren-font-marks* nil)))
84
85
86
87 ;;;; Active regions.
88
89 (defhvar "Active Region Highlighting Font"
90 "The string name of the font to be used for highlighting active regions.
91 The font is loaded when initializing Hemlock."
92 :value nil)
93
94 (defvar *active-region-font-marks* nil)
95 (defvar *active-region-highlight-font* 3
96 "The index into the font-map for the active region highlighting font.")
97
98
99 ;;; HIGHLIGHT-ACTIVE-REGION is a redisplay hook for active regions.
100 ;;; Since it is too hard to know how the region may have changed when it is
101 ;;; active and already highlighted, if it does not check out to being exactly
102 ;;; the same, we just delete all the font marks and make new ones. When
103 ;;; the current window is the echo area window, just pretend everything is
104 ;;; okay; this keeps the region highlighted while we're in there.
105 ;;;
106 (defun highlight-active-region (window)
107 (unless (eq window *echo-area-window*)
108 (when (value highlight-active-region)
109 (cond ((region-active-p)
110 (cond ((not *active-region-font-marks*)
111 (set-active-region-font-marks))
112 ((check-active-region-font-marks))
113 (t (kill-active-region-font-marks)
114 (set-active-region-font-marks))))
115 (*active-region-font-marks*
116 (kill-active-region-font-marks))))))
117 ;;;
118 (add-hook redisplay-hook 'highlight-active-region)
119
120 (defun set-active-region-font-marks ()
121 (flet ((stash-a-mark (m &optional (font *active-region-highlight-font*))
122 (push (font-mark (mark-line m) (mark-charpos m) font)
123 *active-region-font-marks*)))
124 (let* ((region (current-region nil nil))
125 (start (region-start region))
126 (end (region-end region)))
127 (with-mark ((mark start))
128 (unless (mark= mark end)
129 (loop
130 (stash-a-mark mark)
131 (unless (line-offset mark 1 0) (return))
132 (when (mark>= mark end) (return)))
133 (unless (start-line-p end) (stash-a-mark end 0))))))
134 (setf *active-region-font-marks* (nreverse *active-region-font-marks*)))
135
136 (defun kill-active-region-font-marks ()
137 (dolist (m *active-region-font-marks*)
138 (delete-font-mark m))
139 (setf *active-region-font-marks* nil))
140
141 ;;; CHECK-ACTIVE-REGION-FONT-MARKS returns t if the current region is the same
142 ;;; as that what is highlighted on the screen. This assumes
143 ;;; *active-region-font-marks* is non-nil. At the very beginning, our start
144 ;;; mark must not be at the end; it must be at the first font mark; and the
145 ;;; font marks must be in the current buffer. We don't make font marks if the
146 ;;; start is at the end, so if this is the case, then they just moved together.
147 ;;; We return nil in this case to kill all the font marks and make new ones, but
148 ;;; no new ones will be made.
149 ;;;
150 ;;; Sometimes we hack the font marks list and return t because we can easily
151 ;;; adjust the highlighting to be correct. This keeps all the font marks from
152 ;;; being killed and re-established. In the loop, if there are no more font
153 ;;; marks, we either ended a region already highlighted on the next line down,
154 ;;; or we have to revamp the font marks. Before returning here, we see if the
155 ;;; region ends one more line down at the beginning of the line. If this is
156 ;;; true, then the user is simply doing "Next Line" at the beginning of the
157 ;;; line.
158 ;;;
159 ;;; Each time through the loop we look at the top font mark, move our roving
160 ;;; mark down one line, and see if they compare. If they are not equal, the
161 ;;; region may still be the same as that highlighted on the screen. If this
162 ;;; is the last font mark, not at the beginning of the line, and it is at the
163 ;;; region's end, then this last font mark is in the middle of a line somewhere
164 ;;; changing the font from the highlighting font to the default font. Return
165 ;;; t.
166 ;;;
167 ;;; If our roving mark is not at the current font mark, but it is at or after
168 ;;; the end of the active region, then the end of the active region has moved
169 ;;; before its previous location.
170 ;;;
171 ;;; Otherwise, move on to the next font mark.
172 ;;;
173 ;;; If our roving mark never moved onto a next line, then the buffer ends on the
174 ;;; previous line, and the last font mark changes from the highlighting font to
175 ;;; the default font.
176 ;;;
177 (defun check-active-region-font-marks ()
178 (let* ((region (current-region nil nil))
179 (end (region-end region)))
180 (with-mark ((mark (region-start region)))
181 (let ((first-active-mark (car *active-region-font-marks*))
182 (last-active-mark (last *active-region-font-marks*)))
183 (if (and (mark/= mark end)
184 (eq (current-buffer)
185 (line-buffer (mark-line first-active-mark)))
186 (mark= first-active-mark mark))
187 (let ((marks (cdr *active-region-font-marks*)))
188 (loop
189 (unless marks
190 (let ((res (and (line-offset mark 1 0)
191 (mark= mark end))))
192 (when (and (not res)
193 (line-offset mark 1 0)
194 (mark= mark end)
195 (start-line-p (car last-active-mark)))
196 (setf (cdr last-active-mark)
197 (list (font-mark (line-previous (mark-line mark))
198 0
199 *active-region-highlight-font*)))
200 (return t))
201 (return res)))
202 (let ((fmark (car marks)))
203 (if (line-offset mark 1 0)
204 (cond ((mark/= mark fmark)
205 (return (and (not (cdr marks))
206 (not (start-line-p fmark))
207 (mark= fmark end))))
208 ((mark>= mark end)
209 (return nil))
210 (t (setf marks (cdr marks))))
211
212 (return (and (not (cdr marks))
213 (not (start-line-p fmark))
214 (mark= fmark end))))))))))))
215

  ViewVC Help
Powered by ViewVC 1.1.5