source: trunk/ccl/hemlock/src/htext1.lisp @ 2064

Last change on this file since 2064 was 2064, checked in by gb, 14 years ago

Don't modify buffer if doing so would change a protected region.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 23.9 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;;; Hemlock Text-Manipulation functions.
13;;; Written by Skef Wholey.
14;;;
15;;; The code in this file implements the functions in the "Representation
16;;; of Text," "Buffers," and "Predicates" chapters of the Hemlock design
17;;; document.
18;;;
19
20(in-package :hemlock-internals)
21
22
23;;;; Representation of Text:
24
25;;; Line cache mechanism.
26;;;
27;;; The "open line" is used when inserting and deleting characters from a line.
28;;; It acts as a cache that provides a more flexible (but more expensive)
29;;; representation of the line for multiple insertions and deletions.  When a
30;;; line is open, it is represented as a vector of characters and two indices:
31;;;
32;;; +-----------------------------------------------------------+
33;;; | F | O | O |   | B | x | x | x | x | x | x | x | x | A | R |
34;;; +-----------------------------------------------------------+
35;;;                       ^                               ^
36;;;                   Left Pointer                   Right Pointer
37;;;
38;;; The open line is represented by 4 special variables:
39;;;     *Open-Line*: the line object that is opened
40;;;     *Open-Chars*: the vector of cached characters
41;;;     *Left-Open-Pos*: index of first free character in the gap
42;;;     *Right-Open-Pos*: index of first used character after the gap
43;;;
44;;; Note:
45;;;    Any modificiation of the line cache must be protected by
46;;; Without-Interrupts.  This is done automatically by modifying-buffer; other
47;;; users beware.
48
49
50
51#+no
52(defvar *line-cache-length* 200
53  "Length of Open-Chars.")
54
55
56
57#+no
58(defvar *open-line* ()
59  "Line open for hacking on.")
60
61
62
63#+no
64(defvar *open-chars*  (make-string *line-cache-length*)
65  "Vector of characters for hacking on.")
66
67
68
69#+no
70(defvar *left-open-pos* 0
71  "Index to first free character to left of mark in *Open-Chars*.")
72
73
74
75#+no
76(defvar *right-open-pos* 0
77  "Index to first used character to right of mark in *Open-Chars*.")
78
79(defun grow-open-chars (&optional (new-length (* *line-cache-length* 2)))
80  "Grows *Open-Chars* to twice its current length, or the New-Length if
81  specified."
82  (let ((new-chars (make-string new-length))
83        (new-right (- new-length (- *line-cache-length* *right-open-pos*))))
84    (%sp-byte-blt *open-chars* 0 new-chars 0 *left-open-pos*)
85    (%sp-byte-blt *open-chars* *right-open-pos* new-chars new-right new-length)
86    (setf *right-open-pos* new-right)
87    (setf *open-chars* new-chars)
88    (setf *line-cache-length* new-length)))
89
90(defun close-line ()
91  "Stuffs the characters in the currently open line back into the line they
92  came from, and sets *open-line* to Nil."
93  (when *open-line*
94    (hemlock-ext:without-interrupts
95      (let* ((length (+ *left-open-pos* (- *line-cache-length* *right-open-pos*)))
96             (string (make-string length)))
97        (%sp-byte-blt *open-chars* 0 string 0 *left-open-pos*)
98        (%sp-byte-blt *open-chars* *right-open-pos*  string *left-open-pos* length)
99        (setf (line-chars *open-line*) string)
100        (setf *open-line* nil)))))
101
102;;; We stick decrementing fixnums in the line-chars slot of the open line
103;;; so that whenever the cache is changed the chars are no longer eq.
104;;; They decrement so that they will be distinct from positive fixnums,
105;;; which might mean something else.
106;;;
107(defvar *cache-modification-tick* -1
108  "The counter for the fixnums we stick in the chars of the cached line.")
109
110(defun open-line (line mark)
111  "Closes the current *Open-Line* and opens the given Line at the Mark.
112  Don't call this, use modifying-line instead."
113  (cond ((eq line *open-line*)
114           (let ((charpos (mark-charpos mark)))
115             (cond ((< charpos *left-open-pos*) ; BLT 'em right!
116                    (let ((right-start (- *right-open-pos*
117                                          (- *left-open-pos* charpos))))
118                      (%sp-byte-blt *open-chars*
119                                    charpos
120                                    *open-chars*
121                                    right-start
122                                    *right-open-pos*)
123                      (setf *left-open-pos* charpos)
124                      (setf *right-open-pos* right-start)))
125                   ((> charpos *left-open-pos*) ; BLT 'em left!
126                    (%sp-byte-blt *open-chars*
127                                  *right-open-pos*
128                                  *open-chars*
129                                  *left-open-pos*
130                                  charpos)
131                    (setf *right-open-pos*
132                          (+ *right-open-pos*
133                             (- charpos *left-open-pos*)))
134                    (setf *left-open-pos* charpos)))))
135
136          (t
137           (close-line)
138           (let* ((chars (line-chars line))
139                  (len (length chars)))
140             (declare (simple-string chars))
141             (when (> len *line-cache-length*)
142               (setf *line-cache-length* (* len 2))
143               (setf *open-chars* (make-string *line-cache-length*)))
144             (setf *open-line* line)
145             (setf *left-open-pos* (mark-charpos mark))
146             (setf *right-open-pos*
147                   (- *line-cache-length*
148                      (- (length chars) *left-open-pos*)))
149             (%sp-byte-blt chars 0 *open-chars* 0
150                           *left-open-pos*)
151             (%sp-byte-blt chars *left-open-pos*
152                           *open-chars*
153                           *right-open-pos*
154                           *line-cache-length*)))))
155
156;;;; Some macros for Text hacking:
157
158
159(defmacro modifying-line (line mark)
160  "Checks to see if the Line is already opened at the Mark, and calls Open-Line
161  if not.  Sticks a tick in the *open-line*'s chars.  This must be called within
162  the body of a Modifying-Buffer form."
163  `(progn
164    (unless (and (= (mark-charpos ,mark) *left-open-pos*) (eq ,line *open-line*))
165      (open-line ,line ,mark))
166    (setf (line-chars *open-line*) (decf *cache-modification-tick*))))
167
168;;; Now-Tick tells us when now is and isn't.
169;;;
170(defvar now-tick 0 "Current tick.")
171
172(defmacro tick ()
173  "Increments the ``now'' tick."
174  `(ccl::atomic-incf now-tick))
175
176 
177(defun buffer-document-begin-editing (buffer)
178  (when (bufferp buffer)
179    (let* ((document (buffer-document buffer)))
180      (when document
181        (lock-buffer buffer)
182        (document-begin-editing document)))))
183
184(defun buffer-document-end-editing (buffer)
185  (when (bufferp buffer)
186    (let* ((document (buffer-document buffer)))
187      (when document
188        (unlock-buffer buffer)
189        (document-end-editing document)))))
190
191
192
193;;; Yeah, the following is kind of obscure, but at least it doesn't
194;;; call Bufferp twice.  The without-interrupts is just to prevent
195;;; people from being screwed by interrupting when the buffer structure
196;;; is in an inconsistent state.
197;;;
198(defmacro modifying-buffer (buffer &body forms)
199  "Does groovy stuff for modifying buffers."
200  (let* ((b (gensym))
201         (bp (gensym)))
202    `(let* ((,b ,buffer)
203            (,bp (bufferp ,b)))
204      (when ,bp
205        (unless (buffer-writable ,b)
206          (error "Buffer ~S is read only." (buffer-name ,b)))
207        (when (< (buffer-modified-tick ,b)
208                 (buffer-unmodified-tick ,b))
209          (invoke-hook hemlock::buffer-modified-hook ,b t))
210        (setf (buffer-modified ,b) t))
211      (unwind-protect
212           (progn
213             (if ,bp (buffer-document-begin-editing ,b))
214             (hemlock-ext:without-interrupts ,@forms))
215        (if ,bp (buffer-document-end-editing ,b))))))
216
217(defmacro always-change-line (mark new-line)
218  (let ((scan (gensym))
219        (prev (gensym))
220        (old-line (gensym)))
221    `(let ((,old-line (mark-line ,mark)))
222       (when (not (eq (mark-%kind ,mark) :temporary))
223         (do ((,scan (line-marks ,old-line) (cdr ,scan))
224              (,prev () ,scan))
225             ((eq (car ,scan) ,mark)
226              (if ,prev
227                  (setf (cdr ,prev) (cdr ,scan))
228                  (setf (line-marks ,old-line) (cdr ,scan)))
229              (setf (cdr ,scan) (line-marks ,new-line)
230                    (line-marks ,new-line) ,scan))))
231       (setf (mark-line ,mark) ,new-line))))
232
233(defmacro change-line (mark new-line)
234  (let ((scan (gensym))
235        (prev (gensym))
236        (old-line (gensym)))
237    `(let ((,old-line (mark-line ,mark)))
238       (unless (or (eq (mark-%kind ,mark) :temporary)
239                   (eq ,old-line ,new-line))
240         (do ((,scan (line-marks ,old-line) (cdr ,scan))
241              (,prev () ,scan))
242             ((eq (car ,scan) ,mark)
243              (if ,prev
244                  (setf (cdr ,prev) (cdr ,scan))
245                  (setf (line-marks ,old-line) (cdr ,scan)))
246              (setf (cdr ,scan) (line-marks ,new-line)
247                    (line-marks ,new-line) ,scan))))
248       (setf (mark-line ,mark) ,new-line))))
249
250;;; MOVE-SOME-MARKS  --  Internal
251;;;
252;;;    Move all the marks from the line Old to New, performing some
253;;; function on their charpos'es.  Charpos is bound to the charpos of
254;;; the mark, and the result of the evaluation of the last form in
255;;; the body should be the new charpos for the mark.  If New is
256;;; not supplied then the marks are left on the old line.
257;;;
258(defmacro move-some-marks ((charpos old &optional new) &body body)
259  (let ((last (gensym)) (mark (gensym)) (marks (gensym)))
260    (if new
261        `(let ((,marks (line-marks ,old)))
262           (do ((,mark ,marks (cdr ,mark))
263                (,last nil ,mark))
264               ((null ,mark)
265                (when ,last
266                  (shiftf (cdr ,last) (line-marks ,new) ,marks))
267                (setf (line-marks ,old) nil))
268             (setf (mark-line (car ,mark)) ,new)
269             (setf (mark-charpos (car ,mark))
270                   (let ((,charpos (mark-charpos (car ,mark))))
271                     ,@body))))
272        `(dolist (,mark (line-marks ,old))
273           (setf (mark-charpos ,mark)
274                 (let ((,charpos (mark-charpos ,mark)))
275                   ,@body))))))
276
277;;; Maybe-Move-Some-Marks  --  Internal
278;;;
279;;;    Like Move-Some-Marks, but only moves the mark if the
280;;; charpos is greater than the bound, OR the charpos equals the bound
281;;; and the marks %kind is :left-inserting.
282;;;
283(defmacro maybe-move-some-marks ((charpos old &optional new) bound &body body)
284  (let ((mark (gensym)) (marks (gensym)) (prev (gensym)))
285    (if new
286        `(do ((,mark (line-marks ,old))
287              (,marks (line-marks ,new))
288              (,prev ()))
289             ((null ,mark)
290              (setf (line-marks ,new) ,marks))
291           (let ((,charpos (mark-charpos (car ,mark))))
292             (cond
293               ((or (> ,charpos ,bound)
294                    (and (= ,charpos ,bound) 
295                         (eq (mark-%kind (car ,mark)) :left-inserting)))
296                (setf (mark-line (car ,mark)) ,new)
297                (setf (mark-charpos (car ,mark)) (progn ,@body))
298                (if ,prev
299                    (setf (cdr ,prev) (cdr ,mark))
300                    (setf (line-marks ,old) (cdr ,mark)))
301                (rotatef (cdr ,mark) ,marks ,mark))
302               (t
303                (setq ,prev ,mark  ,mark (cdr ,mark))))))
304        `(dolist (,mark (line-marks ,old))
305           (let ((,charpos (mark-charpos ,mark)))
306             (when (or (> ,charpos ,bound)
307                       (and (= ,charpos ,bound)
308                            (eq (mark-%kind ,mark) :left-inserting)))
309               (setf (mark-charpos ,mark) (progn ,@body))))))))
310
311
312;;; Maybe-Move-Some-Marks*  --  Internal
313;;;
314;;;    Like Maybe-Move-Some-Marks, but ignores the mark %kind.
315;;;
316(defmacro maybe-move-some-marks* ((charpos old &optional new) bound &body body)
317  (let ((mark (gensym)) (marks (gensym)) (prev (gensym)))
318    (if new
319        `(do ((,mark (line-marks ,old))
320              (,marks (line-marks ,new))
321              (,prev ()))
322             ((null ,mark)
323              (setf (line-marks ,new) ,marks))
324           (let ((,charpos (mark-charpos (car ,mark))))
325             (cond
326               ((> ,charpos ,bound)
327                (setf (mark-line (car ,mark)) ,new)
328                (setf (mark-charpos (car ,mark)) (progn ,@body))
329                (if ,prev
330                    (setf (cdr ,prev) (cdr ,mark))
331                    (setf (line-marks ,old) (cdr ,mark)))
332                (rotatef (cdr ,mark) ,marks ,mark))
333               (t
334                (setq ,prev ,mark  ,mark (cdr ,mark))))))
335        `(dolist (,mark (line-marks ,old))
336           (let ((,charpos (mark-charpos ,mark)))
337             (when (> ,charpos ,bound)
338               (setf (mark-charpos ,mark) (progn ,@body))))))))
339
340;;;; Lines.
341
342(defun line-length (line)
343  "Returns the number of characters on the line."
344  (if (linep line)
345      (line-length* line)
346      (error "~S is not a line!" line)))
347
348(defun line-buffer (line)
349  "Returns the buffer with which the Line is associated.  If the line is
350  not in any buffer then Nil is returned."
351  (let ((buffer (line-%buffer line)))
352    (if (bufferp buffer) buffer)))
353
354(defun line-string (line)
355  "Returns the characters in the line as a string.  The resulting string
356  must not be destructively modified.  This may be set with Setf."
357  (if (eq line *open-line*)
358    (close-line))
359  (line-chars line))
360
361(defun %set-line-string (line string)
362  (let ((buffer (line-%buffer line)))
363    (modifying-buffer buffer
364      (unless (simple-string-p string) 
365        (setq string (coerce string 'simple-string)))
366      (when (eq line *open-line*) (setq *open-line* nil))
367      (let ((length (length (the simple-string string))))
368        (dolist (m (line-marks line))
369          (if (eq (mark-%kind m) :left-inserting)
370              (setf (mark-charpos m) length)
371              (setf (mark-charpos m) 0))))
372      (setf (line-chars line) string))))
373
374(defun line-character (line index)
375  "Return the Index'th character in Line.  If the index is the length of the
376  line then #\newline is returned."
377  (if (eq line *open-line*)
378      (if (< index *left-open-pos*)
379          (schar *open-chars* index)
380          (let ((index (+ index (- *right-open-pos* *left-open-pos*))))
381            (if (= index *line-cache-length*)
382                #\newline
383                (schar *open-chars* index))))
384      (let ((chars (line-chars line)))
385        (declare (simple-string chars))
386        (if (= index (length chars))
387            #\newline
388            (schar chars index)))))
389
390;;;; Marks.
391
392(defun mark (line charpos &optional (kind :temporary))
393  "Returns a mark to the Charpos'th character of the Line.  Kind is the
394  kind of mark to make, one of :temporary (the default), :left-inserting
395  or :right-inserting."
396  (let ((mark (internal-make-mark line charpos kind)))
397    (if (not (eq kind :temporary))
398        (push mark (line-marks line)))
399    mark))
400
401(defun mark-kind (mark)
402  "Returns the kind of the given Mark, :Temporary, :Left-Inserting, or
403  :Right-Inserting.  This may be set with Setf."
404  (mark-%kind mark))
405
406(defun %set-mark-kind (mark kind)
407  (let ((line (mark-line mark)))
408    (cond ((eq kind :temporary)
409           (setf (line-marks line) (delq mark (line-marks line)))
410           (setf (mark-%kind mark) kind))
411          ((or (eq kind :left-inserting) (eq kind :right-inserting))
412           (if (not (member mark (line-marks line)))
413               (push mark (line-marks line)))
414           (setf (mark-%kind mark) kind))
415          (t
416           (error "~S is an invalid mark type." kind)))))
417
418(defun copy-mark (mark &optional (kind (mark-%kind mark)))
419  "Returns a new mark pointing to the same position as Mark.  The kind
420  of mark created may be specified by Kind, which defaults to the
421  kind of the copied mark."
422  (let ((mark (internal-make-mark (mark-line mark) (mark-charpos mark) kind)))
423    (if (not (eq kind :temporary))
424        (push mark (line-marks (mark-line mark))))
425    mark))
426
427(defun delete-mark (mark)
428  "Deletes the Mark.  This should be done to any mark that may not be
429  temporary which is no longer needed."
430  (if (not (eq (mark-%kind mark) :temporary))
431      (let ((line (mark-line mark)))
432        (when line
433          (setf (line-marks line) (delq mark (line-marks line))))
434        nil))
435  (setf (mark-line mark) nil))
436
437(defun move-to-position (mark charpos &optional (line (mark-line mark)))
438  "Changes the Mark to point to the given character position on the Line,
439  which defaults to the line the mark is currently on."
440  (change-line mark line)
441  (setf (mark-charpos mark) charpos)
442  mark)
443
444;;;; Regions.
445
446(defun region (start end)
447  "Returns a region constructed from the marks Start and End."
448  (let ((l1 (mark-line start))
449        (l2 (mark-line end)))
450    (unless (eq (line-%buffer l1) (line-%buffer l2))
451      (error "Can't make a region with lines of different buffers."))
452    (unless (if (eq l1 l2)
453                (<= (mark-charpos start) (mark-charpos end))
454                (< (line-number l1) (line-number l2)))
455      (error "Start ~S is after end ~S." start end)))
456  (internal-make-region start end))
457
458;;; The *Disembodied-Buffer-Counter* exists to give that are not in any buffer
459;;; unique buffer slots.
460
461(defvar *disembodied-buffer-counter* 0
462  "``Buffer'' given to lines in regions not in any buffer.")
463
464(defun make-empty-region ()
465  "Returns a region with start and end marks pointing to the start of one empty
466  line.  The start mark is right-inserting and the end mark is left-inserting."
467  (let* ((line (make-line :chars ""  :number 0
468                          :%buffer (incf *disembodied-buffer-counter*)))
469         (start (mark line 0 :right-inserting))
470         (end (mark line 0 :left-inserting)))
471    (internal-make-region start end)))
472
473;;; Line-Increment is the default difference for line numbers when we don't
474;;; know any better.
475
476(defconstant line-increment 256 "Default difference for line numbers.")
477
478;;; Renumber-Region is used internally to keep line numbers in ascending order.
479;;; The lines in the region are numbered starting with the given Start value
480;;; by increments of the given Step value.  It returns the region.
481
482(defun renumber-region (region &optional (start 0) (step line-increment))
483  (do ((line (mark-line (region-start region)) (line-next line))
484       (last-line (mark-line (region-end region)))
485       (number start (+ number step)))
486      ((eq line last-line)
487       (setf (line-number line) number)
488       region)
489    (setf (line-number line) number))
490  region)
491
492;;; Renumber-Region-Containing renumbers the region containing the given line.
493
494(defun renumber-region-containing (line)
495  (cond ((line-buffer line)
496         (renumber-region (buffer-region (line-%buffer line))))
497        (t
498         (do ((line line (line-previous line))
499              (number 0 (- number line-increment)))
500             ((null line))
501           (setf (line-number line) number))
502         (do ((line (line-next line) (line-next line))
503              (number line-increment (+ number line-increment)))
504             ((null line))
505           (setf (line-number line) number)))))
506 
507
508;;; Number-Line numbers a newly created line.  The line has to have a previous
509;;; line.
510(defun number-line (line)
511  (let ((prev (line-number (line-previous line)))
512        (next (line-next line)))
513    (if (null next)
514        (setf (line-number line) (+ prev line-increment))
515        (let ((new (+ prev (truncate (- (line-number next) prev) 2))))
516          (if (= new prev)
517              (renumber-region-containing line)
518              (setf (line-number line) new))))))
519
520
521
522;;;; Buffers.
523
524;;; BUFFER-SIGNATURE is the exported interface to the internal function,
525;;; BUFFER-MODIFIED-TICK
526;;;
527(defun buffer-signature (buffer)
528  "Returns an arbitrary number which reflects the buffers current
529  \"signature.\" The value returned by buffer-signature is guaranteed
530  to be eql to the value returned by a previous call of buffer-signature
531  iff the buffer has not been modified between the calls."
532  (unless (bufferp buffer)
533    (error "~S is not a buffer." buffer))
534  (buffer-modified-tick buffer))
535
536
537
538;;;; Predicates:
539
540
541(defun start-line-p (mark)
542  "Returns T if the Mark points before the first character in a line, Nil
543  otherwise."
544  (= (mark-charpos mark) 0))
545
546(defun end-line-p (mark)
547  "Returns T if the Mark points after the last character in a line, Nil
548  otherwise."
549  (= (mark-charpos mark) (line-length (mark-line mark))))
550
551(defun empty-line-p (mark)
552  "Returns T if the line pointer to by Mark contains no characters, Nil
553  or otherwise."
554  (let ((line (mark-line mark)))
555    (if (eq line *open-line*)
556        (and (= *left-open-pos* 0) (= *right-open-pos* *line-cache-length*))
557        (= (length (line-chars line)) 0))))
558
559;;; blank-between-positions  --  Internal
560;;;
561;;;    Check if a line is blank between two positions.  Used by blank-XXX-p.
562;;;
563(eval-when (:compile-toplevel :execute)
564(defmacro check-range (chars start end)
565  `(do ((i ,start (1+ i)))
566       ((= i ,end) t)
567     (when (zerop (character-attribute :whitespace (schar ,chars i)))
568       (return nil)))))
569;;;
570(defun blank-between-positions (line start end)
571  (if (eq line *open-line*)
572      (let ((gap (- *right-open-pos* *left-open-pos*)))
573        (cond ((>= start *left-open-pos*)
574               (check-range *open-chars* (+ start gap) (+ end gap)))
575              ((<= end *left-open-pos*)
576               (check-range *open-chars* start end))
577              (t
578               (and (check-range *open-chars* start *left-open-pos*)
579                    (check-range *open-chars* *right-open-pos* (+ end gap))))))
580      (let ((chars (line-chars line)))
581        (check-range chars start end))))
582
583(defun blank-line-p (line)
584  "True if line contains only characters with a :whitespace attribute of 1."
585  (blank-between-positions line 0 (line-length line)))
586
587(defun blank-before-p (mark)
588  "True is all of the characters before Mark on the line it is on have a
589  :whitespace attribute of 1."
590  (blank-between-positions (mark-line mark) 0 (mark-charpos mark)))
591
592(defun blank-after-p (mark)
593  "True if all characters on the part part of the line after Mark have
594  a :whitespace attribute of 1."
595  (let ((line (mark-line mark)))
596    (blank-between-positions line (mark-charpos mark)
597                             (line-length line))))
598 
599(defun same-line-p (mark1 mark2)
600  "Returns T if Mark1 and Mark2 point to the same line, Nil otherwise."
601  (eq (mark-line mark1) (mark-line mark2)))
602
603(defun mark< (mark1 mark2)
604  "Returns T if Mark1 points to a character before Mark2, Nil otherwise."
605  (if (not (eq (line-%buffer (mark-line mark1))
606               (line-%buffer (mark-line mark2))))
607      (error "Marks in different buffers have no relation."))
608  (or (< (line-number (mark-line mark1)) (line-number (mark-line mark2)))
609      (and (= (line-number (mark-line mark1)) (line-number (mark-line mark2)))
610           (< (mark-charpos mark1) (mark-charpos mark2)))))
611
612(defun mark<= (mark1 mark2)
613  "Returns T if Mark1 points to a character at or before Mark2, Nil otherwise."
614  (if (not (eq (line-%buffer (mark-line mark1))
615               (line-%buffer (mark-line mark2))))
616      (error "Marks in different buffers have no relation."))
617  (or (< (line-number (mark-line mark1)) (line-number (mark-line mark2)))
618      (and (= (line-number (mark-line mark1)) (line-number (mark-line mark2)))
619           (<= (mark-charpos mark1) (mark-charpos mark2)))))
620
621(defun mark> (mark1 mark2)
622  "Returns T if Mark1 points to a character after Mark2, Nil otherwise."
623  (if (not (eq (line-%buffer (mark-line mark1))
624               (line-%buffer (mark-line mark2))))
625      (error "Marks in different buffers have no relation."))
626  (or (> (line-number (mark-line mark1)) (line-number (mark-line mark2)))
627      (and (= (line-number (mark-line mark1)) (line-number (mark-line mark2)))
628           (> (mark-charpos mark1) (mark-charpos mark2)))))
629
630(defun mark>= (mark1 mark2)
631  "Returns T if Mark1 points to a character at or after Mark2, Nil otherwise."
632  (if (not (eq (line-%buffer (mark-line mark1))
633               (line-%buffer (mark-line mark2))))
634      (error "Marks in different buffers have no relation."))
635  (or (> (line-number (mark-line mark1)) (line-number (mark-line mark2)))
636      (and (= (line-number (mark-line mark1)) (line-number (mark-line mark2)))
637           (>= (mark-charpos mark1) (mark-charpos mark2)))))
638
639(defun mark= (mark1 mark2)
640  "Returns T if both marks point to the same position, Nil otherwise."
641  (and (eq (mark-line mark1) (mark-line mark2))
642       (= (mark-charpos mark1) (mark-charpos mark2))))
643
644(defun mark/= (mark1 mark2)
645  "Returns T if both marks point to different positions, Nil otherwise."
646  (not (and (eq (mark-line mark1) (mark-line mark2))
647            (= (mark-charpos mark1) (mark-charpos mark2)))))
648
649(defun line< (line1 line2)
650  "Returns T if Line1 comes before Line2, NIL otherwise."
651  (if (neq (line-%buffer line1) (line-%buffer line2))
652      (error "Lines in different buffers have no relation."))
653  (< (line-number line1) (line-number line2)))
654
655(defun line<= (line1 line2)
656  "Returns T if Line1 comes before or is the same as Line2, NIL otherwise."
657  (if (neq (line-%buffer line1) (line-%buffer line2))
658      (error "Lines in different buffers have no relation."))
659  (<= (line-number line1) (line-number line2)))
660
661(defun line>= (line1 line2)
662  "Returns T if Line1 comes after or is the same as Line2, NIL otherwise."
663  (if (neq (line-%buffer line1) (line-%buffer line2))
664      (error "Lines in different buffers have no relation."))
665  (>= (line-number line1) (line-number line2)))
666
667(defun line> (line1 line2)
668  "Returns T if Line1 comes after Line2, NIL otherwise."
669  (if (neq (line-%buffer line1) (line-%buffer line2))
670      (error "Lines in different buffers have no relation."))
671  (> (line-number line1) (line-number line2)))
672
673(defun lines-related (line1 line2)
674  "Returns T if an order relation exists between Line1 and Line2."
675  (eq (line-%buffer line1) (line-%buffer line2)))
676
677(defun first-line-p (mark)
678  "Returns T if the line pointed to by mark has no previous line,
679  Nil otherwise."
680  (null (line-previous (mark-line mark))))
681
682(defun last-line-p (mark)
683  "Returns T if the line pointed to by mark has no next line,
684  Nil otherwise."
685  (null (line-next (mark-line mark))))
Note: See TracBrowser for help on using the repository browser.