/[climacs]/climacs/core.lisp
ViewVC logotype

Contents of /climacs/core.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Mon Jul 24 14:18:59 2006 UTC (7 years, 8 months ago) by thenriksen
Branch: MAIN
Added core.lisp - needed for my previous patch. Oops.
1 ;;; -*- Mode: Lisp; Package: CLIMACS-CORE -*-
2
3 ;;; (c) copyright 2004-2005 by
4 ;;; Robert Strandh (strandh@labri.fr)
5 ;;; (c) copyright 2004-2005 by
6 ;;; Elliott Johnson (ejohnson@fasl.info)
7 ;;; (c) copyright 2005 by
8 ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr)
9 ;;; (c) copyright 2005 by
10 ;;; Aleksandar Bakic (a_bakic@yahoo.com)
11 ;;; (c) copyright 2006 by
12 ;;; Troels Henriksen (athas@sigkill.dk)
13
14 (in-package :climacs-core)
15
16 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
17 ;;;
18 ;;; Misc stuff
19
20 (defun possibly-fill-line ()
21 (let* ((pane (current-window))
22 (buffer (buffer pane)))
23 (when (auto-fill-mode pane)
24 (let* ((fill-column (auto-fill-column pane))
25 (point (point pane))
26 (offset (offset point))
27 (tab-width (tab-space-count (stream-default-view pane)))
28 (syntax (syntax buffer)))
29 (when (>= (buffer-display-column buffer offset tab-width)
30 (1- fill-column))
31 (fill-line point
32 (lambda (mark)
33 (syntax-line-indentation mark tab-width syntax))
34 fill-column
35 tab-width
36 (syntax buffer)))))))
37
38 (defun insert-character (char)
39 (let* ((window (current-window))
40 (point (point window)))
41 (unless (constituentp char)
42 (possibly-expand-abbrev point))
43 (when (whitespacep (syntax (buffer window)) char)
44 (possibly-fill-line))
45 (if (and (slot-value window 'overwrite-mode) (not (end-of-line-p point)))
46 (progn
47 (delete-range point)
48 (insert-object point char))
49 (insert-object point char))))
50
51 (defun back-to-indentation (mark syntax)
52 (beginning-of-line mark)
53 (loop until (end-of-line-p mark)
54 while (whitespacep syntax (object-after mark))
55 do (forward-object mark)))
56
57 (defun delete-horizontal-space (mark syntax &optional (backward-only-p nil))
58 (let ((mark2 (clone-mark mark)))
59 (loop until (beginning-of-line-p mark)
60 while (whitespacep syntax (object-before mark))
61 do (backward-object mark))
62 (unless backward-only-p
63 (loop until (end-of-line-p mark2)
64 while (whitespacep syntax (object-after mark2))
65 do (forward-object mark2)))
66 (delete-region mark mark2)))
67
68 (defun goto-position (mark pos)
69 (setf (offset mark) pos))
70
71 (defun goto-line (mark line-number)
72 (loop with m = (clone-mark (low-mark (buffer mark))
73 :right)
74 initially (beginning-of-buffer m)
75 do (end-of-line m)
76 until (end-of-buffer-p m)
77 repeat (1- line-number)
78 do (incf (offset m))
79 (end-of-line m)
80 finally (beginning-of-line m)
81 (setf (offset mark) (offset m))))
82
83 (defun indent-current-line (pane point)
84 (let* ((buffer (buffer pane))
85 (view (stream-default-view pane))
86 (tab-space-count (tab-space-count view))
87 (indentation (syntax-line-indentation point
88 tab-space-count
89 (syntax buffer))))
90 (indent-line point indentation (and (indent-tabs-mode buffer)
91 tab-space-count))))
92
93 (defun insert-pair (mark syntax &optional (count 0) (open #\() (close #\)))
94 (cond ((> count 0)
95 (loop while (and (not (end-of-buffer-p mark))
96 (whitespacep syntax (object-after mark)))
97 do (forward-object mark)))
98 ((< count 0)
99 (setf count (- count))
100 (loop repeat count do (backward-expression mark syntax))))
101 (unless (or (beginning-of-buffer-p mark)
102 (whitespacep syntax (object-before mark)))
103 (insert-object mark #\Space))
104 (insert-object mark open)
105 (let ((here (clone-mark mark)))
106 (loop repeat count
107 do (forward-expression here syntax))
108 (insert-object here close)
109 (unless (or (end-of-buffer-p here)
110 (whitespacep syntax (object-after here)))
111 (insert-object here #\Space))))
112
113 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
114 ;;;
115 ;;; Character case
116
117 (defun downcase-word (mark &optional (n 1))
118 "Convert the next N words to lowercase, leaving mark after the last word."
119 (let ((syntax (syntax (buffer mark))))
120 (loop repeat n
121 do (forward-to-word-boundary mark syntax)
122 (let ((offset (offset mark)))
123 (forward-word mark syntax 1 nil)
124 (downcase-region offset mark)))))
125
126 (defun upcase-word (mark syntax &optional (n 1))
127 "Convert the next N words to uppercase, leaving mark after the last word."
128 (loop repeat n
129 do (forward-to-word-boundary mark syntax)
130 (let ((offset (offset mark)))
131 (forward-word mark syntax 1 nil)
132 (upcase-region offset mark))))
133
134 (defun capitalize-word (mark &optional (n 1))
135 "Capitalize the next N words, leaving mark after the last word."
136 (let ((syntax (syntax (buffer mark))))
137 (loop repeat n
138 do (forward-to-word-boundary mark syntax)
139 (let ((offset (offset mark)))
140 (forward-word mark syntax 1 nil)
141 (capitalize-region offset mark)))))
142
143 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
144 ;;;
145 ;;; Indentation
146
147 (defun indent-region (pane mark1 mark2)
148 "Indent all lines in the region delimited by `mark1' and `mark2'
149 according to the rules of the active syntax in `pane'."
150 (let* ((buffer (buffer pane))
151 (view (clim:stream-default-view pane))
152 (tab-space-count (tab-space-count view))
153 (tab-width (and (indent-tabs-mode buffer)
154 tab-space-count))
155 (syntax (syntax buffer)))
156 (do-buffer-region-lines (line mark1 mark2)
157 (let ((indentation (syntax-line-indentation
158 line
159 tab-space-count
160 syntax)))
161 (indent-line line indentation tab-width))
162 ;; We need to update the syntax every time we perform an
163 ;; indentation, so that subsequent indentations will be
164 ;; correctly indented (this matters in list forms). FIXME: This
165 ;; should probably happen automatically.
166 (update-syntax buffer syntax))))
167
168 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
169 ;;;
170 ;;; Auto fill
171
172 (defun fill-line (mark syntax-line-indentation-function fill-column tab-width syntax
173 &optional (compress-whitespaces t))
174 "Breaks the contents of line pointed to by MARK up to MARK into
175 multiple lines such that none of them is longer than FILL-COLUMN. If
176 COMPRESS-WHITESPACES is non-nil, whitespaces are compressed after the
177 decision is made to break the line at a point. For now, the
178 compression means just the deletion of trailing whitespaces."
179 (let ((begin-mark (clone-mark mark)))
180 (beginning-of-line begin-mark)
181 (loop with column = 0
182 with line-beginning-offset = (offset begin-mark)
183 with walking-mark = (clone-mark begin-mark)
184 while (mark< walking-mark mark)
185 as object = (object-after walking-mark)
186 do (case object
187 (#\Space
188 (setf (offset begin-mark) (offset walking-mark))
189 (incf column))
190 (#\Tab
191 (setf (offset begin-mark) (offset walking-mark))
192 (incf column (- tab-width (mod column tab-width))))
193 (t
194 (incf column)))
195 (when (and (>= column fill-column)
196 (/= (offset begin-mark) line-beginning-offset))
197 (when compress-whitespaces
198 (let ((offset (buffer-search-backward
199 (buffer begin-mark)
200 (offset begin-mark)
201 #(nil)
202 :test #'(lambda (o1 o2)
203 (declare (ignore o2))
204 (not (whitespacep syntax o1))))))
205 (when offset
206 (delete-region begin-mark (1+ offset)))))
207 (insert-object begin-mark #\Newline)
208 (incf (offset begin-mark))
209 (let ((indentation
210 (funcall syntax-line-indentation-function begin-mark)))
211 (indent-line begin-mark indentation tab-width))
212 (beginning-of-line begin-mark)
213 (setf line-beginning-offset (offset begin-mark))
214 (setf (offset walking-mark) (offset begin-mark))
215 (setf column 0))
216 (incf (offset walking-mark)))))
217
218 (defun fill-region (mark1 mark2 syntax-line-indentation-function fill-column tab-width syntax
219 &optional (compress-whitespaces t))
220 "Fill the region delimited by `mark1' and `mark2'. `Mark1' must be
221 mark<= `mark2.'"
222 (let* ((buffer (buffer mark1)))
223 (do-buffer-region (object offset buffer
224 (offset mark1) (offset mark2))
225 (when (eql object #\Newline)
226 (setf object #\Space)))
227 (when (>= (buffer-display-column buffer (offset mark2) tab-width)
228 (1- fill-column))
229 (fill-line mark2
230 syntax-line-indentation-function
231 fill-column
232 tab-width
233 compress-whitespaces
234 syntax))))
235
236 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
237 ;;;
238 ;;; Indentation
239
240 (defgeneric indent-line (mark indentation tab-width)
241 (:documentation "Indent the line containing mark with indentation
242 spaces. Use tabs and spaces if tab-width is not nil, otherwise use
243 spaces only."))
244
245 (defun indent-line* (mark indentation tab-width left)
246 (let ((mark2 (clone-mark mark)))
247 (beginning-of-line mark2)
248 (loop until (end-of-buffer-p mark2)
249 as object = (object-after mark2)
250 while (or (eql object #\Space) (eql object #\Tab))
251 do (delete-range mark2 1))
252 (loop until (zerop indentation)
253 do (cond ((and tab-width (>= indentation tab-width))
254 (insert-object mark2 #\Tab)
255 (when left ; spaces must follow tabs
256 (forward-object mark2))
257 (decf indentation tab-width))
258 (t
259 (insert-object mark2 #\Space)
260 (decf indentation))))))
261
262 (defmethod indent-line ((mark left-sticky-mark) indentation tab-width)
263 (indent-line* mark indentation tab-width t))
264
265 (defmethod indent-line ((mark right-sticky-mark) indentation tab-width)
266 (indent-line* mark indentation tab-width nil))
267
268 (defun delete-indentation (mark)
269 (beginning-of-line mark)
270 (unless (beginning-of-buffer-p mark)
271 (delete-range mark -1)
272 (loop until (end-of-buffer-p mark)
273 while (buffer-whitespacep (object-after mark))
274 do (delete-range mark 1))
275 (loop until (beginning-of-buffer-p mark)
276 while (buffer-whitespacep (object-before mark))
277 do (delete-range mark -1))
278 (when (and (not (beginning-of-buffer-p mark))
279 (constituentp (object-before mark)))
280 (insert-object mark #\Space))))

  ViewVC Help
Powered by ViewVC 1.1.5