blob: ded94cc522d6d556f734dee575cad2d597f8c20e (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
|
#!/usr/bin/guile \
-s
!#
(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)
(srfi srfi-64) ; test suite
(srfi srfi-88) ; suffix keywords
((util) :select (for awhen))
;; datetime introduces the reader extensions for datetimes,
;; which leaks into the sandboxes below.
(datetime))
(define files
(scandir here
(lambda (name)
(and (< 2 (string-length name))
(not (string=? name (basename (current-filename))))
(string=? "scm" (string-take-right name 3))))))
;; Load tests
(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")
(awhen (member "--skip" (command-line))
(for skip in (cdr it)
(test-skip skip)))
(for fname in files
(format (current-error-port) "Running test ~a~%" fname)
(test-group
fname
(with-throw-handler #t
(lambda ()
(with-input-from-file (string-append here "/" fname)
(lambda ()
(let ((modules (read)))
(eval-in-sandbox
`(begin ,@(read-multiple))
#:time-limit 60 ; larger than should be needed
#: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)))))))
(lambda args (format (current-error-port)
"Test really crashed: ~a~%" args) ))))
(test-end "tests")
|