[mcclim-cvs] CVS mcclim/Drei/Tests

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]