mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

[mcclim-cvs] CVS mcclim/Drei/Tests
by thenriksen 15 Aug '07

15 Aug '07

Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv25734/Drei/Tests Modified Files: undo-tests.lisp testing.lisp rectangle-tests.lisp motion-tests.lisp lisp-syntax-tests.lisp kill-ring-tests.lisp editing-tests.lisp core-tests.lisp buffer-tests.lisp buffer-streams-tests.lisp base-tests.lisp Log Message: Revamped the Drei test suite infrastructure slightly. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/undo-tests.lisp 2006/12/04 07:54:51 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/undo-tests.lisp 2007/08/15 10:03:32 1.2 @@ -21,7 +21,7 @@ (cl:in-package :drei-tests) (def-suite undo-tests :description "The test suite for tests -related to Drei's undo system.") +related to Drei's undo system." :in drei-tests) (in-suite undo-tests) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/testing.lisp 2007/02/17 17:54:06 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/testing.lisp 2007/08/15 10:03:32 1.5 @@ -23,7 +23,7 @@ (cl:in-package :drei-tests) ;; Define some stuff to ease the pain of writing repetitive test -;; cases. Also provide test-running entry point. +;; cases. Also provide global test-suite and test-running entry point. (defclass delegating-standard-buffer (delegating-buffer) () (:default-initargs :implementation (make-instance 'standard-buffer))) @@ -93,34 +93,11 @@ (with-bound-drei-special-variables (,drei :minibuffer nil) ,@body))))) +(def-suite drei-tests :description "The test suite for all Drei +test cases. Has nested test suites for the actual tests.") + (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 buffer-based gray streams~%") - (run! 'buffer-streams-tests) - (format t "Testing rectangle editing~%") - (run! 'rectangle-tests) - (format t "Testing undo~%") - (run! 'undo-tests) - (format t "Testing the Lisp syntax module~%") - (run! 'lisp-syntax-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)) + "Run the Drei test suite. A dot will be printed for each passed +test, a \"f\" for each failed test, a \"X\" for each test that +causes an error, and an \"s\" for each skipped test." + (run! 'drei-tests)) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/rectangle-tests.lisp 2006/12/04 07:54:51 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/rectangle-tests.lisp 2007/08/15 10:03:32 1.2 @@ -21,7 +21,7 @@ (cl:in-package :drei-tests) (def-suite rectangle-tests :description "The test suite for -rectangle-editing related tests.") +rectangle-editing related tests." :in drei-tests) (in-suite rectangle-tests) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/motion-tests.lisp 2007/04/27 21:37:15 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/motion-tests.lisp 2007/08/15 10:03:32 1.4 @@ -22,7 +22,7 @@ (cl:in-package :drei-tests) (def-suite motion-tests :description "The test suite for -DREI-MOTION related tests.") +DREI-MOTION related tests." :in drei-tests) (in-suite motion-tests) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2007/08/13 21:58:43 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2007/08/15 10:03:32 1.6 @@ -25,7 +25,7 @@ explicitly tested. Instead, it is hoped that any defects will be caught by other test cases, all of which depend on correct parsing. Also, redisplay is not tested, because no-one has any -idea how to do it.") +idea how to do it." :in drei-tests) (in-suite lisp-syntax-tests) @@ -1797,6 +1797,7 @@ ;; Also, as fun as infinite recursion would be... disable this ;; test before running the suite. (let ((*run-self-compilation-test* nil)) - (format t "Re-running Drei test suite with newly evaluated Drei definitions~%") - (run-tests))) + (format *test-dribble* "~%Re-running Drei test suite with newly evaluated Drei definitions~%") + (is-true (results-status (let ((fiveam:*test-dribble* (make-broadcast-stream))) + (fiveam:run 'drei-tests)))))) (skip "Sensibly skipping self-compilation test. Set DREI-TESTS:*RUN-SELF-COMPILATION-TEST* to true if you don't want to skip it"))) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/kill-ring-tests.lisp 2006/12/04 07:54:51 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/kill-ring-tests.lisp 2007/08/15 10:03:32 1.2 @@ -27,7 +27,7 @@ (in-package :drei-tests) (def-suite kill-ring-tests :description "The test suite for DREI-KILL-RING -related tests.") +related tests." :in drei-tests) (in-suite kill-ring-tests) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/editing-tests.lisp 2006/12/04 07:54:51 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/editing-tests.lisp 2007/08/15 10:03:32 1.2 @@ -23,7 +23,7 @@ (cl:in-package :drei-tests) (def-suite editing-tests :description "The test suite for -DREI-EDITING related tests.") +DREI-EDITING related tests." :in drei-tests) (in-suite editing-tests) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/core-tests.lisp 2007/02/13 12:14:11 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/core-tests.lisp 2007/08/15 10:03:32 1.4 @@ -23,7 +23,7 @@ (cl:in-package :drei-tests) (def-suite core-tests :description "The test suite for -DREI-CORE related tests.") +DREI-CORE related tests." :in drei-tests) (in-suite core-tests) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/buffer-tests.lisp 2006/12/04 07:54:51 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/buffer-tests.lisp 2007/08/15 10:03:32 1.2 @@ -28,7 +28,7 @@ (cl:in-package :drei-tests) (def-suite buffer-tests :description "The test suite for -buffer-protocol related tests.") +buffer-protocol related tests." :in drei-tests) (in-suite buffer-tests) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/buffer-streams-tests.lisp 2007/01/15 11:35:53 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/buffer-streams-tests.lisp 2007/08/15 10:03:32 1.2 @@ -23,7 +23,7 @@ (cl:in-package :drei-tests) (def-suite buffer-streams-tests :description "The test suite for -buffer-streams related tests.") +buffer-streams related tests." :in drei-tests) (in-suite buffer-streams-tests) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/base-tests.lisp 2007/02/13 12:14:11 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/base-tests.lisp 2007/08/15 10:03:32 1.3 @@ -26,7 +26,7 @@ (cl:in-package :drei-tests) (def-suite base-tests :description "The test suite for DREI-BASE -related tests.") +related tests." :in drei-tests) (in-suite base-tests)

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 15 Aug '07

15 Aug '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv25734 Modified Files: mcclim.asd Log Message: Revamped the Drei test suite infrastructure slightly. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/08/13 21:58:46 1.57 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/08/15 10:03:32 1.58 @@ -327,10 +327,10 @@ "cl-automaton" :depends-on ("testing") :components - ((:file "eqv-hash-tests") - (:file "state-and-transition-tests") - (:file "automaton-tests") - (:file "regexp-tests"))) + ((:file "automaton-tests") + (:file "state-and-transition-tests" :depends-on ("automaton-tests")) + (:file "eqv-hash-tests" :depends-on ("automaton-tests")) + (:file "regexp-tests" :depends-on ("automaton-tests")))) (:file "packages") (:file "testing" :depends-on ("packages")) (:file "buffer-tests" :depends-on ("testing"))

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 13 Aug '07

13 Aug '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv19592 Modified Files: mcclim.asd Log Message: Revised Lisp syntax module, making a bunch of improvements and added handling of even the craziest lambda lists. Now conses more! --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/04/27 21:37:14 1.56 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/08/13 21:58:46 1.57 @@ -342,7 +342,8 @@ (:file "buffer-streams-tests" :depends-on ("testing")) (:file "rectangle-tests" :depends-on ("testing")) (:file "undo-tests" :depends-on ("testing")) - (:file "lisp-syntax-tests" :depends-on ("testing" "motion-tests")))))) + (:file "lisp-syntax-tests" :depends-on ("testing" "motion-tests")) + (:file "lisp-syntax-swine-tests" :depends-on ("lisp-syntax-tests")))))) (defsystem :clim :depends-on (:clim-core :goatee-core :clim-postscript :drei-mcclim)

1 0

[mcclim-cvs] CVS mcclim/Drei/Tests
by thenriksen 13 Aug '07

13 Aug '07

Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv19592/Drei/Tests Modified Files: lisp-syntax-tests.lisp Added Files: lisp-syntax-swine-tests.lisp Log Message: Revised Lisp syntax module, making a bunch of improvements and added handling of even the craziest lambda lists. Now conses more! --- /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2007/02/17 17:54:06 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2007/08/13 21:58:43 1.5 @@ -53,6 +53,15 @@ (get-form) args))) ,@body)))))) +(defmacro swine-test (name &body body) + `(test ,name + ,(when (stringp (first body)) + (first body)) + (if (eq (drei-lisp-syntax::default-image) t) + (skip "No useful image link found") + (progn + ,@body)))) + (defmacro testing-symbol ((sym-sym &rest args) &body body) `(let ((,sym-sym (get-object ,@args))) ,@body @@ -60,7 +69,9 @@ (eq (symbol-package sym) (find-package :clim)) (eq (symbol-package sym) - (find-package :common-lisp))) + (find-package :common-lisp)) + (eq (symbol-package sym) + (find-package :keyword))) (unintern ,sym-sym (symbol-package sym))))) (defmacro testing-lisp-syntax-symbol ((buffer-contents sym-sym &rest args) @@ -582,7 +593,37 @@ ) ") (test-selector-null drei-lisp-syntax::form-before 0) (test-selector-null drei-lisp-syntax::form-before 4) - (test-selector drei-lisp-syntax::form-before 5 'list))) + (test-selector drei-lisp-syntax::form-before 5 'list)) + (testing-form-selectors ("'(list #|foo|# foo #|bar|# bar + baz ; baz indeed +) ") + (test-selector-null drei-lisp-syntax::form-before 0) + (test-selector-null drei-lisp-syntax::form-before 5) + (test-selector drei-lisp-syntax::form-before 6 'list)) + (testing-form-selectors ("#(list #|foo|# foo #|bar|# bar + baz ; baz indeed +) ") + (test-selector-null drei-lisp-syntax::form-before 0) + (test-selector-null drei-lisp-syntax::form-before 5) + (test-selector drei-lisp-syntax::form-before 6 'list)) + (testing-form-selectors ("(list #|foo|# list #|bar|# find + list ; baz indeed + ") + (test-selector drei-lisp-syntax::form-before 53 'list) + (test-selector drei-lisp-syntax::form-before 43 'list) + (test-selector drei-lisp-syntax::form-before 33 'find)) + (testing-form-selectors ("'(list #|foo|# list #|bar|# find + list ; baz indeed + ") + (test-selector drei-lisp-syntax::form-before 54 'list) + (test-selector drei-lisp-syntax::form-before 44 'list) + (test-selector drei-lisp-syntax::form-before 34 'find)) + (testing-form-selectors ("#(list #|foo|# list #|bar|# find + list ; baz indeed + ") + (test-selector drei-lisp-syntax::form-before 54 'list) + (test-selector drei-lisp-syntax::form-before 44 'list) + (test-selector drei-lisp-syntax::form-before 34 'find))) (test form-after "Test the `form-after' form selector of Lisp syntax." @@ -830,9 +871,9 @@ (is-true (drei-lisp-syntax::in-comment-p 60 *current-syntax*)) (is-false (drei-lisp-syntax::in-comment-p 69 *current-syntax*)))) -;; For the arglist fetching tests, we need some dummy functions and -;; macros whose arglists we can be sure of. We define those here. We -;; also hope we don't clobber anything important. +;; For some tests, we need various functions, classes and +;; macros. Define them here and pray we don't clobber anything +;; important. (defun lisp-syntax-f1 ()) (defun lisp-syntax-f2 (l) (declare (ignore l))) @@ -842,18 +883,519 @@ &body forms-decls) ; with-output-to-string (declare (ignore var string element-type forms-decls))) -(defmacro swine-test (name &body body) - `(test ,name - (if (eq (drei-lisp-syntax::default-image) t) - (skip "No useful image link found") - (progn - ,@body)))) +(defmacro lisp-syntax-m2 (&key ((:a (a b c &key d)))) + (declare (ignore a b c d))) + +(defclass lisp-syntax-c1 () + ((foo :initarg :foo) + (bar :initarg bar))) + +(defclass lisp-syntax-c2 (lisp-syntax-c1) + ((baz :initarg :foo))) + +(test parse-lambda-list-1 + "Test that `parse-lambda-list' can correctly parse ordinary and +macro lambda lists with no parameters." + (let ((oll (parse-lambda-list '())) + (mll (parse-lambda-list '() 'macro-lambda-list))) + (is-true (typep oll 'ordinary-lambda-list)) + (is-true (null (required-parameters oll))) + (is-true (null (optional-parameters oll))) + (is-true (null (keyword-parameters oll))) + (is-true (null (rest-parameter oll))) + + (is-true (typep mll 'macro-lambda-list)) + (is-true (null (required-parameters mll))) + (is-true (null (optional-parameters mll))) + (is-true (null (keyword-parameters mll))) + (is-true (null (rest-parameter mll))) + (is-true (null (body-parameter mll))))) + +(test parse-lambda-list-2 + "Test that `parse-lambda-list' can correctly parse ordinary and +macro lambda lists with only required parameters." + (let ((oll1 (parse-lambda-list '(list))) + (oll2 (parse-lambda-list '(list find))) + (mll1 (parse-lambda-list '(list) 'macro-lambda-list)) + (mll2 (parse-lambda-list '(list find) 'macro-lambda-list))) + (is-true (typep oll1 'ordinary-lambda-list)) + (is (= 1 (length (required-parameters oll1)))) + (is (string= 'list (name (first (required-parameters oll1))))) + (is (= 0 (min-arg-index (first (required-parameters oll1))))) + (is-true (null (optional-parameters oll1))) + (is-true (null (keyword-parameters oll1))) + (is-true (null (rest-parameter oll1))) + + (is-true (typep oll2 'ordinary-lambda-list)) + (is (= 2 (length (required-parameters oll2)))) + (is (string= 'list (name (first (required-parameters oll2))))) + (is (= 0 (min-arg-index (first (required-parameters oll2))))) + (is (string= 'find (name (second (required-parameters oll2))))) + (is (= 1 (min-arg-index (second (required-parameters oll2))))) + (is-true (null (optional-parameters oll2))) + (is-true (null (keyword-parameters oll2))) + (is-true (null (rest-parameter oll2))) + + (is-true (typep mll1 'macro-lambda-list)) + (is (= 1 (length (required-parameters mll1)))) + (is (string= (name (first (required-parameters mll1))) 'list)) + (is (= 0 (min-arg-index (first (required-parameters mll1))))) + (is-true (null (optional-parameters mll1))) + (is-true (null (keyword-parameters mll1))) + (is-true (null (rest-parameter mll1))) + (is-true (null (body-parameter mll1))) + + (is-true (typep mll2 'macro-lambda-list)) + (is (= 2 (length (required-parameters mll2)))) + (is (string= (name (first (required-parameters mll2))) 'list)) + (is (= 0 (min-arg-index (first (required-parameters mll2))))) + (is (string= (name (second (required-parameters mll2))) 'find)) + (is (= 1 (min-arg-index (second (required-parameters mll2))))) + (is-true (null (optional-parameters mll2))) + (is-true (null (keyword-parameters mll2))) + (is-true (null (rest-parameter mll2))) + (is-true (null (body-parameter mll2))))) + +(test parse-lambda-list-2a + "Test that `parse-lambda-list' can correctly parse various +destructuring required parameters for macro lambda lists." + (let ((mll1 (parse-lambda-list '((list)))) + (mll2 (parse-lambda-list '((list find))))) + (is-true (typep mll1 'macro-lambda-list)) + (is (= (min-arg-index (first (required-parameters mll1))))) + (is (= 1 (length (required-parameters (inner-lambda-list (first (required-parameters mll1))))))) + (is (string= 'list (name (first (required-parameters (inner-lambda-list (first (required-parameters mll1)))))))) + + (let ((mll2-parameter (first (required-parameters mll2)))) + (is-true (typep (inner-lambda-list mll2-parameter) 'destructuring-lambda-list)) + (is (= 2 (length (required-parameters (inner-lambda-list mll2-parameter))))) + (is (string= 'list (name (first (required-parameters (inner-lambda-list mll2-parameter)))))) + (is (= 0 (min-arg-index (first (required-parameters (inner-lambda-list mll2-parameter)))))) + (is (string= 'find (name (second (required-parameters (inner-lambda-list mll2-parameter)))))) + (is (= 1 (min-arg-index (second (required-parameters (inner-lambda-list mll2-parameter)))))) + (is-true (null (optional-parameters (inner-lambda-list mll2-parameter)))) + (is-true (null (keyword-parameters (inner-lambda-list mll2-parameter)))) + (is-true (null (rest-parameter (inner-lambda-list mll2-parameter))))))) + +(test parse-lambda-list-3 + "Test that `parse-lambda-list' can correctly parse optional +parameters in ordinary and macro lambda lists." + (let ((oll1 (parse-lambda-list '(&optional (list 2)))) + (oll2 (parse-lambda-list '(&optional (list nil) find))) + (oll3 (parse-lambda-list '(reduce &optional list (find 2)))) + (mll1 (parse-lambda-list '(&optional (list 2)) 'macro-lambda-list)) + (mll2 (parse-lambda-list '(&optional (list nil) find) 'macro-lambda-list)) + (mll3 (parse-lambda-list '(reduce &optional list (find 2)) 'macro-lambda-list))) + (is-true (typep oll1 'ordinary-lambda-list)) + (is (= 0 (length (required-parameters oll1)))) + (is (= 1 (length (optional-parameters oll1)))) + (is (= 0 (length (keyword-parameters oll1)))) + (is-true (null (rest-parameter oll1))) + (is (= 0 (min-arg-index (first (optional-parameters oll1))))) + (is (string= 'list (name (first (optional-parameters oll1))))) + (is (= 2 (init-form (first (optional-parameters oll1))))) + + (is-true (typep oll2 'ordinary-lambda-list)) + (is (= 0 (length (required-parameters oll2)))) + (is (= 2 (length (optional-parameters oll2)))) + (is (= 0 (length (keyword-parameters oll2)))) + (is-true (null (rest-parameter oll2))) + (is (= 0 (min-arg-index (first (optional-parameters oll2))))) + (is (string= 'list (name (first (optional-parameters oll2))))) + (is-true (null (init-form (first (optional-parameters oll2))))) + (is (= 1 (min-arg-index (second (optional-parameters oll2))))) + (is (string= 'find (name (second (optional-parameters oll2))))) + (is-true (null (init-form (second (optional-parameters oll2))))) + + (is-true (typep oll3 'ordinary-lambda-list)) + (is (= 1 (length (required-parameters oll3)))) + (is (= 2 (length (optional-parameters oll3)))) + (is (= 0 (length (keyword-parameters oll3)))) + (is-true (null (rest-parameter oll3))) + (is (= 1 (min-arg-index (first (optional-parameters oll3))))) + (is (string= 'list (name (first (optional-parameters oll3))))) + (is-true (null (init-form (first (optional-parameters oll3))))) + (is (= 2 (min-arg-index (second (optional-parameters oll3))))) + (is (string= 'find (name (second (optional-parameters oll3))))) + (is (= 2 (init-form (second (optional-parameters oll3))))) + + (is-true (typep mll1 'macro-lambda-list)) + (is (= 0 (length (required-parameters mll1)))) + (is (= 1 (length (optional-parameters mll1)))) + (is (= 0 (length (keyword-parameters mll1)))) + (is-true (null (rest-parameter mll1))) + (is (= 0 (min-arg-index (first (optional-parameters mll1))))) + (is (string= 'list (name (first (optional-parameters mll1))))) + (is (= 2 (init-form (first (optional-parameters mll1))))) + + (is-true (typep mll2 'macro-lambda-list)) + (is (= 0 (length (required-parameters mll2)))) + (is (= 2 (length (optional-parameters mll2)))) + (is (= 0 (length (keyword-parameters mll2)))) + (is-true (null (rest-parameter mll2))) + (is (= 0 (min-arg-index (first (optional-parameters mll2))))) + (is (string= 'list (name (first (optional-parameters mll2))))) + (is-true (null (init-form (first (optional-parameters mll2))))) + (is (= 1 (min-arg-index (second (optional-parameters mll2))))) + (is (string= 'find (name (second (optional-parameters mll2))))) + (is-true (null (init-form (second (optional-parameters mll2))))) + + (is-true (typep mll3 'macro-lambda-list)) + (is (= 1 (length (required-parameters mll3)))) + (is (= 2 (length (optional-parameters mll3)))) + (is (= 0 (length (keyword-parameters mll3)))) + (is-true (null (rest-parameter mll3))) + (is (= 1 (min-arg-index (first (optional-parameters mll3))))) + (is (string= 'list (name (first (optional-parameters mll3))))) + (is-true (null (init-form (first (optional-parameters mll3))))) + (is (= 2 (min-arg-index (second (optional-parameters mll3))))) + (is (string= 'find (name (second (optional-parameters mll3))))) + (is (= 2 (init-form (second (optional-parameters mll3))))))) + +(test parse-lambda-list-3a + "Test that `parse-lambda-list' can correctly parse +destructuring optional parameters in macro lambda lists." + (let ((mll1 (parse-lambda-list '(&optional ((list))))) + (mll2 (parse-lambda-list '(&optional ((list) '(2))))) + (mll3 (parse-lambda-list '(&optional ((list find))))) + (mll4 (parse-lambda-list '(&optional ((list find) '(2 3)))))) + (is-true (typep mll1 'macro-lambda-list)) + (is-true (typep (first (optional-parameters mll1)) 'destructuring-optional-parameter)) + (is (= 0 (min-arg-index (first (optional-parameters mll1))))) + (is (= 0 (min-arg-index (first (required-parameters (inner-lambda-list (first (optional-parameters mll1)))))))) + + (is-true (typep mll2 'macro-lambda-list)) + (is-true (typep (first (optional-parameters mll2)) 'destructuring-optional-parameter)) + (is (= 0 (min-arg-index (first (optional-parameters mll2))))) + (is (= 0 (min-arg-index (first (required-parameters (inner-lambda-list (first (optional-parameters mll2)))))))) + (is (equal ''(2) (init-form (first (optional-parameters mll2))))) + + (is-true (typep mll3 'macro-lambda-list)) + (is-true (typep (first (optional-parameters mll3)) 'destructuring-optional-parameter)) + (is (= 0 (min-arg-index (first (optional-parameters mll3))))) + (is (= 0 (min-arg-index (first (required-parameters (inner-lambda-list (first (optional-parameters mll3)))))))) + (is (= 1 (min-arg-index (second (required-parameters (inner-lambda-list (first (optional-parameters mll3)))))))) + + (is-true (typep mll4 'macro-lambda-list)) + (is-true (typep (first (optional-parameters mll4)) 'destructuring-optional-parameter)) + (is (= 0 (min-arg-index (first (optional-parameters mll4))))) + (is (= 0 (min-arg-index (first (required-parameters (inner-lambda-list (first (optional-parameters mll4)))))))) + (is (= 1 (min-arg-index (second (required-parameters (inner-lambda-list (first (optional-parameters mll4)))))))) + (is (equal ''(2 3) (init-form (first (optional-parameters mll4))))))) + +(test parse-lambda-list-4 + "Test that `parse-lambda-list' can correctly parse keyword +parameters in ordinary and macro lambda lists." + (let ((oll1 (parse-lambda-list '(&key (list 2)))) + (oll2 (parse-lambda-list '(&key (list nil) find))) + (oll3 (parse-lambda-list '(reduce &key list (find 2)))) + (oll4 (parse-lambda-list '(&key ((:fooarg list) 2)))) + (mll1 (parse-lambda-list '(&key (list 2)) 'macro-lambda-list)) + (mll2 (parse-lambda-list '(&key (list nil) find) 'macro-lambda-list)) + (mll3 (parse-lambda-list '(reduce &key list (find 2)) 'macro-lambda-list)) + (mll4 (parse-lambda-list '(&key ((:fooarg list) 2)) 'macro-lambda-list))) + (is-true (typep oll1 'ordinary-lambda-list)) + (is (= 0 (length (required-parameters oll1)))) + (is (= 0 (length (optional-parameters oll1)))) + (is (= 1 (length (keyword-parameters oll1)))) + (is-true (null (rest-parameter oll1))) + (is (= 0 (min-arg-index (first (keyword-parameters oll1))))) + (is (string= :list (keyword-name (first (keyword-parameters oll1))))) + (is (= 2 (init-form (first (keyword-parameters oll1))))) + + (is-true (typep oll2 'ordinary-lambda-list)) + (is (= 0 (length (required-parameters oll2)))) + (is (= 0 (length (optional-parameters oll2)))) + (is (= 2 (length (keyword-parameters oll2)))) + (is-true (null (rest-parameter oll2))) + (is (= 0 (min-arg-index (first (keyword-parameters oll2))))) + (is (string= :list (keyword-name (first (keyword-parameters oll2))))) + (is-true (null (init-form (first (keyword-parameters oll2))))) + (is (= 0 (min-arg-index (second (keyword-parameters oll2))))) + (is (string= :find (keyword-name (second (keyword-parameters oll2))))) + (is-true (null (init-form (second (keyword-parameters oll2))))) + + (is-true (typep oll3 'ordinary-lambda-list)) + (is (= 1 (length (required-parameters oll3)))) + (is (= 0 (length (optional-parameters oll3)))) + (is (= 2 (length (keyword-parameters oll3)))) + (is-true (null (rest-parameter oll3))) + (is (= 1 (min-arg-index (first (keyword-parameters oll3))))) + (is (string= :list (keyword-name (first (keyword-parameters oll3))))) + (is-true (null (init-form (first (keyword-parameters oll3))))) + (is (= 1 (min-arg-index (second (keyword-parameters oll3))))) + (is (string= :find (keyword-name (second (keyword-parameters oll3))))) + (is (= 2 (init-form (second (keyword-parameters oll3))))) + + (is-true (typep oll4 'ordinary-lambda-list)) + (is (= 0 (length (required-parameters oll4)))) + (is (= 0 (length (optional-parameters oll4)))) + (is (= 1 (length (keyword-parameters oll4)))) + (is-true (null (rest-parameter oll4))) + (is (= 0 (min-arg-index (first (keyword-parameters oll4))))) + (is (string= :fooarg (keyword-name (first (keyword-parameters oll4))))) + (is (= 2 (init-form (first (keyword-parameters oll4))))) + + (is-true (typep mll1 'macro-lambda-list)) + (is (= 0 (length (required-parameters mll1)))) + (is (= 0 (length (optional-parameters mll1)))) + (is (= 1 (length (keyword-parameters mll1)))) + (is-true (null (rest-parameter mll1))) + (is (= 0 (min-arg-index (first (keyword-parameters mll1))))) + (is (string= :list (keyword-name (first (keyword-parameters mll1))))) + (is (= 2 (init-form (first (keyword-parameters mll1))))) + + (is-true (typep mll2 'macro-lambda-list)) + (is (= 0 (length (required-parameters mll2)))) + (is (= 0 (length (optional-parameters mll2)))) + (is (= 2 (length (keyword-parameters mll2)))) + (is-true (null (rest-parameter mll2))) + (is (= 0 (min-arg-index (first (keyword-parameters mll2))))) + (is (string= :list (keyword-name (first (keyword-parameters mll2))))) + (is-true (null (init-form (first (keyword-parameters mll2))))) + (is (= 0 (min-arg-index (second (keyword-parameters mll2))))) + (is (string= :find (keyword-name (second (keyword-parameters mll2))))) + (is-true (null (init-form (second (keyword-parameters mll2))))) + + (is-true (typep mll3 'macro-lambda-list)) + (is (= 1 (length (required-parameters mll3)))) + (is (= 0 (length (optional-parameters mll3)))) + (is (= 2 (length (keyword-parameters mll3)))) + (is-true (null (rest-parameter mll3))) + (is (= 1 (min-arg-index (first (keyword-parameters mll3))))) + (is (string= :list (keyword-name (first (keyword-parameters mll3))))) + (is-true (null (init-form (first (keyword-parameters mll3))))) + (is (= 1 (min-arg-index (second (keyword-parameters mll3))))) + (is (string= :find (keyword-name (second (keyword-parameters mll3))))) + (is (= 2 (init-form (second (keyword-parameters mll3))))) + + (is-true (typep mll4 'macro-lambda-list)) + (is (= 0 (length (required-parameters mll4)))) + (is (= 0 (length (optional-parameters mll4)))) + (is (= 1 (length (keyword-parameters mll4)))) + (is-true (null (rest-parameter mll4))) + (is (= 0 (min-arg-index (first (keyword-parameters mll4))))) + (is (string= :fooarg (keyword-name (first (keyword-parameters mll4))))) + (is (= 2 (init-form (first (keyword-parameters mll4))))))) + +(test parse-lambda-list-4a + "Test that `parse-lambda-list' can correctly parse +destructuring keyword parameters in macro lambda lists." + (let ((mll1 (parse-lambda-list '(&key ((:list (list)))))) + (mll2 (parse-lambda-list '(&key ((:list (list)) '(2))))) + (mll3 (parse-lambda-list '(&key ((:list (list find)))))) + (mll4 (parse-lambda-list '(&key ((:list (list find)) '(2 3)))))) + (is-true (typep mll1 'macro-lambda-list)) + (is-true (typep (first (keyword-parameters mll1)) 'destructuring-keyword-parameter)) + (is (= 0 (min-arg-index (first (keyword-parameters mll1))))) + (is (= 0 (min-arg-index (first (required-parameters (inner-lambda-list (first (keyword-parameters mll1)))))))) + (is (equal :list (keyword-name (first (keyword-parameters mll1))))) + (is-true (null (init-form (first (keyword-parameters mll1))))) + [226 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-swine-tests.lisp 2007/08/13 21:58:44 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-swine-tests.lisp 2007/08/13 21:58:44 1.1 [579 lines skipped]

1 0

[mcclim-cvs] CVS mcclim/ESA
by thenriksen 13 Aug '07

13 Aug '07

Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv19125/ESA Modified Files: utils.lisp packages.lisp Log Message: Add SUBTYPE-COMPATIBLE-P function to ESA. --- /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2006/12/09 21:28:05 1.2 +++ /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2007/08/13 21:56:04 1.3 @@ -205,3 +205,10 @@ (if (and (eql a (car x)) (eql d (cdr x))) x (cons a d))))) + +(defun subtype-compatible-p (types) + "Return true if an element of `types' is a subtype of every +other type specifier in `types'. `Types' must be a list of type +specifiers." + (some (lambda (x) + (subtypep x `(and ,@types))) types)) --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2006/12/09 21:28:05 1.2 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2007/08/13 21:56:04 1.3 @@ -40,7 +40,8 @@ #:with-keywords-removed #:invoke-with-dynamic-bindings-1 #:invoke-with-dynamic-bindings - #:maptree)) + #:maptree + #:subtype-compatible-p)) (defpackage :esa (:use :clim-lisp :clim :esa-utils)

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 06 Aug '07

06 Aug '07

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv14105 Modified Files: drei-clim.lisp Log Message: Use the output record, not the pane, for finding the position of the output record... --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/08/06 13:23:13 1.19 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/08/06 15:27:27 1.20 @@ -355,7 +355,7 @@ (defmethod initialize-instance :after ((area drei-area) &key) (setf (input-editor-position area) - (multiple-value-list (output-record-position (editor-pane area)))) + (multiple-value-list (output-record-position area))) (tree-recompute-extent area)) (defmethod display-drei ((drei drei-area))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 06 Aug '07

06 Aug '07

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv16214/Drei Modified Files: drei-clim.lisp Log Message: (Hopefully) restore the functionality of :x-position and :y-position initargs to Drei input-editor-streams. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/08/06 13:19:03 1.18 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/08/06 13:23:13 1.19 @@ -355,7 +355,7 @@ (defmethod initialize-instance :after ((area drei-area) &key) (setf (input-editor-position area) - (multiple-value-list (stream-cursor-position (editor-pane area)))) + (multiple-value-list (output-record-position (editor-pane area)))) (tree-recompute-extent area)) (defmethod display-drei ((drei drei-area))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 06 Aug '07

06 Aug '07

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv13603/Drei Modified Files: drei-redisplay.lisp drei-clim.lisp Log Message: Fixed the "wandering Drei" input-editor redisplay bug by enforcing the original coordinates of the Drei instance. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2007/01/24 10:57:24 1.6 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2007/08/06 13:19:03 1.7 @@ -79,7 +79,7 @@ ;; very beginning of the output. (defmethod display-drei-contents :before ((stream extended-output-stream) (drei drei-area) syntax) (with-new-output-record (stream 'standard-sequence-output-record record) - (setf (output-record-position record) (stream-cursor-position stream)))) + (setf (output-record-position record) (values-list (input-editor-position drei))))) (defgeneric display-drei-cursor (stream drei cursor syntax) (:documentation "The purpose of this function is to display a @@ -289,7 +289,7 @@ (cursors drei)) (with-output-recording-options (stream :record t :draw nil) (letf (((stream-current-output-record stream) drei) - ((stream-cursor-position stream) (output-record-position drei))) + ((stream-cursor-position stream) (values-list (input-editor-position drei)))) (display-drei-contents stream drei (syntax (buffer drei))))))) (defmethod replay-output-record :after ((drei drei-area) (stream extended-output-stream) &optional @@ -315,9 +315,7 @@ "Adjust the returned offset with the position of the Drei area on display." (multiple-value-bind (x y height style-width) (call-next-method) - (multiple-value-bind (drei-x drei-y) (output-record-position drei) - (declare (ignore drei-y)) - (values (+ x drei-x) y height style-width)))) + (values (+ x (first (input-editor-position drei))) y height style-width))) (defun display-drei-area (drei) (with-accessors ((stream editor-pane)) drei --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/02/07 12:44:20 1.17 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/08/06 13:19:03 1.18 @@ -341,13 +341,21 @@ :documentation "The minimum width of the Drei editable area. Should be an integer >= 0 or T, meaning that it will extend to the end of the viewport, if the Drei area is in a -scrolling arrangement.")) +scrolling arrangement.") + (%drei-position :accessor input-editor-position + :initarg :input-editor-position + :documentation "The position of the Drei +editing area in the coordinate system of the encapsulated +stream. An (X,Y) list, not necessarily the same as the position +of the associated output record.")) (:default-initargs :command-executor 'execute-drei-command) (:documentation "A Drei editable area implemented as an output record.")) (defmethod initialize-instance :after ((area drei-area) &key) + (setf (input-editor-position area) + (multiple-value-list (stream-cursor-position (editor-pane area)))) (tree-recompute-extent area)) (defmethod display-drei ((drei drei-area))

1 0

[mcclim-cvs] CVS mcclim/Backends/CLX
by rstrandh 22 Jul '07

22 Jul '07

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv24361/Backends/CLX Modified Files: port.lisp Log Message: Added more IGNORE declarations to avoid compiler warnings. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2007/02/07 12:44:18 1.127 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2007/07/22 06:30:41 1.128 @@ -137,6 +137,7 @@ (let ((entry (fontset-point point fontset))) (if entry (destructuring-bind ((range-start . range-stop) font translator) entry + (declare (ignore range-start range-stop)) (xlib:char-width font (funcall translator point))) 0))) @@ -350,6 +351,10 @@ :structure-notify :pointer-motion :button-motion))) + ;; I am declaring BORDER-WIDTH ignore to get a cleaner build, but I + ;; don't really understand why the use of it is commented out in favor + ;; of the constant 0. -- RS 2007-07-22 + (declare (ignore border-width)) (when (null (port-lookup-mirror port sheet)) (update-mirror-geometry sheet) (let* ((desired-color (typecase sheet @@ -665,6 +670,7 @@ target property requestor selection request first-keycode count &allow-other-keys) + (declare (ignore display request first-keycode count)) (declare (special *clx-port*)) (let ((sheet (and window (port-lookup-sheet *clx-port* window)))) (when sheet

1 0

[mcclim-cvs] CVS mcclim
by rstrandh 21 Jul '07

21 Jul '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv4727 Modified Files: table-formatting.lisp Log Message: Added IGNORABLE declaration. --- /project/mcclim/cvsroot/mcclim/table-formatting.lisp 2006/03/10 21:58:13 1.39 +++ /project/mcclim/cvsroot/mcclim/table-formatting.lisp 2007/07/21 14:17:15 1.40 @@ -132,6 +132,7 @@ (min-width 0) (min-height 0) (record-type ''standard-cell-output-record)) &body body) + (declare (ignorable align-x align-y)) (setq stream (stream-designator-symbol stream '*standard-output*)) (with-keywords-removed (more (:record-type :min-width :min-height)) (with-gensyms (record)

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