diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..b25c15b --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +*~ diff --git a/testing.scm b/testing.scm new file mode 100644 index 0000000..aa3f0c5 --- /dev/null +++ b/testing.scm @@ -0,0 +1,68 @@ +;; +;; testing.scm +;; +;; ISC License +;; +;; Copyright 2023 Brmlab, z.s. +;; Dominik Pantůček +;; +;; Permission to use, copy, modify, and/or distribute this software +;; for any purpose with or without fee is hereby granted, provided +;; that the above copyright notice and this permission notice appear +;; in all copies. +;; +;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL +;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED +;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE +;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR +;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS +;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, +;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN +;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +;; +(module + testing + (test-eq? test-equal? test-exn) + + (import scheme) + + ;; Evaluates body ... expressions with exception handler installed. + (define-syntax with-handler + (syntax-rules () + ((_ handler body ...) + (call-with-current-continuation + (lambda (k) + (with-exception-handler + (lambda (x) (k (handler x))) + (lambda () body ...))))))) + + ;; Test passes if the-test does not raise an exception and the result + ;; is eq? to expected-result. + (define-syntax test-eq? + (syntax-rules () + ((_ name the-test expected-result) + (if (with-handler (lambda (x) #f) + (eq? the-test expected-result)) + (display ".") + (error 'unit-test name))))) + + ;; Test passes if the-test does not raise an exception and the result + ;; is equal? to expected-result. + (define-syntax test-equal? + (syntax-rules () + ((_ name the-test expected-result) + (if (with-handler (lambda (x) #f) + (eq? the-test expected-result)) + (display ".") + (error 'unit-test name))))) + + ;; Passes if the-test raises an exception + (define-syntax test-exn + (syntax-rules () + ((_ name the-test) + (if (with-handler (lambda (x) #t) + the-test #f) + (display ".") + (error 'unit-test name))))) + + )