source: project/release/5/slib-arraymap/trunk/tests/run.scm @ 39814

Last change on this file since 39814 was 39814, checked in by Kon Lovett, 6 months ago

fix test runner fail exit pass-thru, add test runner config

File size: 3.1 KB
Line 
1;;;; run.scm  -*- Scheme -*-
2
3;chicken-install invokes as "<csi> -s run.scm <eggnam>"
4
5(import scheme
6  (only (chicken pathname)
7    make-pathname pathname-file pathname-replace-directory pathname-strip-extension)
8  (only (chicken process) system)
9  (only (chicken process-context) command-line-arguments)
10  (only (chicken format) format)
11  (only (chicken file) file-exists? find-files)
12  (only (chicken irregex) irregex irregex-match?))
13
14;; Globals
15
16(define *csc-init-options* '(
17  ;"-disable-interrupts"
18  "-inline-global" "-inline" "-local"
19  "-specialize" "-strict-types"
20  "-optimize-leaf-routines" "-clustering" "-lfa2"
21  "-no-trace" "-no-lambda-info" "-unsafe"))
22
23(define *test-directory* ".")
24(define *test-extension* "scm")
25(define *test-files-rx* (irregex `(: (+ graph) #\- "test" #\. ,*test-extension*)))
26
27(include-relative "run-ident")
28
29;; Support
30
31(define (system-must cmd)
32  (let ((stat (system cmd)))
33    (if (zero? stat) 0
34      ;failed, actual code irrelevant
35      (exit 1) ) ) )
36
37(define (remove rmv? ls)
38  (let loop ((ls ls) (os '()))
39    (cond
40      ((null? ls)       (reverse os))
41      ((rmv? (car ls))  (loop (cdr ls) os))
42      (else             (loop (cdr ls) (cons (car ls) os))) ) ) )
43
44(define (remove/list os ls) (remove (cut member <> os) ls))
45
46;; Test Run Support
47
48(define (egg-name #!optional (args (command-line-arguments)) (def EGG-NAME))
49  (cond
50    ((not (null? args)) (car args))
51    (def                def)
52    (else
53      (error 'run "cannot determine egg-name")) ) )
54
55(define (csc-options)
56  (append *csc-incl-options* (remove/list *csc-excl-options* *csc-init-options*)) )
57
58(define (test-filename name) (string-append name "-test"))
59
60(define (make-test-pathname name)
61  (make-pathname *test-directory* (test-filename name) *test-extension*) )
62
63(define (matching-test-file? x #!optional (remvs '()))
64  (and (irregex-match? *test-files-rx* x) (not (member x remvs))) )
65
66(define (test-files)
67  (let ((remvs (map make-test-pathname *test-excl-names*)))
68    (find-files
69      *test-directory*
70      #:test (cut matching-test-file? <> remvs)
71      #:limit 0) ) )
72
73(define (ensure-test-pathname name)
74  (if (irregex-match? *test-files-rx* name)
75    name
76    (make-test-pathname name)) )
77
78;; Run Tests
79
80(define (run-test-evaluated source)
81  (format #t "*** csi ~A ***~%" (pathname-file source))
82  (system-must (string-append "csi -s " source)) )
83
84(define (run-test-compiled source csc-options)
85  (let ((optstr (apply string-append (intersperse csc-options " "))))
86    (format #t "*** csc ~A ~A ***~%" (pathname-file source) optstr)
87    ;csc output is in current directory
88    (system-must (string-append "csc" " " optstr " " source)) )
89  (system-must (pathname-replace-directory (pathname-strip-extension source) *test-directory*)) )
90
91(define (run-test #!optional (name (egg-name)) (csc-options (csc-options)))
92  (let ((source (ensure-test-pathname name)))
93    (unless (file-exists? source)
94      (error 'run "no such file" source) )
95    (run-test-evaluated source)
96    (newline)
97    (run-test-compiled source csc-options) ) )
98
99(define (run-tests #!optional (tests (test-files)) (csc-options (csc-options)))
100  (for-each (cut run-test <> csc-options) tests) )
101
102;; Do Tests
103
104(run-tests)
Note: See TracBrowser for help on using the repository browser.