[lisplab-cvs] r9 - src/test
Jørn Inge Vestgården
jivestgarden at common-lisp.net
Sun Mar 1 19:28:37 UTC 2009
Author: jivestgarden
Date: Sun Mar 1 19:28:36 2009
New Revision: 9
Log:
unfinished test code
Added:
src/test/CLUnit.lisp
src/test/lisplab-test.lisp
Added: src/test/CLUnit.lisp
==============================================================================
--- (empty file)
+++ src/test/CLUnit.lisp Sun Mar 1 19:28:36 2009
@@ -0,0 +1,387 @@
+;;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: USER; Base:10 -*-
+;;;;
+;;;; Author: Frank A. Adrian
+;;;;
+;;;; Release history:
+;;;; 20021126 - Release 1.3
+;;;; 20021125 - Release 1.2a
+;;;; 20021124 - Release 1.2
+;;;; 20010605 - Release 1.1
+;;;; 20010527 - Release 1.0
+;;;;
+;;;; Modification history:
+;;;; 20021126 - Fixed compilation issues
+;;;; 20021125 - Fixed :nconc-name issue for Corman Lisp
+;;;; 20021124 - Fixed "AND error", switched from test object to structure
+;;;; 20010605 - Added licensing text, compare-fn keyword.
+;;;; 20010604 - Added :input-form and :output-form options,
+;;;; failed-tests function
+;;;; 20010524 - Code readied for public distribution.
+;;;; 20010219 - Added list-* functions.
+;;;; 20000614 - Added input-fn, output-fn.
+;;;; 20000520 - Added categories.
+;;;; 20000502 - Added deftest.
+;;;; 20000428 - Initial Revision.
+;;;;
+;;;; Copyright (c) 2000-2002. Frank A. Adrian. All rights reserved.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 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
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser 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
+;;;;
+;;;; The author also requests that any changes and/or improvents to the
+;;;; code be shared with the author for use in subsequent releases. Author's
+;;;; E-mail: fadrian at ancar.org.
+;;;;
+;;;;
+
+(defpackage :org.ancar.CLUnit
+ (:use "COMMON-LISP")
+;Kill the next form in Corman and Franz Lisps because their defpackage :documentation
+;option is not present.
+#-(or :cormanlisp excl)
+ (:documentation
+ "This package contains a unit testing environment for Common Lisp.
+ All tests are held in the system image. Each test has a name and
+ a category. All tests in the system can be run, as can all tests
+ in a given category.
+
+ The tests are specified by a test function that is normally written
+ so as to take no input and to return T if the test passes. Optionally,
+ an input function and/or an output function can also be specified.
+ If an input function is specified, the test function is applied to
+ the return value(s) of the input function. If the output function
+ is specified, then the return value(s) of the test function is
+ compared (via #'eql) to the return value(s) of the output function
+ to check if the test succeeded.
+
+ The package provides several functions and a deftest macro that makes
+ specifying a test simple:
+ clear-tests: Remove all tests from the system.
+ remove-test: Remove a test from the system by name.
+ run-category: Run all tests from a given category.
+ run-all-tests: Run all the tests in the system.
+ list-categories: List the categories of tests in the system.
+ list-tests: List all of the tests in the system.
+ run-named-test: Run the test of the given name (mainly for
+ debugging use after a given test has not
+ passed).
+ failed-tests: Return a list of all tests that failed during the
+ last run-all-tests or run-category call.
+ deftest: Define a test for the system."))
+
+(in-package :org.ancar.CLUnit)
+(provide :org.ancar.CLUnit)
+
+(defparameter *not-categorized* "*UNCATEGORIZED*")
+(defun t-func () t)
+(defun nil-func () nil)`
+(defun equal-func (x y) (funcall (symbol-function 'equal) x y))
+
+(defun print-test (test str depth)
+ (declare (ignore depth))
+ (print-unreadable-object (test str :type t :identity t)
+ (format str "~A/~A" (descr test) (category test))))
+
+(defstruct (test (:conc-name nil) (:print-function print-test))
+
+ "Test holds information that enables test to be located and run.
+ Slots:
+ descr: Test name.
+ category: Category test belongs to.
+ test-fn: Function run for test - by default, a zero-input,
+ boolean output function. T means the test succeeded.
+ compare-fn: Function that compares test function output to the
+ expected output. Takes 2 lists of values.
+ input-fn: Function that provides input to the test. When this
+ item is used, test-fn is applied to the values returned
+ by this function.
+ output-fn: Function that provides data that the output of test-fn
+ is compared against."
+ descr (category *not-categorized*) test-fn compare-fn input-fn output-fn)
+
+
+(defvar *all-tests* nil
+ "Currently, this is a simple list of tests. If the number of tests
+ starts becoming too large, this should probably turn into a hash-table
+ of tests hashed on category name.")
+
+(defun clear-tests ()
+ "Remove all tests from the system."
+ (setf *all-tests* nil))
+
+(defun remove-test (test-name)
+ "Remove the test with the given name."
+ ;(format t "In remove-test~%")
+ (setf *all-tests*
+ (delete-if #'(lambda (i) (string-equal (descr i) test-name)) *all-tests*)))
+
+(defun run-unprotected (test)
+ "Run a test. No protection against errors."
+ (let* ((input-fn (input-fn test))
+ (output-fn (output-fn test))
+ (test-fn (test-fn test))
+ (has-specified-input-fn input-fn))
+
+ (unless input-fn (setf input-fn #'nil-func))
+ (unless output-fn (setf output-fn #'t-func))
+ (let ((test-input (multiple-value-list (funcall input-fn))))
+ ;(format t "~&Input: ~A~%" test-input)
+ (let ((vals (multiple-value-list
+ (if has-specified-input-fn
+ (apply test-fn test-input)
+ (funcall test-fn))))
+ (tvals (multiple-value-list (funcall output-fn))))
+ ;(format t "~&Test output: ~A~%Expected output: ~A~%"
+ ; vals tvals)
+ (funcall (compare-fn test) vals tvals)))))
+
+(defun run-protected (test)
+ "Protect the test while running with ignore-errors."
+ (let ((vals (multiple-value-list (ignore-errors (run-unprotected test)))))
+ ;(format t "~&vals: ~A~%" vals)
+ (unless (eq (car vals) t)
+ (if (cadr vals)
+ (format t "~&~A occurred in test ~S~%"
+ (cadr vals) (descr test))
+ (format t "~&Output did not match expected output in test ~S~%"
+ (descr test))))
+ vals))
+
+(defun test-or-tests (count)
+ "This is for Corman Lisp which does not handle ~[ quite correctly."
+ (if (eq count 1) "test" "tests"))
+
+(defvar *failed-tests* nil
+ "Holds the set of failed tests from last test run.")
+
+(defun failed-tests ()
+ "Return the set of tests that failed during the last test run"
+ *failed-tests*)
+
+(defun run-tests (tests)
+ "Run the set of tests passed in."
+ (let ((passed-tests nil)
+ (failed-tests nil))
+ (loop for test in tests do
+ ;(format t "~&Running test: ~A~%" test)
+ (let ((test-result (run-protected test)))
+ (if (eq (car test-result) t)
+ (push test passed-tests)
+ (push test failed-tests))))
+ (setf *failed-tests* failed-tests)
+; (format t "~&Passed tests: ~A; failed tests: ~A.~%"
+; passed-tests failed-tests)
+ (let ((passed-count (length passed-tests))
+ (failed-count (length failed-tests)))
+; (format t "~&Passed count: ~A; failed count: ~A~%"
+; passed-count failed-count)
+; (format t "~&~A ~[tests~;test~:;tests~] run; ~A ~[tests~;test~:;tests~] passed; ~A ~[tests~;test~:;tests~] failed.~%"
+; (+ passed-count failed-count) (+ passed-count failed-count)
+; passed-count passed-count failed-count failed-count)
+ (format t "~&~A ~A run; ~A ~A passed; ~A ~A failed.~%"
+ (+ passed-count failed-count) (test-or-tests (+ passed-count failed-count))
+ passed-count (test-or-tests passed-count)
+ failed-count (test-or-tests failed-count))
+ (values (null failed-tests) failed-count passed-count))))
+
+(defun filter-tests (category)
+ "Filter tests by category."
+ (remove-if #'(lambda (test) ;(format t "~&~A~A~%" category (category test))
+ (not (string-equal category (category test))))
+ *all-tests*))
+
+(defun run-category (category)
+ "Run all the tests in a given category."
+ (run-tests (filter-tests category)))
+
+(defun run-all-tests ()
+ "Run all tests in the system."
+ (run-tests *all-tests*))
+
+(defmacro form-to-fn (form)
+ "Return a function that will return the form when evaluated.
+ Will be used when we add input-form and output-form parameters to
+ deftest."
+ `#'(lambda () ,form))
+
+(defmacro deftest (description &key category
+ test-fn
+ (input-fn nil input-fn-present)
+ (output-fn nil output-fn-present)
+ (input-form nil input-form-present)
+ (output-form nil output-form-present)
+ compare-fn)
+
+ "Use of :input-fn and :output-fn keywords override use of :input-form and
+ :output-form keywords respectively."
+
+ (let ((mia-args-gen (gensym))
+ (cat-gen (gensym))
+ (inst-gen (gensym))
+ (ifmfn `#'(lambda () ,input-form))
+ (ofmfn `#'(lambda () ,output-form))
+ (cf-gen (gensym))
+ (tf-gen (gensym)))
+ `(let (,mia-args-gen
+ (,cat-gen ,category)
+ (,cf-gen ,compare-fn)
+ (,tf-gen ,test-fn))
+ (push :descr ,mia-args-gen) (push ,description ,mia-args-gen)
+ (when ,cat-gen
+ (push :category ,mia-args-gen) (push ,cat-gen ,mia-args-gen))
+ (push :compare-fn ,mia-args-gen) (push (if ,cf-gen ,cf-gen #'equal) ,mia-args-gen)
+ (push :test-fn ,mia-args-gen) (push (if ,tf-gen ,tf-gen #'t-func) ,mia-args-gen)
+ (when (and ,output-form-present (not ,output-fn-present))
+ (push :output-fn ,mia-args-gen) (push ,ofmfn ,mia-args-gen))
+ (when ,output-fn-present
+ (push :output-fn ,mia-args-gen) (push ,output-fn ,mia-args-gen))
+ (when (and ,input-form-present (not ,input-fn-present))
+ (push :input-fn ,mia-args-gen) (push ,ifmfn ,mia-args-gen))
+ (when ,input-fn-present
+ (push :input-fn ,mia-args-gen) (push ,input-fn ,mia-args-gen))
+ (let ((,inst-gen (apply #'make-test (nreverse ,mia-args-gen))))
+ (remove-test (descr ,inst-gen))
+ (push ,inst-gen *all-tests*)))))
+
+(defun list-categories ()
+ "List all of the categories in the system."
+ (let (cats)
+ (loop for test in *all-tests* doing
+ (setf cats (adjoin (category test) cats :test #'string-equal)))
+ cats))
+
+(defun list-tests (&optional category)
+ "List the tets in the system / category."
+ (let ((tests (if category (filter-tests category) *all-tests*)))
+ (loop for test in tests collecting
+ (concatenate 'string (descr test) "/" (category test)))))
+
+(defun run-named-test (name &optional protected)
+ "Run the given test in either protected or unprotected mode."
+ (let ((test (find name *all-tests* :key #'descr :test #'string-equal)))
+ (when test
+ (if protected
+ (run-protected test)
+ (run-unprotected test)))))
+
+(export '(
+ run-category
+ run-all-tests
+ clear-tests
+ remove-test
+ deftest
+ list-categories
+ list-tests
+ run-named-test
+ failed-tests
+ clear-tests
+ ;with-supressed-summary
+ ))
+
+#|
+
+(in-package "COMMON-LISP-USER")
+(use-package :org.ancar.CLUnit)
+
+;;;
+;;; Self test...
+;;;
+
+;; tests basic test definition
+(load-time-value (progn
+
+(deftest "test1" :category "CLUnit-pass1"
+ :test-fn #'(lambda () (eq (car '(a)) 'a)))
+
+;; tests input-fn
+(deftest "test-2" :category "CLUnit-pass1"
+ :input-fn #'(lambda () '(a))
+ :test-fn #'(lambda (x) (eq (car x) 'a)))
+
+;; tests output-fn
+(deftest "test-3" :category "CLUnit-pass1"
+ :input-fn #'(lambda () '(a))
+ :output-fn #'(lambda () 'a)
+ :test-fn #'(lambda (x) (car x)))
+
+;; tests remove-test, run-category, and multiple-values in test-fn and
+;; output-fn
+(deftest "meta" :category "CLUnit-meta"
+ :input-fn #'(lambda () (remove-test "test1"))
+ :test-fn #'(lambda (x) (declare (ignore x)) (run-category "CLUnit-pass1"))
+ :output-fn #'(lambda () (values t 0 2)))
+
+;; tests multiple values from input-fn to test-fn
+(deftest "test1" :category "CLUnit-pass2"
+ :input-fn #'(lambda () (values 'a '(b)))
+ :test-fn #'cons
+ :output-fn #'(lambda () '(a b)))
+
+;;check error trapping
+(deftest "meta2" :category "CLUnit-meta"
+ :input-fn
+ #'(lambda () (deftest "Error test" :category "CLUnit-pass3"
+ :test-fn #'(lambda ()
+ (remove-test "Error test") (error "Dummy error"))))
+ :test-fn #'(lambda (x) (declare (ignore x)) (run-category "CLUnit-pass3"))
+ :output-fn #'(lambda () (values nil 1 0)))
+
+;;check input-form
+(deftest "testx" :category "CLUnit"
+ :input-form '(a b c)
+ :test-fn #'car
+ :output-fn #'(lambda () 'a))
+
+;;check output form
+(deftest "testx2" :category "CLUnit"
+ :input-form '(a b c)
+ :test-fn #'car
+ :output-form 'a)
+
+;;check multiple input-forms
+(deftest "testx3" :category "CLUnit"
+ :input-form (values '(1 2 3) '(10 20 30))
+ :test-fn #'(lambda (&rest lists) (car lists))
+ :output-fn #'(lambda () '(1 2 3)))
+
+;;check multiple output-forms
+(deftest "testx4" :category "CLUnit"
+ :input-form (values '(1 2 3) '(10 20 30))
+ :test-fn #'(lambda (&rest lists) (apply #'values lists))
+ :output-fn #'(lambda () (values '(1 2 3) '(10 20 30))))
+
+;;check failed-tests
+(deftest "meta5" :category "CLUnit-meta"
+ :input-fn
+ #'(lambda () (deftest "Error test" :category "CLUnit-pass4"
+ :test-fn #'(lambda ()
+ (remove-test "Error test") (error "Dummy error"))))
+ :test-fn #'(lambda (x) (declare (ignore x))
+ (run-category "CLUnit-pass4")
+ (values (length (failed-tests)) (org.ancar.CLUnit::descr (car (failed-tests)))))
+ :output-fn #'(lambda () (values 1 "Error test")))
+
+(deftest "Test compare-fn"
+ :test-fn #'(lambda () "abc")
+ :output-form "abc"
+ :compare-fn #'(lambda (rlist1 rlist2)
+ (not (null (reduce #'(lambda (x y) (and x y))
+ (mapcar #'string-equal rlist1 rlist2) :initial-value t)))))
+
+;;; run self test
+(when (run-all-tests)
+ (format t "~&CLUnit self-test passed.~%")
+ (clear-tests)
+ (values))))
+|#
\ No newline at end of file
Added: src/test/lisplab-test.lisp
==============================================================================
--- (empty file)
+++ src/test/lisplab-test.lisp Sun Mar 1 19:28:36 2009
@@ -0,0 +1,102 @@
+
+
+(defpackage "LISPLAB.TEST"
+ (:use "COMMON-LISP" "ORG.ANCAR.CLUNIT"))
+
+(in-package :lisplab.test)
+
+(defparameter *a22* #2a((1 4) (1 -2)))
+(defparameter *a33* #2a((1 4 7) (3 4 2) (1 -2 -8)))
+
+(defparameter *r22* (ll:rmat (1 4) (1 -2)))
+(defparameter *r33* (ll:rmat (1 4 7) (3 4 2) (1 -2 -8)))
+
+(defparameter *c22* (ll:cmat (1 4) (1 -2)))
+(defparameter *c33* (ll:cmat (1 4 7) (3 4 2) (1 -2 -8)))
+
+(deftest "level0 .="
+ :test-fn (lambda ()
+ (ll:.= 0 0)
+ (ll:.= 42 42.0)
+ (ll:.= 'x 'x)))
+
+(deftest "level0 .+"
+ :test-fn (lambda ()
+ (= 4 (ll:.+ 0 4))
+ (= 7 (ll:.+ 3 4))
+ (= 0.5 (ll:.+ 1 -0.25 -0.25))
+ (= 10.3 (ll:.+ 6.3 4))
+ (= 3/4 (ll:.+ 1/2 1/4))
+ ))
+
+(deftest "level0 .-"
+ :test-fn (lambda ()
+ (= -4 (ll:.- 0 4))
+ (= -1 (ll:.- 3 4))
+ (= 1.5 (ll:.- 1 -0.25 -0.25))
+ (= 2.3 (ll:.- 6.3 4))
+ (= 1/4 (ll:.- 1/2 1/4))
+ ))
+
+(deftest "level0 .*"
+ :test-fn (lambda ()
+ (= 0 (ll:.* 0 4))
+ (= 12 (ll:.* 3 4))
+ (= 1.5 (ll:.* 1 -0.25 -6))
+ (= 26 (ll:.* 6.5 4))
+ (= 12/10 (ll:.* 4/5 3/2))
+ ))
+
+(deftest "level0 ./"
+ :test-fn (lambda ()
+ (= 0 (ll:./ 0 4))
+ (= 3/4 (ll:./ 3 4))
+ (= 1.5 (ll:./ 1 -0.25 -6))
+ (= 26 (ll:./ 6.5 4))
+ (= 8/15 (ll:./ 4/5 3/2))
+ ))
+
+(deftest "level0 .^"
+ :test-fn (lambda ()
+ (= 1 (ll:.^ 7 0))
+ (= 64 (ll:.^ 4 3))
+ (= 15.620749173070115 (ll:.^ 2.3 3.3))
+ (= 9/49 (ll:.^ 3/7 2))
+ ))
+
+(deftest "level1 blas-real"
+ :test-fn (lambda ()
+ (let ((x1 (ll:rnew 1 3 4))
+ (x2 (ll:rmat (4 3) (-1 4)))
+ (c1 (ll:rrow 2 7 8))
+ (c2 (ll:rcol 3 2 4)))
+ (and (= 1 (ll:vref x1 1))
+ (= -1 (ll:vref x2 1)) ; row major order
+ (= 8 (ll:mref c1 0 2))
+ (= 4 (ll:mref c2 2 0))
+ (= 3 (ll:mref x2 0 1))))))
+
+(deftest "level1 blas-complex"
+ :test-fn (lambda ()
+ (let ((x1 (ll:cnew 1 3 4))
+ (x2 (ll:cmat (4 3) (-1 4)))
+ (c1 (ll:crow 2 7 8))
+ (c2 (ll:ccol 3 2 4)))
+ (and (= 1 (ll:vref x1 1))
+ (= -1 (ll:vref x2 1)) ; row major order
+ (= 8 (ll:mref c1 0 2))
+ (= 4 (ll:mref c2 2 0))
+ (= 3 (ll:mref x2 0 1))))))
+
+(deftest "level1 array"
+ :test-fn (lambda ()
+ (let ((x2 #2a((4 3) (-1 4)))
+ (c1 #a(2 7 8)))
+ (and (= 1 (ll:vref x1 1))
+ (= -1 (ll:vref x2 1)) ; row major order
+ (= 8 (ll:mref c1 0 2))
+ (= 4 (ll:mref c2 2 0))
+ (= 3 (ll:mref x2 0 1))))))
+
+
+
More information about the lisplab-cvs
mailing list