source: project/release/5/expand-full/trunk/tests/run.scm @ 39010

Last change on this file since 39010 was 39010, checked in by Kon Lovett, 7 weeks ago

better names, macros at runtime for test

File size: 2.4 KB
Line 
1;;;; run.scm -*- Scheme -*-
2
3(import scheme)
4
5;;; Create Egg Const
6
7(define EGG-NAME "expand-full")
8
9;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
10
11(import (only (chicken pathname)
12  make-pathname pathname-file pathname-replace-directory pathname-strip-extension))
13(import (only (chicken process) system))
14(import (only (chicken process-context) argv))
15(import (only (chicken format) format))
16(import (only (chicken file) file-exists? find-files))
17(import (only (chicken irregex) irregex irregex-match?))
18
19(define *args* (argv))
20
21(define (egg-name args #!optional (def EGG-NAME))
22  (cond
23    ((<= 4 (length *args*)) (cadddr *args*) )
24    (def                    def )
25    (else
26      (error 'run "cannot determine egg-name") ) ) )
27
28(define *current-directory* (cond-expand (unix "./") (else #f)))
29(define *egg* (egg-name *args*))
30
31;no -disable-interrupts or -no-lambda-info
32(define *csc-options* "-inline-global -local -inline \
33  -specialize -optimize-leaf-routines -clustering -lfa2 \
34  -no-trace -unsafe \
35  -strict-types \
36  -compile-syntax")
37
38(define *test-files-rx* (irregex '(: (+ graph) #\- "test" #\. "scm")))
39(define (test-filename name) (string-append name "-test"))
40(define (test-files) (find-files "." #:test *test-files-rx* #:limit 1))
41
42(define (ensure-test-source-name name)
43  (if (irregex-match? *test-files-rx* name)
44    name
45    (make-pathname *current-directory* (test-filename name) "scm") ) )
46
47(define (run-test-evaluated source)
48  (format #t "*** ~A - csi ***~%" (pathname-file source))
49  (system (string-append "csi -s " source)) )
50
51(define (run-test-compiled source csc-options)
52  (format #t "*** ~A - csc ~A ***~%" (pathname-file source) csc-options)
53  ;csc output is in current directory
54  (system (string-append "csc" " " csc-options " " source))
55  (system (pathname-replace-directory (pathname-strip-extension source) *current-directory*)) )
56
57;;;
58
59(define (run-test #!optional (name *egg*) (csc-options *csc-options*))
60  (let (
61    (source (ensure-test-source-name name)) )
62    (unless (file-exists? source)
63      (error 'run "no such file" source) )
64    (run-test-evaluated source)
65    (newline)
66    (run-test-compiled source csc-options) ) )
67
68(define (run-tests #!optional (tests (test-files)) (csc-options *csc-options*))
69  (for-each (cut run-test <> csc-options) tests) )
70
71;;; Do Test
72
73(set! *csc-options* (string-append *csc-options* " " "-compile-syntax"))
74(run-tests)
Note: See TracBrowser for help on using the repository browser.