blob: d2b868284b72de5192839cec99c23d32fe4cef12 (
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
76
77
78
79
80
81
82
83
84
85
86
87
88
|
#!/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)
(ice-9 getopt-long)
(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))))))
(define options
'((skip (value #t))
(only (value #t))))
(define opts (getopt-long (command-line) options))
(define to-skip (call-with-input-string (option-ref opts 'skip "")
read))
(define only (option-ref opts 'only #f))
(when only (set! files (list only)))
(when (list? to-skip)
(for skip in to-skip
(test-skip skip)))
;; 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 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
#:allocation-limit #e10e8
#: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 unexpectedly crashed: ~a~%" args) ))))
(test-end "tests")
|
