From jivestgarden at common-lisp.net Tue May 1 19:30:49 2012 From: jivestgarden at common-lisp.net (jivestgarden at common-lisp.net) Date: Tue, 01 May 2012 12:30:49 -0700 Subject: [lisplab-cvs] r234 - trunk/src/test/unit Message-ID: 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*)) +|# + +