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))))