[climacs-cvs] CVS update: climacs/Persistent/persistent-buffer.lisp

[Aleksandar Bakic]

Update of /project/climacs/cvsroot/climacs/Persistent
In directory common-lisp.net:/tmp/cvs-serv20153/Persistent

Modified Files:
	persistent-buffer.lisp 
Log Message:
Updated persistent buffers and tests to catch up with recent changes.

Date: Fri Feb 25 21:45:14 2005
Author: abakic

Index: climacs/Persistent/persistent-buffer.lisp
diff -u climacs/Persistent/persistent-buffer.lisp:1.6 climacs/Persistent/persistent-buffer.lisp:1.7
--- climacs/Persistent/persistent-buffer.lisp:1.6	Sun Feb  6 17:33:52 2005
+++ climacs/Persistent/persistent-buffer.lisp	Fri Feb 25 21:45:11 2005
@@ -103,8 +103,10 @@
   (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))
+  (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))
   (setf (cursor-pos (cursor mark)) new-offset))
 
 (defclass persistent-left-sticky-mark (left-sticky-mark p-mark-mixin) ()
@@ -119,8 +121,10 @@
 				       &rest args &key (offset 0))
   "Associates a created mark with the buffer for which it was created."
   (declare (ignorable args))
-  (assert (<= 0 offset (size (buffer mark))) ()
-	  (make-condition 'no-such-offset :offset offset))
+  (assert (<= 0 offset) ()
+	  (make-condition 'motion-before-beginning :offset offset))
+  (assert (<= offset (size (buffer mark))) ()
+	  (make-condition 'motion-after-end :offset offset))
   (setf (slot-value mark 'cursor)
 	(make-instance 'left-sticky-persistent-cursor
 		       :buffer (buffer mark)
@@ -130,8 +134,10 @@
 				       &rest args &key (offset 0))
   "Associates a created mark with the buffer for which it was created."
   (declare (ignorable args))
-  (assert (<= 0 offset (size (buffer mark))) ()
-	  (make-condition 'no-such-offset :offset offset))
+  (assert (<= 0 offset) ()
+	  (make-condition 'motion-before-beginning :offset offset))
+  (assert (<= offset (size (buffer mark))) ()
+	  (make-condition 'motion-after-end :offset offset))
   (setf (slot-value mark 'cursor)
 	(make-instance 'right-sticky-persistent-cursor
 		       :buffer (buffer mark)
@@ -145,6 +151,26 @@
     (setf high-mark (make-instance 'persistent-right-sticky-mark
 				   :buffer buffer))))
 
+(defmethod clone-mark ((mark persistent-left-sticky-mark) &optional stick-to)
+  (cond
+    ((or (null stick-to) (eq stick-to :left))
+     (make-instance 'persistent-left-sticky-mark
+		    :buffer (buffer mark) :offset (offset mark)))
+    ((eq stick-to :right)
+     (make-instance 'persistent-right-sticky-mark
+		    :buffer (buffer mark) :offset (offset mark)))
+    (t (error "invalid value for stick-to"))))
+
+(defmethod clone-mark ((mark persistent-right-sticky-mark) &optional stick-to)
+  (cond
+    ((or (null stick-to) (eq stick-to :right))
+     (make-instance 'persistent-right-sticky-mark
+		    :buffer (buffer mark) :offset (offset mark)))
+    ((eq stick-to :left)
+     (make-instance 'persistent-left-sticky-mark
+		    :buffer (buffer mark) :offset (offset mark)))
+    (t (error "invalid value for stick-to"))))
+
 (defmethod size ((buffer binseq-buffer))
   (binseq-length (slot-value buffer 'contents)))
 
@@ -258,8 +284,10 @@
 ;;; it can be saved for UNDO purposes in a history tree, by an UNDOABLE-BUFFER
 
 (defmethod insert-buffer-object ((buffer binseq-buffer) offset object)
-  (assert (<= 0 offset (size buffer)) ()
-	  (make-condition 'no-such-offset :offset offset))
+  (assert (<= 0 offset) ()
+	  (make-condition 'offset-before-beginning :offset offset))
+  (assert (<= offset (size buffer)) ()
+	  (make-condition 'offset-after-end :offset offset))
   (setf (slot-value buffer 'contents)
 	(binseq-insert (slot-value buffer 'contents) offset object)))
 
@@ -286,8 +314,10 @@
   (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))
+  (assert (<= 0 offset) ()
+	  (make-condition 'offset-before-beginning :offset offset))
+  (assert (<= offset (size buffer)) ()
+	  (make-condition 'offset-after-end :offset offset))
   (setf (slot-value buffer 'contents)
 	(binseq-remove* (slot-value buffer 'contents) offset n)))
 
@@ -324,32 +354,44 @@
     (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))
+  (assert (<= 0 offset) ()
+	  (make-condition 'offset-before-beginning :offset offset))
+  (assert (<= offset (1- (size buffer))) ()
+	  (make-condition 'offset-after-end :offset offset))
   (binseq-get (slot-value buffer 'contents) offset))
 
 (defmethod (setf buffer-object) (object (buffer binseq-buffer) offset)
-  (assert (<= 0 offset (1- (size buffer))) ()
-	  (make-condition 'no-such-offset :offset offset))
+  (assert (<= 0 offset) ()
+	  (make-condition 'offset-before-beginning :offset offset))
+  (assert (<= offset (1- (size buffer))) ()
+	  (make-condition 'offset-after-end :offset offset))
   (setf (slot-value buffer 'contents)
 	(binseq-set (slot-value buffer 'contents) offset object)))
 
 (defmethod buffer-object ((buffer obinseq-buffer) offset)
-  (assert (<= 0 offset (1- (size buffer))) ()
-	  (make-condition 'no-such-offset :offset offset))
+  (assert (<= 0 offset) ()
+	  (make-condition 'offset-before-beginning :offset offset))
+  (assert (<= offset (1- (size buffer))) ()
+	  (make-condition 'offset-after-end :offset offset))
   (obinseq-get (slot-value buffer 'contents) offset))
 
 (defmethod (setf buffer-object) (object (buffer obinseq-buffer) offset)
-  (assert (<= 0 offset (1- (size buffer))) ()
-	  (make-condition 'no-such-offset :offset offset))
+  (assert (<= 0 offset) ()
+	  (make-condition 'offset-before-beginning :offset offset))
+  (assert (<= offset (1- (size buffer))) ()
+	  (make-condition 'offset-after-end :offset offset))
   (setf (slot-value buffer 'contents)
 	(obinseq-set (slot-value buffer 'contents) offset object)))
 
 (defmethod buffer-sequence ((buffer binseq-buffer) offset1 offset2)
-  (assert (<= 0 offset1 (size buffer)) ()
-	  (make-condition 'no-such-offset :offset offset1))
-  (assert (<= 0 offset2 (size buffer)) ()
-	  (make-condition 'no-such-offset :offset offset2))
+  (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))
   (coerce
    (let ((len (- offset2 offset1)))
      (if (> len 0)