Changeset 39802 in project


Ignore:
Timestamp:
04/04/21 02:07:40 (3 weeks ago)
Author:
Kon Lovett
Message:

fix test runner fail exit pass-thru, add test runner config

Location:
release/5/md5/trunk/tests
Files:
1 added
1 edited

Legend:

Unmodified
Added
Removed
  • release/5/md5/trunk/tests/run.scm

    r35863 r39802  
     1;;;; run.scm  -*- Scheme -*-
    12
    2 (define EGG-NAME "md5")
     3;chicken-install invokes as "<csi> -s run.scm <eggnam>"
    34
    4 ;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
     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?))
    513
    6 (import
    7   (only (chicken pathname) make-pathname)
    8   (only (chicken process) system)
    9   (only (chicken process-context) argv)
    10   (only (chicken format) format))
     14;; Globals
    1115
    12 (define *args* (argv))
     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"))
    1322
    14 ;no -disable-interrupts
    15 (define *csc-options* "-inline-global \
    16   -specialize -optimize-leaf-routines -clustering -lfa2 \
    17   -local -inline \
    18   -no-trace -no-lambda-info \
    19   -unsafe")
     23(define *test-directory* ".")
     24(define *test-extension* "scm")
     25(define *test-files-rx* (irregex `(: (+ graph) #\- "test" #\. ,*test-extension*)))
    2026
    21 (define (test-name #!optional (eggnam EGG-NAME))
    22   (string-append eggnam "-test") )
     27(include-relative "run-ident")
    2328
    24 (define (egg-name #!optional (def EGG-NAME))
     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))
    2549  (cond
    26     ((<= 4 (length *args*))
    27       (cadddr *args*) )
    28     (def
    29       def )
     50    ((not (null? args)) (car args))
     51    (def                def)
    3052    (else
    31       (error 'test "cannot determine egg-name") ) ) )
     53      (error 'run "cannot determine egg-name")) ) )
    3254
    33 ;;;
     55(define (csc-options)
     56  (append *csc-incl-options* (remove/list *csc-excl-options* *csc-init-options*)) )
    3457
    35 (set! EGG-NAME (egg-name))
     58(define (test-filename name) (string-append name "-test"))
    3659
    37 (define (run-test #!optional (eggnam EGG-NAME) (cscopts *csc-options*))
    38   (let ((tstnam (test-name eggnam)))
    39     (format #t "*** csi ***~%")
    40     (system (string-append "csi -s " (make-pathname #f tstnam "scm")))
     60(define (make-test-pathname name)
     61  (make-pathname *test-directory* (test-filename name) *test-extension*) )
     62
     63(define (matching-test-file? x #!optional (remvs '()))
     64  (and (irregex-match? *test-files-rx* x) (not (member x remvs))) )
     65
     66(define (test-files)
     67  (let ((remvs (map make-test-pathname *test-excl-names*)))
     68    (find-files
     69      *test-directory*
     70      #:test (cut matching-test-file? <> remvs)
     71      #:limit 0) ) )
     72
     73(define (ensure-test-pathname name)
     74  (if (irregex-match? *test-files-rx* name)
     75    name
     76    (make-test-pathname name)) )
     77
     78;; Run Tests
     79
     80(define (run-test-evaluated source)
     81  (format #t "*** csi ~A ***~%" (pathname-file source))
     82  (system-must (string-append "csi -s " source)) )
     83
     84(define (run-test-compiled source csc-options)
     85  (let ((optstr (apply string-append (intersperse csc-options " "))))
     86    (format #t "*** csc ~A ~A ***~%" (pathname-file source) optstr)
     87    ;csc output is in current directory
     88    (system-must (string-append "csc" " " optstr " " source)) )
     89  (system-must (pathname-replace-directory (pathname-strip-extension source) *test-directory*)) )
     90
     91(define (run-test #!optional (name (egg-name)) (csc-options (csc-options)))
     92  (let ((source (ensure-test-pathname name)))
     93    (unless (file-exists? source)
     94      (error 'run "no such file" source) )
     95    (run-test-evaluated source)
    4196    (newline)
    42     (format #t "*** csc ~s ***~%" cscopts)
    43     (system (string-append "csc" " " cscopts " " (make-pathname #f tstnam "scm")))
    44     (system (make-pathname (cond-expand (unix "./") (else #f)) tstnam)) ) )
     97    (run-test-compiled source csc-options) ) )
    4598
    46 (define (run-tests eggnams #!optional (cscopts *csc-options*))
    47   (for-each (cut run-test <> cscopts) eggnams) )
     99(define (run-tests #!optional (tests (test-files)) (csc-options (csc-options)))
     100  (for-each (cut run-test <> csc-options) tests) )
    48101
    49 ;;;
     102;; Do Tests
    50103
    51 (run-test)
     104(run-tests)
Note: See TracChangeset for help on using the changeset viewer.