Commit fc4dbace authored by Aleksandar Bakic's avatar Aleksandar Bakic

Cleanup and performance improvements.

parent 30587f9d
......@@ -24,6 +24,8 @@
#:binseq-p
#:list-binseq
#:binseq-list
#:vector-binseq
#:binseq-vector
#:binseq-empty
#:binseq-length
#:binseq-front
......@@ -42,6 +44,8 @@
#:obinseq-p
#:list-obinseq
#:obinseq-list
#:vector-obinseq
#:obinseq-vector
#:obinseq-empty
#:obinseq-length
#:obinseq-front
......
......@@ -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))
......
......@@ -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))
......
......@@ -301,12 +301,12 @@ PERSISTENT-BUFFER."))
(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 @@ PERSISTENT-BUFFER."))
(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))))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment