mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 04 Dec '06

04 Dec '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv5240/Drei Modified Files: undo.lisp drei.lisp Log Message: Explicitly define the generic functions of some accessor methods. --- /project/mcclim/cvsroot/mcclim/Drei/undo.lisp 2006/11/19 11:39:45 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/undo.lisp 2006/12/04 10:17:21 1.3 @@ -84,6 +84,10 @@ (defclass undo-record () () (:documentation "The base class for all undo records.")) +(defgeneric undo-tree (record) + (:documentation "The undo tree to which the undo record +`record' belongs.")) + (defclass standard-undo-record (undo-record) ((parent :initform nil :accessor parent) (tree :initform nil --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/11/30 17:33:31 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/12/04 10:17:21 1.10 @@ -128,24 +128,39 @@ ;;; ;;; Undo +(defgeneric undo-tree (buffer) + (:documentation "The undo-tree object associated with the +buffer. This usually contains a record of every change that has +been made to the buffer since it was created.")) + +(defgeneric undo-accumulate (buffer) + (:documentation "A list of the changes that have been made to +`buffer' since the last time undo was added to the undo tree for +the buffer. The list returned by this function is initially +NIL (the empty list). The :before methods on +`insert-buffer-object', `insert-buffer-sequence', and +`delete-buffer-range' push undo records on to this list.")) + +(defgeneric performing-undo (buffer) + (:documentation "If true, the buffer is currently performing an +undo operation. The :before methods on `insert-buffer-object', +`insert-buffer-sequence', and `delete-buffer-range' push undo +records onto the undo accumulator only if `performing-undo' is +false, so that no undo information is added as a result of an +undo operation.")) + (defclass undo-mixin () ((tree :initform (make-instance 'standard-undo-tree) :reader undo-tree :documentation "Returns the undo-tree of the buffer.") (undo-accumulate :initform '() :accessor undo-accumulate - :documentation "The list returned by this -function is initially NIL (the empty list). The :before methods -on `insert-buffer-object', `insert-buffer-sequence', and -`delete-buffer-range' push undo records on to this list.") + :documentation "The undo records created +since the start of the undo context.") (performing-undo :initform nil :accessor performing-undo - :documentation "This is initially NIL. -The :before methods on `insert-buffer-object', -`insert-buffer-sequence', and `delete-buffer-range' push undo -records onto the undo accumulator only if this slot is NIL so -that no undo information is added as a result of an undo -operation.")) + :documentation "True if we are currently +performing undo, false otherwise.")) (:documentation "This is a mixin class that buffer classes can inherit from. It contains an undo tree, an undo accumulator and a flag specifyng whether or not it is currently performing

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 04 Dec '06

04 Dec '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv12103/Drei Modified Files: syntax.lisp Log Message: Syntax-querying-methods should be specialised on syntaxes. --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2006/11/18 21:01:46 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2006/12/04 07:57:36 1.4 @@ -865,9 +865,9 @@ (defgeneric word-constituentp (syntax obj) (:documentation "Return T if `obj' is a word constituent character in `syntax'.") - (:method (syntax obj) + (:method ((syntax syntax) obj) nil) - (:method (syntax (obj character)) + (:method ((syntax syntax) (obj character)) (alphanumericp obj))) (defgeneric whitespacep (syntax obj)

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 04 Dec '06

04 Dec '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv11709 Modified Files: mcclim.asd Log Message: Replaced the old RT-based test suite with a new FiveAM-based one. Also added a fair amount of new tests. What isn't tested is: - CLIM parts - Commands - Syntax module and specific syntaxes (Unfortunately, these are arguably the most interesting things to test). --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/11/19 15:55:34 1.35 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/12/04 07:54:51 1.36 @@ -307,6 +307,31 @@ '(:file "lisp-syntax-swank" :depends-on ("lisp-syntax")) (values)))))) +(defsystem :drei-tests + :depends-on (:drei-mcclim :fiveam) + :components + ((:module "Tests" + :pathname #.(make-pathname :directory '(:relative "Drei" "Tests")) + :components + ((:module + "cl-automaton" + :depends-on ("testing") + :components + ((:file "eqv-hash-tests") + (:file "state-and-transition-tests") + (:file "automaton-tests") + (:file "regexp-tests"))) + (:file "packages") + (:file "testing" :depends-on ("packages")) + (:file "buffer-tests" :depends-on ("testing")) + (:file "base-tests" :depends-on ("testing")) + (:file "kill-ring-tests" :depends-on ("testing")) + (:file "motion-tests" :depends-on ("testing")) + (:file "editing-tests" :depends-on ("testing")) + (:file "core-tests" :depends-on ("testing")) + (:file "rectangle-tests" :depends-on ("testing")) + (:file "undo-tests" :depends-on ("testing")))))) + (defsystem :clim :depends-on (:clim-core :goatee-core :clim-postscript :drei-mcclim) :components

1 0

[mcclim-cvs] CVS mcclim/Drei/Tests/cl-automaton
by thenriksen 04 Dec '06

04 Dec '06

Update of /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton In directory clnet:/tmp/cvs-serv11709/Drei/Tests/cl-automaton Added Files: state-and-transition-tests.lisp regexp-tests.lisp eqv-hash-tests.lisp automaton-tests.lisp Log Message: Replaced the old RT-based test suite with a new FiveAM-based one. Also added a fair amount of new tests. What isn't tested is: - CLIM parts - Commands - Syntax module and specific syntaxes (Unfortunately, these are arguably the most interesting things to test). --- /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton/state-and-transition-tests.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton/state-and-transition-tests.lisp 2006/12/04 07:54:51 1.1 ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic(a)yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas(a)sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) (def-suite state-and-transition-tests :description "The test suite for CL-AUTOMATON state-and-transition related tests.") (in-suite state-and-transition-tests) (test clone.transition (let* ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (t2 (automaton::clone t1))) (is (eqv t1 t2 +equalp-key-situation+)) (is (eql (hash t1 +equalp-key-situation+) (hash t2 +equalp-key-situation+))))) (test transition<.1 (let ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\c) :maxc (char-code #\d) :to (make-instance 'automaton::state))) (automaton::*to-first* nil)) (is-true (automaton::transition< t1 t2)))) (test transition<.2 (let ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\c) :maxc (char-code #\d) :to (make-instance 'automaton::state))) (automaton::*to-first* t)) (setf (automaton::num (automaton::to t1)) 1) (is-true (automaton::transition< t2 t1))) (let ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\d) :to (make-instance 'automaton::state))) (automaton::*to-first* t)) (is-true (automaton::transition< t2 t1)))) (test transition<.3 (let ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\c) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (automaton::*to-first* nil)) (is-true (automaton::transition< t1 t2)))) (test sstep.test-1 (let* ((s (make-instance 'automaton::state)) (tr (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to s))) (htadd (automaton::transitions s) tr) (is (eq (automaton::sstep s #\a) s)))) (test sstep.test-2 (let* ((s (make-instance 'automaton::state)) (tr (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to s))) (htadd (automaton::transitions s) tr) (is-false (automaton::sstep s #\c)))) (test add-epsilon (let* ((s1 (make-instance 'automaton::state)) (s2 (make-instance 'automaton::state)) (tr (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to s2))) (htadd (automaton::transitions s2) tr) (automaton::add-epsilon s1 s2) (is-true (htpresent (automaton::transitions s1) tr)))) (test sorted-transition-vector (let* ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\c) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (s (make-instance 'automaton::state))) (htadd (automaton::transitions s) t1) (htadd (automaton::transitions s) t2) (is (equalp (automaton::sorted-transition-vector s nil) (vector t1 t2))))) (test sorted-transition-list (let* ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\c) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (s (make-instance 'automaton::state))) (htadd (automaton::transitions s) t1) (htadd (automaton::transitions s) t2) (is (equal (automaton::sorted-transition-list s nil) (list t1 t2)))))--- /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton/regexp-tests.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton/regexp-tests.lisp 2006/12/04 07:54:51 1.1 ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic(a)yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas(a)sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) (def-suite regexp-tests :description "The test suite for CL-AUTOMATON regexp related tests.") (in-suite regexp-tests) (automaton-test string-regexp.1 (is-true (regexp-equal (string-regexp "#") (automaton::make-regexp :empty)))) (automaton-test string-regexp.2 (is-true (regexp-equal (string-regexp "foo") (make-instance 'automaton::regexp :kind :string :s "foo"))) (is-true (regexp-equal (string-regexp "\"foo\"") (make-instance 'automaton::regexp :kind :string :s "foo"))) (is-true (regexp-equal (string-regexp "()") (make-instance 'automaton::regexp :kind :string :s "")))) (automaton-test string-regexp.3 (is-true (regexp-equal (string-regexp "c") (make-instance 'automaton::regexp :kind :char :c #\c))) (is-true (regexp-equal (string-regexp "\c") (make-instance 'automaton::regexp :kind :char :c #\c))) (is-true (regexp-equal (string-regexp "\\c") (make-instance 'automaton::regexp :kind :char :c #\c)))) (automaton-test string-regexp.4 (is-true (regexp-equal (string-regexp ".") (automaton::make-regexp :anychar)))) (automaton-test string-regexp.5 (is-true (regexp-equal (string-regexp "@") (automaton::make-regexp :anystring)))) (automaton-test string-regexp.6 (is-true (regexp-equal (string-regexp "<11-15>") (make-instance 'automaton::regexp :kind :interval :minr 11 :maxr 15 :digits 2))) (is-true (regexp-equal (string-regexp "<11-115>") (make-instance 'automaton::regexp :kind :interval :minr 11 :maxr 115 :digits 0))) (is-true (regexp-equal (string-regexp "<115-11>") (make-instance 'automaton::regexp :kind :interval :minr 11 :maxr 115 :digits 0)))) (automaton-test string-regexp.7 (is-true (regexp-equal (string-regexp "<sub>") (make-instance 'automaton::regexp :kind :automaton :s "sub")))) (automaton-test string-regexp.8 (is-true (regexp-equal (string-regexp "[a-z]") (make-instance 'automaton::regexp :kind :char-range :from #\a :to #\z))) (is-true (regexp-equal (string-regexp "[a]") (make-instance 'automaton::regexp :kind :char :c #\a)))) (automaton-test string-regexp.9 (is-true (regexp-equal (string-regexp "[a][b][c]") (make-instance 'automaton::regexp :kind :string :s "abc")))) (automaton-test string-regexp.10 (is-true (regexp-equal (string-regexp "[ab]") (automaton::make-regexp :union (make-instance 'automaton::regexp :kind :char :c #\a) (make-instance 'automaton::regexp :kind :char :c #\b))))) (automaton-test string-regexp.11 (is-true (regexp-equal (string-regexp "[^a-c0-3]") (automaton::make-regexp :intersection (automaton::make-regexp :anychar) (automaton::make-regexp :complement (automaton::make-regexp :union (make-instance 'automaton::regexp :kind :char-range :from #\a :to #\c) (make-instance 'automaton::regexp :kind :char-range :from #\0 :to #\3)))))) (is-true (regexp-equal (string-regexp "[a^b-c]") (automaton::make-regexp :union (automaton::make-regexp :union (make-instance 'automaton::regexp :kind :char :c #\a) (make-instance 'automaton::regexp :kind :char :c #\^)) (make-instance 'automaton::regexp :kind :char-range :from #\b :to #\c))))) (automaton-test string-regexp.12 (is-true (regexp-equal (string-regexp "~[a-c]") (automaton::make-regexp :complement (make-instance 'automaton::regexp :kind :char-range :from #\a :to #\c))))) (automaton-test string-regexp.13 (is-true (regexp-equal (string-regexp "f?") (automaton::make-regexp :optional (make-instance 'automaton::regexp :kind :char :c #\f))))) (automaton-test string-regexp.14 (is-true (regexp-equal (string-regexp "(\"foo\")?") (automaton::make-regexp :optional (make-instance 'automaton::regexp :kind :string :s "foo"))))) (automaton-test string-regexp.15 (is-true (regexp-equal (string-regexp "[a-c]*") (automaton::make-regexp :repeat (make-instance 'automaton::regexp :kind :char-range :from #\a :to #\c))))) (automaton-test string-regexp.16 (is-true (regexp-equal (string-regexp "(\"foo\")+") (make-instance 'automaton::regexp :kind :repeat-min :exp1 (make-instance 'automaton::regexp :kind :string :s "foo") :minr 1)))) (automaton-test string-regexp.17 (is-true (regexp-equal (string-regexp "[a-c]{3}") (make-instance 'automaton::regexp :kind :repeat-minmax :exp1 (make-instance 'automaton::regexp :kind :char-range :from #\a :to #\c) :minr 3 :maxr 3)))) (automaton-test string-regexp.18 (is-true (regexp-equal (string-regexp "(~c){1,2}") (make-instance 'automaton::regexp :kind :repeat-minmax :exp1 (automaton::make-regexp :complement (make-instance 'automaton::regexp :kind :char :c #\c)) :minr 1 :maxr 2)))) (automaton-test string-regexp.19 (is-true (regexp-equal (string-regexp "[a-z]~[0-9]") (automaton::make-regexp :concatenation (make-instance 'automaton::regexp :kind :char-range :from #\a :to #\z) (automaton::make-regexp :complement (make-instance 'automaton::regexp :kind :char-range :from #\0 :to #\9)))))) (automaton-test string-regexp.20 (is-true (regexp-equal (string-regexp "(ab+)&(a+b)|c") (automaton::make-regexp :union (automaton::make-regexp :intersection (automaton::make-regexp :concatenation (make-instance 'automaton::regexp :kind :char :c #\a) (make-instance 'automaton::regexp :kind :repeat-min :exp1 (make-instance 'automaton::regexp :kind :char :c #\b) :minr 1)) (automaton::make-regexp :concatenation (make-instance 'automaton::regexp :kind :repeat-min :exp1 (make-instance 'automaton::regexp :kind :char :c #\a) :minr 1) (make-instance 'automaton::regexp :kind :char :c #\b))) (make-instance 'automaton::regexp :kind :char :c #\c))))) (automaton-test string-regexp.21 (is-true (regexp-equal (string-regexp "a\"b\"+c") (automaton::make-regexp :concatenation (make-instance 'automaton::regexp :kind :char :c #\a) (automaton::make-regexp :concatenation (make-instance 'automaton::regexp :kind :repeat-min :exp1 (make-instance 'automaton::regexp :kind :string :s "b") :minr 1) (make-instance 'automaton::regexp :kind :char :c #\c)))))) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton/eqv-hash-tests.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton/eqv-hash-tests.lisp 2006/12/04 07:54:51 1.1 ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic(a)yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas(a)sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) (def-suite eqv-hash-tests :description "The test suite for CL-AUTOMATON eqv-hash related tests.") (in-suite eqv-hash-tests) (defclass foo () ((slot1 :initform 0 :initarg :slot1 :type fixnum :accessor slot1) (slot2 :initform 0 :initarg :slot2 :type fixnum :accessor slot2))) (defclass foo-intention (equalp-key-situation) ()) (defparameter +foo-intention+ (make-instance 'foo-intention)) (defmethod eqv ((foo1 foo) (foo2 foo) (s (eql +foo-intention+))) (eql (slot1 foo1) (slot1 foo2))) (defmethod hash ((foo1 foo) (s (eql +foo-intention+))) (floor (slot1 foo1) 2)) (test htref.test-1 ; (eqv i1 i2), (= (hash i1) (hash i2)) (let ((ght (make-generalized-hash-table +foo-intention+)) (i1 (make-instance 'foo :slot1 1 :slot2 2)) (i2 (make-instance 'foo :slot1 1 :slot2 3))) (setf (htref ght i1) i1) (setf (htref ght i2) i2) (is (= (cnt ght) 1)) (is (eq (htref ght i1) i2)) (is (htref ght i2) i2))) [143 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton/automaton-tests.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton/automaton-tests.lisp 2006/12/04 07:54:51 1.1 [439 lines skipped]

1 0

[mcclim-cvs] CVS mcclim/Drei/Tests
by thenriksen 04 Dec '06

04 Dec '06

Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv11709/Drei/Tests Added Files: undo-tests.lisp testing.lisp rectangle-tests.lisp packages.lisp motion-tests.lisp kill-ring-tests.lisp editing-tests.lisp core-tests.lisp buffer-tests.lisp base-tests.lisp Log Message: Replaced the old RT-based test suite with a new FiveAM-based one. Also added a fair amount of new tests. What isn't tested is: - CLIM parts - Commands - Syntax module and specific syntaxes (Unfortunately, these are arguably the most interesting things to test). --- /project/mcclim/cvsroot/mcclim/Drei/Tests/undo-tests.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/undo-tests.lisp 2006/12/04 07:54:51 1.1 ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas(a)sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) (def-suite undo-tests :description "The test suite for tests related to Drei's undo system.") (in-suite undo-tests) (defclass test-undo-record (standard-undo-record) ()) (defmethod flip-undo-record ((record test-undo-record))) (test add-undo (let ((tree (make-instance 'standard-undo-tree))) (finishes (add-undo (make-instance 'test-undo-record) tree)) (finishes (add-undo (make-instance 'test-undo-record) tree)))) (test undo (let ((tree (make-instance 'standard-undo-tree))) (add-undo (make-instance 'test-undo-record) tree) (add-undo (make-instance 'test-undo-record) tree) (finishes (undo tree 2)) (signals no-more-undo (undo tree 1)))) (test redo (let ((tree (make-instance 'standard-undo-tree))) (add-undo (make-instance 'test-undo-record) tree) (undo tree 1) (redo tree 1) (finishes (undo tree 1)))) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/testing.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/testing.lisp 2006/12/04 07:54:51 1.1 ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic(a)yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas(a)sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) ;; Define some stuff to ease the pain of writing repetitive test ;; cases. Also provide test-running entry point. (defclass delegating-standard-buffer (delegating-buffer) () (:default-initargs :implementation (make-instance 'standard-buffer))) (eval-when (:load-toplevel :compile-toplevel :execute) (defparameter *buffer-classes* '((standard-buffer) (delegating-standard-buffer) (binseq-buffer persistent-left-sticky-mark persistent-right-sticky-mark) (obinseq-buffer persistent-left-sticky-mark persistent-right-sticky-mark) (binseq2-buffer persistent-left-sticky-line-mark persistent-right-sticky-line-mark)))) (defmacro buffer-test (name &body body) "Define FiveAM tests for all the standard buffer classes. %%BUFFER in `body' will be substituted for a buffer class, %%LEFT-STICKY-MARK will be substituted for a left-sticky-mark class and %%RIGHT-STICKY-MARK will be substituted for a right sticky mark class." (let (result) (dolist (class-spec *buffer-classes*) (destructuring-bind (buffer &optional (left-sticky-mark 'standard-left-sticky-mark) (right-sticky-mark 'standard-right-sticky-mark)) class-spec (let ((alist (list (cons '%%buffer `',buffer) (cons '%%left-sticky-mark `',left-sticky-mark) (cons '%%right-sticky-mark `',right-sticky-mark)))) (push `(test ,(intern (concatenate 'string (symbol-name buffer) "-" (symbol-name name))) ,@(sublis alist body)) result)))) (list* 'progn result))) (defmacro with-buffer ((buffer &key (syntax ''drei-fundamental-syntax:fundamental-syntax) (initial-contents "")) &body body) `(let ((,buffer (make-instance 'drei-buffer :syntax ,syntax :initial-contents ,initial-contents))) (update-syntax ,buffer (syntax ,buffer)) ,@body)) (defun buffer-contents (&optional (buffer *current-buffer*)) "The contents of `*current-buffer*' as a string." (buffer-substring buffer 0 (size buffer))) (defun buffer-is (string &optional (buffer *current-buffer*) (begin-offset 0) (end-offset (size buffer))) "Check (using FiveAM) whether `buffer' contains `string' in the subsequence delimited by `begin-offset' and `end-offset'." (is (string= (buffer-substring buffer begin-offset end-offset) string))) (defclass test-drei (drei) () (:documentation "An instantiable Drei variant with no display. Used for testing.")) (defmacro with-drei-environment ((&key (initial-contents "") (syntax ''drei-fundamental-syntax:fundamental-syntax)) &body body) (with-gensyms (buffer drei) `(with-buffer (,buffer :initial-contents ,initial-contents :syntax ,syntax) (let ((,drei (make-instance 'test-drei :buffer ,buffer))) (with-bound-drei-special-variables (,drei :minibuffer nil) ,@body))))) (defun run-tests () (format t "Testing buffer protocol implementation(s)~%") (run! 'buffer-tests) (format t "Testing basic functions~%") (run! 'base-tests) (format t "Testing the kill ring~%") (run! 'kill-ring-tests) (format t "Testing mark motion~%") (run! 'motion-tests) (format t "Testing text editing functions~%") (run! 'editing-tests) (format t "Testing miscellaneus editor functions~%") (run! 'core-tests) (format t "Testing rectangle editing~%") (run! 'rectangle-tests) (format t "Testing undo~%") (run! 'undo-tests) (format t "Running the CL-AUTOMATON tests~%") (format t "Testing regular expressions~%") (run! 'regexp-tests) (format t "Testing eqv-hash~%") (run! 'eqv-hash-tests) (format t "Testing states and transitions~%") (run! 'state-and-transition-tests) (format t "Testing core automata functions~%") (run! 'automaton-tests)) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/rectangle-tests.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/rectangle-tests.lisp 2006/12/04 07:54:51 1.1 ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas(a)sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) (def-suite rectangle-tests :description "The test suite for rectangle-editing related tests.") (in-suite rectangle-tests) (test map-rectangle-lines (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (macrolet ((check (startcol endcol) `(progn (is-true (beginning-of-line-p mark)) (is (= (line-number mark) (incf line))) (is (> 4 line)) (is (= startcol ,startcol)) (is (= endcol ,endcol))))) (beginning-of-buffer *current-point*) (end-of-buffer *current-mark*) (let ((line -1)) (map-rectangle-lines *current-buffer* #'(lambda (mark startcol endcol) (check 0 16)) *current-point* *current-mark*) (is (= line 3))) (let ((line -1)) (map-rectangle-lines *current-buffer* #'(lambda (mark startcol endcol) (check 0 16)) *current-mark* *current-point*) (is (= line 3))) (setf (offset *current-point*) 2) (setf (offset *current-mark*) 63) (let ((line -1)) (map-rectangle-lines *current-buffer* #'(lambda (mark startcol endcol) (check 2 13)) *current-point* *current-mark*) (is (= line 3))) (let ((line -1)) (map-rectangle-lines *current-buffer* #'(lambda (mark startcol endcol) (check 2 13)) *current-mark* *current-point*) (is (= line 3))) (beginning-of-buffer *current-point*) (beginning-of-buffer *current-mark*) (let ((line -1)) (map-rectangle-lines *current-buffer* #'(lambda (mark startcol endcol) (check 0 0)) *current-point* *current-mark*) (is (= line 0)))))) (test extract-and-delete-rectangle-line (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer *current-point*) (end-of-buffer *current-mark*) (is (equal (map-rectangle-lines *current-buffer* #'extract-and-delete-rectangle-line *current-point* *current-mark*) '("Line number one " "Line number two " "Line number thre" "Line number four"))) (buffer-is " e ")) (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer *current-point*) (end-of-buffer *current-mark*) (beginning-of-line *current-mark*) (is (equal (map-rectangle-lines *current-buffer* #'extract-and-delete-rectangle-line *current-point* *current-mark*) '("" "" "" ""))) (buffer-is "Line number one Line number two Line number three Line number four")) (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer *current-point*) (forward-line *current-point* *current-syntax*) (forward-object *current-point* 5) (end-of-buffer *current-mark*) (backward-line *current-mark* *current-syntax*) (beginning-of-line *current-mark*) (forward-object *current-mark* 12) (is (equal (map-rectangle-lines *current-buffer* #'extract-and-delete-rectangle-line *current-point* *current-mark*) '("number " "number "))) (buffer-is "Line number one Line two Line three Line number four"))) (test open-rectangle-line (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer *current-point*) (end-of-buffer *current-mark*) (map-rectangle-lines *current-buffer* #'open-rectangle-line *current-point* *current-mark*) (buffer-is " Line number one Line number two Line number three Line number four")) (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer *current-point*) (end-of-buffer *current-mark*) (beginning-of-line *current-mark*) (map-rectangle-lines *current-buffer* #'open-rectangle-line *current-point* *current-mark*) (buffer-is "Line number one Line number two Line number three Line number four")) (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer *current-point*) (forward-line *current-point* *current-syntax*) (forward-object *current-point* 5) (end-of-buffer *current-mark*) (backward-line *current-mark* *current-syntax*) (beginning-of-line *current-mark*) (forward-object *current-mark* 12) (map-rectangle-lines *current-buffer* #'open-rectangle-line *current-point* *current-mark*) (buffer-is "Line number one Line number two Line number three Line number four"))) (test clear-rectangle-line (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer *current-point*) (end-of-buffer *current-mark*) (map-rectangle-lines *current-buffer* #'clear-rectangle-line *current-point* *current-mark*) (buffer-is " e ")) (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer *current-point*) (end-of-buffer *current-mark*) (beginning-of-line *current-mark*) (map-rectangle-lines *current-buffer* #'clear-rectangle-line *current-point* *current-mark*) (buffer-is "Line number one Line number two Line number three Line number four")) (with-drei-environment (:initial-contents "Line number one [234 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Tests/packages.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/packages.lisp 2006/12/04 07:54:51 1.1 [267 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Tests/motion-tests.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/motion-tests.lisp 2006/12/04 07:54:51 1.1 [583 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Tests/kill-ring-tests.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/kill-ring-tests.lisp 2006/12/04 07:54:51 1.1 [702 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Tests/editing-tests.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/editing-tests.lisp 2006/12/04 07:54:51 1.1 [1117 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Tests/core-tests.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/core-tests.lisp 2006/12/04 07:54:51 1.1 [1503 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Tests/buffer-tests.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/buffer-tests.lisp 2006/12/04 07:54:51 1.1 [2397 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Tests/base-tests.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/base-tests.lisp 2006/12/04 07:54:51 1.1 [3252 lines skipped]

1 0

[mcclim-cvs] CVS mcclim/Drei/Tests/cl-automaton
by thenriksen 04 Dec '06

04 Dec '06

Update of /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton In directory clnet:/tmp/cvs-serv11497/Drei/Tests/cl-automaton Log Message: Directory /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton added to the repository

1 0

[mcclim-cvs] CVS mcclim/Drei/Tests
by thenriksen 04 Dec '06

04 Dec '06

Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv11404/Drei/Tests Log Message: Directory /project/mcclim/cvsroot/mcclim/Drei/Tests added to the repository

1 0

[mcclim-cvs] CVS mcclim/Drei/cl-automaton
by thenriksen 04 Dec '06

04 Dec '06

Update of /project/mcclim/cvsroot/mcclim/Drei/cl-automaton In directory clnet:/tmp/cvs-serv11067/Drei/cl-automaton Removed Files: state-and-transition-test.lisp eqv-hash-test.lisp automaton-test.lisp automaton-test-package.lisp Log Message: Removed old RT-based tests.

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 04 Dec '06

04 Dec '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv11067/Drei Removed Files: kill-ring-test.lisp drei.asd buffer-test.lisp base-test.lisp Log Message: Removed old RT-based tests.

1 0

[mcclim-cvs] CVS mcclim/Apps/Listener
by ahefner 03 Dec '06

03 Dec '06

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv20883 Modified Files: dev-commands.lisp listener.lisp Log Message: If we're going to present the package portion of the prompt, we might as well define a translator to do something useful with it (or am I missing the point?). While we're at it, present the package in the wholine-pane, and add a popup to choose a new package. Also, added discussion of presentation of values at the REPL, as I'm not entirely happy with the current behavior, but leave it unchanged for the moment. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/11/21 20:34:40 1.38 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/12/03 22:56:46 1.39 @@ -23,7 +23,7 @@ (define-command-table application-commands) -(define-command-table lisp-dev-commands :inherit-from nil) ;; "Abstract" command table used for defining some translators in +(define-command-table lisp-dev-commands :inherit-from nil) ;; Translators live here (define-command-table lisp-commands :inherit-from (lisp-dev-commands)) (define-command-table show-commands :inherit-from (lisp-dev-commands)) @@ -519,11 +519,11 @@ ((class-spec 'class-name :prompt "class") &key (orientation 'keyword :prompt "orientation" :default :horizontal)) - (let ((class (frob-to-class class-spec))) - (if (not (null class)) + (let ((class (frob-to-class class-spec))) + (if (not (null class)) (class-grapher *standard-output* class #'clim-mop:class-direct-subclasses :orientation orientation) - (note "~A is not a defined class." class-spec)))) + (note "~A is not a defined class." class-spec)))) ; Lookup direct slots from along the CPL given a class and a slot name. @@ -1261,7 +1261,7 @@ ;; So.. yeah. (defun automagic-translator (pathname) - "Returns values, the command translation, and a documentation string for the translation." + "Returns 2 values: the command translation, and a documentation string for the translation." (cond ((wild-pathname-p pathname) (values `(com-show-directory ,pathname) "Show Matching Files" @@ -1443,26 +1443,47 @@ ;;; Eval (defun display-evalues (values) - (with-drawing-options (t :ink +olivedrab+) - (cond ((null values) - (format t "No values.~%")) - ((= 1 (length values)) - (let ((o (first values))) - (with-output-as-presentation (t o (presentation-type-of o) - :single-box t) - (present (first values) 'expression))) - (fresh-line)) - (t (do* ((i 0 (1+ i)) - (items values (rest items)) - (o (first items) (first items))) - ((null items)) + (labels + ((present-value (value) + ;; I would really prefer this to behave as below, as presenting + ;; things as expressions causes translators applicable to expression + ;; to override those which would be otherwise applicable (such as + ;; the set-current-package translator). I retain the use of w-o-a-p, + ;; swapping the inner/outer presentation types, with the assumption + ;; that someone (the form reader?) really does want expressions, and + ;; the presentation-type-of is seldom a subtype of expression. + ;; Aside from that, the problem with my code below is that it + ;; will use the default presentation method for the type, which will + ;; not necessarily print in the fashion expected from the lisp REPL. + ;; Possibly this +listener-view+ could save the day here, but I'm + ;; unclear on why it exists. --Hefner + + ;; Okay, set-current-package translator now mysteriously works, but + ;; I stand by the notion that 'expression should not be the type of + ;; the innermost presentation. + + #+(or) + (with-output-as-presentation (t value 'expression :single-box t) + (present value (presentation-type-of value) :single-box t)) + + (with-output-as-presentation (t value (presentation-type-of value) + :single-box t) + (present (first values) 'expression)))) + (with-drawing-options (t :ink +olivedrab+) + (cond ((null values) + (format t "No values.~%")) + ((= 1 (length values)) + (present-value (first values)) + (fresh-line)) + (t (do* ((i 0 (1+ i)) + (items values (rest items)) + (object (first items) (first items))) + ((null items)) (with-drawing-options (t :ink +limegreen+) (with-text-style (t (make-text-style nil :italic :small)) (format t "~A " i))) - (with-output-as-presentation (t o (presentation-type-of o) - :single-box t) - (present o 'expression)) - (fresh-line)))))) + (present-value object) + (fresh-line))))))) (defun shuffle-specials (form values) (setf +++ ++ @@ -1476,7 +1497,7 @@ * (first values))) (define-command (com-eval :menu t :command-table lisp-commands) - ((form 'clim:form :prompt "form")) + ((form 'clim:form :prompt "form")) (let* ((- form) (values (multiple-value-list (eval form)))) (fresh-line) @@ -1563,3 +1584,14 @@ :provide-output-destination-keyword nil) ((p 'package)) (setf *package* p)) + +(define-presentation-to-command-translator set-current-package + (package com-set-package lisp-commands + :pointer-documentation ((object stream) + (format stream "Set current package to ~A" (package-name object))) + :documentation ((stream) (format stream "Set Package")) + :menu t + :tester ((object) (not (eql *package* object)))) + (object) + (list object)) + --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/11/21 22:39:32 1.30 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/12/03 22:56:46 1.31 @@ -19,6 +19,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. +(define-presentation-type listener-current-package () :inherit-from 'package) ;; Wholine Pane @@ -92,7 +93,8 @@ (cell (:left) (format t "~A@~A" username sitename)) (cell (:center) (format t "Package ") - (print-package-name t)) + (with-output-as-presentation (t *package* 'listener-current-package) + (print-package-name t))) (cell (:center) (when (probe-file *default-pathname-defaults*) (with-output-as-presentation (t (truename *default-pathname-defaults*) 'pathname) @@ -163,7 +165,7 @@ (defmethod stream-present :around ((stream listener-interactor-pane) object type &rest args &key (single-box nil sbp) &allow-other-keys) - (apply #'call-next-method stream object type :single-box t args) + (apply #'call-next-method stream object type :single-box t args) ;; we would do this, but CLIM:PRESENT calls STREAM-PRESENT with all ;; the keyword arguments explicitly. *sigh*. #+nil @@ -199,6 +201,29 @@ doc wholine)))) +;;; Package selection popup + +(define-listener-command (com-choose-package) + () + (let ((new-package (menu-choose (sort (mapcar (lambda (package) (cons (package-name package) + package)) + (list-all-packages)) + #'string< + :key #'car) + :label "Choose Package"))) + (when new-package + (setf *package* new-package)))) + +(define-presentation-to-command-translator choose-package-translator + (listener-current-package com-choose-package listener + :echo nil + :priority 100 ; These presentations appear in exactly one context, so give this a high priority. + :documentation ((object stream) + (declare (ignore object)) + (format stream "Choose package"))) + (current-package) + nil) + ;;; Lisp listener command loop (defmethod read-frame-command ((frame listener) &key (stream *standard-input*))

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs