[lisplab-cvs] r233 - in trunk/src: draft test
jivestgarden at common-lisp.net
jivestgarden at common-lisp.net
Sun Apr 29 19:29:44 UTC 2012
Author: jivestgarden
Date: Sun Apr 29 12:29:43 2012
New Revision: 233
Log:
Prepear new tests
Added:
trunk/src/draft/CLUnit.lisp
- copied unchanged from r227, trunk/src/test/CLUnit.lisp
trunk/src/draft/lisplab-test.lisp
- copied unchanged from r227, trunk/src/test/lisplab-test.lisp
trunk/src/draft/mat2txt.c
- copied unchanged from r227, trunk/src/test/mat2txt.c
Deleted:
trunk/src/test/CLUnit.lisp
trunk/src/test/lisplab-test.lisp
trunk/src/test/mat2txt.c
Copied: trunk/src/draft/CLUnit.lisp (from r227, trunk/src/test/CLUnit.lisp)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/src/draft/CLUnit.lisp Sun Apr 29 12:29:43 2012 (r233, copy of r227, trunk/src/test/CLUnit.lisp)
@@ -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
Copied: trunk/src/draft/lisplab-test.lisp (from r227, trunk/src/test/lisplab-test.lisp)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/src/draft/lisplab-test.lisp Sun Apr 29 12:29:43 2012 (r233, copy of r227, trunk/src/test/lisplab-test.lisp)
@@ -0,0 +1,36 @@
+
+
+#+nil (defpackage "LISPLAB.TEST"
+ (:use "COMMON-LISP" "ORG.ANCAR.CLUNIT"))
+
+(in-package :org.ancar.CLUnit)
+
+#+nil (in-package :lisplab.test)
+
+(deftest "level1-dge-new"
+ :test-fn (lambda ()
+ (and
+ (equalp (ll:dim (ll:mnew 'll:matrix-dge 0 3 7)) '(3 7))
+ (equalp (ll:dim (ll:mnew '(:d :ge :any) 0 3 7)) '(3 7))
+ (equalp (ll:dim (ll:dnew 0 3 7)) '(3 7)))))
+
+(deftest "level1-zge-new"
+ :test-fn (lambda ()
+ (and
+ (equalp (ll:dim (ll:mnew 'll:matrix-zge 0 3 7)) '(3 7))
+ (equalp (ll:dim (ll:mnew '(:z :ge :any) 0 3 7)) '(3 7))
+ (equalp (ll:dim (ll:znew 0 3 7)) '(3 7)) )))
+
+(deftest "level1-dge-mref"
+ :test-fn (lambda ()
+ (let ((A (ll:dnew 42 3 7)))
+ (setf (ll:mref A 2 2) 7)
+ (and (= 42 (ll:mref A 0 1))
+ (= 7 (ll:mref A 2 2))))))
+
+(deftest "level1-zge-mref"
+ :test-fn (lambda ()
+ (let ((A (ll:znew ll:%i 3 7)))
+ (setf (ll:mref A 2 2) 7)
+ (and (= ll:%i (ll:mref A 0 1))
+ (= 7 (ll:mref A 2 2))))))
\ No newline at end of file
Copied: trunk/src/draft/mat2txt.c (from r227, trunk/src/test/mat2txt.c)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/src/draft/mat2txt.c Sun Apr 29 12:29:43 2012 (r233, copy of r227, trunk/src/test/mat2txt.c)
@@ -0,0 +1,69 @@
+/* A utility that converts binary matrix files to text files,
+ * i.e., files stored with lisplabs msave.
+ *
+ * This file should never be needed, but it gives
+ * some extra data safety to have to independent
+ * implementations of the same file protocol
+ *
+ * This file is in the public domain
+ */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <arpa/inet.h>
+#include <assert.h>
+
+unsigned read_ui32 (FILE *f) {
+ unsigned buf;
+ fread(&buf, 1, 4, f);
+ return ntohl(buf);
+}
+
+double read_f64 (FILE *f) {
+ double x;
+ fread(&x, 8, 1, f);
+ return x;
+}
+
+int main (int argn, char *arg[]) {
+ FILE *f = NULL;
+ FILE *out = stdout;
+ unsigned rows = 0;
+ unsigned cols=0;
+ int i=-1,j=-1;
+ int hdr_len=-1;
+ double x = -1.0;
+
+ if (argn == 1) {
+ printf("usage: %s binary_file [text_file]\n", arg[0]);
+ exit(1);
+ }
+
+ f = fopen(arg[1],"r");
+ assert(f);
+ assert(read_ui32 (f) == 154777230);
+ assert(read_ui32 (f) == 10000042);
+ hdr_len = read_ui32(f);
+ for (i = 0; i < hdr_len; i++) getc(f);
+
+ rows = read_ui32 (f);
+ cols = read_ui32 (f);
+
+ if (argn > 2) {
+ out = fopen(arg[2],"w");
+ assert(out);
+ }
+
+ for (i = 0; i < rows; i++) {
+ for (j = 0; j < cols; j++) {
+ fprintf(out,"%.14g ", read_f64(f));
+ }
+ if (i < rows - 1)
+ fprintf(out,"\n");
+ }
+ if (argn > 2)
+ fclose(out);
+
+ fclose(f);
+ return 0;
+}
More information about the lisplab-cvs
mailing list