Changeset 39805 in project


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

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

Location:
release/5/message-digest-utils/trunk/tests
Files:
1 added
1 edited

Legend:

Unmodified
Added
Removed
  • release/5/message-digest-utils/trunk/tests/run.scm

    r38970 r39805  
    1 ;;;; run.scm -*- Scheme -*-
     1;;;; run.scm  -*- Scheme -*-
    22
    3 (import scheme)
     3;chicken-install invokes as "<csi> -s run.scm <eggnam>"
    44
    5 ;;; Create Egg Const
     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?))
    613
    7 (define EGG-NAME "message-digest-utils")
     14;; Globals
    815
    9 ;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
     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"))
    1022
    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?))
     23(define *test-directory* ".")
     24(define *test-extension* "scm")
     25(define *test-files-rx* (irregex `(: (+ graph) #\- "test" #\. ,*test-extension*)))
    1826
    19 (define *args* (argv))
     27(include-relative "run-ident")
    2028
    21 (define (egg-name args #!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))
    2249  (cond
    23     ((<= 4 (length *args*)) (cadddr *args*) )
    24     (def                    def )
     50    ((not (null? args)) (car args))
     51    (def                def)
    2552    (else
    26       (error 'run "cannot determine egg-name") ) ) )
     53      (error 'run "cannot determine egg-name")) ) )
    2754
    28 (define *current-directory* (cond-expand (unix "./") (else #f)))
    29 (define *egg* (egg-name *args*))
     55(define (csc-options)
     56  (append *csc-incl-options* (remove/list *csc-excl-options* *csc-init-options*)) )
    3057
    31 ;no -disable-interrupts or -no-lambda-info
    32 #; ;FIXME -strict-types doesn't like union return type; ex: (or string false)
    33 (define *csc-options* "-inline-global -local -inline \
    34   -specialize -optimize-leaf-routines -clustering -lfa2 \
    35   -no-trace -unsafe \
    36   -strict-types")
    37 (define *csc-options* "-inline-global -local -inline \
    38   -specialize -optimize-leaf-routines -clustering -lfa2 \
    39   -no-trace -unsafe")
     58(define (test-filename name) (string-append name "-test"))
    4059
    41 (define *test-files-rx* (irregex '(: (+ graph) #\- "test" #\. "scm")))
    42 (define (test-filename name) (string-append name "-test"))
    43 (define (test-files) (find-files "." #:test *test-files-rx* #:limit 1))
     60(define (make-test-pathname name)
     61  (make-pathname *test-directory* (test-filename name) *test-extension*) )
    4462
    45 (define (ensure-test-source-name name)
     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)
    4674  (if (irregex-match? *test-files-rx* name)
    4775    name
    48     (make-pathname *current-directory* (test-filename name) "scm") ) )
     76    (make-test-pathname name)) )
     77
     78;; Run Tests
    4979
    5080(define (run-test-evaluated source)
    51   (format #t "*** ~A - csi ***~%" (pathname-file source))
    52   (system (string-append "csi -s " source)) )
     81  (format #t "*** csi ~A ***~%" (pathname-file source))
     82  (system-must (string-append "csi -s " source)) )
    5383
    5484(define (run-test-compiled source csc-options)
    55   (format #t "*** ~A - csc ~A ***~%" (pathname-file source) csc-options)
    56   ;csc output is in current directory
    57   (system (string-append "csc" " " csc-options " " source))
    58   (system (pathname-replace-directory (pathname-strip-extension source) *current-directory*)) )
     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*)) )
    5990
    60 ;;;
    61 
    62 (define (run-test #!optional (name *egg*) (csc-options *csc-options*))
    63   (let (
    64     (source (ensure-test-source-name name)) )
     91(define (run-test #!optional (name (egg-name)) (csc-options (csc-options)))
     92  (let ((source (ensure-test-pathname name)))
    6593    (unless (file-exists? source)
    6694      (error 'run "no such file" source) )
     
    6997    (run-test-compiled source csc-options) ) )
    7098
    71 (define (run-tests #!optional (tests (test-files)) (csc-options *csc-options*))
     99(define (run-tests #!optional (tests (test-files)) (csc-options (csc-options)))
    72100  (for-each (cut run-test <> csc-options) tests) )
    73101
    74 ;;; Do Test
     102;; Do Tests
    75103
    76104(run-tests)
Note: See TracChangeset for help on using the changeset viewer.