source: trunk/source/cocoa-ide/hemlock/src/htext4.lisp @ 12696

Last change on this file since 12696 was 12696, checked in by rme, 10 years ago

In COPY-REGION: copy the first line's charprops to the end
of line, not to the charpos of the region's end mark.

For ticket:589.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 18.9 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 and Rob MacLachlan.
14;;; Modified by Bill Chiles.
15;;;
16;;; The code in this file implements the delete and copy functions in the
17;;; "Doing Stuff and Going Places" chapter of the Hemlock Design document.
18;;;
19
20(in-package :hemlock-internals)
21
22
23;;;; DELETE-CHARACTERS.
24
25(defun delete-characters (mark &optional (n 1))
26  "Deletes N characters after the mark (or -N before if N is negative)."
27  (let* ((line (mark-line mark))
28         (charpos (mark-charpos mark))
29         (length (line-length* line)))
30    (check-buffer-modification (line-%buffer line) mark)
31    (cond
32     ((zerop n) t)
33     ;; Deleting chars on one line, just bump the pointers.
34     ((<= 0 (+ charpos n) length)
35      (let* ((buffer (line-%buffer line)))
36        (modifying-buffer buffer
37          (modifying-line line mark)
38          (cond
39           ((minusp n)
40            (delete-line-charprops line :start (+ charpos n) :end charpos)
41            (setf (current-left-open-pos) (+ (current-left-open-pos) n))
42            (move-some-marks (pos line)
43                             (if (> pos (current-left-open-pos))
44                               (if (<= pos charpos) (current-left-open-pos) (+ pos n))
45                               pos)))
46           
47           (t
48            (delete-line-charprops line :start charpos :end (+ charpos n))
49            (setf (current-right-open-pos) (+ (current-right-open-pos) n))
50            (let ((bound (+ charpos n)))
51              (move-some-marks (pos line)
52                               (if (> pos charpos)
53                                 (if (<= pos bound) (current-left-open-pos) (- pos n))
54                                 pos)))))
55          (adjust-line-origins-forward line)
56          (buffer-note-deletion buffer mark n)
57          t)))
58     
59     ;; Deleting some newlines, punt out to delete-region.
60     (t
61      (let* ((temp-mark (mark line charpos))
62             (other-mark (character-offset temp-mark n))
63             (temp-region (make-empty-region)))
64        (cond
65         (other-mark
66          (if (< n 0)
67            (setf (region-start temp-region) other-mark
68                  (region-end temp-region) mark)
69            (setf (region-start temp-region) mark
70                  (region-end temp-region) other-mark))
71          (delete-region temp-region) t)
72         (t nil)))))))
73
74;;;; DELETE-REGION.
75
76(defun delete-region (region)
77  "Deletes the Region."
78  (let* ((start (region-start region))
79         (end (region-end region))
80         (first-line (mark-line start))
81         (last-line (mark-line end))
82         (first-charpos (mark-charpos start))
83         (last-charpos (mark-charpos end))
84         (buffer (line-%buffer first-line))
85         (ndel (count-characters region)))
86    (unless (and (eq first-line last-line)
87                 (= first-charpos last-charpos))
88      (modifying-buffer buffer
89        (cond ((eq first-line last-line)
90               ;; Simple case -- just skip over the characters:
91               (modifying-line first-line start)
92               (let ((num (- last-charpos first-charpos)))
93                 (setf (current-right-open-pos) (+ (current-right-open-pos) num))
94                 ;; and fix up any charprops or marks in there:
95                 (delete-line-charprops first-line :start first-charpos
96                                        :end last-charpos)
97                 (move-some-marks (charpos first-line)
98                   (if (> charpos first-charpos)
99                       (if (<= charpos last-charpos) 
100                           first-charpos
101                           (- charpos num))
102                       charpos))))
103              (t
104               ;; hairy case -- squish lines together:
105               (close-line)
106               (let* ((first-chars (line-chars first-line))
107                      (last-chars (line-chars last-line))
108                      (last-length (length last-chars)))
109                 (declare (simple-string last-chars first-chars))
110                 ;; Cons new chars for the first line.
111                 (let* ((length (+ first-charpos (- last-length last-charpos)))
112                        (new-chars (make-string length)))
113                   (%sp-byte-blt first-chars 0 new-chars 0 first-charpos)
114                   (%sp-byte-blt last-chars last-charpos new-chars first-charpos
115                                 length)
116                   (setf (line-chars first-line) new-chars))
117                 (copy-line-charprops last-line :start last-charpos
118                                      :end last-length)
119                 ;; fix up the first line's marks:
120                 (move-some-marks (charpos first-line)
121                   (if (> charpos first-charpos)
122                       first-charpos
123                       charpos))
124                 ;; fix up the marks of the lines in the middle and mash
125                 ;;line-%buffer:
126                 (do* ((line (line-next first-line) (line-next line))
127                       (count (next-disembodied-buffer-counter)))
128                      ((eq line last-line)
129                       (setf (line-%buffer last-line) count))
130                   (setf (line-%buffer line) count)
131                   (move-some-marks (ignore line first-line)
132                     (declare (ignore ignore))
133                     first-charpos))
134                 ;; and fix up the last line's marks:
135                 (move-some-marks (charpos last-line first-line)
136                   (if (<= charpos last-charpos)
137                       first-charpos
138                       (+ (- charpos last-charpos)
139                          first-charpos)))
140                 ;; And splice the losers out:
141                 (let ((next (line-next last-line)))
142                   (setf (line-next first-line) next)
143                   (when next (setf (line-previous next) first-line))))))
144        (adjust-line-origins-forward first-line)
145        (buffer-note-deletion buffer start ndel)))))
146
147
148
149;;;; DELETE-AND-SAVE-REGION.
150
151(defun delete-and-save-region (region)
152  "Deletes Region and returns a region containing the deleted characters."
153  (let* ((start (region-start region))
154         (end (region-end region))
155         (first-line (mark-line start))
156         (last-line (mark-line end))
157         (first-charpos (mark-charpos start))
158         (last-charpos (mark-charpos end))
159         (buffer (line-%buffer first-line))
160         (ndel (count-characters region)))
161    (check-buffer-modification buffer start)
162    (check-buffer-modification buffer end)
163    (cond
164      ((and (eq first-line last-line)
165            (= first-charpos last-charpos))
166       (make-empty-region))
167      (t
168       (modifying-buffer
169        buffer
170        (prog1
171            (cond ((eq first-line last-line)
172                   ;; simple case -- just skip over the characters:
173                   (modifying-line first-line start)
174                   (let* ((num (- last-charpos first-charpos))
175                          (new-right (+ (current-right-open-pos) num))
176                          (new-chars (make-string num))
177                          (new-line (make-line
178                                     :chars new-chars  :number 0
179                                     :charprops-changes
180                                     (copy-line-charprops first-line
181                                                          :start first-charpos
182                                                          :end last-charpos)
183                                     :%buffer (next-disembodied-buffer-counter))))
184                     (declare (simple-string new-chars))
185                     (%sp-byte-blt (current-open-chars) (current-right-open-pos) new-chars 0 num) 
186                     (setf (current-right-open-pos) new-right)
187                     ;; and fix up any charprops or marks in there:
188                     (delete-line-charprops first-line :start first-charpos
189                                            :end last-charpos)
190                     (move-some-marks (charpos first-line)
191                                      (if (> charpos first-charpos)
192                                        (if (<= charpos last-charpos)
193                                          first-charpos
194                                          (- charpos num))
195                                        charpos))
196                     ;; And return the region with the nuked characters:
197                     (internal-make-region (mark new-line 0 :right-inserting)
198                                           (mark new-line num :left-inserting))))
199                  (t
200                   ;; hairy case -- squish lines together:
201                   (close-line)
202                   (let* ((first-chars (line-chars first-line))
203                          (last-chars (line-chars last-line))
204                          (first-length (length first-chars))
205                          (last-length (length last-chars))
206                          (saved-first-length (- first-length first-charpos))
207                          (saved-first-chars (make-string saved-first-length))
208                          (saved-last-chars (make-string last-charpos))
209                          (count (next-disembodied-buffer-counter))
210                          (saved-line (make-line :chars saved-first-chars
211                                                 :%buffer count)))
212                     (declare (simple-string first-chars last-chars
213                                             saved-first-chars saved-last-chars))
214                     ;; Cons new chars for victim line.
215                     (let* ((length (+ first-charpos (- last-length last-charpos)))
216                            (new-chars (make-string length)))
217                       (%sp-byte-blt first-chars 0 new-chars 0 first-charpos)
218                       (%sp-byte-blt last-chars last-charpos new-chars first-charpos
219                                     length)
220                       (setf (line-chars first-line) new-chars))
221                     ;; Make a region with all the lost stuff:
222                     (%sp-byte-blt first-chars first-charpos saved-first-chars 0
223                                   saved-first-length)
224                     (%sp-byte-blt last-chars 0 saved-last-chars 0 last-charpos)
225                     ;; Mash the chars and buff of the last line.
226                     (setf (line-chars last-line) saved-last-chars
227                           (line-%buffer last-line) count)
228                     ;; fix up the marks of the lines in the middle and mash
229                     ;;line-%buffer:
230                     (do ((line (line-next first-line) (line-next line)))
231                         ((eq line last-line)
232                          (setf (line-%buffer last-line) count))
233                       (setf (line-%buffer line) count)
234                       (move-some-marks (ignore line first-line)
235                                        (declare (ignore ignore))
236                                        first-charpos))
237                     ;; And splice the losers out:
238                     (let ((next (line-next first-line))
239                           (after (line-next last-line)))
240                       (setf (line-next saved-line) next
241                             (line-previous next) saved-line
242                             (line-next first-line) after)
243                       (when after
244                         (setf (line-previous after) first-line
245                               (line-next last-line) nil)))
246                     
247                     ;; fix up the first line's marks:
248                     (move-some-marks (charpos first-line)
249                                      (if (> charpos first-charpos)
250                                        first-charpos
251                                        charpos))
252                     ;; and fix up the last line's marks:
253                     (move-some-marks (charpos last-line first-line)
254                                      (if (<= charpos last-charpos)
255                                        first-charpos
256                                        (+ (- charpos last-charpos)
257                                           first-charpos)))
258                     ;; And return the region with the nuked characters:
259                     (renumber-region
260                      (internal-make-region
261                       (mark saved-line 0 :right-inserting)
262                       (mark last-line last-charpos :left-inserting))))))
263          (adjust-line-origins-forward first-line)
264          (buffer-note-deletion buffer start ndel)))))))
265
266
267
268;;;; COPY-REGION.
269
270(defun copy-region (region)
271  "Returns a region containing a copy of the text within Region."
272  (let* ((start (region-start region))
273         (end (region-end region))
274         (first-line (mark-line start))
275         (last-line (mark-line end))
276         (first-charpos (mark-charpos start))
277         (last-charpos (mark-charpos end))
278         (count (next-disembodied-buffer-counter)))
279    (cond
280     ((eq first-line last-line)
281      (when (current-open-line-p first-line) (close-line))
282      (let* ((length (- last-charpos first-charpos))
283             (chars (make-string length))
284             (line (make-line :chars chars  :%buffer count  :number 0)))
285        (%sp-byte-blt (line-chars first-line) first-charpos chars 0 length)
286        (setf (line-charprops-changes line)
287              (copy-line-charprops line :start first-charpos :end last-charpos))
288        (internal-make-region (mark line 0 :right-inserting)
289                              (mark line length :left-inserting))))
290     (t
291      (close-line)
292      (let* ((first-chars (line-chars first-line))
293             (length (- (length first-chars) first-charpos))
294             (chars (make-string length))
295             (first-copied-line (make-line :chars chars  :%buffer count
296                                           :number 0)))
297        (declare (simple-string first-chars))
298        (%sp-byte-blt first-chars first-charpos chars 0 length)
299        (setf (line-charprops-changes first-copied-line)
300              (copy-line-charprops first-line :start first-charpos))
301        (do ((line (line-next first-line) (line-next line))
302             (previous first-copied-line)
303             (number line-increment (+ number line-increment)))
304            ((eq line last-line)
305             (let* ((chars (make-string last-charpos))
306                    (last-copied-line (make-line :chars chars
307                                                 :number number
308                                                 :%buffer count
309                                                 :previous previous)))
310               (%sp-byte-blt (line-chars last-line) 0 chars 0 last-charpos)
311               (setf (line-charprops-changes last-copied-line)
312                     (copy-line-charprops last-line :end last-charpos))
313               (setf (line-next previous) last-copied-line)
314               (internal-make-region
315                (mark first-copied-line 0 :right-inserting)
316                (mark last-copied-line last-charpos :left-inserting))))
317          (let* ((new-line (%copy-line line :%buffer count
318                                       :number number
319                                       :previous previous)))
320            ;; note that %copy-line also copies charprops changes
321            (setf (line-next previous) new-line)
322            (setq previous new-line))))))))
323
324
325
326;;;; FILTER-REGION.
327
328(eval-when (:compile-toplevel :execute)
329(defmacro fcs (fun str)
330  `(let ((rs (funcall ,fun ,str)))
331     (if (simple-string-p rs) rs
332         (coerce rs 'simple-string))))
333); eval-when
334
335;;; FILTER-REGION  --  Public
336;;;
337;;;    After we deal with the nasty boundry conditions of the first and
338;;; last lines, we just scan through lines in the region replacing their
339;;; chars with the result of applying the function to the chars.
340;;;
341(defun filter-region (function region)
342  "This function filters the text in a region though a Lisp function.  The
343   argument function must map from a string to a string.  It is passed each
344   line string from region in order, and each resulting string replaces the
345   original.  The function must neither destructively modify its argument nor
346   modify the result string after it is returned.  The argument will always be
347   a simple-string.  It is an error for any string returned to contain
348   newlines."
349  (let* ((start (region-start region))
350         (count (hemlock::count-characters region))
351         (origin (copy-mark start :right-inserting))
352         (start-line (mark-line start))
353         (first (mark-charpos start))
354         (end (region-end region))
355         (end-line (mark-line end))
356         (last (mark-charpos end))
357         (marks ())
358         (buffer (line-%buffer start-line)))
359    (check-buffer-modification buffer start)
360    (check-buffer-modification buffer end)
361    (modifying-buffer buffer
362      (modifying-line end-line end)
363      (cond ((eq start-line end-line)
364             (let* ((res (fcs function (subseq (current-open-chars) first last)))
365                    (rlen (length res))
366                    (new-left (+ first rlen))
367                    (delta (- new-left (current-left-open-pos))))
368               (declare (simple-string res))
369               (when (> new-left (current-right-open-pos))
370                 (grow-open-chars (+ new-left (current-line-cache-length))))
371               (%sp-byte-blt res 0 (current-open-chars) first (current-left-open-pos))
372               ;;
373               ;; Move marks to start or end of region, depending on kind.
374               (dolist (m (line-marks start-line))
375                 (let ((charpos (mark-charpos m)))
376                   (when (>= charpos first)
377                     (setf (mark-charpos m)
378                           (if (<= charpos last)
379                               (if (eq (mark-%kind m) :left-inserting)
380                                   new-left first)
381                               (+ charpos delta))))))
382               (setf (current-left-open-pos) new-left)))
383            (t
384             ;;
385             ;; Do the chars for the first line.
386             (let* ((first-chars (line-chars start-line))
387                    (first-len (length first-chars))
388                    (res (fcs function (subseq first-chars first first-len)))
389                    (rlen (length res))
390                    (nlen (+ first rlen))
391                    (new (make-string nlen)))
392               (declare (simple-string res first-chars new))
393               (%sp-byte-blt first-chars 0 new 0 first)
394               (%sp-byte-blt res 0 new first nlen)
395               (setf (line-%chars start-line) new))
396             ;;
397             ;; Fix up marks on the first line, saving any within the region
398             ;; to be dealt with later.
399             (let ((outside ()))
400               (dolist (m (line-marks start-line))
401                 (if (<= (mark-charpos m) first)
402                     (push m outside) (push m marks)))
403               (setf (line-marks start-line) outside))
404             ;;
405             ;; Do chars of intermediate lines in the region, saving their
406             ;; marks.
407             (do ((line (line-next start-line) (line-next line)))
408                 ((eq line end-line))
409               (when (line-marks line)
410                 (setq marks (nconc (line-marks line) marks))
411                 (setf (line-marks line) nil))
412               (setf (line-%chars line) (fcs function (line-chars line))))
413             ;;
414             ;; Do the last line, which is cached.
415             (let* ((res (fcs function (subseq (the simple-string (current-open-chars))
416                                               0 last)))
417                    (rlen (length res))
418                    (delta (- rlen last)))
419               (declare (simple-string res))
420               (when (> rlen (current-right-open-pos))
421                 (grow-open-chars (+ rlen (current-line-cache-length))))
422               (%sp-byte-blt res 0 (current-open-chars) 0 rlen)
423               (setf (current-left-open-pos) rlen)
424               ;;
425               ;; Adjust marks after the end of the region and save ones in it.
426               (let ((outside ()))
427                 (dolist (m (line-marks end-line))
428                   (let ((charpos (mark-charpos m)))
429                     (cond ((> charpos last)
430                            (setf (mark-charpos m) (+ charpos delta))
431                            (push m outside))
432                           (t
433                            (push m marks)))))
434                 (setf (line-marks end-line) outside))
435               ;;
436               ;; Scan over saved marks, moving them to the correct end of the
437               ;; region.
438               (dolist (m marks)
439                 (cond ((eq (mark-%kind m) :left-inserting)
440                        (setf (mark-charpos m) rlen)
441                        (setf (mark-line m) end-line)
442                        (push m (line-marks end-line)))
443                       (t
444                        (setf (mark-charpos m) first)
445                        (setf (mark-line m) start-line)
446                        (push m (line-marks start-line)))))))))
447    (hi::buffer-note-modification buffer origin count)
448    (delete-mark origin)
449    region))
Note: See TracBrowser for help on using the repository browser.