source: project/release/5/slib-prec/trunk/tests/run.scm @ 39829

Last change on this file since 39829 was 39829, checked in by Kon Lovett, 6 weeks 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) (remove/list *csc-remv-options* *csc-init-options*))
56
57(define (test-filename name) (string-append name "-test"))
58
59(define (make-test-pathname name)
60  (make-pathname *test-directory* (test-filename name) *test-extension*) )
61
62(define (matching-test-file? x #!optional (remvs '()))
63  (and (irregex-match? *test-files-rx* x) (not (member x remvs))) )
64
65(define (test-files)
66  (let ((remvs (map make-test-pathname *test-remv-names*)))
67    (find-files
68      *test-directory*
69      #:test (cut matching-test-file? <> remvs)
70      #:limit 0) ) )
71
72(define (ensure-test-pathname name)
73  (if (irregex-match? *test-files-rx* name)
74    name
75    (make-test-pathname name)) )
76
77;; Run Tests
78
79(define (run-test-evaluated source)
80  (format #t "*** csi ~A ***~%" (pathname-file source))
81  (system-must (string-append "csi -s " source)) )
82
83(define (run-test-compiled source csc-options)
84  (let ((optstr (apply string-append (intersperse csc-options " "))))
85    (format #t "*** csc ~A ~A ***~%" (pathname-file source) optstr)
86    ;csc output is in current directory
87    (system-must (string-append "csc" " " optstr " " source)) )
88  (system-must (pathname-replace-directory (pathname-strip-extension source) *test-directory*)) )
89
90(define (run-test #!optional (name (egg-name)) (csc-options (csc-options)))
91  (let ((source (ensure-test-pathname name)))
92    (unless (file-exists? source)
93      (error 'run "no such file" source) )
94    (run-test-evaluated source)
95    (newline)
96    (run-test-compiled source csc-options) ) )
97
98(define (run-tests #!optional (tests (test-files)) (csc-options (csc-options)))
99  (for-each (cut run-test <> csc-options) tests) )
100
101;; Do Tests
102
103(run-tests)
Note: See TracBrowser for help on using the repository browser.