300 lines
8.3 KiB
Scheme
300 lines
8.3 KiB
Scheme
;;;; test-utils.run.scm -*- Scheme -*-
|
|
|
|
;; Notes
|
|
;;
|
|
;; - chicken-install invokes "run.scm" as "<csi> -s run.scm <eggnam>"
|
|
|
|
(module (test-utils run)
|
|
|
|
(;export
|
|
;
|
|
make-test-filename
|
|
make-test-pathname
|
|
;
|
|
test-list-order<
|
|
;
|
|
run-ident runid
|
|
;
|
|
run-test run-test-for
|
|
test-files-rx
|
|
test-lineup
|
|
run-tests run-tests-for
|
|
;
|
|
csi-options csc-options
|
|
run-test-evaluated run-test-compiled)
|
|
|
|
(import scheme
|
|
(scheme case-lambda)
|
|
(chicken base)
|
|
(chicken type)
|
|
(only (chicken pathname)
|
|
make-pathname pathname-file pathname-replace-directory
|
|
pathname-strip-extension pathname-directory
|
|
pathname-strip-directory)
|
|
(only (chicken process) system)
|
|
(only (chicken process-context)
|
|
command-line-arguments get-environment-variable executable-pathname)
|
|
(only (chicken format) format)
|
|
(only (chicken sort) sort)
|
|
(only (chicken file) file-exists? find-files)
|
|
(only (chicken irregex) irregex? irregex irregex-match?))
|
|
|
|
(define-type filename string)
|
|
(define-type pathname string)
|
|
(define-type irregex (struct regexp))
|
|
|
|
(define-type alist (list-of (pair symbol *)))
|
|
|
|
(define-type eggname string)
|
|
(define-type testname (or eggname pathname))
|
|
|
|
(define-type options (list-of string))
|
|
(define-type tests (list-of testname))
|
|
|
|
(define-type opt-options (or false (list-of string)))
|
|
(define-type opt-tests (or false tests))
|
|
|
|
(: test-list-order< ((list-of testname) -> (testname testname -> boolean)))
|
|
|
|
(: run-ident (#!optional (or false alist) -> (or false alist)))
|
|
(: runid (symbol #!optional * -> *))
|
|
|
|
(: make-test-filename (string -> filename))
|
|
(: make-test-pathname (string -> pathname))
|
|
|
|
(: test-files-rx (#!optional (or false list irregex) -> (or false irregex)))
|
|
|
|
(: test-lineup (#!optional opt-tests -> opt-tests))
|
|
|
|
(: run-test (#!optional testname options options -> fixnum))
|
|
(: run-test-for (eggname #!optional testname options options -> fixnum))
|
|
|
|
(: run-tests (#!optional tests options options -> void))
|
|
(: run-tests-for (eggname #!optional tests options options -> void))
|
|
|
|
;not so "testy"
|
|
|
|
(: csi-options (#!optional opt-options -> opt-options))
|
|
(: csc-options (#!optional opt-options -> opt-options))
|
|
|
|
(: run-test-evaluated (pathname options -> fixnum))
|
|
(: run-test-compiled (pathname options -> fixnum))
|
|
|
|
;; Support
|
|
|
|
(define (system-must cmd)
|
|
(let ((stat (system cmd)))
|
|
(if (zero? stat) 0
|
|
;failed, actual code irrelevant
|
|
(exit 1) ) ) )
|
|
|
|
;(srfi 1)
|
|
|
|
;/1 good enough
|
|
(define (list-index pd? ls)
|
|
(let loop ((ls ls) (i 0))
|
|
(cond ((null? ls) #f)
|
|
((pd? (car ls)) i)
|
|
(else (loop (cdr ls) (add1 i)))) ) )
|
|
|
|
(define (remove rmv? ls)
|
|
(let loop ((ls ls) (os '()))
|
|
(cond ((null? ls)
|
|
(reverse os))
|
|
((rmv? (car ls))
|
|
(loop (cdr ls) os))
|
|
(else
|
|
(loop (cdr ls) (cons (car ls) os))) ) ) )
|
|
|
|
(define (remove/list os ls) (remove (cut member <> os) ls))
|
|
|
|
;; Globals
|
|
|
|
; Where to find CHICKEN binaries
|
|
|
|
(define *bin* (pathname-directory (executable-pathname)))
|
|
|
|
(define *csi* (or (get-environment-variable "CHICKEN_CSI") (make-pathname *bin* "csi")))
|
|
(define *csc* (or (get-environment-variable "CHICKEN_CSC") (make-pathname *bin* "csc")))
|
|
|
|
; What options for the test run
|
|
|
|
(define *csi-init-options* '())
|
|
|
|
(define *csc-init-options* '(
|
|
;Highly Problematic
|
|
;"-disable-interrupts" "-unsafe"
|
|
"-local"
|
|
"-inline-global" "-inline"
|
|
"-specialize" "-strict-types"
|
|
"-optimize-leaf-routines" "-clustering" "-lfa2"
|
|
"-no-trace" "-no-lambda-info"))
|
|
|
|
(define *egg-name*
|
|
(let ((args (command-line-arguments)))
|
|
(if (null? args) "" (car args)) ) )
|
|
|
|
(define *run-ident* `(
|
|
(*test-directory* . ".")
|
|
(*test-extension* . "scm")
|
|
(*csi-options* . ())
|
|
(*csi-excl-options* . ())
|
|
(*csc-options* . ())
|
|
(*csc-excl-options* . ())
|
|
(*test-excl-names* . ())
|
|
(*test-order* . ,string<?)
|
|
(EGG-NAME . ,*egg-name*) ) )
|
|
|
|
;; Test Run Support
|
|
|
|
(define ((test-list-order< ordered) a b)
|
|
(define (warn-test-order i tst)
|
|
(unless i (warning 'test-list-order< "unknown test" tst))
|
|
tst )
|
|
;
|
|
(let ((ai (list-index (cut string=? a <>) ordered))
|
|
(bi (list-index (cut string=? b <>) ordered)) )
|
|
(if (and ai bi) (< ai bi)
|
|
(string<? (warn-test-order ai a) (warn-test-order bi b)) ) ) )
|
|
|
|
(define run-ident
|
|
(let ((ids (the (or false alist) #f)))
|
|
(case-lambda
|
|
(()
|
|
(or ids
|
|
(run-ident *run-ident*)) )
|
|
((x)
|
|
;allow #f to reset
|
|
(set! ids x) x) ) ) )
|
|
|
|
(define runid
|
|
(case-lambda
|
|
((id)
|
|
(let ((cell (assq id (run-ident))))
|
|
(if cell (cdr cell)
|
|
(error 'runid "no such run ident" id) ) ) )
|
|
((id v) (run-ident (cons (cons id v) (run-ident))) v) ) )
|
|
|
|
(define (make-test-filename name) (string-append name "-test"))
|
|
|
|
(define (make-test-pathname name)
|
|
(make-pathname (runid '*test-directory*)
|
|
(make-test-filename name) (runid '*test-extension*)) )
|
|
|
|
(define csi-options
|
|
(let ((opts (the (or false options) #f)))
|
|
(case-lambda
|
|
(()
|
|
(or opts
|
|
(remove/list (runid '*csi-excl-options*)
|
|
(append (runid '*csi-options*) *csi-init-options*))) )
|
|
((x)
|
|
;allow #f to reset
|
|
(set! opts x) x) ) ) )
|
|
|
|
(define csc-options
|
|
(let ((opts (the (or false options) #f)))
|
|
(case-lambda
|
|
(()
|
|
(or opts
|
|
(remove/list (runid '*csc-excl-options*)
|
|
(append (runid '*csc-options*) *csc-init-options*))) )
|
|
((x)
|
|
;allow #f to reset
|
|
(set! opts x) x) ) ) )
|
|
|
|
(define (extn-test-files-rx ext) `(: (+ graph) #\- "test" #\. ,ext))
|
|
|
|
(define test-files-rx
|
|
(let ((rx (the (or false irregex) #f)))
|
|
(case-lambda
|
|
(()
|
|
(or rx
|
|
(test-files-rx (extn-test-files-rx (runid '*test-extension*)))) )
|
|
((x)
|
|
;allow #f to reset
|
|
(set! rx (and x
|
|
(if (irregex? x) x
|
|
(irregex x 'utf8))))
|
|
rx) ) ) )
|
|
|
|
;Internal
|
|
|
|
(define (egg-name) (runid 'EGG-NAME))
|
|
|
|
(define (test-file-name? x) (irregex-match? (test-files-rx) x))
|
|
|
|
(define (matching-test-file? x #!optional (remvs '()))
|
|
(and (test-file-name? x) (not (member x remvs))) )
|
|
|
|
(define (test-files)
|
|
(let ((remvs (map make-test-pathname (runid '*test-excl-names*))))
|
|
(find-files (runid '*test-directory*)
|
|
#:test (cut matching-test-file? <> remvs)
|
|
#:limit 0) ) )
|
|
|
|
;FIXME very weak
|
|
(define (ensure-test-pathname name)
|
|
(if (test-file-name? name) name
|
|
(make-test-pathname name)) )
|
|
|
|
(define (options->string opts)
|
|
;FIXME map ->string over options & allow symbols, etc, not just strings
|
|
(apply string-append (intersperse opts " ")) )
|
|
|
|
;; Run Tests
|
|
|
|
(define test-lineup
|
|
(let ((fls #f))
|
|
(case-lambda
|
|
(()
|
|
(or fls
|
|
(let ((fls (test-files))
|
|
(ord (runid '*test-order*)) )
|
|
(define (stripped-ord a b)
|
|
(ord (pathname-file a) (pathname-file b)) )
|
|
(test-lineup (sort fls stripped-ord)))) )
|
|
((x)
|
|
;allow #f to reset
|
|
(set! fls x) x) ) ) )
|
|
|
|
(define (run-test-evaluated source opts)
|
|
(let ((optstr (options->string opts)))
|
|
(format #t "*** ~A ~A ~A ***~%" *csi* (pathname-file source) optstr)
|
|
(system-must (string-append *csi* " " optstr " -s " source)) ) )
|
|
|
|
(define (run-test-compiled source opts)
|
|
(let ((optstr (options->string opts)))
|
|
(format #t "*** ~A ~A ~A ***~%" *csc* (pathname-file source) optstr)
|
|
;csc output is in current directory
|
|
(system-must (string-append *csc* " " optstr " " source)) )
|
|
(system-must
|
|
(pathname-replace-directory (pathname-strip-extension source)
|
|
(runid '*test-directory*))) )
|
|
|
|
(define (run-test #!optional
|
|
(name (egg-name))
|
|
(csc-options (csc-options))
|
|
(csi-options (csi-options)))
|
|
(let ((source (ensure-test-pathname name)))
|
|
(unless (file-exists? source)
|
|
(error 'run-test "no such file" source) )
|
|
(run-test-evaluated source csi-options)
|
|
(newline)
|
|
(run-test-compiled source csc-options) ) )
|
|
|
|
(define (run-tests #!optional
|
|
(tests (test-lineup))
|
|
(csc-options (csc-options))
|
|
(csi-options (csi-options)))
|
|
(for-each (cut run-test <> csc-options csi-options) tests) )
|
|
|
|
(define (run-test-for eggnam . rest)
|
|
(runid 'EGG-NAME eggnam)
|
|
(apply run-test eggnam rest) )
|
|
|
|
(define (run-tests-for eggnam . rest)
|
|
(runid 'EGG-NAME eggnam)
|
|
(apply run-tests rest) )
|
|
|
|
) ;module (test-utils run)
|