Changeset 39817 in project

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:

• run-ident.scm (added)
• run.scm (modified) (2 diffs)

release/5/srfi-27/trunk/tests/run.scm

@@ -1 @@
-;;;; srfi-27 run.scm -*- Scheme -*-
-;;;; Kon Lovett, Dec '17
+;;;; run.scm  -*- Scheme -*-
 
-(import scheme)
+;chicken-install invokes as "<csi> -s run.scm <eggnam>"
 
-;;; Create Egg Const
+(import scheme
+  (only (chicken pathname)
+    make-pathname pathname-file pathname-replace-directory pathname-strip-extension)
+  (only (chicken process) system)
+  (only (chicken process-context) command-line-arguments)
+  (only (chicken format) format)
+  (only (chicken file) file-exists? find-files)
+  (only (chicken irregex) irregex irregex-match?))
 
-(define EGG-NAME "srfi-27")
+;; Globals
 
-;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
+(define *csc-init-options* '(
+  ;"-disable-interrupts"
+  "-inline-global" "-inline" "-local"
+  "-specialize" "-strict-types"
+  "-optimize-leaf-routines" "-clustering" "-lfa2"
+  "-no-trace" "-no-lambda-info" "-unsafe"))
 
-(import (only (chicken pathname)
-  make-pathname pathname-file pathname-replace-directory pathname-strip-extension))
-(import (only (chicken process) system))
-(import (only (chicken process-context) argv))
-(import (only (chicken format) format))
-(import (only (chicken file) file-exists? find-files))
-(import (only (chicken irregex) irregex irregex-match?))
+(define *test-directory* ".")
+(define *test-extension* "scm")
+(define *test-files-rx* (irregex `(: (+ graph) #\- "test" #\. ,*test-extension*)))
 
-(define *args* (argv))
+(include-relative "run-ident")
 
-(define (egg-name args #!optional (def EGG-NAME))
+;; Support
+
+(define (system-must cmd)
+  (let ((stat (system cmd)))
+    (if (zero? stat) 0
+      ;failed, actual code irrelevant
+      (exit 1) ) ) )
+
+(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))
+
+;; Test Run Support
+
+(define (egg-name #!optional (args (command-line-arguments)) (def EGG-NAME))
   (cond
-    ((<= 4 (length *args*)) (cadddr *args*) )
-    (def                    def )
+    ((not (null? args)) (car args))
+    (def                def)
     (else
-      (error 'run "cannot determine egg-name") ) ) )
+      (error 'run "cannot determine egg-name")) ) )
 
-(define *current-directory* (cond-expand (unix "./") (else #f)))
-(define *egg* (egg-name *args*))
+(define (csc-options)
+  (append *csc-incl-options* (remove/list *csc-excl-options* *csc-init-options*)) )
 
-;no -disable-interrupts or -no-lambda-info
-(define *csc-options* "-inline-global -local -inline \
-  -specialize -optimize-leaf-routines -clustering -lfa2 \
-  -no-trace -unsafe \
-  -strict-types")
+(define (test-filename name) (string-append name "-test"))
 
-(define *test-files-rx* (irregex '(: (+ graph) #\- "test" #\. "scm")))
-(define (test-filename name) (string-append name "-test"))
-(define (test-files) (find-files "." #:test *test-files-rx* #:limit 1))
+(define (make-test-pathname name)
+  (make-pathname *test-directory* (test-filename name) *test-extension*) )
 
-(define (ensure-test-source-name name)
+(define (matching-test-file? x #!optional (remvs '()))
+  (and (irregex-match? *test-files-rx* x) (not (member x remvs))) )
+
+(define (test-files)
+  (let ((remvs (map make-test-pathname *test-excl-names*)))
+    (find-files
+      *test-directory*
+      #:test (cut matching-test-file? <> remvs)
+      #:limit 0) ) )
+
+(define (ensure-test-pathname name)
   (if (irregex-match? *test-files-rx* name)
     name
-    (make-pathname *current-directory* (test-filename name) "scm") ) )
+    (make-test-pathname name)) )
+
+;; Run Tests
 
 (define (run-test-evaluated source)
-  (format #t "*** ~A - csi ***~%" (pathname-file source))
-  (system (string-append "csi -s " source)) )
+  (format #t "*** csi ~A ***~%" (pathname-file source))
+  (system-must (string-append "csi -s " source)) )
 
 (define (run-test-compiled source csc-options)
-  (format #t "*** ~A - csc ~A ***~%" (pathname-file source) csc-options)
-  ;csc output is in current directory
-  (system (string-append "csc" " " csc-options " " source))
-  (system (pathname-replace-directory (pathname-strip-extension source) *current-directory*)) )
+  (let ((optstr (apply string-append (intersperse csc-options " "))))
+    (format #t "*** csc ~A ~A ***~%" (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) *test-directory*)) )
 
-;;;
-
-(define (run-test #!optional (name *egg*) (csc-options *csc-options*))
-  (let (
-    (source (ensure-test-source-name name)) )
+(define (run-test #!optional (name (egg-name)) (csc-options (csc-options)))
+  (let ((source (ensure-test-pathname name)))
     (unless (file-exists? source)
       (error 'run "no such file" source) )
@@ -66 +97 @@
     (run-test-compiled source csc-options) ) )
 
-(define (run-tests #!optional (tests (test-files)) (csc-options *csc-options*))
+(define (run-tests #!optional (tests (test-files)) (csc-options (csc-options)))
   (for-each (cut run-test <> csc-options) tests) )
 
-;;; Do Test
+;; Do Tests
 
 (run-tests)