buffer.lisp 26 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
;;; -*- Mode: Lisp; Package: CLIMACS-BUFFER -*-

;;;  (c) copyright 2004-2005 by
;;;           Robert Strandh (strandh at labri.fr)
;;;  (c) copyright 2004-2005 by
;;;           Elliott Johnson (ejohnson at fasl.info)
;;;  (c) copyright 2005 by
;;;           Matthieu Villeneuve (matthieu.villeneuve at free.fr)

;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA  02111-1307  USA.

;;; A not-so-stupid implementation of the buffer protocol.  This
;;; implementation serves two purposes: First, so that higher-level
;;; functionality can be built on top of a working implementation of
;;; the buffer protocol, and second, to use as a comparison for
;;; testing a new, better implementation of the buffer protocol.

(in-package :climacs-buffer)

strandh's avatar
strandh committed
33
34
35
36
37
(defclass buffer () ()
  (:documentation "A base class for all buffers. A buffer conceptually contains a
large array of arbitrary objects.  Lines of objects are separated by
newline characters.  The last object of the buffer is not
necessarily a newline character."))
strandh's avatar
strandh committed
38

39
40
41
42
(defgeneric low-mark (buffer))

(defgeneric high-mark (buffer))

43
44
(defgeneric modified-p (buffer))

strandh's avatar
strandh committed
45
(defclass standard-buffer (buffer)
46
47
  ((contents :initform (make-instance 'standard-cursorchain))
   (low-mark :reader low-mark)
48
49
   (high-mark :reader high-mark)
   (modified :initform nil :reader modified-p))
strandh's avatar
strandh committed
50
51
52
53
  (:documentation "The Climacs standard buffer [an instantable subclass of buffer]."))

(defgeneric buffer (mark)
  (:documentation "Return the buffer that the mark is positioned in."))  
strandh's avatar
strandh committed
54

strandh's avatar
strandh committed
55
56
(defclass mark () ()
  (:documentation "A base class for all marks."))
strandh's avatar
strandh committed
57

strandh's avatar
strandh committed
58
59
60
61
(defclass left-sticky-mark (mark) ()
  (:documentation "A subclass of mark.  A mark of this type will \"stick\" to the left of 
an object, i.e. when an object is inserted at this mark, the mark will 
be positioned to the left of the object"))
strandh's avatar
strandh committed
62

strandh's avatar
strandh committed
63
64
65
66
(defclass right-sticky-mark (mark) ()
  (:documentation "A subclass of mark.  A mark of this type will \"stick\" to the right of 
an object, i.e. when an object is inserted at this mark, the mark will 
be positioned to the right of the object."))
strandh's avatar
strandh committed
67

strandh's avatar
strandh committed
68
69
(defgeneric offset (mark)
  (:documentation "Return the offset of the mark into the buffer."))
strandh's avatar
strandh committed
70

strandh's avatar
strandh committed
71
72
73
74
(defgeneric (setf offset) (new-offset mark)
  (:documentation "Set the offset of the mark into the buffer.  A no-such-offset
condition is signaled if the offset is less than zero or greater than
the size of the buffer."))
strandh's avatar
strandh committed
75

strandh's avatar
strandh committed
76
77
(defclass mark-mixin ()
  ((buffer :initarg :buffer :reader buffer)
strandh's avatar
strandh committed
78
79
   (cursor :reader cursor))
  (:documentation "A mixin class used in the initialization of a mark."))
strandh's avatar
strandh committed
80

81
(defmethod offset ((mark mark-mixin))
82
  (cursor-pos (cursor mark)))
strandh's avatar
strandh committed
83

84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
(define-condition no-such-offset (simple-error)
  ((offset :reader condition-offset :initarg :offset))
  (:report (lambda (condition stream)
	     (format stream "No such offset: ~a" (condition-offset condition))))
  (:documentation "This condition is signaled whenever an attempt is
made to access buffer contents that is before the beginning or after
the end of the buffer."))

(define-condition offset-before-beginning (no-such-offset)
  ()
  (:report (lambda (condition stream)
	     (format stream "Offset before beginning: ~a" (condition-offset condition))))
  (:documentation "This condition is signaled whenever an attempt is
made to access buffer contents that is before the beginning of the buffer."))

(define-condition offset-after-end (no-such-offset)
  ()
  (:report (lambda (condition stream)
	     (format stream "Offset after end: ~a" (condition-offset condition))))
  (:documentation "This condition is signaled whenever an attempt is
made to access buffer contents that is after the end of the buffer."))

(define-condition invalid-motion (simple-error)
  ((offset :reader condition-offset :initarg :offset))
  (:report (lambda (condition stream)
	     (format stream "Invalid motion to offset: ~a" (condition-offset condition))))
  (:documentation "This condition is signaled whenever an attempt is
made to move a mark before the beginning or after the end of the
buffer."))

(define-condition motion-before-beginning (invalid-motion)
  ()
  (:report (lambda (condition stream)
	     (format stream "Motion before beginning: ~a" (condition-offset condition))))
  (:documentation "This condition is signaled whenever an attempt is
made to move a mark before the beginning of the buffer."))

(define-condition motion-after-end (invalid-motion)
  ()
  (:report (lambda (condition stream)
	     (format stream "Motion after end: ~a" (condition-offset condition))))
  (:documentation "This condition is signaled whenever an attempt is
made to move a mark after the end of the buffer."))

128
(defmethod (setf offset) (new-offset (mark mark-mixin))
129
130
131
132
  (assert (<= 0 new-offset) ()
	  (make-condition 'motion-before-beginning :offset new-offset))
  (assert (<= new-offset (size (buffer mark))) ()
	  (make-condition 'motion-after-end :offset new-offset))
133
  (setf (cursor-pos (cursor mark)) new-offset))
strandh's avatar
strandh committed
134

135
136
137
138
139
140
141
142
(defgeneric backward-object (mark &optional count)
  (:documentation "Move `mark' `count' objects backwards. Returns
  `mark'."))

(defgeneric forward-object (mark &optional count)
  (:documentation "Move `mark' `count' objects forwards. Returns
  `mark'"))

143
(defmethod forward-object ((mark mark-mixin) &optional (count 1))
144
145
146
147
148
149
  (incf (offset mark) count)
  t)

(defmethod backward-object ((mark mark-mixin) &optional (count 1))
  (decf (offset mark) count)
  t)
150

strandh's avatar
strandh committed
151
152
153
154
155
(defclass standard-left-sticky-mark (left-sticky-mark mark-mixin) ()
  (:documentation "A left-sticky-mark subclass suitable for use in a standard-buffer"))
 
(defclass standard-right-sticky-mark (right-sticky-mark mark-mixin) ()
  (:documentation "A right-sticky-mark subclass suitable for use in a standard-buffer"))
strandh's avatar
strandh committed
156

157
(defmethod initialize-instance :after ((mark standard-left-sticky-mark) &rest args &key (offset 0))
strandh's avatar
strandh committed
158
  "Associates a created mark with the buffer it was created for."
159
  (declare (ignore args))
160
161
162
163
  (assert (<= 0 offset) ()
	  (make-condition 'motion-before-beginning :offset offset))
  (assert (<= offset (size (buffer mark))) ()
	  (make-condition 'motion-after-end :offset offset))
164
165
166
167
168
  (setf (slot-value mark 'cursor)
	(make-instance 'left-sticky-flexicursor
	   :chain (slot-value (buffer mark) 'contents)
	   :position offset)))

169
(defmethod initialize-instance :after ((mark standard-right-sticky-mark) &rest args &key (offset 0))
strandh's avatar
strandh committed
170
  "Associates a created mark with the buffer it was created for."
171
  (declare (ignore args))
172
173
174
175
  (assert (<= 0 offset) ()
	  (make-condition 'motion-before-beginning :offset offset))
  (assert (<= offset (size (buffer mark))) ()
	  (make-condition 'motion-after-end :offset offset))
176
177
178
179
180
  (setf (slot-value mark 'cursor)
	(make-instance 'right-sticky-flexicursor
	   :chain (slot-value (buffer mark) 'contents)
	   :position offset)))

181
182
183
184
185
186
187
(defmethod initialize-instance :after ((buffer standard-buffer) &rest args)
  "Create the low-mark and high-mark"
  (declare (ignore args))
  (with-slots (low-mark high-mark) buffer
     (setf low-mark (make-instance 'standard-left-sticky-mark :buffer buffer))
     (setf high-mark (make-instance 'standard-right-sticky-mark :buffer buffer))))

188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
(defgeneric clone-mark (mark &optional stick-to)
  (:documentation "Clone a mark.  By default (when stick-to is NIL)
the same type of mark is returned.  Otherwise stick-to is either :left
or :right indicating whether a left-sticky or a right-sticky mark
should be created."))

(defmethod clone-mark ((mark standard-left-sticky-mark) &optional stick-to)
  (cond ((or (null stick-to) (eq stick-to :left))
	 (make-instance 'standard-left-sticky-mark
	    :buffer (buffer mark) :offset (offset mark)))
	((eq stick-to :right)
	 (make-instance 'standard-right-sticky-mark
	    :buffer (buffer mark) :offset (offset mark)))
	(t (error "invalid value for stick-to"))))

(defmethod clone-mark ((mark standard-right-sticky-mark) &optional stick-to)
  (cond ((or (null stick-to) (eq stick-to :right))
	 (make-instance 'standard-right-sticky-mark
	    :buffer (buffer mark) :offset (offset mark)))
	((eq stick-to :left)
	 (make-instance 'standard-left-sticky-mark
	    :buffer (buffer mark) :offset (offset mark)))
	(t (error "invalid value for stick-to"))))
strandh's avatar
strandh committed
211

strandh's avatar
strandh committed
212
213
(defgeneric size (buffer)
  (:documentation "Return the number of objects in the buffer."))
strandh's avatar
strandh committed
214
215

(defmethod size ((buffer standard-buffer))
216
  (nb-elements (slot-value buffer 'contents)))
strandh's avatar
strandh committed
217

strandh's avatar
strandh committed
218
219
220
(defgeneric number-of-lines (buffer)
  (:documentation "Return the number of lines of the buffer, or really the number of
newline characters."))
strandh's avatar
strandh committed
221
222

(defmethod number-of-lines ((buffer standard-buffer))
223
224
  (loop for offset from 0 below (size buffer)
	count (eql (buffer-object buffer offset) #\Newline)))
strandh's avatar
strandh committed
225

strandh's avatar
strandh committed
226
227
228
229
230
(defgeneric mark< (mark1 mark2)
  (:documentation "Return t if the offset of mark1 is strictly less than that of mark2.
An error is signaled if the two marks are not positioned in the same
buffer.  It is acceptable to pass an offset in place of one of the
marks"))
strandh's avatar
strandh committed
231
232
233
234
235
236
237
238
239
240
241

(defmethod mark< ((mark1 mark-mixin) (mark2 mark-mixin))
  (assert (eq (buffer mark1) (buffer mark2)))
  (< (offset mark1) (offset mark2)))

(defmethod mark< ((mark1 mark-mixin) (mark2 integer))
  (< (offset mark1) mark2))

(defmethod mark< ((mark1 integer) (mark2 mark-mixin))
  (< mark1 (offset mark2)))

strandh's avatar
strandh committed
242
243
244
245
246
(defgeneric mark<= (mark1 mark2)
  (:documentation "Return t if the offset of mark1 is less than or equal to that of
mark2.  An error is signaled if the two marks are not positioned in
the same buffer.  It is acceptable to pass an offset in place of one
of the marks."))
strandh's avatar
strandh committed
247
248
249
250
251
252
253
254
255
256
257

(defmethod mark<= ((mark1 mark-mixin) (mark2 mark-mixin))
  (assert (eq (buffer mark1) (buffer mark2)))
  (<= (offset mark1) (offset mark2)))

(defmethod mark<= ((mark1 mark-mixin) (mark2 integer))
  (<= (offset mark1) mark2))

(defmethod mark<= ((mark1 integer) (mark2 mark-mixin))
  (<= mark1 (offset mark2)))

strandh's avatar
strandh committed
258
259
260
261
(defgeneric mark= (mark1 mark2)
  (:documentation "Return t if the offset of mark1 is equal to that of mark2.  An error
 is signaled if the two marks are not positioned in the same buffer.
 It is acceptable to pass an offset in place of one of the marks."))
strandh's avatar
strandh committed
262
263
264
265
266
267
268
269
270
271
272

(defmethod mark= ((mark1 mark-mixin) (mark2 mark-mixin))
  (assert (eq (buffer mark1) (buffer mark2)))
  (= (offset mark1) (offset mark2)))

(defmethod mark= ((mark1 mark-mixin) (mark2 integer))
  (= (offset mark1) mark2))

(defmethod mark= ((mark1 integer) (mark2 mark-mixin))
  (= mark1 (offset mark2)))

strandh's avatar
strandh committed
273
274
275
276
277
(defgeneric mark> (mark1 mark2)
  (:documentation "Return t if the offset of mark1 is strictly greater than that of
mark2.  An error is signaled if the two marks are not positioned in
the same buffer.  It is acceptable to pass an offset in place of one
of the marks."))
strandh's avatar
strandh committed
278
279
280
281
282
283
284
285
286
287
288

(defmethod mark> ((mark1 mark-mixin) (mark2 mark-mixin))
  (assert (eq (buffer mark1) (buffer mark2)))
  (> (offset mark1) (offset mark2)))

(defmethod mark> ((mark1 mark-mixin) (mark2 integer))
  (> (offset mark1) mark2))

(defmethod mark> ((mark1 integer) (mark2 mark-mixin))
  (> mark1 (offset mark2)))

strandh's avatar
strandh committed
289
290
291
292
293
(defgeneric mark>= (mark1 mark2)
  (:documentation "Return t if the offset of mark1 is greater than or equal to that of
mark2.  An error is signaled if the two marks are not positioned in
the same buffer.  It is acceptable to pass an offset in place of one
of the marks."))
strandh's avatar
strandh committed
294
295
296
297
298
299
300
301
302
303
304

(defmethod mark>= ((mark1 mark-mixin) (mark2 mark-mixin))
  (assert (eq (buffer mark1) (buffer mark2)))
  (>= (offset mark1) (offset mark2)))

(defmethod mark>= ((mark1 mark-mixin) (mark2 integer))
  (>= (offset mark1) mark2))

(defmethod mark>= ((mark1 integer) (mark2 mark-mixin))
  (>= mark1 (offset mark2)))

strandh's avatar
strandh committed
305
(defgeneric beginning-of-buffer (mark)
306
307
308
309
310
311
312
313
  (:documentation "Move the mark to the beginning of the buffer.
  This is equivalent to (setf (offset mark) 0), but returns
  mark."))

;; Easy way to make sure mark is always returned.
(defmethod beginning-of-buffer :around (mark)
  (call-next-method)
  mark)
strandh's avatar
strandh committed
314
315
316
317

(defmethod beginning-of-buffer ((mark mark-mixin))
  (setf (offset mark) 0))

strandh's avatar
strandh committed
318
(defgeneric end-of-buffer (mark)
319
320
321
322
323
324
  (:documentation "Move the mark to the end of the buffer and
  return mark."))

(defmethod end-of-buffer :around (mark)
  (call-next-method)
  mark)
strandh's avatar
strandh committed
325
326
327
328

(defmethod end-of-buffer ((mark mark-mixin))
  (setf (offset mark) (size (buffer mark))))

strandh's avatar
strandh committed
329
(defgeneric beginning-of-buffer-p (mark)
330
331
  (:documentation "Return t if the mark is at the beginning of
 the buffer, nil otherwise."))
strandh's avatar
strandh committed
332
333
334
335

(defmethod beginning-of-buffer-p ((mark mark-mixin))
  (zerop (offset mark)))

strandh's avatar
strandh committed
336
337
(defgeneric end-of-buffer-p (mark)
  (:documentation "Return t if the mark is at the end of the buffer, nil otherwise."))
strandh's avatar
strandh committed
338
339
340
341

(defmethod end-of-buffer-p ((mark mark-mixin))
  (= (offset mark) (size (buffer mark))))

strandh's avatar
strandh committed
342
343
344
345
(defgeneric beginning-of-line-p (mark)
  (:documentation "Return t if the mark is at the beginning of the line (i.e., if the
character preceding the mark is a newline character or if the mark is
at the beginning of the buffer), nil otherwise."))
strandh's avatar
strandh committed
346
347
348

(defmethod beginning-of-line-p ((mark mark-mixin))
  (or (beginning-of-buffer-p mark)
349
      (eql (object-before mark) #\Newline)))
strandh's avatar
strandh committed
350

strandh's avatar
strandh committed
351
352
353
354
(defgeneric end-of-line-p (mark)
  (:documentation "Return t if the mark is at the end of the line (i.e., if the character
following the mark is a newline character, or if the mark is at the
end of the buffer), nil otherwise."))
strandh's avatar
strandh committed
355
356
357

(defmethod end-of-line-p ((mark mark-mixin))
  (or (end-of-buffer-p mark)
358
      (eql (object-after mark) #\Newline)))
strandh's avatar
strandh committed
359

360
361
362
363
(defgeneric beginning-of-line (mark)
  (:documentation "Move the mark to the beginning of the line.  The mark will be
 positioned either immediately after the closest preceding newline
 character, or at the beginning of the buffer if no preceding newline
364
365
366
367
368
 character exists. Returns mark."))

(defmethod beginning-of-line :around (mark)
  (call-next-method)
  mark)
369
370
371

(defmethod beginning-of-line ((mark mark-mixin))
  (loop until (beginning-of-line-p mark)
372
	do (backward-object mark)))
373
374
375
376

(defgeneric end-of-line (mark)
  (:documentation "Move the mark to the end of the line. The mark will be positioned
either immediately before the closest following newline character, or
377
378
379
380
381
at the end of the buffer if no following newline character exists. Returns mark."))

(defmethod end-of-line :around (mark)
  (call-next-method)
  mark)
382

383
(defmethod end-of-line ((mark mark-mixin))
384
385
386
387
388
389
390
391
  (let* ((offset (offset mark))
	 (buffer (buffer mark))
	 (chain (slot-value buffer 'contents))
	 (size (nb-elements chain)))
    (loop until (or (= offset size)
		    (eql (element* chain offset) #\Newline))
	  do (incf offset))
    (setf (offset mark) offset)))
392

393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
(defgeneric buffer-line-number (buffer offset)
  (:documentation "Return the line number of the offset.  Lines are numbered from zero."))

(defmethod buffer-line-number ((buffer standard-buffer) (offset integer))
  (loop for i from 0 below offset
	count (eql (buffer-object buffer i) #\Newline)))

(defgeneric buffer-column-number (buffer offset)
  (:documentation "Return the column number of the offset. The column number of an offset is
 the number of objects between it and the preceding newline, or
 between it and the beginning of the buffer if the offset is on the
 first line of the buffer."))

(defmethod buffer-column-number ((buffer standard-buffer) (offset integer))
  (loop for i downfrom offset
	while (> i 0)
	until (eql (buffer-object buffer (1- i)) #\Newline)
	count t))

strandh's avatar
strandh committed
412
413
(defgeneric line-number (mark)
  (:documentation "Return the line number of the mark.  Lines are numbered from zero."))
strandh's avatar
strandh committed
414
415

(defmethod line-number ((mark mark-mixin))
416
  (buffer-line-number (buffer mark) (offset mark)))
strandh's avatar
strandh committed
417

strandh's avatar
strandh committed
418
419
420
421
422
(defgeneric column-number (mark)
  (:documentation "Return the column number of the mark. The column number of a mark is
 the number of objects between it and the preceding newline, or
 between it and the beginning of the buffer if the mark is on the
 first line of the buffer."))
strandh's avatar
strandh committed
423
424

(defmethod column-number ((mark mark-mixin))
425
  (buffer-column-number (buffer mark) (offset mark)))
strandh's avatar
strandh committed
426

427
(defgeneric (setf column-number) (number mark)
428
429
430
431
  (:documentation "Set the column number of the mark, return the
  column number. Note that if `number' is larger than the length
  of the line `mark' is in, `mark' will be moved to end of
  line."))
432
433
434
435
436

(defmethod (setf column-number) (number mark)
  (beginning-of-line mark)
  (loop repeat number
       until (end-of-line-p mark)
437
438
       do (incf (offset mark))
       finally (return (column-number mark))))
439

strandh's avatar
strandh committed
440
441
442
443
444
(defgeneric insert-buffer-object (buffer offset object)
  (:documentation "Insert the object at the offset in the buffer.  Any left-sticky marks
 that are placed at the offset will remain positioned before the
 inserted object.  Any right-sticky marks that are placed at the
 offset will be positioned after the inserted object."))
strandh's avatar
strandh committed
445

446
(defmethod insert-buffer-object ((buffer standard-buffer) offset object)
447
448
449
450
  (assert (<= 0 offset) ()
	  (make-condition 'offset-before-beginning :offset offset))
  (assert (<= offset (size buffer)) ()
	  (make-condition 'offset-after-end :offset offset))
451
  (insert* (slot-value buffer 'contents) offset object))
452

strandh's avatar
strandh committed
453
454
455
(defgeneric insert-buffer-sequence (buffer offset sequence)
  (:documentation "Like calling insert-buffer-object on each of the objects in the
sequence."))
strandh's avatar
strandh committed
456
      
457
(defmethod insert-buffer-sequence ((buffer standard-buffer) offset sequence)
458
  (insert-vector* (slot-value buffer 'contents) offset sequence))
strandh's avatar
strandh committed
459

strandh's avatar
strandh committed
460
461
462
(defgeneric insert-object (mark object)
  (:documentation "Insert the object at the mark.  This function simply calls
insert-buffer-object with the buffer and the position of the mark."))
463
464
465
466

(defmethod insert-object ((mark mark-mixin) object)
  (insert-buffer-object (buffer mark) (offset mark) object))

467
(defgeneric insert-sequence (mark sequence)
strandh's avatar
strandh committed
468
469
470
  (:documentation "Insert the objects in the sequence at the mark. This function simply
calls insert-buffer-sequence with the buffer and the position of the
mark."))
strandh's avatar
strandh committed
471

472
473
(defmethod insert-sequence ((mark mark-mixin) sequence)
  (insert-buffer-sequence (buffer mark) (offset mark) sequence))
strandh's avatar
strandh committed
474

strandh's avatar
strandh committed
475
476
477
478
(defgeneric delete-buffer-range (buffer offset n)
  (:documentation "Delete n objects from the buffer starting at the offset.  If offset
 is negative or offset+n is greater than the size of the buffer, a
 no-such-offset condition is signaled."))
strandh's avatar
strandh committed
479

480
(defmethod delete-buffer-range ((buffer standard-buffer) offset n)
481
482
483
484
  (assert (<= 0 offset) ()
	  (make-condition 'offset-before-beginning :offset offset))
  (assert (<= offset (size buffer)) ()
	  (make-condition 'offset-after-end :offset offset))
485
486
  (loop repeat n
	do (delete* (slot-value buffer 'contents) offset)))
strandh's avatar
strandh committed
487

strandh's avatar
strandh committed
488
489
490
491
(defgeneric delete-range (mark &optional n)
  (:documentation "Delete n objects after (if n > 0) or before (if n < 0) the mark.
This function eventually calls delete-buffer-range, provided that n
is not zero."))
strandh's avatar
strandh committed
492

493
494
495
(defmethod delete-range ((mark mark-mixin) &optional (n 1))
  (cond ((plusp n) (delete-buffer-range (buffer mark) (offset mark) n))
	((minusp n) (delete-buffer-range (buffer mark) (+ (offset mark) n) (- n)))
strandh's avatar
strandh committed
496
497
	(t nil)))

strandh's avatar
strandh committed
498
(defgeneric delete-region (mark1 mark2)
499
500
501
502
  (:documentation "Delete the objects in the buffer that are
between mark1 and mark2.  An error is signaled if the two marks
are positioned in different buffers.  It is acceptable to pass an
offset in place of one of the marks."))
strandh's avatar
strandh committed
503
504
505

(defmethod delete-region ((mark1 mark-mixin) (mark2 mark-mixin))
  (assert (eq (buffer mark1) (buffer mark2)))
506
507
508
509
510
  (let ((offset1 (offset mark1))
        (offset2 (offset mark2)))
    (when (> offset1 offset2)
      (rotatef offset1 offset2))
    (delete-buffer-range (buffer mark1) offset1 (- offset2 offset1))))
strandh's avatar
strandh committed
511
512

(defmethod delete-region ((mark1 mark-mixin) offset2)
513
514
515
516
  (let ((offset1 (offset mark1)))
    (when (> offset1 offset2)
      (rotatef offset1 offset2))
    (delete-buffer-range (buffer mark1) offset1 (- offset2 offset1))))
strandh's avatar
strandh committed
517
518

(defmethod delete-region (offset1 (mark2 mark-mixin))
519
520
521
522
  (let ((offset2 (offset mark2)))
    (when (> offset1 offset2)
      (rotatef offset1 offset2))
    (delete-buffer-range (buffer mark2) offset1 (- offset2 offset1))))
strandh's avatar
strandh committed
523

strandh's avatar
strandh committed
524
525
526
527
(defgeneric buffer-object (buffer offset)
  (:documentation "Return the object at the offset in the buffer.  The first object
has offset 0. If offset is less than zero or greater than or equal to
the size of the buffer, a no-such-offset condition is signaled."))
strandh's avatar
strandh committed
528

529
(defmethod buffer-object ((buffer standard-buffer) offset)
530
531
532
533
  (assert (<= 0 offset) ()
	  (make-condition 'offset-before-beginning :offset offset))
  (assert (<= offset (1- (size buffer))) ()
	  (make-condition 'offset-after-end :offset offset))
534
  (element* (slot-value buffer 'contents) offset))
strandh's avatar
strandh committed
535

536
537
538
539
540
541
(defgeneric (setf buffer-object) (object buffer offset)
  (:documentation "Set the object at the offset in the buffer. The first object
has offset 0. If offset is less than zero or greater than or equal to
the size of the buffer, a no-such-offset condition is signaled."))

(defmethod (setf buffer-object) (object (buffer standard-buffer) offset)
542
543
544
545
  (assert (<= 0 offset) ()
          (make-condition 'offset-before-beginning :offset offset))
  (assert (<= offset (1- (size buffer))) ()
          (make-condition 'offset-after-end :offset offset))
546
547
  (setf (element* (slot-value buffer 'contents) offset) object))

strandh's avatar
strandh committed
548
549
550
551
552
553
(defgeneric buffer-sequence (buffer offset1 offset2)
  (:documentation "Return the contents of the buffer starting at offset1 and ending at
offset2-1 as a sequence.  If either of the offsets is less than zero
or greater than or equal to the size of the buffer, a no-such-offset
condition is signaled.  If offset2 is smaller than or equal to
offset1, an empty sequence will be returned."))
strandh's avatar
strandh committed
554

555
(defmethod buffer-sequence ((buffer standard-buffer) offset1 offset2)
556
557
558
559
560
561
562
563
  (assert (<= 0 offset1) ()
	  (make-condition 'offset-before-beginning :offset offset1))
  (assert (<= offset1 (size buffer)) ()
	  (make-condition 'offset-after-end :offset offset1))
  (assert (<= 0 offset2) ()
	  (make-condition 'offset-before-beginning :offset offset2))
  (assert (<= offset2 (size buffer)) ()
	  (make-condition 'offset-after-end :offset offset2))
564
565
566
567
568
569
  (if (< offset1 offset2)
      (loop with result = (make-array (- offset2 offset1))
	    for offset from offset1 below offset2
	    for i upfrom 0
	    do (setf (aref result i) (buffer-object buffer offset))
	    finally (return result))
570
571
572
573
574
575
      (make-array 0)))

(defun buffer-substring (buffer start end)
  "Return a string of the contents of buffer from `start' to
`end', which must be offsets."
  (coerce (buffer-sequence buffer start end) 'string))
strandh's avatar
strandh committed
576

strandh's avatar
strandh committed
577
578
579
580
581
(defgeneric object-before (mark)
  (:documentation "Return the object that is immediately before the mark.  If mark is at
the beginning of the buffer, a no-such-offset condition is signaled.
If the mark is at the beginning of a line, but not at the beginning
of the buffer, a newline character is returned."))
strandh's avatar
strandh committed
582

583
584
(defmethod object-before ((mark mark-mixin))
  (buffer-object (buffer mark) (1- (offset mark))))
strandh's avatar
strandh committed
585

strandh's avatar
strandh committed
586
587
588
589
590
(defgeneric object-after (mark)
  (:documentation "Return the object that is immediately after the mark.  If mark is at
the end of the buffer, a no-such-offset condition is signaled.  If
the mark is at the end of a line, but not at the end of the buffer, a
newline character is returned."))
strandh's avatar
strandh committed
591

592
593
(defmethod object-after ((mark mark-mixin))
  (buffer-object (buffer mark) (offset mark)))
strandh's avatar
strandh committed
594

strandh's avatar
strandh committed
595
596
597
598
599
600
(defgeneric region-to-sequence (mark1 mark2)
  (:documentation "Return a freshly allocated sequence of the objects after mark1 and
before mark2.  An error is signaled if the two marks are positioned
in different buffers.  If mark1 is positioned at an offset equal to
or greater than that of mark2, an empty sequence is returned.  It is
acceptable to pass an offset in place of one of the marks."))
strandh's avatar
strandh committed
601

602
(defmethod region-to-sequence ((mark1 mark-mixin) (mark2 mark-mixin))
strandh's avatar
strandh committed
603
  (assert (eq (buffer mark1) (buffer mark2)))
604
605
606
607
608
  (let ((offset1 (offset mark1))
	(offset2 (offset mark2)))
    (when (> offset1 offset2)
      (rotatef offset1 offset2))
    (buffer-sequence (buffer mark1) offset1 offset2)))
strandh's avatar
strandh committed
609

610
611
612
613
614
(defmethod region-to-sequence ((offset1 integer) (mark2 mark-mixin))
  (let ((offset2 (offset mark2)))
    (when (> offset1 offset2)
      (rotatef offset1 offset2))
    (buffer-sequence (buffer mark2) offset1 offset2)))
615

616
617
618
619
620
(defmethod region-to-sequence ((mark1 mark-mixin) (offset2 integer))
  (let ((offset1 (offset mark1)))
    (when (> offset1 offset2)
      (rotatef offset1 offset2))
    (buffer-sequence (buffer mark1) offset1 offset2)))
621

622
623
624
625
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Buffer modification protocol

626
627
628
629
630
631
632
633
(defmethod (setf buffer-object) :before (object (buffer standard-buffer) offset)
  (declare (ignore object))
  (setf (offset (low-mark buffer))
        (min (offset (low-mark buffer)) offset))
  (setf (offset (high-mark buffer))
        (max (offset (high-mark buffer)) offset))
  (setf (slot-value buffer 'modified) t))

634
635
636
637
638
(defmethod insert-buffer-object :before ((buffer standard-buffer) offset object)
  (declare (ignore object))
  (setf (offset (low-mark buffer))
	(min (offset (low-mark buffer)) offset))
  (setf (offset (high-mark buffer))
639
640
	(max (offset (high-mark buffer)) offset))
  (setf (slot-value buffer 'modified) t))
641
642
643
644
645
646

(defmethod insert-buffer-sequence :before ((buffer standard-buffer) offset sequence)
  (declare (ignore sequence))
  (setf (offset (low-mark buffer))
	(min (offset (low-mark buffer)) offset))
  (setf (offset (high-mark buffer))
647
648
	(max (offset (high-mark buffer)) offset))
  (setf (slot-value buffer 'modified) t))
649
650
651
652
653

(defmethod delete-buffer-range :before ((buffer standard-buffer) offset n)
  (setf (offset (low-mark buffer))
	(min (offset (low-mark buffer)) offset))
  (setf (offset (high-mark buffer))
654
	(max (offset (high-mark buffer)) (+ offset n)))
655
  (setf (slot-value buffer 'modified) t))
656

657
(defgeneric clear-modify (buffer))
658

659
(defmethod clear-modify ((buffer standard-buffer))
660
  (beginning-of-buffer (high-mark buffer))
661
662
  (end-of-buffer (low-mark buffer))
  (setf (slot-value buffer 'modified) nil))