[lisplab-cvs] r234 - trunk/src/test/unit
jivestgarden at common-lisp.net
jivestgarden at common-lisp.net
Tue May 1 19:30:49 UTC 2012
Author: jivestgarden
Date: Tue May 1 12:30:48 2012
New Revision: 234
Log:
The first tests
Added:
trunk/src/test/unit/
trunk/src/test/unit/package.lisp
trunk/src/test/unit/test-level0.lisp
trunk/src/test/unit/unit-test.asd
trunk/src/test/unit/unit-test.lisp
Added: trunk/src/test/unit/package.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/src/test/unit/package.lisp Tue May 1 12:30:48 2012 (r234)
@@ -0,0 +1,22 @@
+;;; Package for units tests
+
+;;; Copyright (C) 2012 Joern Inge Vestgaarden
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License along
+;;; with this program; if not, write to the Free Software Foundation, Inc.,
+;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+(defpackage "LL-TEST"
+ (:use "COMMON-LISP" "LISPLAB")
+ (:documentation "Unit test"))
+
\ No newline at end of file
Added: trunk/src/test/unit/test-level0.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/src/test/unit/test-level0.lisp Tue May 1 12:30:48 2012 (r234)
@@ -0,0 +1,87 @@
+(in-package :ll-test)
+
+(defun test-level0-all ()
+ (test-level0-operators)
+ (test-level0-ordinary-functions)
+ (test-level0-special-functions))
+
+(defvar *l0-op* nil)
+
+(defun test-level0-operators (&key (suite *l0-op*))
+ (setf suite (make-test-suite "level0"))
+ (def-test-ok suite ".+ 12 134" (eql (.+ 12 134) 146))
+ (def-test-ok suite ".- 12 134" (eql (.- 12 134) -122))
+ (def-test-ok suite ".* 12 134" (eql (.* 12 134) 1608))
+ (def-test-ok suite "./ 12 134" (eql (./ 12 134) 12/134))
+ (def-test-ok suite ".^ 134 12" (eql (.^ 134 12) 33516416633376182864121856 ))
+ (def-test-ok suite ".+ 12 .134" (eql (.+ 12 .134) 12.134))
+ (def-test-ok suite ".- 12 .134" (eql (.- 12 .134) 11.866))
+ (def-test-ok suite ".* 12 .134" (eql (.* 12 .134) 1.608))
+ (def-test-ok suite "./ 12 .134" (eql (./ 12 .134) 89.55223880597015))
+ (def-test-ok suite ".^ 12 .134" (eql (.^ 12 .134) 1.3951158955525682))
+ (test-it suite)
+ (test-report suite))
+
+(defvar *l0-fun* nil)
+
+(defun test-level0-ordinary-functions (&key (suite *l0-fun*))
+ (setf suite (make-test-suite "level0"))
+ (def-test-ok suite ".sin 12" (eql (.sin 12) -0.5365729180004349 ))
+ (def-test-ok suite ".cos 12" (eql (.cos 12) 0.8438539587324921 ))
+ (def-test-ok suite ".tan 12" (eql (.tan 12) -0.6358599286615808 ))
+
+ (def-test-ok suite ".asin 12" (eql (.asin 12) #C(1.5707963267948966 -3.176313180591656) ))
+ (def-test-ok suite ".acos 12" (eql (.acos 12) #C(0.0 3.176313180591656)))
+ (def-test-ok suite ".atan 12" (eql (.atan 12) 1.4876550949064553))
+
+ (def-test-ok suite ".sinh 12" (eql (.sinh 12) 81377.39570642984))
+ (def-test-ok suite ".cosh 12" (eql (.cosh 12) 81377.39571257407))
+ (def-test-ok suite ".tanh 12" (eql (.tanh 12) 0.9999999999244973))
+
+ (def-test-ok suite ".sinh 12" (eql (.asinh 12) 3.179785437699879))
+ (def-test-ok suite ".cosh 12" (eql (.acosh 12) 3.176313180591656))
+ (def-test-ok suite ".tanh 12" (eql (.atanh 12) #C(0.08352704233158309 1.5707963267948966)))
+
+ (def-test-ok suite ".log 12" (eql (.log 12) 2.4849066497880004))
+
+ (test-it suite)
+ (test-report suite))
+
+(defvar *l0-specfun* nil)
+
+(defun test-level0-special-functions (&key (suite *l0-specfun*))
+ (setf suite (make-test-suite "level0"))
+ (def-test-ok suite ".besj -1 1.4" (eql (.besj -1 1.4) -0.5419477139308545))
+ (def-test-ok suite ".besj 0 1.4" (eql (.besj 0 1.4) 0.5668551203742889 ))
+ (def-test-ok suite ".besj 1 1.4" (eql (.besj 1 1.4) 0.5419477139308545 ))
+ (def-test-ok suite ".besj 1.3 1.4" (eql (.besj 1.3 1.4) 0.4324531285021261 ))
+
+ ;; (def-test-ok suite ".besy -1 1.4" (eql (.besy -1 1.4) -0.5419477139308545))
+ (def-test-ok suite ".besy 0 1.4" (eql (.besy 0 1.4) 0.33789512967968804))
+ (def-test-ok suite ".besy 1 1.4" (eql (.besy 1 1.4) -0.47914697423279995))
+ (def-test-ok suite ".besy 1.3 1.4" (eql (.besy 1.3 1.4) -0.646048650800112))
+
+ ;; (def-test-ok suite ".besi -1 1.4" (eql (.besi -1 1.4) -0.5419477139308545))
+ (def-test-ok suite ".besi 0 1.4" (eql (.besi 0 1.4) 1.5533950997312165))
+ (def-test-ok suite ".besi 1 1.4" (eql (.besi 1 1.4) 0.8860919814143272))
+ (def-test-ok suite ".besi 1.3 1.4" (eql (.besi 1.3 1.4) 0.6628016954062065))
+
+ ;; (def-test-ok suite ".besk -1 1.4" (eql (.besk -1 1.4) -0.5419477139308545))
+ (def-test-ok suite ".besk 0 1.4" (eql (.besk 0 1.4) 0.2436550611815419))
+ (def-test-ok suite ".besk 1 1.4" (eql (.besk 1 1.4) 0.3208359022298758))
+ (def-test-ok suite ".besk 1.3 1.4" (eql (.besk 1.3 1.4) 0.3861853846058274))
+
+ ;; (def-test-ok suite ".besh1 -1 1.4" (eql (.besh1 -1 1.4) -0.5419477139308545))
+ (def-test-ok suite ".besh1 0 1.4" (eql (.besh1 0 1.4) #C(0.5668551203742888 0.3378951296796882)))
+ (def-test-ok suite ".besh1 1 1.4" (eql (.besh1 1 1.4) #C(0.5419477139308544 -0.4791469742327999)))
+ (def-test-ok suite ".besh1 1.3 1.4" (eql (.besh1 1.3 1.4) #C(0.4324531285021258 -0.6460486508001115)))
+
+ ;; (def-test-ok suite ".besh2 -1 1.4" (eql (.besh2 -1 1.4) -0.5419477139308545))
+ (def-test-ok suite ".besh2 0 1.4" (eql (.besh2 0 1.4) #C(0.5668551203742888 -0.3378951296796882)))
+ (def-test-ok suite ".besh2 1 1.4" (eql (.besh2 1 1.4) #C(0.5419477139308544 0.4791469742327999) ))
+ (def-test-ok suite ".besh2 1.3 1.4" (eql (.besh2 1.3 1.4) #C(0.4324531285021258 0.6460486508001115)))
+
+ (def-test-ok suite ".gamma 1.3" (eql (.gamma 1.3) 0.8974706963062772))
+
+ (test-it suite)
+ (test-report suite))
\ No newline at end of file
Added: trunk/src/test/unit/unit-test.asd
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/src/test/unit/unit-test.asd Tue May 1 12:30:48 2012 (r234)
@@ -0,0 +1,10 @@
+
+
+(defsystem :unit-test
+ :depends-on
+ (:lisplab lisplab-extension)
+ :serial t
+ :components
+ ((:file "package")
+ (:file "unit-test")
+ (:file "test-level0")))
\ No newline at end of file
Added: trunk/src/test/unit/unit-test.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/src/test/unit/unit-test.lisp Tue May 1 12:30:48 2012 (r234)
@@ -0,0 +1,156 @@
+(in-package :ll-test)
+
+(defgeneric test-it (test))
+(defgeneric test-reset (test))
+(defgeneric test-report (test &key) )
+
+(defclass test-base ()
+ ((name :accessor test-name :initarg :name)
+ (fun :initarg :fun)
+ (has-run :initarg :has-run)
+ (ok :initarg :ok)
+ (msg :initarg :msg :initform "")))
+
+(defmethod test-report ((test test-base) &key (stream *standard-output*))
+ (with-slots (name has-run ok msg) test
+ (if (not has-run)
+ (format stream "~&Not run [~a]" name)
+ (if ok
+ (format stream "~&OK [~a]" name)
+ (format stream "~&FAILED [~a] [~a]" name msg)))))
+
+(defmethod test-reset ((test test-base))
+ (with-slots (has-run ok msg)
+ test
+ (setf has-run nil
+ ok nil
+ msg "")))
+
+(defclass test-ok (test-base) ())
+
+(defmethod test-it ((test test-ok))
+ (with-slots (fun has-run ok msg) test
+ (multiple-value-bind (val err)
+ (ignore-errors (funcall fun))
+ (setf has-run t)
+ (if val
+ (setf ok t)
+ (progn
+ (setf ok nil)
+ (setf msg err))
+ ))
+ ok))
+
+
+(defclass test-type (test-base)
+ ((type :initarg :type)))
+
+(defmethod test-it ((test test-type))
+ (with-slots (fun has-run ok msg type) test
+ (multiple-value-bind (val err)
+ (ignore-errors (eql type (type-of (funcall fun))))
+ (setf has-run t)
+ (if (and (not val) err)
+ (progn
+ (setf ok nil)
+ (setf msg err))
+ (setf ok t)))
+ ok))
+
+
+
+(defclass test-suite (test-base)
+ ((tests :initform nil)
+ (verbose-p :initform t)))
+
+(defun make-test-suite (name)
+ (make-instance 'test-suite :name name))
+
+(defmethod test-reset (test-suite)
+ (call-next-method )
+ (with-slots (tests) test-suite
+ (dolist (test tests)
+ (test-reset test))))
+
+
+(defmethod test-it ((suite test-suite))
+ (with-slots (tests msg ok has-run) suite
+ (setf ok t
+ msg "FAILED: ")
+ (dolist (test tests)
+ (unless (test-it test)
+ (setf ok nil)
+ (setf msg (format nil "~a ~a" msg (test-name test)))))
+ (setf has-run t)))
+
+(defmethod test-report ((suite test-suite) &key (stream *standard-output*))
+ (with-slots (name tests has-run ok msg) suite
+ (format stream "~&==== START [~a]" name)
+ (if (not has-run)
+ (format stream "~&Not run [~a]" name)
+ (progn
+ (dolist (test tests)
+ (test-report test :stream stream))
+ (format stream "~&==== END [~a]: " name)
+ (if ok
+ (format stream "OK")
+ (format stream "FAILED [~a]" msg))))))
+
+(defmethod add-test ((suite test-suite) (test test-base))
+ (with-slots (tests) suite
+ (setf tests (append tests (list test)))))
+
+;;; Macros
+
+(defmacro def-test-ok (suite name &body body)
+ `(add-test ,suite
+ (make-instance 'test-ok
+ :name ,name
+ :fun (lambda ()
+ , at body))))
+
+(defmacro def-test-type (suite name type &body body)
+ `(add-test ,suite
+ (make-instance 'test-type
+ :type ,type
+ :name ,name
+ :fun (lambda ()
+ , at body))))
+
+
+
+#|
+
+
+
+
+
+
+(defclass test-suite-no-error (test-suite) ())
+
+(defmethod reset-test-suite ((test-suite test-suite-no-error))
+ (with-slots (tests run-p failed-tests) test-suite
+ (setf tests (make-hash-table)
+ run-p nil
+ failed-tests (make-hash-table))))
+
+(defun put-test-no-error (name test)
+ (setf (gethash name *test-no-error* ) test))
+
+(defmacro def-test-no-error (name &body body)
+ `(put-test-no-error ',name (lambda () , at body)))
+
+(defun run-test-no-error (&key (stream *standard-output*))
+ (maphash #'(lambda (name test)
+ (multiple-value-bind (val err)
+ (ignore-errors
+ (funcall test))
+ (if val
+ (format stream "~&OK [~a]" name)
+ (progn
+ (push name *test-no-error-failed*)
+ (format stream "~&FAILED [~a]. [~a]" name err)))))
+ *test-no-error*))
+|#
+
+
More information about the lisplab-cvs
mailing list