diff options
author | Hugo Hörnquist <hugo@hornquist.se> | 2019-12-30 02:11:38 +0100 |
---|---|---|
committer | Hugo Hörnquist <hugo@hornquist.se> | 2019-12-30 02:11:38 +0100 |
commit | b6d12e309b207c25de7873f658aa0f88ea77080c (patch) | |
tree | ea4a8515c4c5b3e6798f6b3b69e24ad76f53b883 /tests/run-tests.scm | |
parent | Fix keyword argument. (diff) | |
download | calp-b6d12e309b207c25de7873f658aa0f88ea77080c.tar.gz calp-b6d12e309b207c25de7873f658aa0f88ea77080c.tar.xz |
Reworked tests.
Diffstat (limited to '')
-rwxr-xr-x | tests/run-tests.scm | 39 |
1 files changed, 33 insertions, 6 deletions
diff --git a/tests/run-tests.scm b/tests/run-tests.scm index 529878c7..c024f3a9 100755 --- a/tests/run-tests.scm +++ b/tests/run-tests.scm @@ -5,12 +5,17 @@ (eval-when (compile load) (define here (dirname (current-filename)))) +(format #t "current filename = ~a~%" here) + + (add-to-load-path (format #f "~a/module" (dirname here))) (use-modules (ice-9 ftw) - (ice-9 sandbox)) + (ice-9 sandbox) + (srfi srfi-64) + ((util) :select (for))) (define files (scandir here @@ -19,15 +24,37 @@ (not (string=? name (basename (current-filename)))) (string=? "scm" (string-take-right name 3)))))) -(setenv "TESTPATH" - (format #f "~a/testdata" (dirname here))) -(use-modules (srfi srfi-64)) ;; Load tests -(add-to-load-path here) +(define (read-multiple) +(let loop ((done '())) + (let ((sexp (read))) + (if (eof-object? sexp) + (reverse done) + (loop (cons sexp done)))))) +;; TODO test-group fails if called before any test begin, since +;; (test-runner-current) needs to be a test-runner (dead or not), +;; but is initially bound to #f. (test-begin "tests") -(for-each load-from-path files) +(for fname in files + (format (current-error-port) "Running test ~a~%" fname) + (test-group + fname + (with-input-from-file (string-append here "/" fname) + (lambda () + (let ((modules (read))) + (eval-in-sandbox + `(begin ,@(read-multiple)) + #:module (make-sandbox-module + (append modules + '(((srfi srfi-64) test-assert test-equal test-error) + ((ice-9 ports) call-with-input-string) + ((guile) make-struct/no-tail) + ) + all-pure-bindings)))))))) (test-end "tests") + + |