January 2005 - climacs-cvs@common-lisp.net

[climacs-cvs] CVS update: climacs/Persistent/persistent-base-test.lisp climacs/Persistent/persistent-buffer.lisp climacs/Persistent/persistent-buffer-test.lisp
by abakic＠common-lisp.net 26 Jan '05

26 Jan '05

Update of /project/climacs/cvsroot/climacs/Persistent In directory common-lisp.net:/tmp/cvs-serv9143 Modified Files: persistent-base-test.lisp persistent-buffer.lisp persistent-buffer-test.lisp Log Message: Cleanup and some more info. Date: Wed Jan 26 10:28:57 2005 Author: abakic Index: climacs/Persistent/persistent-base-test.lisp diff -u climacs/Persistent/persistent-base-test.lisp:1.1 climacs/Persistent/persistent-base-test.lisp:1.2 --- climacs/Persistent/persistent-base-test.lisp:1.1 Wed Jan 26 08:10:45 2005 +++ climacs/Persistent/persistent-base-test.lisp Wed Jan 26 10:28:56 2005 @@ -461,26 +461,6 @@ (number-of-lines-in-region 10 m2r)))) 1 1 1 1 0 0 0 1 1) -(deftest constituentp.test-1 ; NOTE: more tests may be needed for sbcl - (values - (constituentp #\a) - (constituentp #\Newline) - (constituentp #\Space) - (constituentp #\Tab) - (constituentp "a") - (constituentp #\Null)) - t nil nil nil nil nil) - -(deftest whitespacep.test-1 - (values - (not (null (whitespacep #\a))) - (not (null (whitespacep #\Newline))) - (not (null (whitespacep #\Space))) - (not (null (whitespacep #\Tab))) - (not (null (whitespacep " "))) - (not (null (whitespacep #\Null)))) - nil nil t t nil nil) - (deftest binseq-buffer-forward-to-word-boundary.test-1 (let ((buffer (make-instance 'binseq-buffer))) (insert-buffer-sequence buffer 0 " climacs @@ -1080,26 +1060,6 @@ (number-of-lines-in-region m2l 10) (number-of-lines-in-region 10 m2r)))) 1 1 1 1 0 0 0 1 1) - -(deftest constituentp.test-1 ; NOTE: more tests may be needed for sbcl - (values - (constituentp #\a) - (constituentp #\Newline) - (constituentp #\Space) - (constituentp #\Tab) - (constituentp "a") - (constituentp #\Null)) - t nil nil nil nil nil) - -(deftest whitespacep.test-1 - (values - (not (null (whitespacep #\a))) - (not (null (whitespacep #\Newline))) - (not (null (whitespacep #\Space))) - (not (null (whitespacep #\Tab))) - (not (null (whitespacep " "))) - (not (null (whitespacep #\Null)))) - nil nil t t nil nil) (deftest obinseq-buffer-forward-to-word-boundary.test-1 (let ((buffer (make-instance 'obinseq-buffer))) Index: climacs/Persistent/persistent-buffer.lisp diff -u climacs/Persistent/persistent-buffer.lisp:1.1 climacs/Persistent/persistent-buffer.lisp:1.2 --- climacs/Persistent/persistent-buffer.lisp:1.1 Wed Jan 26 08:10:45 2005 +++ climacs/Persistent/persistent-buffer.lisp Wed Jan 26 10:28:56 2005 @@ -24,6 +24,9 @@ (in-package :climacs-buffer) +;;; For now, pos contains just an integer, while it might contain a cons +;;; of two adjacent buffer elements for higher performance (with the help +;;; of buffer implementation, especially the rebalancing part). (defclass persistent-cursor () ((buffer :reader buffer :initarg :buffer) ; TODO: fix overlap with mark? (pos :accessor cursor-pos)) @@ -151,6 +154,9 @@ while (> i 0) until (eql (buffer-object buffer (1- i)) #\Newline) count t)) + +;;; the old value of the CONTENTS slot is dropped upon modification +;;; it can be saved for UNDO purposes in a history tree, by an UNDOABLE-BUFFER (defmethod insert-buffer-object ((buffer binseq-buffer) offset object) (assert (<= 0 offset (size buffer)) () Index: climacs/Persistent/persistent-buffer-test.lisp diff -u climacs/Persistent/persistent-buffer-test.lisp:1.1 climacs/Persistent/persistent-buffer-test.lisp:1.2 --- climacs/Persistent/persistent-buffer-test.lisp:1.1 Wed Jan 26 08:10:45 2005 +++ climacs/Persistent/persistent-buffer-test.lisp Wed Jan 26 10:28:56 2005 @@ -53,11 +53,7 @@ (flet ((%all-eq (&optional x y) (cond ((null x) nil) - (t (when (eq x y) y)))) - (%all-= (&optional x y) - (cond - ((null x) nil) - (t (when (= x y) y))))) + (t (when (eq x y) y))))) (let* ((buffer (make-instance 'binseq-buffer)) (low (slot-value buffer 'low-mark)) (high (slot-value buffer 'high-mark)) @@ -762,11 +758,7 @@ (flet ((%all-eq (&optional x y) (cond ((null x) nil) - (t (when (eq x y) y)))) - (%all-= (&optional x y) - (cond - ((null x) nil) - (t (when (= x y) y))))) + (t (when (eq x y) y))))) (let* ((buffer (make-instance 'obinseq-buffer)) (low (slot-value buffer 'low-mark)) (high (slot-value buffer 'high-mark))

1 0

[climacs-cvs] CVS update: climacs/Persistent/README climacs/Persistent/binseq-package.lisp climacs/Persistent/binseq.lisp climacs/Persistent/obinseq.lisp climacs/Persistent/persistent-base-test.lisp climacs/Persistent/persistent-buffer-test.lisp climacs/Persistent/persistent-buffer.lisp
by abakic＠common-lisp.net 26 Jan '05

26 Jan '05

Update of /project/climacs/cvsroot/climacs/Persistent In directory common-lisp.net:/tmp/cvs-serv1821/Persistent Added Files: README binseq-package.lisp binseq.lisp obinseq.lisp persistent-base-test.lisp persistent-buffer-test.lisp persistent-buffer.lisp Log Message: Persistent/balanced-tree buffer implementations with tests. Date: Wed Jan 26 08:10:45 2005 Author: abakic

1 0

[climacs-cvs] CVS update: climacs/buffer.lisp climacs/climacs.asd climacs/gui.lisp climacs/packages.lisp climacs/pane.lisp
by abakic＠common-lisp.net 26 Jan '05

26 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv1821 Modified Files: buffer.lisp climacs.asd gui.lisp packages.lisp pane.lisp Log Message: Persistent/balanced-tree buffer implementations with tests. Date: Wed Jan 26 08:10:41 2005 Author: abakic Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.23 climacs/buffer.lisp:1.24 --- climacs/buffer.lisp:1.23 Tue Jan 18 10:59:51 2005 +++ climacs/buffer.lisp Wed Jan 26 08:10:40 2005 @@ -92,7 +92,7 @@ (defclass standard-right-sticky-mark (right-sticky-mark mark-mixin) () (:documentation "A right-sticky-mark subclass suitable for use in a standard-buffer")) -(defmethod initialize-instance :after ((mark left-sticky-mark) &rest args &key (offset 0)) +(defmethod initialize-instance :after ((mark standard-left-sticky-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer it was created for." (declare (ignore args)) (assert (<= 0 offset (size (buffer mark))) () @@ -102,7 +102,7 @@ :chain (slot-value (buffer mark) 'contents) :position offset))) -(defmethod initialize-instance :after ((mark right-sticky-mark) &rest args &key (offset 0)) +(defmethod initialize-instance :after ((mark standard-right-sticky-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer it was created for." (declare (ignore args)) (assert (<= 0 offset (size (buffer mark))) () @@ -287,7 +287,7 @@ either immediately before the closest following newline character, or at the end of the buffer if no following newline character exists.")) -(defmethod end-of-line ((mark mark-mixin)) +(defmethod end-of-line ((mark mark-mixin)) ;PB (let* ((offset (offset mark)) (buffer (buffer mark)) (chain (slot-value buffer 'contents)) Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.15 climacs/climacs.asd:1.16 --- climacs/climacs.asd:1.15 Mon Jan 24 15:01:37 2005 +++ climacs/climacs.asd Wed Jan 26 08:10:40 2005 @@ -49,9 +49,13 @@ "Flexichain/utilities" "Flexichain/flexichain" "Flexichain/flexicursor" + "Persistent/binseq-package" + "Persistent/binseq" + "Persistent/obinseq" "translate" "packages" "buffer" + "Persistent/persistent-buffer" "base" "io" "abbrev" @@ -64,7 +68,9 @@ ;;---- optional ---- "testing/rt" "buffer-test" - "base-test") + "base-test" + "Persistent/persistent-buffer-test" + "Persistent/persistent-base-test") #+asdf (defmethod asdf:perform :around ((o asdf:compile-op) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.98 climacs/gui.lisp:1.99 --- climacs/gui.lisp:1.98 Mon Jan 24 04:49:09 2005 +++ climacs/gui.lisp Wed Jan 26 08:10:40 2005 @@ -747,7 +747,7 @@ (accept 'integer :prompt "Goto Position"))) (define-named-command com-goto-line () - (loop with mark = (make-instance 'standard-right-sticky-mark + (loop with mark = (make-instance 'standard-right-sticky-mark ;PB :buffer (buffer (current-window))) do (end-of-line mark) until (end-of-buffer-p mark) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.40 climacs/packages.lisp:1.41 --- climacs/packages.lisp:1.40 Mon Jan 24 04:49:09 2005 +++ climacs/packages.lisp Wed Jan 26 08:10:40 2005 @@ -23,7 +23,7 @@ ;;; Package definitions for the Climacs editor. (defpackage :climacs-buffer - (:use :clim-lisp :flexichain) + (:use :clim-lisp :flexichain :binseq) (:export #:buffer #:standard-buffer #:mark #:left-sticky-mark #:right-sticky-mark #:standard-left-sticky-mark #:standard-right-sticky-mark @@ -41,7 +41,10 @@ #:delete-region #:buffer-object #:buffer-sequence #:object-before #:object-after #:region-to-sequence - #:low-mark #:high-mark #:modified-p #:clear-modify)) + #:low-mark #:high-mark #:modified-p #:clear-modify + + #:binseq-buffer #:obinseq-buffer + #:persistent-left-sticky-mark #:persistent-right-sticky-mark)) (defpackage :climacs-base (:use :clim-lisp :climacs-buffer) Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.13 climacs/pane.lisp:1.14 --- climacs/pane.lisp:1.13 Mon Jan 24 04:49:09 2005 +++ climacs/pane.lisp Wed Jan 26 08:10:41 2005 @@ -156,7 +156,7 @@ ;(defgeneric indent-tabs-mode (climacs-buffer)) -(defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin name-mixin undo-mixin) +(defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin name-mixin undo-mixin) ;PB ((needs-saving :initform nil :accessor needs-saving) (syntax :initarg :syntax :initform (make-instance 'basic-syntax) :accessor syntax) (indent-tabs-mode :initarg indent-tabs-mode :initform t @@ -195,14 +195,14 @@ (declare (ignore args)) (with-slots (buffer point mark) pane (when (null point) - (setf point (make-instance 'standard-right-sticky-mark + (setf point (make-instance 'standard-right-sticky-mark ;PB :buffer buffer))) (when (null mark) - (setf mark (make-instance 'standard-right-sticky-mark + (setf mark (make-instance 'standard-right-sticky-mark ;PB :buffer buffer)))) (with-slots (buffer top bot scan) pane - (setf top (make-instance 'standard-left-sticky-mark :buffer buffer) - bot (make-instance 'standard-right-sticky-mark :buffer buffer))) + (setf top (make-instance 'standard-left-sticky-mark :buffer buffer) ;PB + bot (make-instance 'standard-right-sticky-mark :buffer buffer))) ;PB (setf (stream-default-view pane) (make-instance 'climacs-textual-view)) (with-slots (space-width tab-width) (stream-default-view pane) (let* ((medium (sheet-medium pane)) @@ -212,12 +212,12 @@ (defmethod (setf buffer) :after (buffer (pane climacs-pane)) (with-slots (point mark top bot) pane - (setf point (make-instance 'standard-right-sticky-mark + (setf point (make-instance 'standard-right-sticky-mark ;PB :buffer buffer) - mark (make-instance 'standard-right-sticky-mark + mark (make-instance 'standard-right-sticky-mark ;PB :buffer buffer) - top (make-instance 'standard-left-sticky-mark :buffer buffer) - bot (make-instance 'standard-right-sticky-mark :buffer buffer)))) + top (make-instance 'standard-left-sticky-mark :buffer buffer) ;PB + bot (make-instance 'standard-right-sticky-mark :buffer buffer)))) ;PB (define-presentation-type url () :inherit-from 'string)

1 0

[climacs-cvs] CVS update: Directory change: climacs/Persistent
by abakic＠common-lisp.net 26 Jan '05

26 Jan '05

Update of /project/climacs/cvsroot/climacs/Persistent In directory common-lisp.net:/tmp/cvs-serv1060/Persistent Log Message: Directory /project/climacs/cvsroot/climacs/Persistent added to the repository Date: Wed Jan 26 07:59:42 2005 Author: abakic New directory climacs/Persistent added

1 0

[climacs-cvs] CVS update: climacs/base.lisp climacs/base-test.lisp climacs/buffer-test.lisp
by abakic＠common-lisp.net 24 Jan '05

24 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv5683 Modified Files: base.lisp base-test.lisp buffer-test.lisp Log Message: Changes in open-line and number-of-lines-in-region, and more tests. Date: Mon Jan 24 15:53:53 2005 Author: abakic Index: climacs/base.lisp diff -u climacs/base.lisp:1.24 climacs/base.lisp:1.25 --- climacs/base.lisp:1.24 Thu Jan 20 15:37:38 2005 +++ climacs/base.lisp Mon Jan 24 15:53:52 2005 @@ -75,8 +75,12 @@ (beginning-of-line mark) (incf (offset mark) column))))) -(defun open-line (mark) - "Create a new line in a buffer." +(defmethod open-line ((mark left-sticky-mark)) + "Create a new line in a buffer after the mark." + (insert-object mark #\Newline)) + +(defmethod open-line ((mark right-sticky-mark)) + "Create a new line in a buffer after the mark." (insert-object mark #\Newline) (decf (offset mark))) @@ -132,13 +136,23 @@ (defmethod number-of-lines-in-region ((mark1 mark) (mark2 mark)) (assert (eq (buffer mark1) (buffer mark2))) - (buffer-number-of-lines-in-region (buffer mark1) (offset mark1) (offset mark2))) - -(defmethod number-of-lines-in-region ((offset integer) (mark mark)) - (buffer-number-of-lines-in-region (buffer mark) offset (offset mark))) - -(defmethod number-of-lines-in-region ((mark mark) (offset integer)) - (buffer-number-of-lines-in-region (buffer mark) (offset mark) offset)) + (let ((offset1 (offset mark1)) + (offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (buffer-number-of-lines-in-region (buffer mark1) offset1 offset2))) + +(defmethod number-of-lines-in-region ((offset1 integer) (mark2 mark)) + (let ((offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (buffer-number-of-lines-in-region (buffer mark2) offset1 offset2))) + +(defmethod number-of-lines-in-region ((mark1 mark) (offset2 integer)) + (let ((offset1 (offset mark1))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (buffer-number-of-lines-in-region (buffer mark1) offset1 offset2))) (defun constituentp (obj) "A predicate to ensure that an object is a constituent character." @@ -153,7 +167,7 @@ #-sbcl (member obj '(#\Space #\Tab)))) (defun forward-to-word-boundary (mark) - "Forward the mark forward to the beginning of the next word." + "Move the mark forward to the beginning of the next word." (loop until (end-of-buffer-p mark) until (constituentp (object-after mark)) do (incf (offset mark)))) Index: climacs/base-test.lisp diff -u climacs/base-test.lisp:1.1 climacs/base-test.lisp:1.2 --- climacs/base-test.lisp:1.1 Thu Jan 20 15:21:53 2005 +++ climacs/base-test.lisp Mon Jan 24 15:53:52 2005 @@ -143,4 +143,482 @@ :buffer buffer :offset 0))) (next-line mark) (offset mark))) - 8) \ No newline at end of file + 8) + +(deftest standard-buffer-open-line.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs") + (let ((mark (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 0))) + (open-line mark) + (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) + " +climacs" 0) + +(deftest standard-buffer-open-line.test-2 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs") + (let ((mark (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 0))) + (open-line mark) + (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) + " +climacs" 0) + +(deftest standard-buffer-open-line.test-3 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs") + (let ((mark (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 7))) + (open-line mark) + (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) + "climacs +" 7) + +(deftest standard-buffer-open-line.test-4 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs") + (let ((mark (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 7))) + (open-line mark) + (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) + "climacs +" 7) + +(deftest standard-buffer-kill-line.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs") + (let ((mark (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 0))) + (kill-line mark) + (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) + #() 0) + +(deftest standard-buffer-kill-line.test-2 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs") + (let ((mark (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 0))) + (kill-line mark) + (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) + #() 0) + +(deftest standard-buffer-kill-line.test-3 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs") + (let ((mark (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 7))) + (kill-line mark) + (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) + "climacs" 7) + +(deftest standard-buffer-kill-line.test-4 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs") + (let ((mark (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 7))) + (kill-line mark) + (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) + "climacs" 7) + +(deftest standard-buffer-kill-line.test-5 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs +climacs") + (let ((mark (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 7))) + (kill-line mark) + (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) + "climacsclimacs" 7) + +(deftest standard-buffer-kill-line.test-6 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs +climacs") + (let ((mark (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 7))) + (kill-line mark) + (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) + "climacsclimacs" 7) + +(deftest standard-buffer-empty-line-p.test-1 + (let* ((buffer (make-instance 'standard-buffer)) + (m1 (make-instance 'standard-left-sticky-mark :buffer buffer)) + (m2 (make-instance 'standard-right-sticky-mark :buffer buffer))) + (values (empty-line-p m1) (empty-line-p m2))) + t t) + +(deftest standard-buffer-empty-line-p.test-2 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-object buffer 0 #\a) + (let ((m1 (make-instance 'standard-left-sticky-mark :buffer buffer)) + (m2 (make-instance 'standard-right-sticky-mark :buffer buffer))) + (values (empty-line-p m1) (empty-line-p m2)))) + nil nil) + +(deftest standard-buffer-empty-line-p.test-3 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-object buffer 0 #\a) + (let ((m1 (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 1)) + (m2 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 1))) + (values (empty-line-p m1) (empty-line-p m2)))) + nil nil) + +(deftest standard-buffer-empty-line-p.test-4 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "a +b") + (let ((m1 (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 1)) + (m2 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 1))) + (values (empty-line-p m1) (empty-line-p m2)))) + nil nil) + +(deftest standard-buffer-line-indentation.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 " climacs") + (let ((m1 (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 0)) + (m2 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 0)) + (m3 (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 10)) + (m4 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 10))) + (values + (line-indentation m1 8) + (line-indentation m2 8) + (line-indentation m3 8) + (line-indentation m4 8) + (offset m1) + (offset m2) + (offset m3) + (offset m4)))) + 10 10 10 10 0 0 10 10) + +(deftest standard-buffer-line-indentation.test-2 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 " climacs") + (let ((m1 (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 0)) + (m2 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 0)) + (m3 (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 11)) + (m4 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 11))) + (values + (line-indentation m1 8) + (line-indentation m2 8) + (line-indentation m3 8) + (line-indentation m4 8) + (offset m1) + (offset m2) + (offset m3) + (offset m4)))) + 18 18 18 18 0 0 11 11) + +(deftest standard-buffer-line-indentation.test-3 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 " climacs ") + (let ((m1 (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 0)) + (m2 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 0)) + (m3 (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 11)) + (m4 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 11))) + (values + (line-indentation m1 8) + (line-indentation m2 8) + (line-indentation m3 8) + (line-indentation m4 8) + (offset m1) + (offset m2) + (offset m3) + (offset m4)))) + 10 10 10 10 0 0 11 11) + +(deftest standard-buffer-buffer-number-of-lines-in-region.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs +climacs") + (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 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) + +(deftest standard-buffer-buffer-display-column.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 " cli macs") + (values + (buffer-display-column buffer 0 8) + (buffer-display-column buffer 1 8) + (buffer-display-column buffer 2 8) + (buffer-display-column buffer 5 8) + (buffer-display-column buffer 6 8))) + 0 8 16 19 24) + +(deftest standard-buffer-number-of-lines-in-region.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 " +climacs +climacs +") + (let ((m1l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 0)) + (m1r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 0)) + (m2l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 1)) + (m2r (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 1)) + (m3l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 3)) + (m3r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 3)) + (m4l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 8)) + (m4r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 8)) + (m5l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 15)) + (m5r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 15)) + (m6l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 16)) + (m6r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 16))) + (values + (number-of-lines-in-region m1l m1r) + (number-of-lines-in-region m1r m1l) + (number-of-lines-in-region m1l m2l) + (number-of-lines-in-region m2r m1r) + (number-of-lines-in-region m1l m2r) + (number-of-lines-in-region m2r m1l) + (number-of-lines-in-region m1r m2l) + (number-of-lines-in-region m1l m3l) + (number-of-lines-in-region m1r m3r) + (number-of-lines-in-region m4r m1l) + (number-of-lines-in-region m4l m1r) + (number-of-lines-in-region m3l m5l) + (number-of-lines-in-region m5r m4r) + (number-of-lines-in-region m5l m6l) + (number-of-lines-in-region m6r m5r) + (number-of-lines-in-region m6l m6r) + (number-of-lines-in-region m1l m6r) + (number-of-lines-in-region m3r m6l)))) + 0 0 1 1 1 1 1 1 1 1 1 1 1 0 0 0 2 1) + +(deftest standard-buffer-number-of-lines-in-region.test-2 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs +climacs") + (let ((m1l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 6)) + (m1r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 6)) + (m2l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 7)) + (m2r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 7))) + (values + (number-of-lines-in-region m1l 10) + (number-of-lines-in-region 10 m1l) + (number-of-lines-in-region m1r 10) + (number-of-lines-in-region 10 m1r) + (number-of-lines-in-region m1l 3) + (number-of-lines-in-region 3 m2l) + (number-of-lines-in-region 3 m2r) + (number-of-lines-in-region m2l 10) + (number-of-lines-in-region 10 m2r)))) + 1 1 1 1 0 0 0 1 1) + +(deftest constituentp.test-1 ; NOTE: more tests may be needed for sbcl + (values + (constituentp #\a) + (constituentp #\Newline) + (constituentp #\Space) + (constituentp #\Tab) + (constituentp "a") + (constituentp #\Null)) + t nil nil nil nil nil) + +(deftest whitespacep.test-1 + (values + (not (null (whitespacep #\a))) + (not (null (whitespacep #\Newline))) + (not (null (whitespacep #\Space))) + (not (null (whitespacep #\Tab))) + (not (null (whitespacep " "))) + (not (null (whitespacep #\Null)))) + nil nil t t nil nil) + +(deftest standard-buffer-forward-to-word-boundary.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 " climacs +climacs") + (let ((m0l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 0)) + (m0r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 0)) + (m1l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 5)) + (m1r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 5)) + (m2l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 17)) + (m2r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 17))) + (values + (progn (climacs-base::forward-to-word-boundary m0l) (offset m0l)) + (progn (climacs-base::forward-to-word-boundary m0r) (offset m0r)) + (progn (climacs-base::forward-to-word-boundary m1l) (offset m1l)) + (progn (climacs-base::forward-to-word-boundary m1r) (offset m1r)) + (progn (climacs-base::forward-to-word-boundary m2l) (offset m2l)) + (progn (climacs-base::forward-to-word-boundary m2r) (offset m2r))))) + 2 2 5 5 17 17) + +(deftest standard-buffer-backward-to-word-boundary.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs +climacs ") + (let ((m0l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 17)) + (m0r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 17)) + (m1l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 10)) + (m1r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 10)) + (m2l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 0)) + (m2r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 0))) + (values + (progn (climacs-base::backward-to-word-boundary m0l) (offset m0l)) + (progn (climacs-base::backward-to-word-boundary m0r) (offset m0r)) + (progn (climacs-base::backward-to-word-boundary m1l) (offset m1l)) + (progn (climacs-base::backward-to-word-boundary m1r) (offset m1r)) + (progn (climacs-base::backward-to-word-boundary m2l) (offset m2l)) + (progn (climacs-base::backward-to-word-boundary m2r) (offset m2r))))) + 15 15 10 10 0 0) + +(deftest standard-buffer-forward-word.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 " climacs +climacs") + (let ((m0l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 0)) + (m0r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 0)) + (m1l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 5)) + (m1r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 15)) + (m2l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 17)) + (m2r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 17))) + (values + (progn (forward-word m0l) (offset m0l)) + (progn (forward-word m0r) (offset m0r)) + (progn (forward-word m1l) (offset m1l)) + (progn (forward-word m1r) (offset m1r)) + (progn (forward-word m2l) (offset m2l)) + (progn (forward-word m2r) (offset m2r))))) + 9 9 9 17 17 17) + +(deftest standard-buffer-backward-word.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs +climacs ") + (let ((m0l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 17)) + (m0r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 17)) + (m1l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 10)) + (m1r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 5)) + (m2l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 0)) + (m2r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 0))) + (values + (progn (backward-word m0l) (offset m0l)) + (progn (backward-word m0r) (offset m0r)) + (progn (backward-word m1l) (offset m1l)) + (progn (backward-word m1r) (offset m1r)) + (progn (backward-word m2l) (offset m2l)) + (progn (backward-word m2r) (offset m2r))))) + 8 8 8 0 0 0) + +(deftest standard-buffer-delete-word.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs") + (let ((m (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 3))) + (delete-word m) + (values + (buffer-sequence buffer 0 (size buffer)) + (offset m)))) + "cli" 3) + +(deftest standard-buffer-delete-word.test-2 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 " climacs") + (let ((m (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 0))) + (delete-word m) + (values + (buffer-sequence buffer 0 (size buffer)) + (offset m)))) + #() 0) + +(deftest standard-buffer-backward-delete-word.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs") + (let ((m (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 3))) + (backward-delete-word m) + (values + (buffer-sequence buffer 0 (size buffer)) + (offset m)))) + "macs" 0) + +(deftest standard-buffer-backward-delete-word.test-2 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs ") + (let ((m (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 9))) + (backward-delete-word m) + (values + (buffer-sequence buffer 0 (size buffer)) + (offset m)))) + #() 0) + +(deftest standard-buffer-previous-word.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs climacs") + (let ((m0 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 7)) + (m1 (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 8)) + (m2 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 10))) + (values + (climacs-base::previous-word m0) + (climacs-base::previous-word m1) + (climacs-base::previous-word m2)))) + "climacs" #() "cl") \ No newline at end of file Index: climacs/buffer-test.lisp diff -u climacs/buffer-test.lisp:1.8 climacs/buffer-test.lisp:1.9 --- climacs/buffer-test.lisp:1.8 Thu Jan 20 15:21:52 2005 +++ climacs/buffer-test.lisp Mon Jan 24 15:53:52 2005 @@ -526,6 +526,23 @@ (= 0 (line-number m1) (1- (line-number m2))))) t) +(deftest standard-buffer-buffer-column-number.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 " climacs") + (values + (buffer-object buffer 2) + (buffer-column-number buffer 2))) + #\c 2) + +(deftest standard-buffer-buffer-column-number.test-2 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 " + climacs") + (values + (buffer-object buffer 3) + (buffer-column-number buffer 3))) + #\c 2) + (deftest standard-buffer-column-number.test-1 (let ((buffer (make-instance 'standard-buffer))) (insert-buffer-sequence buffer 0 "climacs

1 0

[climacs-cvs] CVS update: climacs/climacs.asd
by mvilleneuve＠common-lisp.net 24 Jan '05

24 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv2689 Modified Files: climacs.asd Log Message: Fixed file order issue preventing compilation in CMUCL Date: Mon Jan 24 15:01:39 2005 Author: mvilleneuve Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.14 climacs/climacs.asd:1.15 --- climacs/climacs.asd:1.14 Mon Jan 24 04:49:08 2005 +++ climacs/climacs.asd Mon Jan 24 15:01:37 2005 @@ -58,8 +58,8 @@ "syntax" "text-syntax" "kill-ring" - "pane" "undo" + "pane" "gui" ;;---- optional ---- "testing/rt"

1 0

[climacs-cvs] CVS update: climacs/undo.lisp
by rstrandh＠common-lisp.net 24 Jan '05

24 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv5047 Added Files: undo.lisp Log Message: Undo Date: Mon Jan 24 05:12:52 2005 Author: rstrandh

1 0

[climacs-cvs] CVS update: climacs/climacs.asd climacs/gui.lisp climacs/packages.lisp climacs/pane.lisp
by rstrandh＠common-lisp.net 24 Jan '05

24 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv3921 Modified Files: climacs.asd gui.lisp packages.lisp pane.lisp Log Message: Implemented undo and redo. Date: Mon Jan 24 04:49:09 2005 Author: rstrandh Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.13 climacs/climacs.asd:1.14 --- climacs/climacs.asd:1.13 Thu Jan 20 15:21:52 2005 +++ climacs/climacs.asd Mon Jan 24 04:49:08 2005 @@ -59,6 +59,7 @@ "text-syntax" "kill-ring" "pane" + "undo" "gui" ;;---- optional ---- "testing/rt" Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.97 climacs/gui.lisp:1.98 --- climacs/gui.lisp:1.97 Sun Jan 23 15:30:34 2005 +++ climacs/gui.lisp Mon Jan 24 04:49:09 2005 @@ -88,6 +88,11 @@ (defmacro current-window () ; shouldn't this be an inlined function? --amb `(car (windows *application-frame*))) +(defmethod execute-frame-command :around ((frame climacs) command) + (declare (ignore command)) + (with-undo ((buffer (current-window))) + (call-next-method))) + (defmethod redisplay-frame-panes :around ((frame climacs) &rest args) (declare (ignore args)) (let ((buffers (remove-duplicates (mapcar #'buffer (windows frame))))) @@ -1099,6 +1104,12 @@ (define-named-command com-isearch-exit () (setf (isearch-mode (current-window)) nil)) +(define-named-command com-undo () + (undo (undo-tree (buffer (current-window))))) + +(define-named-command com-redo () + (redo (undo-tree (buffer (current-window))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Dynamic abbrevs @@ -1263,6 +1274,8 @@ (c-x-set-key '(#\k) 'com-kill-buffer) (c-x-set-key '(#\l :control) 'com-load-file) (c-x-set-key '(#\o) 'com-other-window) +(c-x-set-key '(#\r) 'com-redo) +(c-x-set-key '(#\u) 'com-undo) (c-x-set-key '(#\s :control) 'com-save-buffer) (c-x-set-key '(#\t :control) 'com-transpose-lines) (c-x-set-key '(#\w :control) 'com-write-buffer) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.39 climacs/packages.lisp:1.40 --- climacs/packages.lisp:1.39 Sun Jan 23 15:30:34 2005 +++ climacs/packages.lisp Mon Jan 24 04:49:09 2005 @@ -88,9 +88,16 @@ #:reset-yank-position #:rotate-yank-position #:kill-ring-yank #:kill-ring-standard-push #:kill-ring-concatenating-push)) +(defpackage :undo + (:use :common-lisp) + (:export #:no-more-undo + #:undo-tree #:standard-undo-tree + #:undo-record #:standard-undo-record + #:add-undo #:flip-undo-record #:undo #:redo)) + (defpackage :climacs-pane (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev - :climacs-syntax :flexichain) + :climacs-syntax :flexichain :undo) (:export #:climacs-buffer #:needs-saving #:filename #:climacs-pane #:point #:mark #:redisplay-pane #:full-redisplay @@ -100,9 +107,10 @@ #:auto-fill-mode #:auto-fill-column #:isearch-state #:search-string #:search-mark #:search-forward-p #:isearch-mode #:isearch-states #:isearch-previous-string + #:with-undo #:url)) (defpackage :climacs-gui (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax - :climacs-kill-ring :climacs-pane :clim-extensions)) + :climacs-kill-ring :climacs-pane :clim-extensions :undo)) Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.12 climacs/pane.lisp:1.13 --- climacs/pane.lisp:1.12 Sun Jan 23 15:30:35 2005 +++ climacs/pane.lisp Mon Jan 24 04:49:09 2005 @@ -44,6 +44,99 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Undo + +(defclass undo-mixin () + ((tree :initform (make-instance 'standard-undo-tree) :reader undo-tree) + (undo-accumulate :initform '() :accessor undo-accumulate) + (performing-undo :initform nil :accessor performing-undo))) + +(defclass climacs-undo-record (standard-undo-record) + ((buffer :initarg :buffer))) + +(defclass simple-undo-record (climacs-undo-record) + ((offset :initarg :offset))) + +(defclass insert-record (simple-undo-record) + ((objects :initarg :objects))) + +(defclass delete-record (simple-undo-record) + ((length :initarg :length))) + +(defclass compound-record (climacs-undo-record) + ((records :initform '() :initarg :records))) + +(defmethod print-object ((object delete-record) stream) + (with-slots (offset length) object + (format stream "[offset: ~a length: ~a]" offset length))) + +(defmethod print-object ((object insert-record) stream) + (with-slots (offset objects) object + (format stream "[offset: ~a objects: ~a]" offset objects))) + +(defmethod print-object ((object compound-record) stream) + (with-slots (records) object + (format stream "[records: ~a]" records))) + +(defmethod insert-buffer-object :before ((buffer undo-mixin) offset object) + (declare (ignore object)) + (unless (performing-undo buffer) + (push (make-instance 'delete-record + :buffer buffer :offset offset :length 1) + (undo-accumulate buffer)))) + +(defmethod insert-buffer-sequence :before ((buffer undo-mixin) offset sequence) + (unless (performing-undo buffer) + (push (make-instance 'delete-record + :buffer buffer :offset offset :length (length sequence)) + (undo-accumulate buffer)))) + + +(defmethod delete-buffer-range :before ((buffer undo-mixin) offset n) + (unless (performing-undo buffer) + (push (make-instance 'insert-record + :buffer buffer :offset offset + :objects (buffer-sequence buffer offset (+ offset n))) + (undo-accumulate buffer)))) + +(defmacro with-undo ((buffer) &body body) + (let ((buffer-var (gensym))) + `(let ((,buffer-var ,buffer)) + (setf (undo-accumulate ,buffer-var) '()) + ,@body + (cond ((null (undo-accumulate ,buffer-var)) nil) + ((null (cdr (undo-accumulate ,buffer-var))) + (add-undo (car (undo-accumulate ,buffer-var)) (undo-tree ,buffer-var))) + (t + (add-undo (make-instance 'compound-record :records (undo-accumulate ,buffer-var)) + (undo-tree ,buffer-var))))))) + +(defmethod flip-undo-record :around ((record climacs-undo-record)) + (with-slots (buffer) record + (let ((performing-undo (performing-undo buffer))) + (setf (performing-undo buffer) t) + (unwind-protect (call-next-method) + (setf (performing-undo buffer) performing-undo))))) + +(defmethod flip-undo-record ((record insert-record)) + (with-slots (buffer offset objects) record + (change-class record 'delete-record + :length (length objects)) + (insert-buffer-sequence buffer offset objects))) + +(defmethod flip-undo-record ((record delete-record)) + (with-slots (buffer offset length) record + (change-class record 'insert-record + :objects (buffer-sequence buffer offset (+ offset length))) + (delete-buffer-range buffer offset length))) + +(defmethod flip-undo-record ((record compound-record)) + (with-slots (records) record + (mapc #'flip-undo-record records) + (setf records (nreverse records)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; Isearch (defclass isearch-state () @@ -63,7 +156,7 @@ ;(defgeneric indent-tabs-mode (climacs-buffer)) -(defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin name-mixin) +(defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin name-mixin undo-mixin) ((needs-saving :initform nil :accessor needs-saving) (syntax :initarg :syntax :initform (make-instance 'basic-syntax) :accessor syntax) (indent-tabs-mode :initarg indent-tabs-mode :initform t

1 0

[climacs-cvs] CVS update: climacs/gui.lisp climacs/packages.lisp climacs/pane.lisp
by mvilleneuve＠common-lisp.net 23 Jan '05

23 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv28339 Modified Files: gui.lisp packages.lisp pane.lisp Log Message: Added backward isearch Date: Sun Jan 23 15:30:35 2005 Author: mvilleneuve Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.96 climacs/gui.lisp:1.97 --- climacs/gui.lisp:1.96 Sun Jan 23 02:21:08 2005 +++ climacs/gui.lisp Sun Jan 23 15:30:34 2005 @@ -990,9 +990,8 @@ ;;; ;;; Incremental search -(define-named-command com-isearch-mode () - (let* ((pane (current-window)) - (point (point pane))) +(defun isearch-command-loop (pane forwardp) + (let ((point (point pane))) (unless (endp (isearch-states pane)) (setf (isearch-previous-string pane) (search-string (first (isearch-states pane))))) @@ -1000,7 +999,8 @@ (setf (isearch-states pane) (list (make-instance 'isearch-state :search-string "" - :search-mark (clone-mark point)))) + :search-mark (clone-mark point) + :search-forward-p forwardp))) (redisplay-frame-panes *application-frame*) (loop while (isearch-mode pane) as gesture = (climacs-read-gesture) @@ -1020,33 +1020,47 @@ (setf (isearch-mode pane) nil))) (redisplay-frame-panes *application-frame*)))) -(defun isearch-from-mark (pane mark string) - (let* ((point (point pane)) - (mark2 (clone-mark mark))) - (when (search-forward mark2 string - :test (lambda (x y) - (if (characterp x) - (and (characterp y) (char-equal x y)) - (eql x y)))) - (setf (offset point) (offset mark2)) - (setf (offset mark) (- (offset mark2) (length string)))))) +(defun isearch-from-mark (pane mark string forwardp) + (flet ((object-equal (x y) + (if (characterp x) + (and (characterp y) (char-equal x y)) + (eql x y)))) + (let* ((point (point pane)) + (mark2 (clone-mark mark)) + (success (funcall (if forwardp #'search-forward #'search-backward) + mark2 + string + :test #'object-equal))) + (cond (success + (setf (offset point) (offset mark2) + (offset mark) (if forwardp + (- (offset mark2) (length string)) + (+ (offset mark2) (length string)))) + (push (make-instance 'isearch-state + :search-string string + :search-mark mark + :search-forward-p forwardp) + (isearch-states pane))) + (t + (beep)))))) + +(define-named-command com-isearch-mode-forward () + (isearch-command-loop (current-window) t)) + +(define-named-command com-isearch-mode-backward () + (isearch-command-loop (current-window) nil)) (define-named-command com-isearch-append-char () (let* ((pane (current-window)) - (point (point pane)) (states (isearch-states pane)) (string (concatenate 'string (search-string (first states)) (string *current-gesture*))) (mark (clone-mark (search-mark (first states)))) - (previous-point-offset (offset point))) - (isearch-from-mark pane mark string) - (if (/= (offset point) previous-point-offset) - (push (make-instance 'isearch-state - :search-string string - :search-mark mark) - (isearch-states pane)) - (beep)))) + (forwardp (search-forward-p (first states)))) + (unless forwardp + (incf (offset mark))) + (isearch-from-mark pane mark string forwardp))) (define-named-command com-isearch-delete-char () (let* ((pane (current-window))) @@ -1056,8 +1070,11 @@ (pop (isearch-states pane)) (let ((state (first (isearch-states pane)))) (setf (offset (point pane)) - (+ (offset (search-mark state)) - (length (search-string state))))))))) + (if (search-forward-p state) + (+ (offset (search-mark state)) + (length (search-string state))) + (- (offset (search-mark state)) + (length (search-string state)))))))))) (define-named-command com-isearch-forward () (let* ((pane (current-window)) @@ -1066,15 +1083,18 @@ (string (if (null (second states)) (isearch-previous-string pane) (search-string (first states)))) - (mark (clone-mark point)) - (previous-point-offset (offset point))) - (isearch-from-mark pane mark string) - (if (/= (offset point) previous-point-offset) - (push (make-instance 'isearch-state - :search-string string - :search-mark mark) - (isearch-states pane)) - (beep)))) + (mark (clone-mark point))) + (isearch-from-mark pane mark string t))) + +(define-named-command com-isearch-backward () + (let* ((pane (current-window)) + (point (point pane)) + (states (isearch-states pane)) + (string (if (null (second states)) + (isearch-previous-string pane) + (search-string (first states)))) + (mark (clone-mark point))) + (isearch-from-mark pane mark string nil))) (define-named-command com-isearch-exit () (setf (isearch-mode (current-window)) nil)) @@ -1197,7 +1217,8 @@ (global-set-key '(#\/ :meta) 'com-dabbrev-expand) (global-set-key '(#\a :control :meta) 'com-beginning-of-paragraph) (global-set-key '(#\e :control :meta) 'com-end-of-paragraph) -(global-set-key '(#\s :control) 'com-isearch-mode) +(global-set-key '(#\s :control) 'com-isearch-mode-forward) +(global-set-key '(#\r :control) 'com-isearch-mode-backward) (global-set-key '(:up) 'com-previous-line) (global-set-key '(:down) 'com-next-line) @@ -1422,4 +1443,4 @@ (isearch-set-key '(#\Newline) 'com-isearch-exit) (isearch-set-key '(#\Backspace) 'com-isearch-delete-char) (isearch-set-key '(#\s :control) 'com-isearch-forward) - +(isearch-set-key '(#\r :control) 'com-isearch-backward) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.38 climacs/packages.lisp:1.39 --- climacs/packages.lisp:1.38 Sun Jan 23 02:21:08 2005 +++ climacs/packages.lisp Sun Jan 23 15:30:34 2005 @@ -98,7 +98,7 @@ #:tab-space-count #:indent-tabs-mode #:auto-fill-mode #:auto-fill-column - #:isearch-state #:search-string #:search-mark + #:isearch-state #:search-string #:search-mark #:search-forward-p #:isearch-mode #:isearch-states #:isearch-previous-string #:url)) Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.11 climacs/pane.lisp:1.12 --- climacs/pane.lisp:1.11 Sun Jan 23 02:21:08 2005 +++ climacs/pane.lisp Sun Jan 23 15:30:35 2005 @@ -48,7 +48,8 @@ (defclass isearch-state () ((search-string :initarg :search-string :accessor search-string) - (search-mark :initarg :search-mark :accessor search-mark))) + (search-mark :initarg :search-mark :accessor search-mark) + (search-forward-p :initarg :search-forward-p :accessor search-forward-p))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

[climacs-cvs] CVS update: climacs/INSTALL
by rstrandh＠common-lisp.net 23 Jan '05

23 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv7225 Modified Files: INSTALL Log Message: Added warning agains using old versions of McCLIM. Date: Sun Jan 23 08:37:30 2005 Author: rstrandh Index: climacs/INSTALL diff -u climacs/INSTALL:1.3 climacs/INSTALL:1.4 --- climacs/INSTALL:1.3 Sat Jan 8 10:07:30 2005 +++ climacs/INSTALL Sun Jan 23 08:37:24 2005 @@ -33,5 +33,12 @@ Start the Climacs editor. +Finally, please notice that as we develop Climacs, we occasionally +find bugs in McCLIM, or ask for functionality of McCLIM that can be +useful to us. + +For that reason, McCLIM often depend on very fresh CVS versions of +McCLIM. If you discover a bug, please try to install a new version of +McCLIM before looking to hard for any other reasons.

1 0