[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