[climacs-cvs] CVS update: climacs/Persistent/README climacs/Persistent/persistent-buffer-test.lisp climacs/Persistent/persistent-buffer.lisp
Aleksandar Bakic
abakic at common-lisp.net
Sat Feb 5 21:00:08 UTC 2005
Update of /project/climacs/cvsroot/climacs/Persistent
In directory common-lisp.net:/tmp/cvs-serv1016/Persistent
Modified Files:
README persistent-buffer-test.lisp persistent-buffer.lisp
Log Message:
Introduced p-mark-mixin class to separate methods related to the
standard-buffer and its marks, from those related to the persistent
buffers and their marks.
Also added a few tests for (setf buffer-object).
Date: Sat Feb 5 21:59:52 2005
Author: abakic
Index: climacs/Persistent/README
diff -u climacs/Persistent/README:1.2 climacs/Persistent/README:1.3
--- climacs/Persistent/README:1.2 Fri Jan 28 19:47:34 2005
+++ climacs/Persistent/README Sat Feb 5 21:59:51 2005
@@ -8,21 +8,6 @@
all other places marked with "PB" comments, substitute "standard" for
"persistent" in order to use the corresponding mark classes.
-Also, end-of-line method in buffer.lisp has to be fixed and look like:
-
-(defmethod end-of-line ((mark mark-mixin))
- (let* ((offset (offset mark))
- (buffer (buffer mark))
- (size (size buffer)))
- (loop until (or (= offset size)
- (eql (buffer-object buffer offset) #\Newline))
- do (incf offset))
- (setf (offset mark) offset)))
-
-(It is currently "broken" for performance reasons.) Until then,
-(o)binseq-end-of-line, (o)binseq-next-line and (o)binseq-kill-line
-tests will fail (20 of them).
-
NOTE: There is a dependency of Persistent/persistent-buffer.lisp on
Flexichain/utilities.lisp (the weak pointer handling).
Index: climacs/Persistent/persistent-buffer-test.lisp
diff -u climacs/Persistent/persistent-buffer-test.lisp:1.4 climacs/Persistent/persistent-buffer-test.lisp:1.5
--- climacs/Persistent/persistent-buffer-test.lisp:1.4 Sat Feb 5 14:49:23 2005
+++ climacs/Persistent/persistent-buffer-test.lisp Sat Feb 5 21:59:51 2005
@@ -473,6 +473,29 @@
(= (climacs-buffer::condition-offset c) 8)))
t)
+(deftest binseq-buffer-setf-buffer-object.test-1
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 "climacs")
+ (setf (buffer-object buffer 0) #\C)
+ (buffer-sequence buffer 0 (size buffer)))
+ "Climacs")
+
+(deftest binseq-buffer-setf-buffer-object.test-2
+ (handler-case
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (setf (buffer-object buffer 0) #\a))
+ (climacs-buffer::no-such-offset (c)
+ (= (climacs-buffer::condition-offset c) 0)))
+ t)
+
+(deftest binseq-buffer-setf-buffer-object.test-3
+ (handler-case
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (setf (buffer-object buffer -1) #\a))
+ (climacs-buffer::no-such-offset (c)
+ (= (climacs-buffer::condition-offset c) -1)))
+ t)
+
(deftest binseq-buffer-mark<.test-1
(handler-case
(let ((buffer (make-instance 'binseq-buffer))
@@ -1216,6 +1239,29 @@
(setf (offset m) 8)))
(climacs-buffer::no-such-offset (c)
(= (climacs-buffer::condition-offset c) 8)))
+ t)
+
+(deftest obinseq-buffer-setf-buffer-object.test-1
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 "climacs")
+ (setf (buffer-object buffer 0) #\C)
+ (buffer-sequence buffer 0 (size buffer)))
+ "Climacs")
+
+(deftest obinseq-buffer-setf-buffer-object.test-2
+ (handler-case
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (setf (buffer-object buffer 0) #\a))
+ (climacs-buffer::no-such-offset (c)
+ (= (climacs-buffer::condition-offset c) 0)))
+ t)
+
+(deftest obinseq-buffer-setf-buffer-object.test-3
+ (handler-case
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (setf (buffer-object buffer -1) #\a))
+ (climacs-buffer::no-such-offset (c)
+ (= (climacs-buffer::condition-offset c) -1)))
t)
(deftest obinseq-buffer-mark<.test-1
Index: climacs/Persistent/persistent-buffer.lisp
diff -u climacs/Persistent/persistent-buffer.lisp:1.3 climacs/Persistent/persistent-buffer.lisp:1.4
--- climacs/Persistent/persistent-buffer.lisp:1.3 Fri Jan 28 19:47:36 2005
+++ climacs/Persistent/persistent-buffer.lisp Sat Feb 5 21:59:51 2005
@@ -87,11 +87,31 @@
uses an optimized binary sequence (only non-nil atoms are allowed as
elements) for the CONTENTS."))
-(defclass persistent-left-sticky-mark (left-sticky-mark mark-mixin) ()
+(defclass p-mark-mixin ()
+ ((buffer :initarg :buffer :reader buffer)
+ (cursor :reader cursor))
+ (:documentation "A mixin class used in the initialization of a mark
+that is used in a PERSISTENT-BUFFER."))
+
+(defmethod backward-object ((mark p-mark-mixin) &optional (count 1))
+ (decf (offset mark) count))
+
+(defmethod forward-object ((mark p-mark-mixin) &optional (count 1))
+ (incf (offset mark) count))
+
+(defmethod offset ((mark p-mark-mixin))
+ (cursor-pos (cursor mark)))
+
+(defmethod (setf offset) (new-offset (mark p-mark-mixin))
+ (assert (<= 0 new-offset (size (buffer mark))) ()
+ (make-condition 'no-such-offset :offset new-offset))
+ (setf (cursor-pos (cursor mark)) new-offset))
+
+(defclass persistent-left-sticky-mark (left-sticky-mark p-mark-mixin) ()
(:documentation "A LEFT-STICKY-MARK subclass suitable for use in a
PERSISTENT-BUFFER."))
-(defclass persistent-right-sticky-mark (right-sticky-mark mark-mixin) ()
+(defclass persistent-right-sticky-mark (right-sticky-mark p-mark-mixin) ()
(:documentation "A RIGHT-STICKY-MARK subclass suitable for use in a
PERSISTENT-BUFFER."))
@@ -145,16 +165,105 @@
(loop for offset from 0 below (size buffer)
count (eql (buffer-object buffer offset) #\Newline)))
+(defmethod mark< ((mark1 p-mark-mixin) (mark2 p-mark-mixin))
+ (assert (eq (buffer mark1) (buffer mark2)))
+ (< (offset mark1) (offset mark2)))
+
+(defmethod mark< ((mark1 p-mark-mixin) (mark2 integer))
+ (< (offset mark1) mark2))
+
+(defmethod mark< ((mark1 integer) (mark2 p-mark-mixin))
+ (< mark1 (offset mark2)))
+
+(defmethod mark<= ((mark1 p-mark-mixin) (mark2 p-mark-mixin))
+ (assert (eq (buffer mark1) (buffer mark2)))
+ (<= (offset mark1) (offset mark2)))
+
+(defmethod mark<= ((mark1 p-mark-mixin) (mark2 integer))
+ (<= (offset mark1) mark2))
+
+(defmethod mark<= ((mark1 integer) (mark2 p-mark-mixin))
+ (<= mark1 (offset mark2)))
+
+(defmethod mark= ((mark1 p-mark-mixin) (mark2 p-mark-mixin))
+ (assert (eq (buffer mark1) (buffer mark2)))
+ (= (offset mark1) (offset mark2)))
+
+(defmethod mark= ((mark1 p-mark-mixin) (mark2 integer))
+ (= (offset mark1) mark2))
+
+(defmethod mark= ((mark1 integer) (mark2 p-mark-mixin))
+ (= mark1 (offset mark2)))
+
+(defmethod mark> ((mark1 p-mark-mixin) (mark2 p-mark-mixin))
+ (assert (eq (buffer mark1) (buffer mark2)))
+ (> (offset mark1) (offset mark2)))
+
+(defmethod mark> ((mark1 p-mark-mixin) (mark2 integer))
+ (> (offset mark1) mark2))
+
+(defmethod mark> ((mark1 integer) (mark2 p-mark-mixin))
+ (> mark1 (offset mark2)))
+
+(defmethod mark>= ((mark1 p-mark-mixin) (mark2 p-mark-mixin))
+ (assert (eq (buffer mark1) (buffer mark2)))
+ (>= (offset mark1) (offset mark2)))
+
+(defmethod mark>= ((mark1 p-mark-mixin) (mark2 integer))
+ (>= (offset mark1) mark2))
+
+(defmethod mark>= ((mark1 integer) (mark2 p-mark-mixin))
+ (>= mark1 (offset mark2)))
+
+(defmethod beginning-of-buffer ((mark p-mark-mixin))
+ (setf (offset mark) 0))
+
+(defmethod end-of-buffer ((mark p-mark-mixin))
+ (setf (offset mark) (size (buffer mark))))
+
+(defmethod beginning-of-buffer-p ((mark p-mark-mixin))
+ (zerop (offset mark)))
+
+(defmethod end-of-buffer-p ((mark p-mark-mixin))
+ (= (offset mark) (size (buffer mark))))
+
+(defmethod beginning-of-line-p ((mark p-mark-mixin))
+ (or (beginning-of-buffer-p mark)
+ (eql (object-before mark) #\Newline)))
+
+(defmethod end-of-line-p ((mark p-mark-mixin))
+ (or (end-of-buffer-p mark)
+ (eql (object-after mark) #\Newline)))
+
+(defmethod beginning-of-line ((mark p-mark-mixin))
+ (loop until (beginning-of-line-p mark)
+ do (decf (offset mark))))
+
+(defmethod end-of-line ((mark p-mark-mixin))
+ (let* ((offset (offset mark))
+ (buffer (buffer mark))
+ (size (size buffer)))
+ (loop until (or (= offset size)
+ (eql (buffer-object buffer offset) #\Newline))
+ do (incf offset))
+ (setf (offset mark) offset)))
+
(defmethod buffer-line-number ((buffer persistent-buffer) (offset integer))
(loop for i from 0 below offset
count (eql (buffer-object buffer i) #\Newline)))
+(defmethod line-number ((mark p-mark-mixin))
+ (buffer-line-number (buffer mark) (offset mark)))
+
(defmethod buffer-column-number ((buffer persistent-buffer) (offset integer))
(loop for i downfrom offset
while (> i 0)
until (eql (buffer-object buffer (1- i)) #\Newline)
count t))
+(defmethod column-number ((mark p-mark-mixin))
+ (buffer-column-number (buffer mark) (offset mark)))
+
;;; the old value of the CONTENTS slot is dropped upon modification
;;; it can be saved for UNDO purposes in a history tree, by an UNDOABLE-BUFFER
@@ -170,6 +279,9 @@
(setf (slot-value buffer 'contents)
(obinseq-insert (slot-value buffer 'contents) offset object)))
+(defmethod insert-object ((mark p-mark-mixin) object)
+ (insert-buffer-object (buffer mark) (offset mark) object))
+
(defmethod insert-buffer-sequence ((buffer binseq-buffer) offset sequence)
(let ((binseq (list-binseq (loop for e across sequence collect e))))
(setf (slot-value buffer 'contents)
@@ -180,6 +292,9 @@
(setf (slot-value buffer 'contents)
(obinseq-insert* (slot-value buffer 'contents) offset obinseq))))
+(defmethod insert-sequence ((mark p-mark-mixin) sequence)
+ (insert-buffer-sequence (buffer mark) (offset mark) sequence))
+
(defmethod delete-buffer-range ((buffer binseq-buffer) offset n)
(assert (<= 0 offset (size buffer)) ()
(make-condition 'no-such-offset :offset offset))
@@ -192,6 +307,32 @@
(setf (slot-value buffer 'contents)
(obinseq-remove* (slot-value buffer 'contents) offset n)))
+(defmethod delete-range ((mark p-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)))
+ (t nil)))
+
+(defmethod delete-region ((mark1 p-mark-mixin) (mark2 p-mark-mixin))
+ (assert (eq (buffer mark1) (buffer mark2)))
+ (let ((offset1 (offset mark1))
+ (offset2 (offset mark2)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (delete-buffer-range (buffer mark1) offset1 (- offset2 offset1))))
+
+(defmethod delete-region ((mark1 p-mark-mixin) offset2)
+ (let ((offset1 (offset mark1)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (delete-buffer-range (buffer mark1) offset1 (- offset2 offset1))))
+
+(defmethod delete-region (offset1 (mark2 p-mark-mixin))
+ (let ((offset2 (offset mark2)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (delete-buffer-range (buffer mark2) offset1 (- offset2 offset1))))
+
(defmethod buffer-object ((buffer binseq-buffer) offset)
(assert (<= 0 offset (1- (size buffer))) ()
(make-condition 'no-such-offset :offset offset))
@@ -240,6 +381,43 @@
nil))
'vector))
+(defmethod object-before ((mark p-mark-mixin))
+ (buffer-object (buffer mark) (1- (offset mark))))
+
+(defmethod object-after ((mark p-mark-mixin))
+ (buffer-object (buffer mark) (offset mark)))
+
+(defmethod region-to-sequence ((mark1 p-mark-mixin) (mark2 p-mark-mixin))
+ (assert (eq (buffer mark1) (buffer mark2)))
+ (let ((offset1 (offset mark1))
+ (offset2 (offset mark2)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (buffer-sequence (buffer mark1) offset1 offset2)))
+
+(defmethod region-to-sequence ((offset1 integer) (mark2 p-mark-mixin))
+ (let ((offset2 (offset mark2)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (buffer-sequence (buffer mark2) offset1 offset2)))
+
+(defmethod region-to-sequence ((mark1 p-mark-mixin) (offset2 integer))
+ (let ((offset1 (offset mark1)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (buffer-sequence (buffer mark1) offset1 offset2)))
+
+;;; Buffer modification protocol
+
+(defmethod (setf buffer-object)
+ :before (object (buffer persistent-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))
+
(defmethod insert-buffer-object
:before ((buffer persistent-buffer) offset object)
(declare (ignore object))
@@ -309,4 +487,4 @@
(defmethod delete-buffer-range
:after ((buffer persistent-buffer) offset n)
(with-slots (cursors) buffer
- (setf cursors (adjust-cursors-on-delete buffer offset n))))
\ No newline at end of file
+ (setf cursors (adjust-cursors-on-delete buffer offset n))))
More information about the Climacs-cvs
mailing list