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

Modified Files: TODO base-test.lisp base.lisp buffer-test.lisp cl-syntax.lisp climacs.asd html-syntax.lisp packages.lisp pane.lisp text-syntax.lisp Log Message: Line-oriented persistent buffer (binseq2). Warning: Need to fix minor bugs (related to number-of-lines-in-region, I believe).

base.lisp: Added faster methods on previous-line, next-line, buffer-number-of-lines-in-region.

pane.lisp, cl-syntax.lisp, html-syntax.lisp, text-syntax.lisp: Replaced some calls to make-instance to calls to clone-mark and (setf offset), in order to avoid passing climacs-buffer to marks. This also made possible to get rid of delegating methods on syntax.

climacs.asd: Added Persistent/binseq2.

packages.lisp: Added binseq2-related symbols.

Persistent/binseq.lisp, Persistent/obinseq.lisp: Cleanup.

Persistent/persistent-buffer.lisp: Added code for binseq2-buffer and related marks. Also some minor fixes.

Date: Sun Mar 13 21:51:48 2005 Author: abakic

Index: climacs/TODO diff -u climacs/TODO:1.5 climacs/TODO:1.6 --- climacs/TODO:1.5 Sun Feb 20 06:39:15 2005 +++ climacs/TODO Sun Mar 13 21:51:48 2005 @@ -1,8 +1,6 @@ - modify standard-buffer to use obinseq with leafs containing flexichain-based lines

-- implement a persistent buffer as a binseq of obinseqs (or similar, - one sequence type for lines, the other for line contents), then - upgrade it to an undoable buffer +- upgrade persistent buffer based on binseq2 to an undoable buffer

- replace the use of the scroller pane by custom pane

Index: climacs/base-test.lisp diff -u climacs/base-test.lisp:1.12 climacs/base-test.lisp:1.13 --- climacs/base-test.lisp:1.12 Sun Feb 27 19:52:00 2005 +++ climacs/base-test.lisp Sun Mar 13 21:51:48 2005 @@ -350,16 +350,18 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") + (print (climacs-buffer::buffer-line-number buffer 15)) (values (climacs-base::buffer-number-of-lines-in-region buffer 0 6) (climacs-base::buffer-number-of-lines-in-region buffer 0 7) + (climacs-base::buffer-number-of-lines-in-region buffer 0 8) (climacs-base::buffer-number-of-lines-in-region buffer 0 10) (climacs-base::buffer-number-of-lines-in-region buffer 0 13) (climacs-base::buffer-number-of-lines-in-region buffer 0 14) (climacs-base::buffer-number-of-lines-in-region buffer 7 10) (climacs-base::buffer-number-of-lines-in-region buffer 8 13) (climacs-base::buffer-number-of-lines-in-region buffer 8 14))) - 0 0 1 1 1 1 0 0) + 0 0 1 1 1 1 1 0 0)

(defmultitest buffer-display-column.test-1 (let ((buffer (make-instance %%buffer)))

Index: climacs/base.lisp diff -u climacs/base.lisp:1.37 climacs/base.lisp:1.38 --- climacs/base.lisp:1.37 Sat Feb 19 07:19:06 2005 +++ climacs/base.lisp Sun Mar 13 21:51:48 2005 @@ -36,13 +36,13 @@ &body body) "Iterate over the elements of the region delimited by offset1 and offset2. The body is executed for each element, with object being the current object -(setf-able), and offset being its offset." +(setf-able), and offset being its offset." `(symbol-macrolet ((,object (buffer-object ,buffer ,offset))) (loop for ,offset from ,offset1 below ,offset2 do ,@body)))

-(defun previous-line (mark &optional column (count 1)) - "Move a mark up one line conserving horizontal position." +(defmethod previous-line (mark &optional column (count 1)) + "Move a mark up COUNT lines conserving horizontal position." (unless column (setf column (column-number mark))) (loop repeat count @@ -54,8 +54,17 @@ (beginning-of-line mark) (incf (offset mark) column)))

-(defun next-line (mark &optional column (count 1)) - "Move a mark down one line conserving horizontal position." +(defmethod previous-line ((mark p-line-mark-mixin) &optional column (count 1)) + "Move a mark up COUNT lines conserving horizontal position." + (unless column + (setf column (column-number mark))) + (let* ((line (line-number mark)) + (goto-line (max 0 (- line count)))) + (setf (offset mark) + (+ column (buffer-line-offset (buffer mark) goto-line))))) + +(defmethod next-line (mark &optional column (count 1)) + "Move a mark down COUNT lines conserving horizontal position." (unless column (setf column (column-number mark))) (loop repeat count @@ -67,16 +76,26 @@ (beginning-of-line mark) (incf (offset mark) column)))

+(defmethod next-line ((mark p-line-mark-mixin) &optional column (count 1)) + "Move a mark down COUNT lines conserving horizontal position." + (unless column + (setf column (column-number mark))) + (let* ((line (line-number mark)) + (goto-line (min (number-of-lines (buffer mark)) + (+ line count)))) + (setf (offset mark) + (+ column (buffer-line-offset (buffer mark) goto-line))))) + (defmethod open-line ((mark left-sticky-mark) &optional (count 1)) "Create a new line in a buffer after the mark." (loop repeat count - do (insert-object mark #\Newline))) + do (insert-object mark #\Newline)))

(defmethod open-line ((mark right-sticky-mark) &optional (count 1)) "Create a new line in a buffer after the mark." (loop repeat count - do (insert-object mark #\Newline) - (decf (offset mark)))) + do (insert-object mark #\Newline) + (decf (offset mark))))

(defun kill-line (mark) "Remove a line from a buffer." @@ -105,13 +124,19 @@ (incf (offset mark2)) finally (return indentation))))

-(defun buffer-number-of-lines-in-region (buffer offset1 offset2) - "Helper function for number-of-lines-in-region. Count newline -characters in the region between offset1 and offset2" +(defmethod buffer-number-of-lines-in-region (buffer offset1 offset2) + "Helper method for number-of-lines-in-region. Count newline +characters in the region between offset1 and offset2." (loop while (< offset1 offset2) count (eql (buffer-object buffer offset1) #\Newline) do (incf offset1)))

+(defmethod buffer-number-of-lines-in-region + ((buffer binseq2-buffer) offset1 offset2) + "Helper method for NUMBER-OF-LINES-IN-REGION." + (- (buffer-line-number buffer offset2) + (buffer-line-number buffer offset1))) + (defun buffer-display-column (buffer offset tab-width) (let ((line-start-offset (- offset (buffer-column-number buffer offset)))) (loop with column = 0 @@ -578,7 +603,7 @@ (loop for i downfrom (- offset (length vector)) to 0 when (buffer-looking-at buffer i vector :test test) return i - finally (return nil))) + finally (return nil)))

(defun search-forward (mark vector &key (test #'eql)) "move MARK forward after the first occurence of VECTOR after MARK"

Index: climacs/buffer-test.lisp diff -u climacs/buffer-test.lisp:1.18 climacs/buffer-test.lisp:1.19 --- climacs/buffer-test.lisp:1.18 Sun Feb 27 19:52:01 2005 +++ climacs/buffer-test.lisp Sun Mar 13 21:51:48 2005 @@ -48,6 +48,13 @@ ''persistent-right-sticky-mark (intern (concatenate 'string "OBINSEQ-BUFFER-" name-string)) form + results) + ,(%deftest-wrapper + ''binseq2-buffer + ''persistent-left-sticky-line-mark + ''persistent-right-sticky-line-mark + (intern (concatenate 'string "BINSEQ2-BUFFER-" name-string)) + form results)))))

(defmultitest buffer-make-instance.test-1 @@ -966,3 +973,76 @@ do (insert-buffer-sequence b (floor (size b) 2) "abcdefghij") finally (return (size b)))) 1000000) + +(defmultitest performance.test-4 + (time + (let ((b (make-instance %%buffer))) + (insert-buffer-sequence b 0 (make-array '(100000) :initial-element #\a)) + (let ((m (clone-mark (low-mark b)))) + (loop + for i from 0 below 1000 + for f = t then (not b) + do (if f + (end-of-line m) + (beginning-of-line m)))))) + nil) + +(defmultitest performance.test-4b + (time + (let ((b (make-instance %%buffer))) + (insert-buffer-object b 0 #\Newline) + (insert-buffer-sequence b 0 (make-array '(100000) :initial-element #\a)) + (insert-buffer-object b 0 #\Newline) + (let ((m (clone-mark (low-mark b)))) + (loop + for i from 0 below 1000 + for f = t then (not b) + do (if f + (end-of-line m) + (beginning-of-line m)))))) + nil) + +(defmultitest performance.test-4c + (time + (let ((b (make-instance %%buffer))) + (insert-buffer-object b 0 #\Newline) + (insert-buffer-sequence b 0 (make-array '(100000) :initial-element #\a)) + (insert-buffer-object b 0 #\Newline) + (let ((m (clone-mark (low-mark b)))) + (incf (offset m)) + (loop + for i from 0 below 1000 + for f = t then (not b) + do (if f + (end-of-line m) + (beginning-of-line m)))))) + nil) + +(defmultitest performance.test-4d + (time + (let ((b (make-instance %%buffer))) + (insert-buffer-object b 0 #\Newline) + (insert-buffer-sequence b 0 (make-array '(100000) :initial-element #\a)) + (insert-buffer-object b 0 #\Newline) + (let ((m (clone-mark (low-mark b)))) + (setf (offset m) (floor (size b) 2)) + (loop + for i from 0 below 10 + collect (list (line-number m) (column-number m)))))) + ((1 50000) (1 50000) (1 50000) (1 50000) (1 50000) (1 50000) + (1 50000) (1 50000) (1 50000) (1 50000))) + +(defmultitest performance.test-4e + (time + (let ((b (make-instance %%buffer))) + (insert-buffer-sequence + b 0 (make-array '(100000) :initial-element #\Newline)) + (let ((m (clone-mark (low-mark b)))) + (loop + for i from 0 below 1000 + for f = t then (not b) + do (if f + (next-line m 0 100000) + (previous-line m 0 100000)) + finally (return (number-of-lines b)))))) + 100000) \ No newline at end of file

Index: climacs/cl-syntax.lisp diff -u climacs/cl-syntax.lisp:1.5 climacs/cl-syntax.lisp:1.6 --- climacs/cl-syntax.lisp:1.5 Wed Mar 2 04:59:03 2005 +++ climacs/cl-syntax.lisp Sun Mar 13 21:51:48 2005 @@ -166,9 +166,8 @@ (defmethod initialize-instance :after ((syntax cl-syntax) &rest args) (declare (ignore args)) (with-slots (buffer elements) syntax - (let ((mark (make-instance 'standard-left-sticky-mark - :buffer buffer - :offset 0))) + (let ((mark (clone-mark (low-mark buffer) :left))) + (setf (offset mark) 0) (insert* elements 0 (make-instance 'start-entry :start-mark mark :size 0)))))

@@ -257,11 +256,12 @@ (loop until (or (= guess-pos (nb-elements elements)) (mark> (start-mark (element* elements guess-pos)) high-mark)) do (delete* elements guess-pos)) - (setf scan (make-instance 'standard-left-sticky-mark - :buffer buffer - :offset (if (zerop guess-pos) - 0 - (end-offset (element* elements (1- guess-pos)))))) + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) + (if (zerop guess-pos) + 0 + (end-offset (element* elements (1- guess-pos))))) + (setf scan m)) ;; scan (loop with start-mark = nil do (loop until (end-of-buffer-p scan)

Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.23 climacs/climacs.asd:1.24 --- climacs/climacs.asd:1.23 Fri Mar 11 11:23:33 2005 +++ climacs/climacs.asd Sun Mar 13 21:51:48 2005 @@ -46,6 +46,7 @@ "Persistent/binseq-package" "Persistent/binseq" "Persistent/obinseq" + "Persistent/binseq2" "translate" "packages" "buffer"

Index: climacs/html-syntax.lisp diff -u climacs/html-syntax.lisp:1.11 climacs/html-syntax.lisp:1.12 --- climacs/html-syntax.lisp:1.11 Sun Mar 13 07:55:27 2005 +++ climacs/html-syntax.lisp Sun Mar 13 21:51:48 2005 @@ -276,12 +276,12 @@ (setf parser (make-instance 'parser :grammar *html-grammar* :target 'html)) - (insert* lexemes 0 (make-instance 'start-element - :start-mark (make-instance 'standard-left-sticky-mark - :buffer buffer - :offset 0) - :size 0 - :state (initial-state parser))))) + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) 0) + (insert* lexemes 0 (make-instance 'start-element + :start-mark m + :size 0 + :state (initial-state parser))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -325,9 +325,10 @@ do (forward-object scan)))

(defun update-lex (lexemes start-pos end) - (let ((scan (make-instance 'standard-left-sticky-mark - :buffer (buffer end) ; FIXME, eventually use the buffer of the lexer - :offset (end-offset (element* lexemes (1- start-pos)))))) + (let ((scan (clone-mark (low-mark (buffer end)) :left))) + ;; FIXME, eventually use the buffer of the lexer + (setf (offset scan) + (end-offset (element* lexemes (1- start-pos)))) (loop do (skip-inter-lexeme-objects lexemes scan) until (if (end-of-buffer-p end) (end-of-buffer-p scan)

Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.55 climacs/packages.lisp:1.56 --- climacs/packages.lisp:1.55 Thu Mar 10 07:37:40 2005 +++ climacs/packages.lisp Sun Mar 13 21:51:48 2005 @@ -47,8 +47,10 @@ #:object-before #:object-after #:region-to-sequence #:low-mark #:high-mark #:modified-p #:clear-modify

- #:binseq-buffer #:obinseq-buffer + #:binseq-buffer #:obinseq-buffer #:binseq2-buffer #:persistent-left-sticky-mark #:persistent-right-sticky-mark + #:persistent-left-sticky-line-mark #:persistent-right-sticky-line-mark + #:p-line-mark-mixin #:buffer-line-offset

#:delegating-buffer #:implementation))

Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.20 climacs/pane.lisp:1.21 --- climacs/pane.lisp:1.20 Sat Mar 5 08:03:53 2005 +++ climacs/pane.lisp Sun Mar 13 21:51:48 2005 @@ -182,20 +182,10 @@

;(defgeneric indent-tabs-mode (climacs-buffer))

-;;; syntax delegation - -(defmethod update-syntax ((buffer delegating-buffer) syntax) - (update-syntax (implementation buffer) syntax)) - -(defmethod update-syntax-for-redisplay ((buffer delegating-buffer) syntax from to) - (update-syntax-for-redisplay (implementation buffer) syntax from to)) - -;;; buffers - (defclass extended-standard-buffer (standard-buffer undo-mixin abbrev-mixin) () (:documentation "Extensions accessible via marks."))

-(defclass extended-obinseq-buffer (obinseq-buffer undo-mixin abbrev-mixin) () +(defclass extended-binseq2-buffer (binseq2-buffer undo-mixin abbrev-mixin) () (:documentation "Extensions accessible via marks."))

(defclass climacs-buffer (delegating-buffer filename-mixin name-mixin)

Index: climacs/text-syntax.lisp diff -u climacs/text-syntax.lisp:1.5 climacs/text-syntax.lisp:1.6 --- climacs/text-syntax.lisp:1.5 Tue Jan 18 00:10:24 2005 +++ climacs/text-syntax.lisp Sun Mar 13 21:51:48 2005 @@ -80,9 +80,9 @@ (and (eql (buffer-object buffer (1- offset)) #\Newline) (or (= offset 1) (eql (buffer-object buffer (- offset 2)) #\Newline))))) - (insert* paragraphs pos1 - (make-instance 'standard-left-sticky-mark - :buffer buffer :offset offset)) + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) offset) + (insert* paragraphs pos1 m)) (incf pos1)) ((and (plusp offset) (not (eql (buffer-object buffer (1- offset)) #\Newline)) @@ -90,9 +90,9 @@ (and (eql (buffer-object buffer offset) #\Newline) (or (= offset (1- buffer-size)) (eql (buffer-object buffer (1+ offset)) #\Newline))))) - (insert* paragraphs pos1 - (make-instance 'standard-right-sticky-mark - :buffer buffer :offset offset)) + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) offset) + (insert* paragraphs pos1 m)) (incf pos1)) (t nil)))))))