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

Last change on this file since 12859 was 12859, checked in by gz, 10 years ago

Make sure that all hemlock functions defined outside of hemlock are in the hemlock-ext package, to make it easier to keep track of them

  • 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      (hemlock-ext: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          (hemlock-ext: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          (hemlock-ext: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          (hemlock-ext: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.