source: project/release/5/apropos/trunk/tests/run.scm @ 40266

Last change on this file since 40266 was 40266, checked in by Kon Lovett, 3 months ago

updated test runner, comments, reflow

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