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

Contents of /src/hemlock/highlight.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Mon Oct 31 04:50:12 1994 UTC (19 years, 5 months ago) by ram
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, RELEASE_18d, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, RELEASE_18a, RELEASE_18b, RELEASE_18c, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, RELENG_18, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.5: +1 -3 lines
Fix headed boilerplate.
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 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/highlight.lisp,v 1.6 1994/10/31 04:50:12 ram Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Highlighting paren and some other good stuff.
13 ;;;
14 ;;; Written by Bill Chiles and Jim Healy.
15 ;;;
16
17 (in-package "HEMLOCK")
18
19
20
21 ;;;; Open parens.
22
23 (defhvar "Highlight Open Parens"
24 "When non-nil, causes open parens to be displayed in a different font when
25 the cursor is directly to the right of the corresponding close paren."
26 :value nil)
27
28 (defhvar "Open Paren Finder Function"
29 "Should be a function that takes a mark for input and returns either NIL
30 if the mark is not after a close paren, or two (temporary) marks
31 surrounding the corresponding open paren."
32 :value 'lisp-open-paren-finder-function)
33
34
35 (defvar *open-paren-font-marks* nil
36 "The pair of font-marks surrounding the currently highlighted open-
37 paren or nil if there isn't one.")
38
39 (defvar *open-paren-highlight-font* 2
40 "The index into the font-map for the open paren highlighting font.")
41
42
43 ;;; MAYBE-HIGHLIGHT-OPEN-PARENS is a redisplay hook that matches parens by
44 ;;; highlighting the corresponding open-paren after a close-paren is
45 ;;; typed.
46 ;;;
47 (defun maybe-highlight-open-parens (window)
48 (declare (ignore window))
49 (when (value highlight-open-parens)
50 (if (and (value highlight-active-region) (region-active-p))
51 (kill-open-paren-font-marks)
52 (multiple-value-bind
53 (start end)
54 (funcall (value open-paren-finder-function)
55 (current-point))
56 (if (and start end)
57 (set-open-paren-font-marks start end)
58 (kill-open-paren-font-marks))))))
59 ;;;
60 (add-hook redisplay-hook 'maybe-highlight-open-parens)
61
62 (defun set-open-paren-font-marks (start end)
63 (if *open-paren-font-marks*
64 (flet ((maybe-move (dst src)
65 (unless (mark= dst src)
66 (move-font-mark dst src))))
67 (declare (inline maybe-move))
68 (maybe-move (region-start *open-paren-font-marks*) start)
69 (maybe-move (region-end *open-paren-font-marks*) end))
70 (let ((line (mark-line start)))
71 (setf *open-paren-font-marks*
72 (region
73 (font-mark line (mark-charpos start)
74 *open-paren-highlight-font*)
75 (font-mark line (mark-charpos end) 0))))))
76
77 (defun kill-open-paren-font-marks ()
78 (when *open-paren-font-marks*
79 (delete-font-mark (region-start *open-paren-font-marks*))
80 (delete-font-mark (region-end *open-paren-font-marks*))
81 (setf *open-paren-font-marks* nil)))
82
83
84
85
86 ;;;; Active regions.
87
88 (defvar *active-region-font-marks* nil)
89 (defvar *active-region-highlight-font* 3
90 "The index into the font-map for the active region highlighting font.")
91
92
93 ;;; HIGHLIGHT-ACTIVE-REGION is a redisplay hook for active regions.
94 ;;; Since it is too hard to know how the region may have changed when it is
95 ;;; active and already highlighted, if it does not check out to being exactly
96 ;;; the same, we just delete all the font marks and make new ones. When
97 ;;; the current window is the echo area window, just pretend everything is
98 ;;; okay; this keeps the region highlighted while we're in there.
99 ;;;
100 (defun highlight-active-region (window)
101 (unless (eq window *echo-area-window*)
102 (when (value highlight-active-region)
103 (cond ((region-active-p)
104 (cond ((not *active-region-font-marks*)
105 (set-active-region-font-marks))
106 ((check-active-region-font-marks))
107 (t (kill-active-region-font-marks)
108 (set-active-region-font-marks))))
109 (*active-region-font-marks*
110 (kill-active-region-font-marks))))))
111 ;;;
112 (add-hook redisplay-hook 'highlight-active-region)
113
114 (defun set-active-region-font-marks ()
115 (flet ((stash-a-mark (m &optional (font *active-region-highlight-font*))
116 (push (font-mark (mark-line m) (mark-charpos m) font)
117 *active-region-font-marks*)))
118 (let* ((region (current-region nil nil))
119 (start (region-start region))
120 (end (region-end region)))
121 (with-mark ((mark start))
122 (unless (mark= mark end)
123 (loop
124 (stash-a-mark mark)
125 (unless (line-offset mark 1 0) (return))
126 (when (mark>= mark end) (return)))
127 (unless (start-line-p end) (stash-a-mark end 0))))))
128 (setf *active-region-font-marks* (nreverse *active-region-font-marks*)))
129
130 (defun kill-active-region-font-marks ()
131 (dolist (m *active-region-font-marks*)
132 (delete-font-mark m))
133 (setf *active-region-font-marks* nil))
134
135 ;;; CHECK-ACTIVE-REGION-FONT-MARKS returns t if the current region is the same
136 ;;; as that what is highlighted on the screen. This assumes
137 ;;; *active-region-font-marks* is non-nil. At the very beginning, our start
138 ;;; mark must not be at the end; it must be at the first font mark; and the
139 ;;; font marks must be in the current buffer. We don't make font marks if the
140 ;;; start is at the end, so if this is the case, then they just moved together.
141 ;;; We return nil in this case to kill all the font marks and make new ones, but
142 ;;; no new ones will be made.
143 ;;;
144 ;;; Sometimes we hack the font marks list and return t because we can easily
145 ;;; adjust the highlighting to be correct. This keeps all the font marks from
146 ;;; being killed and re-established. In the loop, if there are no more font
147 ;;; marks, we either ended a region already highlighted on the next line down,
148 ;;; or we have to revamp the font marks. Before returning here, we see if the
149 ;;; region ends one more line down at the beginning of the line. If this is
150 ;;; true, then the user is simply doing "Next Line" at the beginning of the
151 ;;; line.
152 ;;;
153 ;;; Each time through the loop we look at the top font mark, move our roving
154 ;;; mark down one line, and see if they compare. If they are not equal, the
155 ;;; region may still be the same as that highlighted on the screen. If this
156 ;;; is the last font mark, not at the beginning of the line, and it is at the
157 ;;; region's end, then this last font mark is in the middle of a line somewhere
158 ;;; changing the font from the highlighting font to the default font. Return
159 ;;; t.
160 ;;;
161 ;;; If our roving mark is not at the current font mark, but it is at or after
162 ;;; the end of the active region, then the end of the active region has moved
163 ;;; before its previous location.
164 ;;;
165 ;;; Otherwise, move on to the next font mark.
166 ;;;
167 ;;; If our roving mark never moved onto a next line, then the buffer ends on the
168 ;;; previous line, and the last font mark changes from the highlighting font to
169 ;;; the default font.
170 ;;;
171 (defun check-active-region-font-marks ()
172 (let* ((region (current-region nil nil))
173 (end (region-end region)))
174 (with-mark ((mark (region-start region)))
175 (let ((first-active-mark (car *active-region-font-marks*))
176 (last-active-mark (last *active-region-font-marks*)))
177 (if (and (mark/= mark end)
178 (eq (current-buffer)
179 (line-buffer (mark-line first-active-mark)))
180 (mark= first-active-mark mark))
181 (let ((marks (cdr *active-region-font-marks*)))
182 (loop
183 (unless marks
184 (let ((res (and (line-offset mark 1 0)
185 (mark= mark end))))
186 (when (and (not res)
187 (line-offset mark 1 0)
188 (mark= mark end)
189 (start-line-p (car last-active-mark)))
190 (setf (cdr last-active-mark)
191 (list (font-mark (line-previous (mark-line mark))
192 0
193 *active-region-highlight-font*)))
194 (return t))
195 (return res)))
196 (let ((fmark (car marks)))
197 (if (line-offset mark 1 0)
198 (cond ((mark/= mark fmark)
199 (return (and (not (cdr marks))
200 (not (start-line-p fmark))
201 (mark= fmark end))))
202 ((mark>= mark end)
203 (return nil))
204 (t (setf marks (cdr marks))))
205
206 (return (and (not (cdr marks))
207 (not (start-line-p fmark))
208 (mark= fmark end))))))))))))
209

  ViewVC Help
Powered by ViewVC 1.1.5