Changeset 39817 in project


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

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

Location:
release/5/srfi-27/trunk/tests
Files:
1 added
1 edited

Legend:

Unmodified
Added
Removed
  • release/5/srfi-27/trunk/tests/run.scm

    r39643 r39817  
    1 ;;;; srfi-27 run.scm -*- Scheme -*-
    2 ;;;; Kon Lovett, Dec '17
     1;;;; run.scm  -*- Scheme -*-
    32
    4 (import scheme)
     3;chicken-install invokes as "<csi> -s run.scm <eggnam>"
    54
    6 ;;; 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?))
    713
    8 (define EGG-NAME "srfi-27")
     14;; Globals
    915
    10 ;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"))
    1122
    12 (import (only (chicken pathname)
    13   make-pathname pathname-file pathname-replace-directory pathname-strip-extension))
    14 (import (only (chicken process) system))
    15 (import (only (chicken process-context) argv))
    16 (import (only (chicken format) format))
    17 (import (only (chicken file) file-exists? find-files))
    18 (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*)))
    1926
    20 (define *args* (argv))
     27(include-relative "run-ident")
    2128
    22 (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))
    2349  (cond
    24     ((<= 4 (length *args*)) (cadddr *args*) )
    25     (def                    def )
     50    ((not (null? args)) (car args))
     51    (def                def)
    2652    (else
    27       (error 'run "cannot determine egg-name") ) ) )
     53      (error 'run "cannot determine egg-name")) ) )
    2854
    29 (define *current-directory* (cond-expand (unix "./") (else #f)))
    30 (define *egg* (egg-name *args*))
     55(define (csc-options)
     56  (append *csc-incl-options* (remove/list *csc-excl-options* *csc-init-options*)) )
    3157
    32 ;no -disable-interrupts or -no-lambda-info
    33 (define *csc-options* "-inline-global -local -inline \
    34   -specialize -optimize-leaf-routines -clustering -lfa2 \
    35   -no-trace -unsafe \
    36   -strict-types")
     58(define (test-filename name) (string-append name "-test"))
    3759
    38 (define *test-files-rx* (irregex '(: (+ graph) #\- "test" #\. "scm")))
    39 (define (test-filename name) (string-append name "-test"))
    40 (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*) )
    4162
    42 (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)
    4374  (if (irregex-match? *test-files-rx* name)
    4475    name
    45     (make-pathname *current-directory* (test-filename name) "scm") ) )
     76    (make-test-pathname name)) )
     77
     78;; Run Tests
    4679
    4780(define (run-test-evaluated source)
    48   (format #t "*** ~A - csi ***~%" (pathname-file source))
    49   (system (string-append "csi -s " source)) )
     81  (format #t "*** csi ~A ***~%" (pathname-file source))
     82  (system-must (string-append "csi -s " source)) )
    5083
    5184(define (run-test-compiled source csc-options)
    52   (format #t "*** ~A - csc ~A ***~%" (pathname-file source) csc-options)
    53   ;csc output is in current directory
    54   (system (string-append "csc" " " csc-options " " source))
    55   (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*)) )
    5690
    57 ;;;
    58 
    59 (define (run-test #!optional (name *egg*) (csc-options *csc-options*))
    60   (let (
    61     (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)))
    6293    (unless (file-exists? source)
    6394      (error 'run "no such file" source) )
     
    6697    (run-test-compiled source csc-options) ) )
    6798
    68 (define (run-tests #!optional (tests (test-files)) (csc-options *csc-options*))
     99(define (run-tests #!optional (tests (test-files)) (csc-options (csc-options)))
    69100  (for-each (cut run-test <> csc-options) tests) )
    70101
    71 ;;; Do Test
     102;; Do Tests
    72103
    73104(run-tests)
Note: See TracChangeset for help on using the changeset viewer.