source: trunk/ccl/hemlock/src/htext3.lisp @ 2064

Last change on this file since 2064 was 2064, checked in by gb, 14 years ago

Don't modify buffer if doing so would change a protected region.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 10.0 KB
Line 
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#+CMU (ext:file-comment
8  "$Header$")
9;;;
10;;; **********************************************************************
11;;;
12;;; More Hemlock Text-Manipulation functions.
13;;; Written by Skef Wholey.
14;;;
15;;; The code in this file implements the insert functions in the
16;;; "Doing Stuff and Going Places" chapter of the Hemlock Design document.
17;;;
18
19(in-package :hemlock-internals)
20
21;;; Return (and deactivate) the current region.
22(defun %buffer-current-region (b)
23  (when (and (typep b 'buffer)
24             (variable-value 'hemlock::active-regions-enabled)
25             (eql (buffer-signature b)
26                  (buffer-region-active b)))
27    (let* ((mark (buffer-%mark b))
28           (point (buffer-point b)))
29      (setf (buffer-region-active b) nil)
30      (if (mark< mark point)
31        (region mark point)
32        (region point mark)))))
33             
34
35(defun insert-character (mark character)
36  "Inserts the Character at the specified Mark."
37  (declare (type base-char character))
38  (let* ((line (mark-line mark))
39         (buffer (line-%buffer line))
40         (region (%buffer-current-region buffer)))
41    (check-buffer-modification buffer mark)
42    (when region
43      (delete-region region))
44    (modifying-buffer buffer
45                      (modifying-line line mark)
46                      (cond ((char= character #\newline)
47                             (let* ((next (line-next line))
48                                    (new-chars (subseq (the simple-string *open-chars*)
49                                                       0 *left-open-pos*))
50                                    (new-line (make-line :%buffer buffer
51                                                         :chars (decf *cache-modification-tick*)
52                                                         :previous line
53                                                         :next next)))
54                               (maybe-move-some-marks (charpos line new-line) *left-open-pos*
55                                                      (- charpos *left-open-pos*))
56                               (setf (line-%chars line) new-chars)
57                               (setf (line-next line) new-line)
58                               (if next (setf (line-previous next) new-line))
59                               (number-line new-line)
60                               (setq *open-line* new-line  *left-open-pos* 0)))
61                            (t
62                             (if (= *right-open-pos* *left-open-pos*)
63                               (grow-open-chars))
64             
65                             (maybe-move-some-marks (charpos line) *left-open-pos*
66                                                    (1+ charpos))
67             
68                             (cond
69                               ((eq (mark-%kind mark) :right-inserting)
70                                (decf *right-open-pos*)
71                                (setf (char (the simple-string *open-chars*) *right-open-pos*)
72                                      character))
73                               (t
74                                (setf (char (the simple-string *open-chars*) *left-open-pos*)
75                                      character)
76                                (incf *left-open-pos*)))))
77                      (buffer-note-insertion buffer mark 1))))
78
79
80(defun insert-string (mark string &optional (start 0) (end (length string)))
81  "Inserts the String at the Mark.  Do not use Start and End unless you
82  know what you're doing!"
83  (let* ((line (mark-line mark))
84         (buffer (line-%buffer line))
85         (string (coerce string 'simple-string))
86         (region (%buffer-current-region buffer)))
87    (declare (simple-string string))
88    (check-buffer-modification buffer mark)
89    (when region
90      (delete-region region))
91    (unless (zerop (- end start))
92      (if (%sp-find-character string start end #\newline)
93        (with-mark ((mark mark :left-inserting))
94           (do ((left-index start (1+ right-index))
95                (right-index
96                 (%sp-find-character string start end #\newline)
97                 (%sp-find-character string (1+ right-index) end #\newline)))
98               ((null right-index)
99                (if (/= left-index end)
100                  (insert-string mark string left-index end)))
101             (insert-string mark string left-index right-index)
102             (insert-character mark #\newline)))
103        (modifying-buffer
104         buffer
105         (modifying-line line mark)
106         (let ((length (- end start)))
107           (if (<= *right-open-pos* (+ *left-open-pos* end))
108             (grow-open-chars (* (+ *line-cache-length* end) 2)))
109             
110           (maybe-move-some-marks (charpos line) *left-open-pos*
111                                  (+ charpos length))
112           (cond
113             ((eq (mark-%kind mark) :right-inserting)
114              (let ((new (- *right-open-pos* length)))
115                (%sp-byte-blt string start *open-chars* new *right-open-pos*)
116                (setq *right-open-pos* new)))
117             (t
118              (let ((new (+ *left-open-pos* length)))
119                (%sp-byte-blt string start *open-chars* *left-open-pos* new)
120                (setq *left-open-pos* new)))))
121         (buffer-note-insertion buffer mark (- end start)))))))
122
123
124(defconstant line-number-interval-guess 8
125  "Our first guess at how we should number an inserted region's lines.")
126
127(defun insert-region (mark region)
128  "Inserts the given Region at the Mark."
129  (let* ((start (region-start region))
130         (end (region-end region))
131         (first-line (mark-line start))
132         (last-line (mark-line end))
133         (first-charpos (mark-charpos start))
134         (last-charpos (mark-charpos end))
135         (nins (count-characters region)))
136    (cond
137     ((eq first-line last-line)
138      ;; simple case -- just BLT the characters in with insert-string
139      (if (eq first-line *open-line*) (close-line))
140      (insert-string mark (line-chars first-line) first-charpos last-charpos))
141     (t
142      (close-line)
143      (let* ((line (mark-line mark))
144             (next (line-next line))
145             (charpos (mark-charpos mark))
146             (buffer (line-%buffer line))
147             (old-chars (line-chars line)))
148        (declare (simple-string old-chars))
149        (check-buffer-modification buffer mark)
150        (modifying-buffer buffer
151          ;;hack marked line's chars
152          (let* ((first-chars (line-chars first-line))
153                 (first-length (length first-chars))
154                 (new-length (+ charpos (- first-length first-charpos)))
155                 (new-chars (make-string new-length)))
156            (declare (simple-string first-chars new-chars))
157            (%sp-byte-blt old-chars 0 new-chars 0 charpos)
158            (%sp-byte-blt first-chars first-charpos new-chars charpos new-length)
159            (setf (line-chars line) new-chars))
160         
161          ;; Copy intervening lines.  We don't link the lines in until we are
162          ;; done in case the mark is within the region we are inserting.
163          (do* ((this-line (line-next first-line) (line-next this-line))
164                (number (+ (line-number line) line-number-interval-guess)
165                        (+ number line-number-interval-guess))
166                (first (%copy-line this-line  :previous line
167                                   :%buffer buffer  :number number))
168                (previous first)
169                (new-line first (%copy-line this-line  :previous previous
170                                            :%buffer buffer  :number number)))
171               ((eq this-line last-line)
172                ;;make last line
173                (let* ((last-chars (line-chars new-line))
174                       (old-length (length old-chars))
175                       (new-length (+ last-charpos (- old-length charpos)))
176                       (new-chars (make-string new-length)))
177                  (%sp-byte-blt last-chars 0 new-chars 0 last-charpos)
178                  (%sp-byte-blt old-chars charpos new-chars last-charpos
179                                new-length)
180                  (setf (line-next line) first)
181                  (setf (line-chars new-line) new-chars)
182                  (setf (line-next previous) new-line)
183                  (setf (line-next new-line) next)
184                  (when next
185                    (setf (line-previous next) new-line)
186                    (if (<= (line-number next) number)
187                        (renumber-region-containing new-line)))
188                  ;;fix up the marks
189                  (maybe-move-some-marks (this-charpos line new-line) charpos
190                    (+ last-charpos (- this-charpos charpos)))))
191            (setf (line-next previous) new-line  previous new-line))
192          (buffer-note-insertion buffer  mark nins)))))))
193
194(defun ninsert-region (mark region)
195  "Inserts the given Region at the Mark, possibly destroying the Region.
196  Region may not be a part of any buffer's region."
197  (let* ((start (region-start region))
198         (end (region-end region))
199         (first-line (mark-line start))
200         (last-line (mark-line end))
201         (first-charpos (mark-charpos start))
202         (last-charpos (mark-charpos end))
203         (nins (count-characters region)))
204    (cond
205     ((eq first-line last-line)
206      ;; Simple case -- just BLT the characters in with insert-string.
207      (if (eq first-line *open-line*) (close-line))
208      (insert-string mark (line-chars first-line) first-charpos last-charpos))
209     (t
210      (when (bufferp (line-%buffer first-line))
211        (error "Region is linked into Buffer ~S." (line-%buffer first-line)))
212      (close-line)
213      (let* ((line (mark-line mark))
214             (second-line (line-next first-line))
215             (next (line-next line))
216             (charpos (mark-charpos mark))
217             (buffer (line-%buffer line))
218             (old-chars (line-chars line)))
219        (declare (simple-string old-chars))
220        (check-buffer-modification buffer mark)
221        (modifying-buffer buffer
222          ;; Make new chars for first and last lines.
223          (let* ((first-chars (line-chars first-line))
224                 (first-length (length first-chars))
225                 (new-length (+ charpos (- first-length first-charpos)))
226                 (new-chars (make-string new-length)))
227            (declare (simple-string first-chars new-chars))
228            (%sp-byte-blt old-chars 0 new-chars 0 charpos)
229            (%sp-byte-blt first-chars first-charpos new-chars charpos
230                          new-length)
231            (setf (line-chars line) new-chars))
232          (let* ((last-chars (line-chars last-line))
233                 (old-length (length old-chars))
234                 (new-length (+ last-charpos (- old-length charpos)))
235                 (new-chars (make-string new-length)))
236            (%sp-byte-blt last-chars 0 new-chars 0 last-charpos)
237            (%sp-byte-blt old-chars charpos new-chars last-charpos new-length)
238            (setf (line-chars last-line) new-chars))
239         
240          ;;; Link stuff together.
241          (setf (line-next last-line) next)
242          (setf (line-next line) second-line)
243          (setf (line-previous second-line) line)
244
245          ;;Number the inserted stuff and mash any marks.
246          (do ((line second-line (line-next line))
247               (number (+ (line-number line) line-number-interval-guess)
248                       (+ number line-number-interval-guess)))
249              ((eq line next)
250               (when next
251                 (setf (line-previous next) last-line)         
252                 (if (<= (line-number next) number)
253                     (renumber-region-containing last-line))))
254            (when (line-marks line)
255              (dolist (m (line-marks line))
256                (setf (mark-line m) nil))
257              (setf (line-marks line) nil))
258            (setf (line-number line) number  (line-%buffer line) buffer))
259         
260          ;; Fix up the marks in the line inserted into.
261          (maybe-move-some-marks (this-charpos line last-line) charpos
262            (+ last-charpos (- this-charpos charpos)))
263          (buffer-note-insertion buffer mark nins)))))))
Note: See TracBrowser for help on using the repository browser.