source: project/release/5/stack/trunk/tests/run.scm @ 39694

Last change on this file since 39694 was 39694, checked in by Kon Lovett, 2 months ago

remove "primitives", use record-variants, add hof tests, new test runner

File size: 2.9 KB
Line 
1;;;; run.scm -*- Scheme -*-
2
3(import scheme)
4
5;; Create Egg Const
6
7(include-relative "run-ident")
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(define *current-directory* (cond-expand (unix "./") (else #f)))
21;no -disable-interrupts or -no-lambda-info
22(define *csc-init-options* '(-inline-global -local -inline -specialize
23  -optimize-leaf-routines -clustering -lfa2 -no-trace -unsafe -strict-types))
24(define *test-files-rx* (irregex '(: (+ graph) #\- "test" #\. "scm")))
25
26(define (remq obj ls)
27  (let loop ((curr ls) (prev '()))
28    (cond
29      ((null? curr)
30        ls )
31      ((eq? obj (car curr))
32        (if (null? prev)
33          (cdr ls)
34          (begin
35            (set-cdr! prev (cdr curr))
36            ls ) ) )
37      (else
38        (loop (cdr curr) curr) ) ) ) )
39
40(define (remqs os ls)
41  (let loop ((ls ls) (os os))
42    (cond
43      ((null? os)
44        ls )
45      (else
46        (loop (remq (car os) ls) (cdr os)) ) ) ) )
47
48(define (egg-name #!optional (args *args*) (def EGG-NAME))
49  (cond
50    ((<= 4 (length *args*)) (cadddr *args*) )
51    (def                    def )
52    (else
53      (error 'run "cannot determine egg-name") ) ) )
54
55(define (as-csc-options ls)
56  (apply string-append (intersperse (map symbol->string ls) " ")) )
57
58(define (csc-options)
59  (as-csc-options (remqs *csc-remv-options* *csc-init-options*)) )
60
61(define (test-filename name) (string-append name "-test"))
62
63(define (test-files) (find-files "." #:test *test-files-rx* #:limit 1))
64
65(define (ensure-test-source-name name)
66  (if (irregex-match? *test-files-rx* name)
67    name
68    (make-pathname *current-directory* (test-filename name) "scm") ) )
69
70;;
71
72(define (run-test-evaluated source)
73  (format #t "*** ~A - csi ***~%" (pathname-file source))
74  (system (string-append "csi -s " source)) )
75
76(define (run-test-compiled source csc-options)
77  (format #t "*** ~A - csc ~A ***~%" (pathname-file source) csc-options)
78  ;csc output is in current directory
79  (system (string-append "csc" " " csc-options " " source))
80  (system (pathname-replace-directory (pathname-strip-extension source) *current-directory*)) )
81
82(define (run-test #!optional (name (egg-name)) (csc-options (csc-options)))
83  (let (
84    (source (ensure-test-source-name name)) )
85    (unless (file-exists? source)
86      (error 'run "no such file" source) )
87    (run-test-evaluated source)
88    (newline)
89    (run-test-compiled source csc-options) ) )
90
91(define (run-tests #!optional (tests (test-files)) (csc-options (csc-options)))
92  (for-each (cut run-test <> csc-options) tests) )
93
94;; Do Test
95
96(run-tests)
Note: See TracBrowser for help on using the repository browser.