source: trunk/source/cocoa-ide/hemlock/src/htext2.lisp @ 12275

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

STRING-TO-REGION: accept charprops keyword arg, apply those charprops to
the lines forming the result region.

%SET-NEXT-CHARACTER: adjust charprops when replacing character.

Tweaks to debugging functions.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 19.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.
14;;;
15;;; The code in this file implements the non-insert/delete functions in the
16;;; "Doing Stuff and Going Places" chapter of the Hemlock Design document.
17;;;
18
19(in-package :hemlock-internals)
20
21
22   
23         
24
25(defun region-to-string (region &optional output-string)
26  "Returns a string containing the characters in the given Region."
27  (close-line)
28  (let* ((dst-length (count-characters region))
29         (string (if (and output-string
30                          (<= dst-length (length output-string)))
31                     output-string
32                     (make-string dst-length)))
33         (start-mark (region-start region))
34         (end-mark (region-end region))
35         (start-line (mark-line start-mark))
36         (end-line (mark-line end-mark))
37         (start-charpos (mark-charpos start-mark)))
38    (declare (simple-string string))
39    (if (eq start-line end-line)
40        (%sp-byte-blt (line-chars start-line) start-charpos string 0
41                      dst-length)
42        (let ((index ()))
43          (let* ((line-chars (line-chars start-line))
44                 (dst-end (- (length line-chars) start-charpos)))
45            (declare (simple-string line-chars))
46            (%sp-byte-blt line-chars start-charpos string 0 dst-end)
47            (setf (char string dst-end) #\newline)
48            (setq index (1+ dst-end)))
49          (do* ((line (line-next start-line) (line-next line))
50                (chars (line-chars line) (line-chars line)))
51               ((eq line end-line)
52                (%sp-byte-blt (line-chars line) 0 string index dst-length))
53            (declare (simple-string chars))
54            (%sp-byte-blt (line-chars line) 0 string index
55                          (incf index (length chars)))
56            (setf (char string index) #\newline)
57            (setq index (1+ index)))))
58    (values string dst-length)))
59
60(defun string-to-region (string &key charprops)
61  "Returns a region containing the characters in the given String."
62  (let* ((string (if (simple-string-p string)
63                     string (coerce string 'simple-string)))
64         (end (length string)))
65    (declare (simple-string string))
66    (do* ((index 0)
67          (buffer (next-disembodied-buffer-counter))
68          (previous-line)
69          (line (make-line :%buffer buffer))
70          (first-line line))
71         (())
72      (set-line-charprops line charprops)
73      (let ((right-index (%sp-find-character string index end #\newline)))
74        (cond (right-index
75               (let* ((length (- right-index index))
76                      (chars (make-string length)))
77                 (%sp-byte-blt string index chars 0 length)
78                 (setf (line-chars line) chars))
79               (setq index (1+ right-index))
80               (setq previous-line line)
81               (setq line (make-line :%buffer buffer))
82               (setf (line-next previous-line) line)
83               (setf (line-previous line) previous-line))
84              (t
85               (let* ((length (- end index))
86                      (chars (make-string length)))
87                 (%sp-byte-blt string index chars 0 length)
88                 (setf (line-chars line) chars))
89               (return (renumber-region
90                        (internal-make-region
91                         (mark first-line 0 :right-inserting)
92                         (mark line (length (line-chars line))
93                               :left-inserting))))))))))
94
95(defun line-to-region (line)
96  "Returns a region containing the specified line."
97  (internal-make-region (mark line 0 :right-inserting)
98                        (mark line (line-length* line) :left-inserting)))
99
100(defun previous-character (mark)
101  "Returns the character immediately before the given Mark."
102  (let ((line (mark-line mark))
103        (charpos (mark-charpos mark)))
104    (if (= charpos 0)
105        (if (line-previous line)
106            #\newline
107            nil)
108        (if (current-open-line-p line)
109            (char (the simple-string (current-open-chars))
110                  (if (<= charpos (current-left-open-pos))
111                      (1- charpos)
112                      (1- (+ (current-right-open-pos) (- charpos (current-left-open-pos))))))
113            (schar (line-chars line) (1- charpos))))))
114
115(defun next-character (mark)
116  "Returns the character immediately after the given Mark."
117  (let ((line (mark-line mark))
118        (charpos (mark-charpos mark)))
119    (if (current-open-line-p line)
120        (if (= charpos (- (current-line-cache-length) (- (current-right-open-pos) (current-left-open-pos))))
121            (if (line-next line)
122                #\newline
123                nil)
124            (schar (current-open-chars)
125                   (if (< charpos (current-left-open-pos))
126                       charpos
127                       (+ (current-right-open-pos) (- charpos (current-left-open-pos))))))
128        (let ((chars (line-chars line)))
129          (if (= charpos (strlen chars))
130              (if (line-next line)
131                  #\newline
132                  nil)
133              (schar chars charpos))))))
134
135;;; %Set-Next-Character  --  Internal
136;;;
137;;;    This is the setf form for Next-Character.  Since we may change a
138;;; character to or from a newline, we must be prepared to split and
139;;; join lines.  We cannot just delete  a character and insert the new one
140;;; because the marks would not be right.
141;;;
142(defun %set-next-character (mark character)
143  (let* ((line (mark-line mark))
144         (charpos (mark-charpos mark))
145         (next (line-next line))
146         (buffer (line-%buffer line)))
147    (check-buffer-modification buffer mark)
148    (modifying-buffer buffer
149      (modifying-line line mark)
150      (cond ((= (mark-charpos mark)
151                (- (current-line-cache-length) (- (current-right-open-pos) (current-left-open-pos))))
152             ;; The mark is at the end of the line.
153             (unless next
154               (error "~S has no next character, so it cannot be set." mark))
155             (unless (char= character #\newline)
156               ;; If the character is no longer a newline then mash two
157               ;; lines together.
158               (let ((chars (line-chars next)))
159                 (declare (simple-string chars))
160                 (setf (current-right-open-pos) (- (current-line-cache-length) (length chars)))
161                 (when (<= (current-right-open-pos) (current-left-open-pos))
162                   (grow-open-chars (* (+ (length chars) (current-left-open-pos) 1) 2)))
163                 (%sp-byte-blt chars 0 (current-open-chars) (current-right-open-pos) 
164                               (current-line-cache-length))
165                 (setf (schar (current-open-chars) (current-left-open-pos)) character)
166                 (incf (current-left-open-pos)))
167
168               ;; merge charprops
169               (join-line-charprops line (line-next line))
170                   
171               (move-some-marks (charpos next line) 
172                                (+ charpos (current-left-open-pos)))
173               (setq next (line-next next))
174               (setf (line-next line) next)
175               (when next (setf (line-previous next) line))))
176            ((char= character #\newline)
177             ;; The char is being changed to a newline, so we must split lines.
178             (incf (current-right-open-pos))
179             (let* ((len (- (current-line-cache-length) (current-right-open-pos)))         
180                    (chars (make-string len))
181                    (new (make-line :chars chars  :previous line 
182                                    :next next  :%buffer buffer)))
183               (%sp-byte-blt (current-open-chars) (current-right-open-pos) chars 0 len)
184
185               ;; split charprops
186               (multiple-value-bind (left right)
187                                    (split-line-charprops line charpos)
188                 (setf (line-charprops-changes line) left
189                       (line-charprops-changes new) right))
190
191               (maybe-move-some-marks* (charpos line new) (current-left-open-pos)
192                                       (- charpos (current-left-open-pos) 1))
193               (setf (line-next line) new)
194               (when next (setf (line-previous next) new))
195               (setf (current-right-open-pos) (current-line-cache-length))
196               (number-line new)))
197            (t
198             (setf (char (the simple-string (current-open-chars)) (current-right-open-pos))
199                   character)
200             (hi::buffer-note-modification buffer mark 1)))))
201  character)
202
203;;; %Set-Previous-Character  --  Internal
204;;;
205;;;    The setf form for Previous-Character.  We just Temporarily move the
206;;; mark back one and call %Set-Next-Character.
207;;;
208(defun %set-previous-character (mark character)
209  (unless (mark-before mark)
210    (error "~S has no previous character, so it cannot be set." mark))
211  (%set-next-character mark character)
212  (mark-after mark)
213  character)
214
215(defun count-lines (region)
216  "Returns the number of lines in the region, first and last lines inclusive."
217  (do ((line (mark-line (region-start region)) (line-next line))
218       (count 1 (1+ count))
219       (last-line (mark-line (region-end region))))
220      ((eq line last-line) count)))
221
222(defun count-characters (region)
223  "Returns the number of characters in the region."
224  (let* ((start (region-start region))
225         (end (region-end region))
226         (first-line (mark-line start))
227         (last-line (mark-line end)))
228    (if (eq first-line last-line)
229      (- (mark-charpos end) (mark-charpos start))
230      (do ((line (line-next first-line) (line-next line))
231           (count (1+ (- (line-length* first-line) (mark-charpos start)))))
232          ((eq line last-line)
233           (+ count (mark-charpos end)))
234        (setq count (+ 1 count (line-length* line)))))))
235
236(defun line-start (mark &optional line)
237  "Changes the Mark to point to the beginning of the Line and returns it.
238  Line defaults to the line Mark is on."
239  (when line
240    (change-line mark line))
241  (setf (mark-charpos mark) 0)
242  mark)
243
244(defun line-end (mark &optional line)
245  "Changes the Mark to point to the end of the line and returns it.
246  Line defaults to the line Mark is on."
247  (if line
248      (change-line mark line)
249      (setq line (mark-line mark)))
250  (setf (mark-charpos mark) (line-length* line))
251  mark)
252
253(defun buffer-start (mark &optional (buffer (mark-buffer mark)))
254  "Change Mark to point to the beginning of Buffer, which defaults to
255  the buffer Mark is currently in."
256  (unless buffer (error "Mark ~S does not point into a buffer." mark))
257  (move-mark mark (buffer-start-mark buffer)))
258
259(defun buffer-end (mark &optional (buffer (mark-buffer mark)))
260  "Change Mark to point to the end of Buffer, which defaults to
261  the buffer Mark is currently in."
262  (unless buffer (error "Mark ~S does not point into a buffer." mark))
263  (move-mark mark (buffer-end-mark buffer)))
264
265(defun move-mark (mark new-position)
266  "Changes the Mark to point to the same position as New-Position."
267  (let* ((line (mark-line new-position)))
268    (change-line mark line))
269  (setf (mark-charpos mark) (mark-charpos new-position))
270  mark)
271
272
273(defun mark-before (mark)
274  "Changes the Mark to point one character before where it currently points.
275  NIL is returned if there is no previous character."
276  (let ((charpos (mark-charpos mark)))
277    (cond ((zerop charpos)
278           (let ((prev (line-previous (mark-line mark))))
279             (when prev
280               (always-change-line mark prev)
281               (setf (mark-charpos mark) (line-length* prev))
282               mark)))
283          (t
284           (setf (mark-charpos mark) (1- charpos))
285           mark))))
286
287(defun mark-after (mark)
288  "Changes the Mark to point one character after where it currently points.
289  NIL is returned if there is no previous character."
290  (let ((line (mark-line mark))
291        (charpos (mark-charpos mark)))
292    (cond ((= charpos (line-length* line))
293           (let ((next (line-next line)))
294             (when next
295               (always-change-line mark next)
296               (setf (mark-charpos mark) 0)
297               mark)))
298          (t
299           (setf (mark-charpos mark) (1+ charpos))
300           mark))))
301
302(defun character-offset (mark n)
303  "Changes the Mark to point N characters after (or -N before if N is negative)
304  where it currently points.  If there aren't N characters before (or after)
305  the mark, Nil is returned."
306  (let* ((charpos (mark-charpos mark)))
307    (if (< n 0)
308      (let ((n (- n)))
309        (if (< charpos n)
310          (do ((line (line-previous (mark-line mark)) (line-previous line))
311               (n (- n charpos 1)))
312              ((null line) nil)
313            (let ((length (line-length* line)))
314              (cond ((<= n length)
315                     (always-change-line mark line)
316                     (setf (mark-charpos mark) (- length n))
317                     (return mark))
318                    (t
319                     (setq n (- n (1+ length)))))))
320          (progn (setf (mark-charpos mark) (- charpos n))
321                 mark)))
322      (let* ((line (mark-line mark))
323             (length (line-length* line)))
324        (if (> (+ charpos n) length)
325          (do ((line (line-next line) (line-next line))
326               (n (- n (1+ (- length charpos)))))
327              ((null line) nil)
328            (let ((length (line-length* line)))
329              (cond ((<= n length)
330                     (always-change-line mark line)
331                     (setf (mark-charpos mark) n)
332                     (return mark))
333                    (t
334                     (setq n (- n (1+ length)))))))
335          (progn (setf (mark-charpos mark) (+ charpos n))
336                 mark))))))
337
338(defun line-offset (mark n &optional charpos)
339  "Changes to Mark to point N lines after (-N before if N is negative) where
340  it currently points.  If there aren't N lines after (or before) the Mark,
341  Nil is returned."
342    (if (< n 0)
343            (do ((line (mark-line mark) (line-previous line))
344                 (n n (1+ n)))
345                ((null line) nil)
346              (when (= n 0)
347                (always-change-line mark line)
348                (setf (mark-charpos mark)
349                      (if charpos
350                        (min (line-length line) charpos)
351                        (min (line-length line) (mark-charpos mark))))
352                (return mark)))
353            (do ((line (mark-line mark) (line-next line))
354                 (n n (1- n)))
355                ((null line) nil)
356              (when (= n 0)
357                (change-line mark line)
358                (setf (mark-charpos mark)
359                      (if charpos
360                        (min (line-length line) charpos)
361                        (min (line-length line) (mark-charpos mark))))
362                (return mark)))))
363
364;;; region-bounds  --  Public
365;;;
366(defun region-bounds (region)
367  "Return as multiple-value the start and end of Region."
368  (values (region-start region) (region-end region)))
369
370(defun set-region-bounds (region start end)
371  "Set the start and end of Region to the marks Start and End."
372  (let ((sl (mark-line start))
373        (el (mark-line end)))
374    (when (or (neq (line-%buffer sl) (line-%buffer el))
375              (> (line-number sl) (line-number el))
376              (and (eq sl el) (> (mark-charpos start) (mark-charpos end))))
377      (error "Marks ~S and ~S cannot be made into a region." start end))
378    (setf (region-start region) start  (region-end region) end))
379  region)
380
381
382;;;; Debugging stuff.
383
384(defun slf (string)
385  "For a good time, figure out what this function does, and why it was written."
386  (delete #\linefeed (the simple-string string)))
387
388(defun %print-whole-line (structure stream)
389  (let* ((hi::*current-buffer* (or (line-buffer structure) hi::*current-buffer*)))
390    (cond ((current-open-line-p structure)
391           (write-string (current-open-chars) stream :end (current-left-open-pos))
392           (write-string (current-open-chars) stream :start (current-right-open-pos)
393                         :end (current-line-cache-length)))
394          (t
395           (write-string (line-chars structure) stream)))))
396
397(defun %print-before-mark (mark stream)
398  (let* ((hi::*current-buffer* (or (mark-buffer mark) hi::*current-buffer*)))
399    (if (mark-line mark)
400        (let* ((line (mark-line mark))
401               (chars (line-chars line))
402               (charpos (mark-charpos mark))
403               (length (line-length line)))
404          (declare (simple-string chars))
405          (cond ((or (> charpos length) (< charpos 0))
406                 (write-string "{bad mark}" stream))
407                ((current-open-line-p line)
408                 (cond ((< charpos (current-left-open-pos))
409                        (write-string (current-open-chars) stream :end charpos))
410                       (t
411                        (write-string (current-open-chars) stream :end (current-left-open-pos))
412                        (let ((p (+ charpos (- (current-right-open-pos) (current-left-open-pos)))))
413                          (write-string (current-open-chars) stream  :start (current-right-open-pos)
414                                        :end p)))))
415                (t
416                 (write-string chars stream :end charpos))))
417        (write-string "{deleted mark}" stream))))
418
419
420(defun %print-after-mark (mark stream)
421  (let* ((hi::*current-buffer* (or (mark-buffer mark) hi::*current-buffer*)))
422    (if (mark-line mark)
423        (let* ((line (mark-line mark))
424               (chars (line-chars line))
425               (charpos (mark-charpos mark))
426               (length (line-length line)))
427          (declare (simple-string chars))
428          (cond ((or (> charpos length) (< charpos 0))
429                 (write-string "{bad mark}" stream))
430                ((current-open-line-p line)
431                 (cond ((< charpos (current-left-open-pos))
432                        (write-string (current-open-chars) stream  :start charpos
433                                      :end (current-left-open-pos))
434                        (write-string (current-open-chars) stream  :start (current-right-open-pos)
435                                      :end (current-line-cache-length)))
436                       (t
437                        (let ((p (+ charpos (- (current-right-open-pos) (current-left-open-pos)))))
438                          (write-string (current-open-chars) stream :start p
439                                        :end (current-line-cache-length))))))
440                (t
441                 (write-string chars stream  :start charpos  :end length))))
442        (write-string "{deleted mark}" stream))))
443
444(defun %print-hline (structure stream d)
445  (declare (ignore d))
446  (write-string "#<Hemlock Line \"" stream)
447  (%print-whole-line structure stream)
448  (write-string "\">" stream))
449
450(defun %print-hmark (structure stream d)
451  (declare (ignore d))
452  (let ((hi::*current-buffer* (or (mark-buffer structure) hi::*current-buffer*)))
453    (write-string "#<Hemlock Mark \"" stream)
454    (%print-before-mark structure stream)
455    (write-string "^" stream)
456    (%print-after-mark structure stream)
457    (write-string "\">" stream)))
458
459(defvar *print-region* 10
460  "The number of lines to print out of a region, or NIL if none.")
461
462(defun %print-hregion (region stream d)
463  (declare (ignore d))
464  (write-string "#<Hemlock Region \"" stream)
465  (let* ((start (region-start region))
466         (end (region-end region))
467         (hi::*current-buffer* (or (mark-buffer start) hi::*current-buffer*))
468         (first-line (mark-line start))
469         (last-line (mark-line end)))
470    (cond
471     ((not (and (linep first-line) (linep last-line)
472                (eq (line-%buffer first-line) (line-%buffer last-line))
473                (mark<= start end)))
474      (write-string "{bad region}" stream))
475     (*print-region*
476      (cond ((eq first-line last-line)
477             (let ((cs (mark-charpos start))
478                   (ce (mark-charpos end))
479                   (len (line-length first-line)))
480               (cond
481                ((or (< cs 0) (> ce len))
482                 (write-string "{bad region}" stream))
483                ((current-open-line-p first-line)
484                 (let ((gap (- (current-right-open-pos) (current-left-open-pos))))
485                   (cond
486                    ((<= ce (current-left-open-pos))
487                     (write-string (current-open-chars) stream  :start cs  :end ce))
488                    ((>= cs (current-left-open-pos))
489                     (write-string (current-open-chars) stream  :start (+ cs gap)
490                                   :end (+ ce gap)))
491                    (t
492                     (write-string (current-open-chars) stream :start cs
493                                   :end (current-left-open-pos))
494                     (write-string (current-open-chars) stream :start (current-right-open-pos)
495                                   :end (+ gap ce))))))
496                (t
497                 (write-string (line-chars first-line) stream  :start cs
498                               :end ce)))))
499            (t
500             (%print-after-mark start stream)
501             (write-char #\/ stream)
502             (do ((line (line-next first-line) (line-next line))
503                  (last-line (mark-line end))
504                  (cnt *print-region* (1- cnt)))
505                 ((or (eq line last-line)
506                      (when (zerop cnt) (write-string "..." stream) t))
507                  (%print-before-mark end stream))
508               (%print-whole-line line stream)
509               (write-char #\/ stream)))))
510     (t
511      (write-string "{mumble}" stream))))
512  (write-string "\">" stream))
513
514(defun %print-hbuffer (structure stream d)
515  (declare (ignore d))
516  (write-string "#<Hemlock Buffer \"" stream)
517  (write-string (buffer-name structure) stream)
518  (write-string "\">" stream))
519
520(defun check-buffer-modification (buffer mark)
521  (when (typep buffer 'buffer)
522    (let* ((protected-region (buffer-protected-region buffer)))
523      (when protected-region
524        (let* ((prot-start (region-start protected-region))
525               (prot-end (region-end protected-region)))
526         
527          (when (and (mark>= mark prot-start)
528                     (mark< mark prot-end))
529            (editor-error "Can't modify protected buffer region.")))))))
Note: See TracBrowser for help on using the repository browser.