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

Contents of /src/hemlock/htext2.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Sun Mar 28 15:48:11 2004 UTC (10 years ago) by emarsden
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, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2004-10, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, 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, unicode-utf16-sync-2008-12, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, merge-sse2-packed, mod-arith-base, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, 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, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, RELEASE_20b, snapshot-2008-04, 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, 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, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, 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, 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, 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, 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, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, 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.3: +3 -3 lines
  - fix some error format strings that were missing arguments (found by the
    compiler's format-string checking!)
1 ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
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/htext2.lisp,v 1.4 2004/03/28 15:48:11 emarsden Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; More Hemlock Text-Manipulation functions.
13 ;;; Written by Skef Wholey.
14 ;;;
15 ;;; The code in this file implements the non-insert/delete functions in the
16 ;;; "Doing Stuff and Going Places" chapter of the Hemlock Design document.
17 ;;;
18
19 (in-package "HEMLOCK-INTERNALS")
20
21 (export '(region-to-string string-to-region line-to-region
22 previous-character next-character count-lines
23 count-characters line-start line-end buffer-start
24 buffer-end move-mark mark-before mark-after
25 character-offset line-offset region-bounds
26 set-region-bounds *print-region*))
27
28
29
30 (defun region-to-string (region)
31 "Returns a string containing the characters in the given Region."
32 (close-line)
33 (let* ((dst-length (count-characters region))
34 (string (make-string dst-length))
35 (start-mark (region-start region))
36 (end-mark (region-end region))
37 (start-line (mark-line start-mark))
38 (end-line (mark-line end-mark))
39 (start-charpos (mark-charpos start-mark)))
40 (declare (simple-string string))
41 (if (eq start-line end-line)
42 (%sp-byte-blt (line-chars start-line) start-charpos string 0
43 dst-length)
44 (let ((index ()))
45 (let* ((line-chars (line-chars start-line))
46 (dst-end (- (length line-chars) start-charpos)))
47 (declare (simple-string line-chars))
48 (%sp-byte-blt line-chars start-charpos string 0 dst-end)
49 (setf (char string dst-end) #\newline)
50 (setq index (1+ dst-end)))
51 (do* ((line (line-next start-line) (line-next line))
52 (chars (line-chars line) (line-chars line)))
53 ((eq line end-line)
54 (%sp-byte-blt (line-chars line) 0 string index dst-length))
55 (declare (simple-string chars))
56 (%sp-byte-blt (line-chars line) 0 string index
57 (incf index (length chars)))
58 (setf (char string index) #\newline)
59 (setq index (1+ index)))))
60 string))
61
62 (defun string-to-region (string)
63 "Returns a region containing the characters in the given String."
64 (let* ((string (if (simple-string-p string)
65 string (coerce string 'simple-string)))
66 (end (length string)))
67 (declare (simple-string string))
68 (do* ((index 0)
69 (buffer (incf *disembodied-buffer-counter*))
70 (previous-line)
71 (line (make-line :%buffer buffer))
72 (first-line line))
73 (())
74 (let ((right-index (%sp-find-character string index end #\newline)))
75 (cond (right-index
76 (let* ((length (- right-index index))
77 (chars (make-string length)))
78 (%sp-byte-blt string index chars 0 length)
79 (setf (line-chars line) chars))
80 (setq index (1+ right-index))
81 (setq previous-line line)
82 (setq line (make-line :%buffer buffer))
83 (setf (line-next previous-line) line)
84 (setf (line-previous line) previous-line))
85 (t
86 (let* ((length (- end index))
87 (chars (make-string length)))
88 (%sp-byte-blt string index chars 0 length)
89 (setf (line-chars line) chars))
90 (return (renumber-region
91 (internal-make-region
92 (mark first-line 0 :right-inserting)
93 (mark line (length (line-chars line))
94 :left-inserting))))))))))
95
96 (defun line-to-region (line)
97 "Returns a region containing the specified line."
98 (internal-make-region (mark line 0 :right-inserting)
99 (mark line (line-length* line) :left-inserting)))
100
101 (defun previous-character (mark)
102 "Returns the character immediately before the given Mark."
103 (let ((line (mark-line mark))
104 (charpos (mark-charpos mark)))
105 (if (= charpos 0)
106 (if (line-previous line)
107 #\newline
108 nil)
109 (if (eq line open-line)
110 (char (the simple-string open-chars)
111 (if (<= charpos left-open-pos)
112 (1- charpos)
113 (1- (+ right-open-pos (- charpos left-open-pos)))))
114 (schar (line-chars line) (1- charpos))))))
115
116 (defun next-character (mark)
117 "Returns the character immediately after the given Mark."
118 (let ((line (mark-line mark))
119 (charpos (mark-charpos mark)))
120 (if (eq line open-line)
121 (if (= charpos (- line-cache-length (- right-open-pos left-open-pos)))
122 (if (line-next line)
123 #\newline
124 nil)
125 (schar open-chars
126 (if (< charpos left-open-pos)
127 charpos
128 (+ right-open-pos (- charpos left-open-pos)))))
129 (let ((chars (line-chars line)))
130 (if (= charpos (strlen chars))
131 (if (line-next line)
132 #\newline
133 nil)
134 (schar chars charpos))))))
135
136 ;;; %Set-Next-Character -- Internal
137 ;;;
138 ;;; This is the setf form for Next-Character. Since we may change a
139 ;;; character to or from a newline, we must be prepared to split and
140 ;;; join lines. We cannot just delete a character and insert the new one
141 ;;; because the marks would not be right.
142 ;;;
143 (defun %set-next-character (mark character)
144 (let* ((line (mark-line mark))
145 (buffer (line-%buffer line))
146 (next (line-next line)))
147 (modifying-buffer buffer
148 (modifying-line line mark)
149 (cond ((= right-open-pos line-cache-length)
150 ;; The mark is at the end of the line.
151 (unless next
152 (error "~S has no next character, so it cannot be set." mark))
153 (unless (char= character #\newline)
154 ;; If the character is no longer a newline then mash two
155 ;; lines together.
156 (let ((chars (line-chars next)))
157 (declare (simple-string chars))
158 (setq right-open-pos (- line-cache-length (length chars)))
159 (when (<= right-open-pos left-open-pos)
160 (grow-open-chars (* (+ (length chars) left-open-pos 1) 2)))
161 (%sp-byte-blt chars 0 open-chars right-open-pos
162 line-cache-length)
163 (setf (schar open-chars left-open-pos) character)
164 (incf left-open-pos))
165 (move-some-marks (charpos next line)
166 (+ charpos left-open-pos))
167 (setq next (line-next next))
168 (setf (line-next line) next)
169 (when next (setf (line-previous next) line))))
170 ((char= character #\newline)
171 ;; The char is being changed to a newline, so we must split lines.
172 (incf right-open-pos)
173 (let* ((len (- line-cache-length right-open-pos))
174 (chars (make-string len))
175 (new (make-line :chars chars :previous line
176 :next next :%buffer buffer)))
177 (%sp-byte-blt open-chars right-open-pos chars 0 len)
178 (maybe-move-some-marks* (charpos line new) left-open-pos
179 (- charpos left-open-pos 1))
180 (setf (line-next line) new)
181 (when next (setf (line-previous next) new))
182 (setq right-open-pos line-cache-length)
183 (number-line new)))
184 (t
185 (setf (char (the simple-string open-chars) right-open-pos)
186 character)))))
187 character)
188
189 ;;; %Set-Previous-Character -- Internal
190 ;;;
191 ;;; The setf form for Previous-Character. We just Temporarily move the
192 ;;; mark back one and call %Set-Next-Character.
193 ;;;
194 (defun %set-previous-character (mark character)
195 (unless (mark-before mark)
196 (error "~S has no previous character, so it cannot be set." mark))
197 (%set-next-character mark character)
198 (mark-after mark)
199 character)
200
201 (defun count-lines (region)
202 "Returns the number of lines in the region, first and last lines inclusive."
203 (do ((line (mark-line (region-start region)) (line-next line))
204 (count 1 (1+ count))
205 (last-line (mark-line (region-end region))))
206 ((eq line last-line) count)))
207
208 (defun count-characters (region)
209 "Returns the number of characters in the region."
210 (let* ((start (region-start region))
211 (end (region-end region))
212 (first-line (mark-line start))
213 (last-line (mark-line end)))
214 (if (eq first-line last-line)
215 (- (mark-charpos end) (mark-charpos start))
216 (do ((line (line-next first-line) (line-next line))
217 (count (1+ (- (line-length* first-line) (mark-charpos start)))))
218 ((eq line last-line)
219 (+ count (mark-charpos end)))
220 (setq count (+ 1 count (line-length* line)))))))
221
222 (defun line-start (mark &optional line)
223 "Changes the Mark to point to the beginning of the Line and returns it.
224 Line defaults to the line Mark is on."
225 (when line
226 (change-line mark line))
227 (setf (mark-charpos mark) 0)
228 mark)
229
230 (defun line-end (mark &optional line)
231 "Changes the Mark to point to the end of the line and returns it.
232 Line defaults to the line Mark is on."
233 (if line
234 (change-line mark line)
235 (setq line (mark-line mark)))
236 (setf (mark-charpos mark) (line-length* line))
237 mark)
238
239 (defun buffer-start (mark &optional (buffer (line-buffer (mark-line mark))))
240 "Change Mark to point to the beginning of Buffer, which defaults to
241 the buffer Mark is currently in."
242 (unless buffer (error "Mark ~S does not point into a buffer." mark))
243 (move-mark mark (buffer-start-mark buffer)))
244
245 (defun buffer-end (mark &optional (buffer (line-buffer (mark-line mark))))
246 "Change Mark to point to the end of Buffer, which defaults to
247 the buffer Mark is currently in."
248 (unless buffer (error "Mark ~S does not point into a buffer." mark))
249 (move-mark mark (buffer-end-mark buffer)))
250
251 (defun move-mark (mark new-position)
252 "Changes the Mark to point to the same position as New-Position."
253 (let ((line (mark-line new-position)))
254 (change-line mark line))
255 (setf (mark-charpos mark) (mark-charpos new-position))
256 mark)
257
258 (defun mark-before (mark)
259 "Changes the Mark to point one character before where it currently points.
260 NIL is returned if there is no previous character."
261 (let ((charpos (mark-charpos mark)))
262 (cond ((zerop charpos)
263 (let ((prev (line-previous (mark-line mark))))
264 (when prev
265 (always-change-line mark prev)
266 (setf (mark-charpos mark) (line-length* prev))
267 mark)))
268 (t
269 (setf (mark-charpos mark) (1- charpos))
270 mark))))
271
272 (defun mark-after (mark)
273 "Changes the Mark to point one character after where it currently points.
274 NIL is returned if there is no previous character."
275 (let ((line (mark-line mark))
276 (charpos (mark-charpos mark)))
277 (cond ((= charpos (line-length* line))
278 (let ((next (line-next line)))
279 (when next
280 (always-change-line mark next)
281 (setf (mark-charpos mark) 0)
282 mark)))
283 (t
284 (setf (mark-charpos mark) (1+ charpos))
285 mark))))
286
287 (defun character-offset (mark n)
288 "Changes the Mark to point N characters after (or -N before if N is negative)
289 where it currently points. If there aren't N characters before (or after)
290 the mark, Nil is returned."
291 (let ((charpos (mark-charpos mark)))
292 (if (< n 0)
293 (let ((n (- n)))
294 (if (< charpos n)
295 (do ((line (line-previous (mark-line mark)) (line-previous line))
296 (n (- n charpos 1)))
297 ((null line) nil)
298 (let ((length (line-length* line)))
299 (cond ((<= n length)
300 (always-change-line mark line)
301 (setf (mark-charpos mark) (- length n))
302 (return mark))
303 (t
304 (setq n (- n (1+ length)))))))
305 (progn (setf (mark-charpos mark) (- charpos n))
306 mark)))
307 (let* ((line (mark-line mark))
308 (length (line-length* line)))
309 (if (> (+ charpos n) length)
310 (do ((line (line-next line) (line-next line))
311 (n (- n (1+ (- length charpos)))))
312 ((null line) nil)
313 (let ((length (line-length* line)))
314 (cond ((<= n length)
315 (always-change-line mark line)
316 (setf (mark-charpos mark) n)
317 (return mark))
318 (t
319 (setq n (- n (1+ length)))))))
320 (progn (setf (mark-charpos mark) (+ charpos n))
321 mark))))))
322
323 (defun line-offset (mark n &optional charpos)
324 "Changes to Mark to point N lines after (-N before if N is negative) where
325 it currently points. If there aren't N lines after (or before) the Mark,
326 Nil is returned."
327 (if (< n 0)
328 (do ((line (mark-line mark) (line-previous line))
329 (n n (1+ n)))
330 ((null line) nil)
331 (when (= n 0)
332 (always-change-line mark line)
333 (setf (mark-charpos mark)
334 (if charpos
335 (min (line-length line) charpos)
336 (min (line-length line) (mark-charpos mark))))
337 (return mark)))
338 (do ((line (mark-line mark) (line-next line))
339 (n n (1- n)))
340 ((null line) nil)
341 (when (= n 0)
342 (change-line mark line)
343 (setf (mark-charpos mark)
344 (if charpos
345 (min (line-length line) charpos)
346 (min (line-length line) (mark-charpos mark))))
347 (return mark)))))
348
349 ;;; region-bounds -- Public
350 ;;;
351 (defun region-bounds (region)
352 "Return as multiple-value the start and end of Region."
353 (values (region-start region) (region-end region)))
354
355 (defun set-region-bounds (region start end)
356 "Set the start and end of Region to the marks Start and End."
357 (let ((sl (mark-line start))
358 (el (mark-line end)))
359 (when (or (neq (line-%buffer sl) (line-%buffer el))
360 (> (line-number sl) (line-number el))
361 (and (eq sl el) (> (mark-charpos start) (mark-charpos end))))
362 (error "Marks ~S and ~S cannot be made into a region." start end))
363 (setf (region-start region) start (region-end region) end))
364 region)
365
366
367 ;;;; Debugging stuff.
368
369 (defun slf (string)
370 "For a good time, figure out what this function does, and why it was written."
371 (delete #\linefeed (the simple-string string)))
372
373 (defun %print-whole-line (structure stream)
374 (cond ((eq structure open-line)
375 (write-string open-chars stream :end left-open-pos)
376 (write-string open-chars stream :start right-open-pos
377 :end line-cache-length))
378 (t
379 (write-string (line-chars structure) stream))))
380
381 (defun %print-before-mark (mark stream)
382 (if (mark-line mark)
383 (let* ((line (mark-line mark))
384 (chars (line-chars line))
385 (charpos (mark-charpos mark))
386 (length (line-length line)))
387 (declare (simple-string chars))
388 (cond ((or (> charpos length) (< charpos 0))
389 (write-string "{bad mark}" stream))
390 ((eq line open-line)
391 (cond ((< charpos left-open-pos)
392 (write-string open-chars stream :end charpos))
393 (t
394 (write-string open-chars stream :end left-open-pos)
395 (let ((p (+ charpos (- right-open-pos left-open-pos))))
396 (write-string open-chars stream :start right-open-pos
397 :end p)))))
398 (t
399 (write-string chars stream :end charpos))))
400 (write-string "{deleted mark}" stream)))
401
402
403 (defun %print-after-mark (mark stream)
404 (if (mark-line mark)
405 (let* ((line (mark-line mark))
406 (chars (line-chars line))
407 (charpos (mark-charpos mark))
408 (length (line-length line)))
409 (declare (simple-string chars))
410 (cond ((or (> charpos length) (< charpos 0))
411 (write-string "{bad mark}" stream))
412 ((eq line open-line)
413 (cond ((< charpos left-open-pos)
414 (write-string open-chars stream :start charpos
415 :end left-open-pos)
416 (write-string open-chars stream :start right-open-pos
417 :end line-cache-length))
418 (t
419 (let ((p (+ charpos (- right-open-pos left-open-pos))))
420 (write-string open-chars stream :start p
421 :end line-cache-length)))))
422 (t
423 (write-string chars stream :start charpos :end length))))
424 (write-string "{deleted mark}" stream)))
425
426 (defun %print-hline (structure stream d)
427 (declare (ignore d))
428 (write-string "#<Hemlock Line \"" stream)
429 (%print-whole-line structure stream)
430 (write-string "\">" stream))
431
432 (defun %print-hmark (structure stream d)
433 (declare (ignore d))
434 (write-string "#<Hemlock Mark \"" stream)
435 (%print-before-mark structure stream)
436 (write-string "/\\" stream)
437 (%print-after-mark structure stream)
438 (write-string "\">" stream))
439
440 (defvar *print-region* 10
441 "The number of lines to print out of a region, or NIL if none.")
442
443 (defun %print-hregion (region stream d)
444 (declare (ignore d))
445 (write-string "#<Hemlock Region \"" stream)
446 (let* ((start (region-start region))
447 (end (region-end region))
448 (first-line (mark-line start))
449 (last-line (mark-line end)))
450 (cond
451 ((not (and (linep first-line) (linep last-line)
452 (eq (line-%buffer first-line) (line-%buffer last-line))
453 (mark<= start end)))
454 (write-string "{bad region}" stream))
455 (*print-region*
456 (cond ((eq first-line last-line)
457 (let ((cs (mark-charpos start))
458 (ce (mark-charpos end))
459 (len (line-length first-line)))
460 (cond
461 ((or (< cs 0) (> ce len))
462 (write-string "{bad region}" stream))
463 ((eq first-line open-line)
464 (let ((gap (- right-open-pos left-open-pos)))
465 (cond
466 ((<= ce left-open-pos)
467 (write-string open-chars stream :start cs :end ce))
468 ((>= cs left-open-pos)
469 (write-string open-chars stream :start (+ cs gap)
470 :end (+ ce gap)))
471 (t
472 (write-string open-chars stream :start cs
473 :end left-open-pos)
474 (write-string open-chars stream :start right-open-pos
475 :end (+ gap ce))))))
476 (t
477 (write-string (line-chars first-line) stream :start cs
478 :end ce)))))
479 (t
480 (%print-after-mark start stream)
481 (write-char #\/ stream)
482 (do ((line (line-next first-line) (line-next line))
483 (last-line (mark-line end))
484 (cnt *print-region* (1- cnt)))
485 ((or (eq line last-line)
486 (when (zerop cnt) (write-string "..." stream) t))
487 (%print-before-mark end stream))
488 (%print-whole-line line stream)
489 (write-char #\/ stream)))))
490 (t
491 (write-string "{mumble}" stream))))
492 (write-string "\">" stream))
493
494 (defun %print-hbuffer (structure stream d)
495 (declare (ignore d))
496 (write-string "#<Hemlock Buffer \"" stream)
497 (write-string (buffer-name structure) stream)
498 (write-string "\">" stream))

  ViewVC Help
Powered by ViewVC 1.1.5