Changeset 39789 in project


Ignore:
Timestamp:
04/04/21 02:06:37 (3 months ago)
Author:
Kon Lovett
Message:

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

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

Legend:

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

    r38962 r39789  
    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 "error-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 (define *csc-options* "-inline-global -local -inline \
    33   -specialize -optimize-leaf-routines -clustering -lfa2 \
    34   -no-trace -unsafe \
    35   -strict-types")
     58(define (test-filename name) (string-append name "-test"))
    3659
    37 (define *test-files-rx* (irregex '(: (+ graph) #\- "test" #\. "scm")))
    38 (define (test-filename name) (string-append name "-test"))
    39 (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*) )
    4062
    41 (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)
    4274  (if (irregex-match? *test-files-rx* name)
    4375    name
    44     (make-pathname *current-directory* (test-filename name) "scm") ) )
     76    (make-test-pathname name)) )
     77
     78;; Run Tests
    4579
    4680(define (run-test-evaluated source)
    47   (format #t "*** ~A - csi ***~%" (pathname-file source))
    48   (system (string-append "csi -s " source)) )
     81  (format #t "*** csi ~A ***~%" (pathname-file source))
     82  (system-must (string-append "csi -s " source)) )
    4983
    5084(define (run-test-compiled source csc-options)
    51   (format #t "*** ~A - csc ~A ***~%" (pathname-file source) csc-options)
    52   ;csc output is in current directory
    53   (system (string-append "csc" " " csc-options " " source))
    54   (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*)) )
    5590
    56 ;;;
    57 
    58 (define (run-test #!optional (name *egg*) (csc-options *csc-options*))
    59   (let (
    60     (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)))
    6193    (unless (file-exists? source)
    6294      (error 'run "no such file" source) )
     
    6597    (run-test-compiled source csc-options) ) )
    6698
    67 (define (run-tests #!optional (tests (test-files)) (csc-options *csc-options*))
     99(define (run-tests #!optional (tests (test-files)) (csc-options (csc-options)))
    68100  (for-each (cut run-test <> csc-options) tests) )
    69101
    70 ;;; Do Test
     102;; Do Tests
    71103
    72104(run-tests)
Note: See TracChangeset for help on using the changeset viewer.