source: tags/pre_1_0_pre_hash_modifications/ccl/hemlock/src/htext4.lisp @ 2475

Last change on this file since 2475 was 2475, checked in by anonymous, 14 years ago

This commit was manufactured by cvs2svn to create tag
'pre_1_0_pre_hash_modifications'.

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