source: trunk/source/cocoa-ide/hemlock/src/htext3.lisp @ 12539

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

Rename adjust-charprops-changes to adjust-line-charprops; update
charprops in insert-region and ninsert-region.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 15.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;;; Return T if the buffer has an active region (without deactivating
35;;; it), NIL otherwise.
36(defun %buffer-current-region-p (b)
37  (and (typep b 'buffer)
38             (variable-value 'hemlock::active-regions-enabled)
39             (eql (buffer-signature b)
40                  (buffer-region-active b))))
41
42
43             
44
45(defun insert-character (mark character &key (charprops :neighbor))
46  "Inserts the Character at the specified Mark."
47  (declare (type base-char character))
48  (let* ((line (mark-line mark))
49         (charpos (mark-charpos mark))
50         (buffer (line-%buffer line)))
51    (modifying-buffer buffer
52      (modifying-line line mark)
53      (cond ((char= character #\newline)
54             (let* ((next (line-next line))
55                    (new-chars (subseq (the simple-string (current-open-chars))
56                                       0 (current-left-open-pos)))
57                    (new-line (make-line :%buffer buffer
58                                         :chars (next-cache-modification-tick)
59                                         :previous line
60                                         :next next)))
61
62               ;; Do newlines get properties?  What if a charprops arg is
63               ;; specified here?
64               (multiple-value-bind (left right)
65                                    (split-line-charprops line charpos)
66                 (setf (line-charprops-changes line) left
67                       (line-charprops-changes new-line) right))
68
69               (maybe-move-some-marks (charpos line new-line) (current-left-open-pos)
70                                      (- charpos (current-left-open-pos)))
71                 
72               (setf (line-%chars line) new-chars)
73               (setf (line-next line) new-line)
74               (if next (setf (line-previous next) new-line))
75               (number-line new-line)
76               (setf (current-open-line) new-line
77                     (current-left-open-pos) 0)))
78            (t
79             (if (= (current-right-open-pos) (current-left-open-pos))
80               (grow-open-chars))
81
82             ;; Rule: when charprops is :neighbor, an inserted character
83             ;; takes on on the properties of the preceding character,
84             ;; unless the character is being inserted at the beginning of
85             ;; a line, in which case it takes on the the properties of the
86             ;; following character.
87
88             (if (eq charprops :neighbor)
89               (if (start-line-p mark)
90                 (adjust-line-charprops line 1)
91                 (adjust-line-charprops line 1 :start (1- charpos)))
92               (let* ((next-props (next-charprops mark))
93                      (prev-props (previous-charprops mark)))
94                 (cond ((charprops-equal charprops prev-props)
95                        ;;(format t "~& prev props (~s) equal" prev-props)
96                        (adjust-line-charprops line 1 :start (1- charpos)))
97                       ((charprops-equal charprops next-props)
98                        ;;(format t "~& next props (~s) equal" next-props)
99                        (adjust-line-charprops (line-charprops-changes line) 1 :start charpos))
100                       (t
101                        ;;(format t "~& surrounding props (~s, ~s) not equal" prev-props next-props)
102                        (adjust-line-charprops line 1 :start charpos)
103                        (set-line-charprops line charprops :start charpos
104                                        :end (1+ charpos))))))
105
106             (maybe-move-some-marks (charpos line) (current-left-open-pos)
107                                    (1+ charpos))
108             
109             (cond
110              ((eq (mark-%kind mark) :right-inserting)
111               (decf (current-right-open-pos))
112               (setf (char (the simple-string (current-open-chars)) (current-right-open-pos))
113                     character))
114              (t
115               (setf (char (the simple-string (current-open-chars)) (current-left-open-pos))
116                     character)
117               (incf (current-left-open-pos))))))
118      (adjust-line-origins-forward line)
119      (buffer-note-insertion buffer mark 1))))
120
121
122(defun insert-string (mark string &key (charprops :neighbor))
123  "Inserts the String at the Mark."
124  (let* ((line (mark-line mark))
125         (charpos (mark-charpos mark))
126         (len (length string))
127         (buffer (line-%buffer line))
128         (string (coerce string 'simple-string)))
129    (declare (simple-string string))
130    (unless (zerop len)
131      (if (%sp-find-character string 0 len #\newline)
132        (progn
133          (when (eq charprops :neighbor)
134            (if (start-line-p mark)
135              (setq charprops (next-charprops mark))
136              (setq charprops (previous-charprops mark))))
137          (ninsert-region mark (string-to-region string :charprops charprops)))
138        (modifying-buffer buffer
139          (modifying-line line mark)
140          (if (<= (current-right-open-pos) (+ (current-left-open-pos) len))
141            (grow-open-chars (* (+ (current-line-cache-length) len) 2)))
142
143          (if (eq charprops :neighbor)
144            (if (start-line-p mark)
145              (adjust-line-charprops line len)
146              (adjust-line-charprops line len :start (1- charpos)))
147            (let* ((next-props (next-charprops mark))
148                   (prev-props (previous-charprops mark)))
149              (cond ((charprops-equal charprops prev-props)
150                     ;;(format t "~& prev props (~s) equal" prev-props)
151                     (adjust-line-charprops line len :start (1- charpos)))
152                    ((charprops-equal charprops next-props)
153                     ;;(format t "~& next props (~s) equal" next-props)
154                     (adjust-line-charprops line len :start charpos))
155                    (t
156                     ;;(format t "~& surrounding props (~s, ~s) not equal" prev-props next-props)
157                     (set-line-charprops line charprops :start charpos
158                                     :end (+ charpos len))))))
159
160          (maybe-move-some-marks (charpos line) (current-left-open-pos)
161                                 (+ charpos len))
162          (cond
163           ((eq (mark-%kind mark) :right-inserting)
164            (let ((new (- (current-right-open-pos) len)))
165              (%sp-byte-blt string 0 (current-open-chars) new (current-right-open-pos))
166              (setf (current-right-open-pos) new)))
167           (t
168            (let ((new (+ (current-left-open-pos) len)))
169              (%sp-byte-blt string 0 (current-open-chars) (current-left-open-pos) new)
170              (setf (current-left-open-pos) new))))
171          (adjust-line-origins-forward line)
172          (buffer-note-insertion buffer mark (length string)))))))
173
174(defconstant line-number-interval-guess 8
175  "Our first guess at how we should number an inserted region's lines.")
176
177(defun insert-region (mark region)
178  "Inserts the given Region at the Mark."
179  (let* ((start (region-start region))
180         (end (region-end region))
181         (first-line (mark-line start))
182         (last-line (mark-line end))
183         (first-charpos (mark-charpos start))
184         (last-charpos (mark-charpos end))
185         (nins (count-characters region))
186         (dest-line (mark-line mark))
187         (dest-charpos (mark-charpos mark)))
188    (cond
189     ((eq first-line last-line)
190      ;; simple case -- just BLT the characters in with insert-string
191      (if (current-open-line-p first-line) (close-line))
192      (let* ((string (line-chars first-line)))
193        (unless (and (eql first-charpos 0)
194                     (eql last-charpos (length string)))
195          (setq string (subseq string first-charpos last-charpos)))
196        (insert-string mark string)
197        (apply-line-charprops dest-line (line-charprops-changes first-line)
198                              dest-charpos (+ dest-charpos (length string)))))
199     (t
200      (close-line)
201      (let* ((line (mark-line mark))
202             (next (line-next line))
203             (charpos (mark-charpos mark))
204             (buffer (line-%buffer line))
205             (old-chars (line-chars line)))
206        (declare (simple-string old-chars))
207        (modifying-buffer buffer
208          ;;hack marked line's chars
209          (let* ((first-chars (line-chars first-line))
210                 (first-length (length first-chars))
211                 (new-length (+ charpos (- first-length first-charpos)))
212                 (new-chars (make-string new-length)))
213            (declare (simple-string first-chars new-chars))
214            (%sp-byte-blt old-chars 0 new-chars 0 charpos)
215            (%sp-byte-blt first-chars first-charpos new-chars charpos new-length)
216            (setf (line-chars line) new-chars)
217            (apply-line-charprops line (line-charprops-changes first-line)
218                                  charpos (+ charpos first-length)))
219
220          ;; Copy intervening lines.  We don't link the lines in until we are
221          ;; done in case the mark is within the region we are inserting.
222          (do* ((this-line (line-next first-line) (line-next this-line))
223                (number (+ (line-number line) line-number-interval-guess)
224                        (+ number line-number-interval-guess))
225                (first (%copy-line this-line  :previous line
226                                   :%buffer buffer  :number number))
227                (previous first)
228                (new-line first (%copy-line this-line  :previous previous
229                                            :%buffer buffer  :number number)))
230               ((eq this-line last-line)
231                ;;make last line
232                (let* ((last-chars (line-chars new-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
238                                new-length)
239                  (setf (line-next line) first)
240                  (setf (line-chars new-line) new-chars)
241                  (apply-line-charprops new-line (line-charprops-changes last-line)
242                                        0 last-charpos)
243                  (setf (line-next previous) new-line)
244                  (setf (line-next new-line) next)
245                  (when next
246                    (setf (line-previous next) new-line)
247                    (if (<= (line-number next) number)
248                        (renumber-region-containing new-line)))
249                  ;;fix up the marks
250                  (maybe-move-some-marks (this-charpos line new-line) charpos
251                    (+ last-charpos (- this-charpos charpos)))))
252            (setf (line-next previous) new-line  previous new-line))
253          (adjust-line-origins-forward line)
254          (buffer-note-insertion buffer  mark nins)))))))
255
256(defun ninsert-region (mark region)
257  "Inserts the given Region at the Mark, possibly destroying the Region.
258  Region may not be a part of any buffer's region."
259  (let* ((start (region-start region))
260         (end (region-end region))
261         (first-line (mark-line start))
262         (last-line (mark-line end))
263         (first-charpos (mark-charpos start))
264         (last-charpos (mark-charpos end))
265         (nins (count-characters region))
266         (dest-line (mark-line mark))
267         (dest-charpos (mark-charpos mark)))
268    (cond
269     ((eq first-line last-line)
270      ;; Simple case -- just BLT the characters in with insert-string.
271      (if (current-open-line-p first-line) (close-line))
272      (let* ((string (line-chars first-line)))
273        (unless (and (eq first-charpos 0)
274                     (eql last-charpos (length string)))
275          (setq string (subseq string first-charpos last-charpos)))
276        (insert-string mark string)
277        (apply-line-charprops dest-line (line-charprops-changes first-line)
278                              dest-charpos (+ dest-charpos (length string)))))
279     (t
280      (when (bufferp (line-%buffer first-line))
281        (error "Region is linked into Buffer ~S." (line-%buffer first-line)))
282      (close-line)
283      (let* ((line (mark-line mark))
284             (second-line (line-next first-line))
285             (next (line-next line))
286             (charpos (mark-charpos mark))
287             (buffer (line-%buffer line))
288             (old-chars (line-chars line)))
289        (declare (simple-string old-chars))
290        (modifying-buffer buffer
291          ;; Make new chars for first and last lines.
292          (let* ((first-chars (line-chars first-line))
293                 (first-length (length first-chars))
294                 (new-length (+ charpos (- first-length first-charpos)))
295                 (new-chars (make-string new-length)))
296            (declare (simple-string first-chars new-chars))
297            (%sp-byte-blt old-chars 0 new-chars 0 charpos)
298            (%sp-byte-blt first-chars first-charpos new-chars charpos
299                          new-length)
300            (setf (line-chars line) new-chars)
301            (apply-line-charprops line (line-charprops-changes first-line)
302                                  charpos (+ charpos first-length)))
303          (let* ((last-chars (line-chars last-line))
304                 (old-length (length old-chars))
305                 (new-length (+ last-charpos (- old-length charpos)))
306                 (new-chars (make-string new-length)))
307            (%sp-byte-blt last-chars 0 new-chars 0 last-charpos)
308            (%sp-byte-blt old-chars charpos new-chars last-charpos new-length)
309            (setf (line-chars last-line) new-chars)
310            (apply-line-charprops last-line (line-charprops-changes last-line)
311                                  0 last-charpos))
312          ;;; Link stuff together.
313          (setf (line-next last-line) next)
314          (setf (line-next line) second-line)
315          (setf (line-previous second-line) line)
316
317          ;;Number the inserted stuff and mash any marks.
318          (do ((line second-line (line-next line))
319               (number (+ (line-number line) line-number-interval-guess)
320                       (+ number line-number-interval-guess)))
321              ((eq line next)
322               (when next
323                 (setf (line-previous next) last-line)         
324                 (if (<= (line-number next) number)
325                     (renumber-region-containing last-line))))
326            (when (line-marks line)
327              (dolist (m (line-marks line))
328                (setf (mark-line m) nil))
329              (setf (line-marks line) nil))
330            (setf (line-number line) number  (line-%buffer line) buffer))
331         
332          ;; Fix up the marks in the line inserted into.
333          (maybe-move-some-marks (this-charpos line last-line) charpos
334            (+ last-charpos (- this-charpos charpos)))
335          (adjust-line-origins-forward line)
336          (buffer-note-insertion buffer mark nins)))))))
337
338(defun paste-characters (position count string)
339  "Replace COUNT characters at POSITION with STRING.  POSITION is the
340absolute character position in buffer"
341  (with-mark ((m (buffer-start-mark (current-buffer))))
342    (unless (character-offset m position)
343      (buffer-end m))
344    (when (> count 0) (delete-characters m count))
345    (when string (insert-string m string))))
Note: See TracBrowser for help on using the repository browser.