March 2005 - climacs-cvs@common-lisp.net - mailman3.common-lisp.net

[climacs-cvs] CVS update: climacs/Persistent/binseq2.lisp climacs/Persistent/binseq-package.lisp climacs/Persistent/binseq.lisp climacs/Persistent/obinseq.lisp climacs/Persistent/persistent-buffer.lisp
by abakic＠common-lisp.net 13 Mar '05

13 Mar '05

Update of /project/climacs/cvsroot/climacs/Persistent In directory common-lisp.net:/tmp/cvs-serv22428/Persistent Modified Files: binseq-package.lisp binseq.lisp obinseq.lisp persistent-buffer.lisp Added Files: binseq2.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:54 2005 Author: abakic Index: climacs/Persistent/binseq-package.lisp diff -u climacs/Persistent/binseq-package.lisp:1.2 climacs/Persistent/binseq-package.lisp:1.3 --- climacs/Persistent/binseq-package.lisp:1.2 Sun Mar 6 00:24:41 2005 +++ climacs/Persistent/binseq-package.lisp Sun Mar 13 21:51:52 2005 @@ -59,4 +59,36 @@ #:obinseq-insert #:obinseq-insert* #:obinseq-remove - #:obinseq-remove*)) \ No newline at end of file + #:obinseq-remove* + + #:binseq2-p + #:list-binseq2 + #:binseq2-list + #:vector-binseq2 + #:binseq2-vector + #:binseq2-empty + #:binseq2-length + #:binseq2-size + #:binseq2-front + #:binseq2-offset + #:binseq2-back + #:binseq2-front2 + #:binseq2-line2 + #:binseq2-back2 + #:binseq2-get + #:binseq2-set + #:binseq2-get2 + #:binseq2-set2 + #:binseq2-sub + #:binseq2-sub2 + #:binseq2-cons + #:binseq2-snoc + #:binseq2-append + #:binseq2-insert + #:binseq2-insert2 + #:binseq2-insert* + #:binseq2-insert*2 + #:binseq2-remove + #:binseq2-remove2 + #:binseq2-remove* + #:binseq2-remove*2)) \ No newline at end of file Index: climacs/Persistent/binseq.lisp diff -u climacs/Persistent/binseq.lisp:1.2 climacs/Persistent/binseq.lisp:1.3 --- climacs/Persistent/binseq.lisp:1.2 Sun Mar 6 00:23:53 2005 +++ climacs/Persistent/binseq.lisp Sun Mar 13 21:51:53 2005 @@ -22,7 +22,7 @@ (in-package :binseq) -(defun binseq-p (s) +(defun binseq-p (s) ; NOTE: should use a 3-vector instead of the 3-list... (or (eq s 'empty) (and (consp s) (or (eq (car s) 'leaf) @@ -160,21 +160,19 @@ (cond ((<= i 0) 'empty) ((<= (binseq-length s) i) s) - (t (cond - ((<= i (binseq-length (caddr s))) (binseq-front (caddr s) i)) - (t (binseq-append - (caddr s) - (binseq-front (cdddr s) (- i (binseq-length (caddr s)))))))))) + ((<= i (binseq-length (caddr s))) (binseq-front (caddr s) i)) + (t (binseq-append + (caddr s) + (binseq-front (cdddr s) (- i (binseq-length (caddr s)))))))) (defun binseq-back (s i) (cond ((<= i 0) 'empty) ((<= (binseq-length s) i) s) - (t (cond - ((<= i (binseq-length (cdddr s))) (binseq-back (cdddr s) i)) - (t (binseq-append - (binseq-back (caddr s) (- i (binseq-length (cdddr s)))) - (cdddr s))))))) + ((<= i (binseq-length (cdddr s))) (binseq-back (cdddr s) i)) + (t (binseq-append + (binseq-back (caddr s) (- i (binseq-length (cdddr s)))) + (cdddr s))))) (defun %has-index (s i) (and (<= 0 i) (< i (binseq-length s)))) Index: climacs/Persistent/obinseq.lisp diff -u climacs/Persistent/obinseq.lisp:1.2 climacs/Persistent/obinseq.lisp:1.3 --- climacs/Persistent/obinseq.lisp:1.2 Sun Mar 6 00:23:54 2005 +++ climacs/Persistent/obinseq.lisp Sun Mar 13 21:51:53 2005 @@ -28,7 +28,7 @@ (or (null s) (atom s) (and (consp s) - (and (integerp (car s)) + (and (integerp (car s)) ; might wanna check the value (consp (cdr s)) (obinseq-p (cadr s)) (obinseq-p (cddr s)))))) @@ -167,21 +167,19 @@ (cond ((<= i 0) nil) ((<= (obinseq-length s) i) s) - (t (cond - ((<= i (obinseq-length (cadr s))) (obinseq-front (cadr s) i)) - (t (obinseq-append - (cadr s) - (obinseq-front (cddr s) (- i (obinseq-length (cadr s)))))))))) + ((<= i (obinseq-length (cadr s))) (obinseq-front (cadr s) i)) + (t (obinseq-append + (cadr s) + (obinseq-front (cddr s) (- i (obinseq-length (cadr s)))))))) (defun obinseq-back (s i) (cond ((<= i 0) nil) ((<= (obinseq-length s) i) s) - (t (cond - ((<= i (obinseq-length (cddr s))) (obinseq-back (cddr s) i)) - (t (obinseq-append - (obinseq-back (cadr s) (- i (obinseq-length (cddr s)))) - (cddr s))))))) + ((<= i (obinseq-length (cddr s))) (obinseq-back (cddr s) i)) + (t (obinseq-append + (obinseq-back (cadr s) (- i (obinseq-length (cddr s)))) + (cddr s))))) (defun %ohas-index (s i) (and (<= 0 i) (< i (obinseq-length s)))) Index: climacs/Persistent/persistent-buffer.lisp diff -u climacs/Persistent/persistent-buffer.lisp:1.9 climacs/Persistent/persistent-buffer.lisp:1.10 --- climacs/Persistent/persistent-buffer.lisp:1.9 Sun Mar 6 00:23:54 2005 +++ climacs/Persistent/persistent-buffer.lisp Sun Mar 13 21:51:53 2005 @@ -36,6 +36,15 @@ (defclass right-sticky-persistent-cursor (persistent-cursor) ()) +(defclass line-cursor-mixin () () + (:documentation "Support for line-oriented buffers.")) + +(defclass left-sticky-line-persistent-cursor + (left-sticky-persistent-cursor line-cursor-mixin) ()) + +(defclass right-sticky-line-persistent-cursor + (right-sticky-persistent-cursor line-cursor-mixin) ()) + (defmethod cursor-pos ((cursor left-sticky-persistent-cursor)) (1+ (slot-value cursor 'pos))) @@ -79,13 +88,19 @@ (defclass binseq-buffer (persistent-buffer) ((contents :initform (list-binseq nil))) (:documentation "An instantiable subclass of PERSISTENT-BUFFER that -uses a binary sequence for the CONTENTS.")) +uses a binary sequence for the CONTENTS slot.")) (defclass obinseq-buffer (persistent-buffer) ((contents :initform (list-obinseq nil))) (:documentation "An instantiable subclass of PERSISTENT-BUFFER that uses an optimized binary sequence (only non-nil atoms are allowed as -elements) for the CONTENTS.")) +elements) for the CONTENTS slot.")) + +(defclass binseq2-buffer (persistent-buffer) + ((contents :initform (list-binseq2 nil))) + (:documentation "An instantiable subclass of PERSISTENT-BUFFER that +uses a binary sequence for lines and optimized binary sequences for +line contents, all kept in the CONTENTS slot.")) (defclass p-mark-mixin () ((buffer :initarg :buffer :reader buffer) @@ -93,6 +108,10 @@ (:documentation "A mixin class used in the initialization of a mark that is used in a PERSISTENT-BUFFER.")) +(defclass p-line-mark-mixin (p-mark-mixin) () + (:documentation "A persistent mark mixin class that works with +cursors that can efficiently work with lines.")) + (defmethod backward-object ((mark p-mark-mixin) &optional (count 1)) (decf (offset mark) count)) @@ -117,6 +136,14 @@ (:documentation "A RIGHT-STICKY-MARK subclass suitable for use in a PERSISTENT-BUFFER.")) +(defclass persistent-left-sticky-line-mark (left-sticky-mark p-line-mark-mixin) () + (:documentation "A LEFT-STICKY-MARK subclass with line support, +suitable for use in a PERSISTENT-BUFFER.")) + +(defclass persistent-right-sticky-line-mark (right-sticky-mark p-line-mark-mixin) () + (:documentation "A RIGHT-STICKY-MARK subclass with line support, +suitable for use in a PERSISTENT-BUFFER.")) + (defmethod initialize-instance :after ((mark persistent-left-sticky-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer for which it was created." @@ -143,7 +170,33 @@ :buffer (buffer mark) :position offset))) -(defmethod initialize-instance :after ((buffer persistent-buffer) &rest args) +(defmethod initialize-instance :after ((mark persistent-left-sticky-line-mark) + &rest args &key (offset 0)) + "Associates a created mark with the buffer for which it was created." + (declare (ignorable args)) + (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-line-persistent-cursor + :buffer (buffer mark) + :position offset))) + +(defmethod initialize-instance :after ((mark persistent-right-sticky-line-mark) + &rest args &key (offset 0)) + "Associates a created mark with the buffer for which it was created." + (declare (ignorable args)) + (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-line-persistent-cursor + :buffer (buffer mark) + :position offset))) + +(defmethod initialize-instance :after ((buffer binseq-buffer) &rest args) "Create the low-mark and high-mark." (declare (ignorable args)) (with-slots (low-mark high-mark) buffer @@ -151,6 +204,23 @@ (setf high-mark (make-instance 'persistent-right-sticky-mark :buffer buffer)))) +(defmethod initialize-instance :after ((buffer obinseq-buffer) &rest args) + "Create the low-mark and high-mark." + (declare (ignorable args)) + (with-slots (low-mark high-mark) buffer + (setf low-mark (make-instance 'persistent-left-sticky-mark :buffer buffer)) + (setf high-mark (make-instance 'persistent-right-sticky-mark + :buffer buffer)))) + +(defmethod initialize-instance :after ((buffer binseq2-buffer) &rest args) + "Create the low-mark and high-mark." + (declare (ignorable args)) + (with-slots (low-mark high-mark) buffer + (setf low-mark + (make-instance 'persistent-left-sticky-line-mark :buffer buffer)) + (setf high-mark + (make-instance 'persistent-right-sticky-line-mark :buffer buffer)))) + (defmethod clone-mark ((mark persistent-left-sticky-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :left)) @@ -171,16 +241,49 @@ :buffer (buffer mark) :offset (offset mark))) (t (error "invalid value for stick-to")))) +(defmethod clone-mark ((mark persistent-left-sticky-line-mark) + &optional stick-to) + (cond + ((or (null stick-to) (eq stick-to :left)) + (make-instance 'persistent-left-sticky-line-mark + :buffer (buffer mark) :offset (offset mark))) + ((eq stick-to :right) + (make-instance 'persistent-right-sticky-line-mark + :buffer (buffer mark) :offset (offset mark))) + (t (error "invalid value for stick-to")))) + +(defmethod clone-mark ((mark persistent-right-sticky-line-mark) + &optional stick-to) + (cond + ((or (null stick-to) (eq stick-to :right)) + (make-instance 'persistent-right-sticky-line-mark + :buffer (buffer mark) :offset (offset mark))) + ((eq stick-to :left) + (make-instance 'persistent-left-sticky-line-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))) (defmethod size ((buffer obinseq-buffer)) (obinseq-length (slot-value buffer 'contents))) +(defmethod size ((buffer binseq2-buffer)) + (binseq2-size (slot-value buffer 'contents))) + (defmethod number-of-lines ((buffer persistent-buffer)) (loop for offset from 0 below (size buffer) count (eql (buffer-object buffer offset) #\Newline))) +(defmethod number-of-lines ((buffer binseq2-buffer)) + (let ((len (binseq2-length (slot-value buffer 'contents))) + (size (size buffer))) + (if (or (eql 0 size) + (eq (buffer-object buffer (1- size)) #\Newline)) + len + (max 0 (1- len))))) ; weird? + (defmethod mark< ((mark1 p-mark-mixin) (mark2 p-mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (< (offset mark1) (offset mark2))) @@ -255,6 +358,11 @@ (loop until (beginning-of-line-p mark) do (decf (offset mark)))) +(defmethod beginning-of-line ((mark p-line-mark-mixin)) + (setf (offset mark) + (binseq2-offset + (slot-value (buffer mark) 'contents) (line-number mark)))) + (defmethod end-of-line ((mark p-mark-mixin)) (let* ((offset (offset mark)) (buffer (buffer mark)) @@ -264,19 +372,40 @@ do (incf offset)) (setf (offset mark) offset))) +(defmethod end-of-line ((mark p-line-mark-mixin)) + (let* ((curr-offset (offset mark)) + (contents (slot-value (buffer mark) 'contents)) + (next-line-offset (binseq2-offset + contents + (1+ (binseq2-line2 contents curr-offset))))) + (if (> next-line-offset curr-offset) + (setf (offset mark) (1- next-line-offset)) + (setf (offset mark) (size (buffer mark)))))) + (defmethod buffer-line-number ((buffer persistent-buffer) (offset integer)) (loop for i from 0 below offset count (eql (buffer-object buffer i) #\Newline))) +(defmethod buffer-line-number ((buffer binseq2-buffer) (offset integer)) + (binseq2-line2 (slot-value buffer 'contents) offset)) + (defmethod line-number ((mark p-mark-mixin)) (buffer-line-number (buffer mark) (offset mark))) +(defmethod buffer-line-offset ((buffer binseq2-buffer) (line-no integer)) + (binseq2-offset (slot-value buffer 'contents) line-no)) + (defmethod buffer-column-number ((buffer persistent-buffer) (offset integer)) (loop for i downfrom offset while (> i 0) until (eql (buffer-object buffer (1- i)) #\Newline) count t)) +(defmethod buffer-column-number ((buffer binseq2-buffer) (offset integer)) + (- offset + (binseq2-offset + (slot-value buffer 'contents) (buffer-line-number buffer offset)))) + (defmethod column-number ((mark p-mark-mixin)) (buffer-column-number (buffer mark) (offset mark))) @@ -292,24 +421,51 @@ (binseq-insert (slot-value buffer 'contents) offset object))) (defmethod insert-buffer-object ((buffer obinseq-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) (obinseq-insert (slot-value buffer 'contents) offset object))) +(defmethod insert-buffer-object ((buffer binseq2-buffer) offset object) + (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) + (binseq2-insert2 (slot-value buffer 'contents) offset object))) + (defmethod insert-object ((mark p-mark-mixin) object) (insert-buffer-object (buffer mark) (offset mark) object)) (defmethod insert-buffer-sequence ((buffer binseq-buffer) offset sequence) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (size buffer)) () + (make-condition 'offset-after-end :offset offset)) (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) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (size buffer)) () + (make-condition 'offset-after-end :offset offset)) (let ((obinseq (vector-obinseq sequence))) (setf (slot-value buffer 'contents) (obinseq-insert* (slot-value buffer 'contents) offset obinseq)))) +(defmethod insert-buffer-sequence ((buffer binseq2-buffer) offset sequence) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (size buffer)) () + (make-condition 'offset-after-end :offset offset)) + (let ((binseq2 (vector-binseq2 sequence))) + (setf (slot-value buffer 'contents) + (binseq2-insert*2 (slot-value buffer 'contents) offset binseq2)))) + (defmethod insert-sequence ((mark p-mark-mixin) sequence) (insert-buffer-sequence (buffer mark) (offset mark) sequence)) @@ -322,11 +478,21 @@ (binseq-remove* (slot-value buffer 'contents) offset n))) (defmethod delete-buffer-range ((buffer obinseq-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) (obinseq-remove* (slot-value buffer 'contents) offset n))) +(defmethod delete-buffer-range ((buffer binseq2-buffer) offset n) + (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) + (binseq2-remove*2 (slot-value buffer 'contents) offset n))) + (defmethod delete-range ((mark p-mark-mixin) &optional (n 1)) (cond ((plusp n) (delete-buffer-range (buffer mark) (offset mark) n)) @@ -383,6 +549,21 @@ (setf (slot-value buffer 'contents) (obinseq-set (slot-value buffer 'contents) offset object))) +(defmethod buffer-object ((buffer binseq2-buffer) offset) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (1- (size buffer))) () + (make-condition 'offset-after-end :offset offset)) + (binseq2-get2 (slot-value buffer 'contents) offset)) + +(defmethod (setf buffer-object) (object (buffer binseq2-buffer) 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) + (binseq2-set2 (slot-value buffer 'contents) offset object))) + (defmethod buffer-sequence ((buffer binseq-buffer) offset1 offset2) (assert (<= 0 offset1) () (make-condition 'offset-before-beginning :offset offset1)) @@ -411,6 +592,21 @@ (if (> len 0) (obinseq-vector (obinseq-sub (slot-value buffer 'contents) offset1 len)) + (make-array 0)))) + +(defmethod buffer-sequence ((buffer binseq2-buffer) offset1 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)) + (let ((len (- offset2 offset1))) + (if (> len 0) + (binseq2-vector + (binseq2-sub2 (slot-value buffer 'contents) offset1 len)) (make-array 0)))) (defmethod object-before ((mark p-mark-mixin))

1 0

[climacs-cvs] CVS update: climacs/TODO climacs/base-test.lisp climacs/base.lisp climacs/buffer-test.lisp climacs/cl-syntax.lisp climacs/climacs.asd climacs/html-syntax.lisp climacs/packages.lisp climacs/pane.lisp climacs/text-syntax.lisp
by abakic＠common-lisp.net 13 Mar '05

13 Mar '05

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

1 0

[climacs-cvs] CVS update: climacs/html-syntax.lisp
by rstrandh＠common-lisp.net 13 Mar '05

13 Mar '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv5617 Modified Files: html-syntax.lisp Log Message: A step on the way to factoring out the incremental lexer. Date: Sun Mar 13 07:55:28 2005 Author: rstrandh Index: climacs/html-syntax.lisp diff -u climacs/html-syntax.lisp:1.10 climacs/html-syntax.lisp:1.11 --- climacs/html-syntax.lisp:1.10 Fri Mar 11 11:25:58 2005 +++ climacs/html-syntax.lisp Sun Mar 13 07:55:27 2005 @@ -41,6 +41,21 @@ (with-slots (start-mark size) tree (+ (offset start-mark) size))) +(defclass lexer () + ((buffer :initarg :buffer :reader buffer))) + +(defgeneric nb-lexemes (lexer)) +(defgeneric lexeme (lexer pos)) + +(defclass incremental-lexer (lexer) + ((lexemes :initform (make-instance 'standard-flexichain) :reader lexemes))) + +(defmethod nb-lexemes ((lexer incremental-lexer)) + (nb-elements (lexemes lexer))) + +(defmethod lexeme ((lexer incremental-lexer) pos) + (element* (lexemes lexer) pos)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; grammar classes @@ -132,30 +147,23 @@ (defclass word (html-element) ()) (defclass delimiter (html-element) ()) -(defun next-token (scan) - (let ((start-mark (clone-mark scan))) - (flet ((fo () (forward-object scan))) - (macrolet ((make-entry (type) - `(return-from next-token - (make-instance ,type :start-mark start-mark - :size (- (offset scan) (offset start-mark)))))) - (loop with object = (object-after scan) - until (end-of-buffer-p scan) - do (case object - (#\< (fo) (make-entry 'tag-start)) - (#\> (fo) (make-entry 'tag-end)) - (#\/ (fo) (make-entry 'slash)) - (t (cond ((alphanumericp object) - (loop until (end-of-buffer-p scan) - while (alphanumericp (object-after scan)) - do (fo)) - (make-entry 'word)) - (t - (fo) (make-entry 'delimiter)))))))))) +(defun next-lexeme (scan) + (flet ((fo () (forward-object scan))) + (let ((object (object-after scan))) + (case object + (#\< (fo) (make-instance 'tag-start)) + (#\> (fo) (make-instance 'tag-end)) + (#\/ (fo) (make-instance 'slash)) + (t (cond ((alphanumericp object) + (loop until (end-of-buffer-p scan) + while (alphanumericp (object-after scan)) + do (fo)) + (make-instance 'word)) + (t + (fo) (make-instance 'delimiter)))))))) (define-syntax html-syntax ("HTML" (basic-syntax)) - ((tokens :initform (make-instance 'standard-flexichain)) - (guess-pos :initform 1) + ((lexemes :initform (make-instance 'standard-flexichain)) (valid-parse :initform 1) (parser))) @@ -264,11 +272,11 @@ (defmethod initialize-instance :after ((syntax html-syntax) &rest args) (declare (ignore args)) - (with-slots (parser tokens buffer) syntax + (with-slots (parser lexemes buffer) syntax (setf parser (make-instance 'parser :grammar *html-grammar* :target 'html)) - (insert* tokens 0 (make-instance 'start-element + (insert* lexemes 0 (make-instance 'start-element :start-mark (make-instance 'standard-left-sticky-mark :buffer buffer :offset 0) @@ -280,52 +288,65 @@ ;;; update syntax (defmethod update-syntax-for-display (buffer (syntax html-syntax) top bot) - (with-slots (parser tokens valid-parse) syntax - (loop until (= valid-parse (nb-elements tokens)) - while (mark<= (end-offset (element* tokens valid-parse)) bot) - do (let ((current-token (element* tokens (1- valid-parse))) - (next-token (element* tokens valid-parse))) - (setf (slot-value next-token 'state) - (advance-parse parser (list next-token) (slot-value current-token 'state)))) + (with-slots (parser lexemes valid-parse) syntax + (loop until (= valid-parse (nb-elements lexemes)) + while (mark<= (end-offset (element* lexemes valid-parse)) bot) + do (let ((current-token (element* lexemes (1- valid-parse))) + (next-lexeme (element* lexemes valid-parse))) + (setf (slot-value next-lexeme 'state) + (advance-parse parser (list next-lexeme) (slot-value current-token 'state)))) (incf valid-parse)))) +(defun delete-invalid-lexemes (lexemes from to) + "delete all lexemes between FROM and TO and return the first invalid +position in LEXEMES" + (let ((start 1) + (end (nb-elements lexemes))) + ;; use binary search to find the first lexeme to delete + (loop while (< start end) + do (let ((middle (floor (+ start end) 2))) + (if (mark< (end-offset (element* lexemes middle)) from) + (setf start (1+ middle)) + (setf end middle)))) + ;; delete lexemes + (loop until (or (= start (nb-elements lexemes)) + (mark> (start-mark (element* lexemes start)) to)) + do (delete* lexemes start)) + start)) + + +(defun inter-lexeme-object-p (lexemes object) + (declare (ignore lexemes)) + (whitespacep object)) + +(defun skip-inter-lexeme-objects (lexemes scan) + (loop until (end-of-buffer-p scan) + while (inter-lexeme-object-p lexemes (object-after scan)) + 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)))))) + (loop do (skip-inter-lexeme-objects lexemes scan) + until (if (end-of-buffer-p end) + (end-of-buffer-p scan) + (mark> scan end)) + do (let* ((start-mark (clone-mark scan)) + (lexeme (next-lexeme scan)) + (size (- (offset scan) (offset start-mark)))) + (setf (slot-value lexeme 'start-mark) start-mark + (slot-value lexeme 'size) size) + (insert* lexemes start-pos lexeme)) + (incf start-pos)))) + (defmethod update-syntax (buffer (syntax html-syntax)) - (let ((low-mark (low-mark buffer)) - (high-mark (high-mark buffer)) - (scan)) - (with-slots (tokens guess-pos valid-parse) syntax - (when (mark<= low-mark high-mark) - ;; go back to a position before low-mark - (loop until (or (= guess-pos 1) - (mark< (end-offset (element* tokens (1- guess-pos))) low-mark)) - do (decf guess-pos)) - ;; go forward to the last position before low-mark - (loop with nb-elements = (nb-elements tokens) - until (or (= guess-pos nb-elements) - (mark>= (end-offset (element* tokens guess-pos)) low-mark)) - do (incf guess-pos)) - ;; mark valid parse - (setf valid-parse guess-pos) - ;; delete entries that must be reparsed - (loop until (or (= guess-pos (nb-elements tokens)) - (mark> (start-mark (element* tokens guess-pos)) high-mark)) - do (delete* tokens guess-pos)) - (setf scan (make-instance 'standard-left-sticky-mark - :buffer buffer - :offset (if (zerop guess-pos) - 0 - (end-offset (element* tokens (1- guess-pos)))))) - ;; scan - (loop with start-mark = nil - do (loop until (end-of-buffer-p scan) - while (whitespacep (object-after scan)) - do (forward-object scan)) - until (if (end-of-buffer-p high-mark) - (end-of-buffer-p scan) - (mark> scan high-mark)) - do (setf start-mark (clone-mark scan)) - (insert* tokens guess-pos (next-token scan)) - (incf guess-pos)))))) + (with-slots (lexemes valid-parse) syntax + (let* ((low-mark (low-mark buffer)) + (high-mark (high-mark buffer)) + (first-invalid-position (delete-invalid-lexemes lexemes low-mark high-mark))) + (setf valid-parse first-invalid-position) + (update-lex lexemes first-invalid-position high-mark)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -451,35 +472,35 @@ (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot))) *current-line* 0 (aref *cursor-positions* 0) (stream-cursor-position pane)) - (with-slots (tokens) syntax - (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-elements tokens))) + (with-slots (lexemes) syntax + (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-elements lexemes))) 1.0))) ;; find the last token before bot (let ((end-token-index (max (floor (/ (offset bot) average-token-size)) 1))) ;; go back to a token before bot - (loop until (mark<= (end-offset (element* tokens (1- end-token-index))) bot) + (loop until (mark<= (end-offset (element* lexemes (1- end-token-index))) bot) do (decf end-token-index)) ;; go forward to the last token before bot - (loop until (or (= end-token-index (nb-elements tokens)) - (mark> (start-offset (element* tokens end-token-index)) bot)) + (loop until (or (= end-token-index (nb-elements lexemes)) + (mark> (start-offset (element* lexemes end-token-index)) bot)) do (incf end-token-index)) (let ((start-token-index end-token-index)) ;; go back to the first token after top, or until the previous token ;; contains a valid parser state - (loop until (or (mark<= (end-offset (element* tokens (1- start-token-index))) top) + (loop until (or (mark<= (end-offset (element* lexemes (1- start-token-index))) top) (not (parse-state-empty-p - (slot-value (element* tokens (1- start-token-index)) 'state)))) + (slot-value (element* lexemes (1- start-token-index)) 'state)))) do (decf start-token-index)) (let ((*white-space-start* (offset top))) ;; display the parse tree if any - (unless (parse-state-empty-p (slot-value (element* tokens (1- start-token-index)) 'state)) - (display-parse-state (slot-value (element* tokens (1- start-token-index)) 'state) + (unless (parse-state-empty-p (slot-value (element* lexemes (1- start-token-index)) 'state)) + (display-parse-state (slot-value (element* lexemes (1- start-token-index)) 'state) syntax pane)) - ;; display the tokens + ;; display the lexemes (with-drawing-options (pane :ink +red+) (loop while (< start-token-index end-token-index) - do (let ((token (element* tokens start-token-index))) + do (let ((token (element* lexemes start-token-index))) (display-parse-tree token syntax pane)) (incf start-token-index)))))))) (let* ((cursor-line (number-of-lines-in-region top (point pane)))

1 0

[climacs-cvs] CVS update: climacs/html-syntax.lisp
by rstrandh＠common-lisp.net 11 Mar '05

11 Mar '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv16497 Modified Files: html-syntax.lisp Log Message: recognize the <a> and </a> tags Date: Fri Mar 11 11:25:58 2005 Author: rstrandh Index: climacs/html-syntax.lisp diff -u climacs/html-syntax.lisp:1.9 climacs/html-syntax.lisp:1.10 --- climacs/html-syntax.lisp:1.9 Fri Mar 11 08:03:31 2005 +++ climacs/html-syntax.lisp Fri Mar 11 11:25:58 2005 @@ -82,6 +82,7 @@ (defclass h1 (html-words) ()) (defclass h2 (html-words) ()) (defclass h3 (html-words) ()) +(defclass a (html-words) ()) (defclass para (html-words) ()) (defclass html-token (html-sym) @@ -109,6 +110,13 @@ (defclass </ul> (html-tag) () (:default-initargs :size 5)) (defclass <li> (html-tag) () (:default-initargs :size 4)) (defclass </li> (html-tag) () (:default-initargs :size 5)) +(defclass <a> (html-tag) + ((start :initarg :start) + (word :initarg :word) + (words :initarg :words) + (end :initarg :end))) +(defclass </a> (html-tag) () (:default-initargs :size 4)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -205,6 +213,20 @@ (word-is word "body"))) (tag-end (= (end-offset word) (start-offset tag-end)))) :start-mark (start-mark tag-start)) + (<a> -> (tag-start + (word (and (= (end-offset tag-start) (start-offset word)) + (word-is word "a"))) + words + tag-end) + :start-mark (start-mark tag-start) + :size (- (end-offset tag-end) (start-offset tag-start)) + :start tag-start :word word :words words :end tag-end) + (</a> -> (tag-start + (slash (= (end-offset tag-start) (start-offset slash))) + (word (and (= (end-offset slash) (start-offset word)) + (word-is word "a"))) + (tag-end (= (end-offset word) (start-offset tag-end)))) + :start-mark (start-mark tag-start)) (html -> (<html> head body </html>) :start-mark (start-mark <html>) :size (- (end-offset </html>) (start-offset <html>)) @@ -221,13 +243,24 @@ :start-mark (start-mark <body>) :size (- (end-offset </body>) (start-offset <body>)) :start <body> :words words :end </body>) + (a -> (<a> words </a>) + :start-mark (start-mark <a>) + :size (- (end-offset </a>) (start-offset <a>)) + :start <a> :words words :end </a>) (words -> () (make-instance 'empty-words :start-mark nil)) (words -> (words word) (make-instance 'nonempty-words :start-mark (or (start-mark words) (start-mark word)) :size (- (end-offset word) (offset (or (start-mark words) (start-mark word)))) - :words words :word word)))) + :words words :word word)) + (word -> (a) + :start-mark (start-mark a) + :size (- (end-offset a) (start-offset a))) + (word -> (delimiter) + :start-mark (start-mark delimiter) + :size (- (end-offset delimiter) (start-offset delimiter))))) + (defmethod initialize-instance :after ((syntax html-syntax) &rest args) (declare (ignore args)) @@ -311,6 +344,7 @@ (#\Newline (terpri pane) (setf (aref *cursor-positions* (incf *current-line*)) (multiple-value-bind (x y) (stream-cursor-position pane) + (declare (ignore x)) y))) (#\Space (stream-increment-cursor-position pane space-width 0)) @@ -390,6 +424,13 @@ (with-slots (title) entity (display-parse-tree title syntax pane))) +(defmethod display-parse-tree ((entity <a>) (syntax html-syntax) pane) + (with-slots (start word words end) entity + (display-parse-tree start syntax pane) + (display-parse-tree word syntax pane) + (display-parse-tree words syntax pane) + (display-parse-tree end syntax pane))) + (defgeneric display-parse-stack (symbol stack syntax pane)) (defmethod display-parse-stack (symbol stack (syntax html-syntax) pane) @@ -452,4 +493,3 @@ (+ cursor-x 2) (+ cursor-y (* 0.8 height)) :ink (if current-p +red+ +blue+)))))) - \ No newline at end of file

1 0

[climacs-cvs] CVS update: climacs/climacs.asd
by rstrandh＠common-lisp.net 11 Mar '05

11 Mar '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv16440 Modified Files: climacs.asd Log Message: Patch from Andreas Fuchs that makes Climacs no longer depend on a specific McCLIM backend. Date: Fri Mar 11 11:23:33 2005 Author: rstrandh Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.22 climacs/climacs.asd:1.23 --- climacs/climacs.asd:1.22 Mon Mar 7 07:51:02 2005 +++ climacs/climacs.asd Fri Mar 11 11:23:33 2005 @@ -42,7 +42,7 @@ :defaults *climacs-directory*)) collect `(:file ,(pathname-name p) :pathname ,p)))))) -(climacs-defsystem (:climacs :depends-on (:clim-clx :flexichain)) +(climacs-defsystem (:climacs :depends-on (:mcclim :flexichain)) "Persistent/binseq-package" "Persistent/binseq" "Persistent/obinseq"

1 0

[climacs-cvs] CVS update: climacs/html-syntax.lisp climacs/syntax.lisp
by rstrandh＠common-lisp.net 11 Mar '05

11 Mar '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv5279 Modified Files: html-syntax.lisp syntax.lisp Log Message: HTML syntax now does syntax highlighting. The current code is a mess, because I haven't figured out how much of html-syntax.lisp can be factored out and put in syntax.lisp for use with other syntax modules. Also, the HTML syntax module is nowhere near complete. It exists merely as an illustration of what can be done with incremental parsing. It is definitely premature to try to turn it into something more complete and truly useful for editing HTML. Date: Fri Mar 11 08:03:32 2005 Author: rstrandh Index: climacs/html-syntax.lisp diff -u climacs/html-syntax.lisp:1.8 climacs/html-syntax.lisp:1.9 --- climacs/html-syntax.lisp:1.8 Thu Mar 10 07:37:40 2005 +++ climacs/html-syntax.lisp Fri Mar 11 08:03:31 2005 @@ -24,9 +24,28 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; this should really go in syntax.lisp + +(defclass parse-tree () + ((start-mark :initarg :start-mark :reader start-mark) + (size :initarg :size))) + +(defgeneric start-offset (parse-tree)) + +(defmethod start-offset ((tree parse-tree)) + (offset (start-mark tree))) + +(defgeneric end-offset (parse-tree)) + +(defmethod end-offset ((tree parse-tree)) + (with-slots (start-mark size) tree + (+ (offset start-mark) size))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; grammar classes -(defclass html-sym () +(defclass html-sym (parse-tree) ((badness :initform 0 :initarg :badness :reader badness) (message :initform "" :initarg :message :reader message))) @@ -34,9 +53,7 @@ (and (eq (class-of t1) (class-of t2)) (< (badness t1) (badness t2)))) -(defclass html-nonterminal (html-sym) - ((start-offset :initarg :start-offset :reader start-offset) - (end-offset :initarg :end-offset :reader end-offset))) +(defclass html-nonterminal (html-sym) ()) (defclass words (html-nonterminal) ()) @@ -68,40 +85,30 @@ (defclass para (html-words) ()) (defclass html-token (html-sym) - ((start-mark :initarg :start-mark :reader start-mark) - (size :initarg :size))) - -(defgeneric end-offset (html-token)) - -(defmethod end-offset ((token html-token)) - (with-slots (start-mark size) token - (+ (offset start-mark) size))) - -(defgeneric start-offset (html-token)) + ((ink) (face))) -(defmethod start-offset ((token html-token)) - (offset (start-mark token))) +(defclass html-tag (html-token) ()) -(defclass <html> (html-token) () (:default-initargs :size 6)) -(defclass </html> (html-token) ()(:default-initargs :size 7)) -(defclass <head> (html-token) () (:default-initargs :size 6)) -(defclass </head> (html-token) () (:default-initargs :size 7)) -(defclass <title> (html-token) () (:default-initargs :size 7)) -(defclass </title> (html-token) () (:default-initargs :size 8)) -(defclass <body> (html-token) () (:default-initargs :size 6)) -(defclass </body> (html-token) () (:default-initargs :size 7)) -(defclass <h1> (html-token) () (:default-initargs :size 4)) -(defclass </h1> (html-token) () (:default-initargs :size 5)) -(defclass <h2> (html-token) () (:default-initargs :size 4)) -(defclass </h2> (html-token) () (:default-initargs :size 5)) -(defclass <h3> (html-token) () (:default-initargs :size 4)) -(defclass </h3> (html-token) () (:default-initargs :size 5)) -(defclass <p> (html-token) () (:default-initargs :size 3)) -(defclass </p> (html-token) () (:default-initargs :size 4)) -(defclass <ul> (html-token) () (:default-initargs :size 4)) -(defclass </ul> (html-token) () (:default-initargs :size 5)) -(defclass <li> (html-token) () (:default-initargs :size 4)) -(defclass </li> (html-token) () (:default-initargs :size 5)) +(defclass <html> (html-tag) () (:default-initargs :size 6)) +(defclass </html> (html-tag) ()(:default-initargs :size 7)) +(defclass <head> (html-tag) () (:default-initargs :size 6)) +(defclass </head> (html-tag) () (:default-initargs :size 7)) +(defclass <title> (html-tag) () (:default-initargs :size 7)) +(defclass </title> (html-tag) () (:default-initargs :size 8)) +(defclass <body> (html-tag) () (:default-initargs :size 6)) +(defclass </body> (html-tag) () (:default-initargs :size 7)) +(defclass <h1> (html-tag) () (:default-initargs :size 4)) +(defclass </h1> (html-tag) () (:default-initargs :size 5)) +(defclass <h2> (html-tag) () (:default-initargs :size 4)) +(defclass </h2> (html-tag) () (:default-initargs :size 5)) +(defclass <h3> (html-tag) () (:default-initargs :size 4)) +(defclass </h3> (html-tag) () (:default-initargs :size 5)) +(defclass <p> (html-tag) () (:default-initargs :size 3)) +(defclass </p> (html-tag) () (:default-initargs :size 4)) +(defclass <ul> (html-tag) () (:default-initargs :size 4)) +(defclass </ul> (html-tag) () (:default-initargs :size 5)) +(defclass <li> (html-tag) () (:default-initargs :size 4)) +(defclass </li> (html-tag) () (:default-initargs :size 5)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -199,23 +206,27 @@ (tag-end (= (end-offset word) (start-offset tag-end)))) :start-mark (start-mark tag-start)) (html -> (<html> head body </html>) - :start-offset (start-offset <html>) :end-offset (end-offset </html>) + :start-mark (start-mark <html>) + :size (- (end-offset </html>) (start-offset <html>)) :start <html> :head head :body body :end </html>) (head -> (<head> title </head>) - :start-offset (start-offset <head>) :end-offset (end-offset </head>) + :start-mark (start-mark <head>) + :size (- (end-offset </head>) (start-offset <head>)) :start <head> :title title :end </head>) (title -> (<title> words </title>) - :start-offset (start-offset <title>) :end-offset (end-offset </title>) + :start-mark (start-mark <title>) + :size (- (end-offset </title>) (start-offset <title>)) :start <title> :words words :end </title>) (body -> (<body> words </body>) - :start-offset (start-offset <body>) :end-offset (end-offset </body>) + :start-mark (start-mark <body>) + :size (- (end-offset </body>) (start-offset <body>)) :start <body> :words words :end </body>) (words -> () - (make-instance 'empty-words :start-offset nil)) + (make-instance 'empty-words :start-mark nil)) (words -> (words word) (make-instance 'nonempty-words - :start-offset (or (start-offset words) (start-offset word)) - :end-offset (end-offset word) + :start-mark (or (start-mark words) (start-mark word)) + :size (- (end-offset word) (offset (or (start-mark words) (start-mark word)))) :words words :word word)))) (defmethod initialize-instance :after ((syntax html-syntax) &rest args) @@ -287,12 +298,20 @@ ;;; ;;; display +(defvar *white-space-start* nil) + +(defvar *cursor-positions* nil) +(defvar *current-line* 0) + (defun handle-whitespace (pane buffer start end) (let ((space-width (space-width pane)) (tab-width (tab-width pane))) (loop while (< start end) do (ecase (buffer-object buffer start) - (#\Newline (terpri pane)) + (#\Newline (terpri pane) + (setf (aref *cursor-positions* (incf *current-line*)) + (multiple-value-bind (x y) (stream-cursor-position pane) + y))) (#\Space (stream-increment-cursor-position pane space-width 0)) (#\Tab (let ((x (stream-cursor-position pane))) @@ -310,15 +329,32 @@ nil) (defmethod display-parse-tree ((entity html-token) (syntax html-syntax) pane) - (updating-output (pane :unique-id entity - :id-test #'eq - :cache-value entity - :cache-test #'eq) - (present (coerce (region-to-sequence (start-mark entity) - (end-offset entity)) - 'string) - 'string - :stream pane))) + (flet ((cache-test (t1 t2) + (and (eq t1 t2) + (eq (slot-value t1 'ink) + (medium-ink (sheet-medium pane))) + (eq (slot-value t1 'face) + (text-style-face (medium-text-style (sheet-medium pane))))))) + (updating-output (pane :unique-id entity + :id-test #'eq + :cache-value entity + :cache-test #'cache-test) + (with-slots (ink face) entity + (setf ink (medium-ink (sheet-medium pane)) + face (text-style-face (medium-text-style (sheet-medium pane)))) + (present (coerce (region-to-sequence (start-mark entity) + (end-offset entity)) + 'string) + 'string + :stream pane))))) + +(defmethod display-parse-tree :around ((entity html-tag) (syntax html-syntax) pane) + (with-drawing-options (pane :ink +green+) + (call-next-method))) + +(defmethod display-parse-tree :before ((entity html-token) (syntax html-syntax) pane) + (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity)) + (setf *white-space-start* (end-offset entity))) (defmethod display-parse-tree :before ((entity html-balanced) (syntax html-syntax) pane) (with-slots (start) entity @@ -328,6 +364,10 @@ (with-slots (end) entity (display-parse-tree end syntax pane))) +(defmethod display-parse-tree :around ((entity title) (syntax html-syntax) pane) + (with-text-face (pane :bold) + (call-next-method))) + (defmethod display-parse-tree ((entity html-words) (syntax html-syntax) pane) (with-slots (words) entity (display-parse-tree words syntax pane))) @@ -367,6 +407,9 @@ (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax html-syntax) current-p) (with-slots (top bot) pane + (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot))) + *current-line* 0 + (aref *cursor-positions* 0) (stream-cursor-position pane)) (with-slots (tokens) syntax (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-elements tokens))) 1.0))) @@ -383,29 +426,30 @@ ;; go back to the first token after top, or until the previous token ;; contains a valid parser state (loop until (or (mark<= (end-offset (element* tokens (1- start-token-index))) top) - (not (null (parse-stack-top - (slot-value (element* tokens (1- start-token-index)) 'state))))) + (not (parse-state-empty-p + (slot-value (element* tokens (1- start-token-index)) 'state)))) do (decf start-token-index)) - ;; display the parse tree if any - (unless (parse-state-empty-p (slot-value (element* tokens (1- start-token-index)) 'state)) - (display-parse-state (slot-value (element* tokens (1- start-token-index)) 'state) - syntax - pane)) - ;; display the tokens - (loop with prev-offset = (end-offset (element* tokens (1- start-token-index))) - while (< start-token-index end-token-index) - do (let ((token (element* tokens start-token-index))) - (handle-whitespace pane (buffer pane) prev-offset (start-offset token)) - (updating-output (pane :unique-id token - :id-test #'eq - :cache-value token - :cache-test #'eq) - (present (coerce (region-to-sequence (start-mark token) - (end-offset token)) - 'string) - 'string - :stream pane)) - (setf prev-offset (end-offset token))) - (incf start-token-index)))))))) + (let ((*white-space-start* (offset top))) + ;; display the parse tree if any + (unless (parse-state-empty-p (slot-value (element* tokens (1- start-token-index)) 'state)) + (display-parse-state (slot-value (element* tokens (1- start-token-index)) 'state) + syntax + pane)) + ;; display the tokens + (with-drawing-options (pane :ink +red+) + (loop while (< start-token-index end-token-index) + do (let ((token (element* tokens start-token-index))) + (display-parse-tree token syntax pane)) + (incf start-token-index)))))))) + (let* ((cursor-line (number-of-lines-in-region top (point pane))) + (height (text-style-height (medium-text-style pane) pane)) + (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane))))) + (cursor-column (column-number (point pane))) + (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane)))) + (updating-output (pane :unique-id -1) + (draw-rectangle* pane + (1- cursor-x) (- cursor-y (* 0.2 height)) + (+ cursor-x 2) (+ cursor-y (* 0.8 height)) + :ink (if current-p +red+ +blue+)))))) Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.35 climacs/syntax.lisp:1.36 --- climacs/syntax.lisp:1.35 Thu Mar 10 07:37:40 2005 +++ climacs/syntax.lisp Fri Mar 11 08:03:31 2005 @@ -139,14 +139,15 @@ (target :initarg :target :reader target) (initial-state :reader initial-state))) -(defclass rule-item () ()) +(defclass rule-item () + ((parse-trees :initform '() :initarg :parse-trees :reader parse-trees))) + (defclass incomplete-item (rule-item) ((orig-state :initarg :orig-state :reader orig-state) (predicted-from :initarg :predicted-from :reader predicted-from) (rule :initarg :rule :reader rule) (dot-position :initarg :dot-position :reader dot-position) - (parse-trees :initarg :parse-trees :reader parse-trees) (suffix :initarg :suffix :reader suffix))) (defmethod print-object ((item incomplete-item) stream) @@ -180,7 +181,8 @@ :suffix remaining)) (t (make-instance 'complete-item - :parse-tree remaining))))) + :parse-tree remaining + :parse-trees (cons parse-tree (parse-trees prev-item))))))) (defgeneric item-equal (item1 item2)) @@ -257,7 +259,6 @@ :predicted-from item :rule rule :dot-position 0 - :parse-trees '() :suffix (right-hand-side rule)) (make-instance 'complete-item :parse-tree (right-hand-side rule))) @@ -284,7 +285,6 @@ :predicted-from nil :rule rule :dot-position 0 - :parse-trees '() :suffix (right-hand-side rule)) (make-instance 'complete-item :parse-tree (right-hand-side rule)))

1 0

[climacs-cvs] CVS update: climacs/html-syntax.lisp climacs/packages.lisp climacs/syntax.lisp
by rstrandh＠common-lisp.net 10 Mar '05

10 Mar '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv20617 Modified Files: html-syntax.lisp packages.lisp syntax.lisp Log Message: More progress on html-syntax, which may eventually become a model for many different language syntax modules. The display function now traverses the parse tree up as long as a valid parse tree exists. The rest of the display is done from the token sequence. It is likely that all of this can be abstracted out and put into syntax.lisp so that html-syntax would just become a client among others for this traversal. Not only is the cursor still not displayed, whitespace is not handled during the traversal of the parse tree. This will likely be fixed in the next few day. Date: Thu Mar 10 07:37:41 2005 Author: rstrandh Index: climacs/html-syntax.lisp diff -u climacs/html-syntax.lisp:1.7 climacs/html-syntax.lisp:1.8 --- climacs/html-syntax.lisp:1.7 Mon Mar 7 07:51:02 2005 +++ climacs/html-syntax.lisp Thu Mar 10 07:37:40 2005 @@ -300,6 +300,71 @@ pane (- tab-width (mod x tab-width)) 0)))) (incf start)))) +(defmethod display-parse-tree :around ((entity html-sym) syntax pane) + (with-slots (top bot) pane + (when (mark> (end-offset entity) top) + (call-next-method)))) + +(defmethod display-parse-tree :around ((entity empty-words) syntax pane) + (declare (ignore syntax pane)) + nil) + +(defmethod display-parse-tree ((entity html-token) (syntax html-syntax) pane) + (updating-output (pane :unique-id entity + :id-test #'eq + :cache-value entity + :cache-test #'eq) + (present (coerce (region-to-sequence (start-mark entity) + (end-offset entity)) + 'string) + 'string + :stream pane))) + +(defmethod display-parse-tree :before ((entity html-balanced) (syntax html-syntax) pane) + (with-slots (start) entity + (display-parse-tree start syntax pane))) + +(defmethod display-parse-tree :after ((entity html-balanced) (syntax html-syntax) pane) + (with-slots (end) entity + (display-parse-tree end syntax pane))) + +(defmethod display-parse-tree ((entity html-words) (syntax html-syntax) pane) + (with-slots (words) entity + (display-parse-tree words syntax pane))) + +(defmethod display-parse-tree ((entity empty-words) (syntax html-syntax) pane) + (declare (ignore pane)) + nil) + +(defmethod display-parse-tree ((entity nonempty-words) (syntax html-syntax) pane) + (with-slots (words word) entity + (display-parse-tree words syntax pane) + (display-parse-tree word syntax pane))) + +(defmethod display-parse-tree ((entity html) (syntax html-syntax) pane) + (with-slots (head body) entity + (display-parse-tree head syntax pane) + (display-parse-tree body syntax pane))) + +(defmethod display-parse-tree ((entity head) (syntax html-syntax) pane) + (with-slots (title) entity + (display-parse-tree title syntax pane))) + +(defgeneric display-parse-stack (symbol stack syntax pane)) + +(defmethod display-parse-stack (symbol stack (syntax html-syntax) pane) + (let ((next (parse-stack-next stack))) + (unless (null next) + (display-parse-stack (parse-stack-symbol next) next syntax pane)) + (loop for parse-tree in (reverse (parse-stack-parse-trees stack)) + do (display-parse-tree parse-tree syntax pane)))) + +(defun display-parse-state (state syntax pane) + (let ((top (parse-stack-top state))) + (if (not (null top)) + (display-parse-stack (parse-stack-symbol top) top syntax pane) + (display-parse-tree (target-parse-tree state) syntax pane)))) + (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax html-syntax) current-p) (with-slots (top bot) pane (with-slots (tokens) syntax @@ -310,16 +375,24 @@ ;; go back to a token before bot (loop until (mark<= (end-offset (element* tokens (1- end-token-index))) bot) do (decf end-token-index)) - ;; for forward to the last token before bot + ;; go forward to the last token before bot (loop until (or (= end-token-index (nb-elements tokens)) (mark> (start-offset (element* tokens end-token-index)) bot)) do (incf end-token-index)) (let ((start-token-index end-token-index)) - ;; go back to the first token after top - (loop until (mark<= (end-offset (element* tokens (1- start-token-index))) top) + ;; go back to the first token after top, or until the previous token + ;; contains a valid parser state + (loop until (or (mark<= (end-offset (element* tokens (1- start-token-index))) top) + (not (null (parse-stack-top + (slot-value (element* tokens (1- start-token-index)) 'state))))) do (decf start-token-index)) + ;; display the parse tree if any + (unless (parse-state-empty-p (slot-value (element* tokens (1- start-token-index)) 'state)) + (display-parse-state (slot-value (element* tokens (1- start-token-index)) 'state) + syntax + pane)) ;; display the tokens - (loop with prev-offset = (offset top) + (loop with prev-offset = (end-offset (element* tokens (1- start-token-index))) while (< start-token-index end-token-index) do (let ((token (element* tokens start-token-index))) (handle-whitespace pane (buffer pane) prev-offset (start-offset token)) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.54 climacs/packages.lisp:1.55 --- climacs/packages.lisp:1.54 Mon Mar 7 07:51:03 2005 +++ climacs/packages.lisp Thu Mar 10 07:37:40 2005 @@ -92,7 +92,7 @@ #:update-syntax #:update-syntax-for-display #:grammar #:parser #:initial-state #:advance-parse - #:parse-stack-top #:target-parse-tree + #:parse-stack-top #:target-parse-tree #:parse-state-empty-p #:parse-stack-next #:parse-stack-symbol #:parse-stack-parse-trees #:map-over-parse-trees #:syntax-line-indentation Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.34 climacs/syntax.lisp:1.35 --- climacs/syntax.lisp:1.34 Sat Mar 5 08:03:53 2005 +++ climacs/syntax.lisp Thu Mar 10 07:37:40 2005 @@ -326,6 +326,10 @@ represent a complete parse of the target." (state-contains-target-p state)) +(defun parse-state-empty-p (state) + (and (null (parse-stack-top state)) + (null (target-parse-tree state)))) + (defun parse-stack-next (parse-stack) "given a parse stack frame, return the next frame in the stack." (assert (not (null parse-stack)))

1 0

[climacs-cvs] CVS update: climacs/climacs.asd climacs/html-syntax.lisp climacs/packages.lisp
by rstrandh＠common-lisp.net 07 Mar '05

07 Mar '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv4561 Modified Files: climacs.asd html-syntax.lisp packages.lisp Log Message: First attempt at a display function (for html syntax) that uses the output of an incremental lexer and parser. This code is not complete yet: * right now, it uses only the lexer output, and not the parser * the cursor is not displayed yet * it is too slow, most likely because the output records are all in one big bag, as opposed to being tree structured, such as the lines of basic syntax. The slowness is not a serious problem, because one day, McCLIM will have tree-structured output records itself, and because most syntax modules (including this one, very soon) will have some tree structure itself. It might be worthwhile to display the part of the buffer beyond a parse error in some artificially structured way, such as by lines as in the current basic syntax. Date: Mon Mar 7 07:51:03 2005 Author: rstrandh Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.21 climacs/climacs.asd:1.22 --- climacs/climacs.asd:1.21 Tue Mar 1 05:56:06 2005 +++ climacs/climacs.asd Mon Mar 7 07:51:02 2005 @@ -55,12 +55,12 @@ "abbrev" "syntax" "text-syntax" - "html-syntax" "cl-syntax" "kill-ring" "undo" "delegating-buffer" "pane" + "html-syntax" "gui" ;;---- optional ---- "testing/rt" Index: climacs/html-syntax.lisp diff -u climacs/html-syntax.lisp:1.6 climacs/html-syntax.lisp:1.7 --- climacs/html-syntax.lisp:1.6 Sat Mar 5 08:03:53 2005 +++ climacs/html-syntax.lisp Mon Mar 7 07:51:02 2005 @@ -287,5 +287,52 @@ ;;; ;;; display +(defun handle-whitespace (pane buffer start end) + (let ((space-width (space-width pane)) + (tab-width (tab-width pane))) + (loop while (< start end) + do (ecase (buffer-object buffer start) + (#\Newline (terpri pane)) + (#\Space (stream-increment-cursor-position + pane space-width 0)) + (#\Tab (let ((x (stream-cursor-position pane))) + (stream-increment-cursor-position + pane (- tab-width (mod x tab-width)) 0)))) + (incf start)))) - +(defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax html-syntax) current-p) + (with-slots (top bot) pane + (with-slots (tokens) syntax + (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-elements tokens))) + 1.0))) + ;; find the last token before bot + (let ((end-token-index (max (floor (/ (offset bot) average-token-size)) 1))) + ;; go back to a token before bot + (loop until (mark<= (end-offset (element* tokens (1- end-token-index))) bot) + do (decf end-token-index)) + ;; for forward to the last token before bot + (loop until (or (= end-token-index (nb-elements tokens)) + (mark> (start-offset (element* tokens end-token-index)) bot)) + do (incf end-token-index)) + (let ((start-token-index end-token-index)) + ;; go back to the first token after top + (loop until (mark<= (end-offset (element* tokens (1- start-token-index))) top) + do (decf start-token-index)) + ;; display the tokens + (loop with prev-offset = (offset top) + while (< start-token-index end-token-index) + do (let ((token (element* tokens start-token-index))) + (handle-whitespace pane (buffer pane) prev-offset (start-offset token)) + (updating-output (pane :unique-id token + :id-test #'eq + :cache-value token + :cache-test #'eq) + (present (coerce (region-to-sequence (start-mark token) + (end-offset token)) + 'string) + 'string + :stream pane)) + (setf prev-offset (end-offset token))) + (incf start-token-index)))))))) + + \ No newline at end of file Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.53 climacs/packages.lisp:1.54 --- climacs/packages.lisp:1.53 Sat Mar 5 08:03:53 2005 +++ climacs/packages.lisp Mon Mar 7 07:51:03 2005 @@ -122,7 +122,8 @@ #:climacs-pane #:point #:mark #:redisplay-pane #:full-redisplay #:page-down #:page-up - #:tab-space-count + #:top #:bot + #:tab-space-count #:space-width #:tab-width #:indent-tabs-mode #:auto-fill-mode #:auto-fill-column #:isearch-state #:search-string #:search-mark

1 0

[climacs-cvs] CVS update: climacs/Persistent/binseq-package.lisp
by abakic＠common-lisp.net 05 Mar '05

05 Mar '05

Update of /project/climacs/cvsroot/climacs/Persistent In directory common-lisp.net:/tmp/cvs-serv27092/Persistent Modified Files: binseq-package.lisp Log Message: Cleanup and performance improvements. Date: Sun Mar 6 00:24:41 2005 Author: abakic Index: climacs/Persistent/binseq-package.lisp diff -u climacs/Persistent/binseq-package.lisp:1.1 climacs/Persistent/binseq-package.lisp:1.2 --- climacs/Persistent/binseq-package.lisp:1.1 Wed Jan 26 17:10:45 2005 +++ climacs/Persistent/binseq-package.lisp Sun Mar 6 00:24:41 2005 @@ -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

1 0

[climacs-cvs] CVS update: climacs/Persistent/binseq.lisp climacs/Persistent/obinseq.lisp climacs/Persistent/persistent-buffer.lisp
by abakic＠common-lisp.net 05 Mar '05

05 Mar '05

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

1 0