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

[Aleksandar Bakic]

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

Modified Files:
	binseq.lisp obinseq.lisp persistent-buffer.lisp 
Log Message:
Cleanup and performance improvements.

Date: Sun Mar  6 00:23:54 2005
Author: abakic

Index: climacs/Persistent/binseq.lisp
diff -u climacs/Persistent/binseq.lisp:1.1 climacs/Persistent/binseq.lisp:1.2
--- climacs/Persistent/binseq.lisp:1.1	Wed Jan 26 17:10:45 2005
+++ climacs/Persistent/binseq.lisp	Sun Mar  6 00:23:53 2005
@@ -55,6 +55,28 @@
 	       (t (%to-list (caddr s) (%to-list (cdddr s) l))))))
     (%to-list s nil)))
 
+(defun vector-binseq (v &optional (start 0) (end (length v)))
+  (cond
+    ((= start end) 'empty)
+    ((= (- end start) 1) `(leaf . ,(aref v start)))
+    (t (let* ((len (- end start))
+	      (mid (+ start (floor len 2))))
+	 `(node . (,len . (,(vector-binseq v start mid) .
+			    ,(vector-binseq v mid end))))))))
+
+(defun binseq-vector (s)
+  (let ((v (make-array (binseq-length s))))
+    (labels ((%set-v (s o)
+	       (cond
+		 ((eq s 'empty))
+		 ((eq (car s) 'leaf) (setf (aref v o) (cdr s)))
+		 (t (let ((a (caddr s))
+			  (b (cdddr s)))
+		      (%set-v a o)
+		      (%set-v b (+ o (binseq-length a))))))))
+      (%set-v s 0)
+      v)))
+
 (defun binseq-empty (s)
   (eq s 'empty))
 


Index: climacs/Persistent/obinseq.lisp
diff -u climacs/Persistent/obinseq.lisp:1.1 climacs/Persistent/obinseq.lisp:1.2
--- climacs/Persistent/obinseq.lisp:1.1	Wed Jan 26 17:10:45 2005
+++ climacs/Persistent/obinseq.lisp	Sun Mar  6 00:23:54 2005
@@ -60,6 +60,32 @@
 	       (t (%to-list (cadr s) (%to-list (cddr s) l))))))
     (%to-list s nil)))
 
+(defun vector-obinseq (v &optional (start 0) (end (length v)))
+  (cond
+    ((= start end) nil)
+    ((= (- end start) 1)
+     (let ((e (aref v start)))
+       (assert (and e (atom e)) nil
+	       "Sequence element must be a non-nil atom: ~S" e)
+       e))
+    (t (let* ((len (- end start))
+	      (mid (+ start (floor len 2))))
+	 `(,len . (,(vector-obinseq v start mid) .
+		    ,(vector-obinseq v mid end)))))))
+
+(defun obinseq-vector (s)
+  (let ((v (make-array (obinseq-length s))))
+    (labels ((%set-v (s o)
+	       (cond
+		 ((null s))
+		 ((atom s) (setf (aref v o) s))
+		 (t (let ((a (cadr s))
+			  (b (cddr s)))
+		      (%set-v a o)
+		      (%set-v b (+ o (obinseq-length a))))))))
+      (%set-v s 0)
+      v)))
+
 (defun obinseq-empty (s)
   (null s))
 


Index: climacs/Persistent/persistent-buffer.lisp
diff -u climacs/Persistent/persistent-buffer.lisp:1.8 climacs/Persistent/persistent-buffer.lisp:1.9
--- climacs/Persistent/persistent-buffer.lisp:1.8	Sat Mar  5 12:56:15 2005
+++ climacs/Persistent/persistent-buffer.lisp	Sun Mar  6 00:23:54 2005
@@ -301,12 +301,12 @@
   (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))))
+  (let ((binseq (vector-binseq sequence)))
     (setf (slot-value buffer 'contents)
 	  (binseq-insert* (slot-value buffer 'contents) offset binseq))))
 
 (defmethod insert-buffer-sequence ((buffer obinseq-buffer) offset sequence)
-  (let ((obinseq (list-obinseq (loop for e across sequence collect e))))
+  (let ((obinseq (vector-obinseq sequence)))
     (setf (slot-value buffer 'contents)
 	  (obinseq-insert* (slot-value buffer 'contents) offset obinseq))))
 
@@ -392,26 +392,26 @@
 	  (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)
-	 (binseq-list
-	  (binseq-sub (slot-value buffer 'contents) offset1 len))
-	 nil))
-   'vector))
+  (let ((len (- offset2 offset1)))
+    (if (> len 0)
+	(binseq-vector
+	 (binseq-sub (slot-value buffer 'contents) offset1 len))
+	(make-array 0))))
 
 (defmethod buffer-sequence ((buffer obinseq-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))
-  (coerce
-   (let ((len (- offset2 offset1)))
-     (if (> len 0)
-	 (obinseq-list
-	  (obinseq-sub (slot-value buffer 'contents) offset1 len))
-	 nil))
-   'vector))
+  (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))
+  (let ((len (- offset2 offset1)))
+    (if (> len 0)
+	(obinseq-vector
+	 (obinseq-sub (slot-value buffer 'contents) offset1 len))
+	(make-array 0))))
 
 (defmethod object-before ((mark p-mark-mixin))
   (buffer-object (buffer mark) (1- (offset mark))))