Changeset 39820 in project

Timestamp:

04/04/21 02:09:08 (3 weeks ago)

Author:

Kon Lovett

Message:

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

Location:

release/5/srfi-45/trunk/tests

Files:

• run-ident.scm (modified) (1 diff)
• run.scm (modified) (2 diffs)

release/5/srfi-45/trunk/tests/run-ident.scm

@@ -2 +2 @@
 
 (define EGG-NAME "srfi-45")
-(define *csc-remv-options* '())
+(define *csc-incl-options* '())
+(define *csc-excl-options* '())
+(define *test-excl-names* '())

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

@@ -1 @@
-;;;; run.scm -*- Scheme -*-
+;;;; 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?))
+
+;; Globals
+
+(define *csc-init-options* '(
+  ;"-disable-interrupts"
+  "-inline-global" "-inline" "-local"
+  "-specialize" "-strict-types"
+  "-optimize-leaf-routines" "-clustering" "-lfa2"
+  "-no-trace" "-no-lambda-info" "-unsafe"))
+
+(define *test-directory* ".")
+(define *test-extension* "scm")
+(define *test-files-rx* (irregex `(: (+ graph) #\- "test" #\. ,*test-extension*)))
 
 (include-relative "run-ident")
 
-;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
+;; Support
 
-(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 (system-must cmd)
+  (let ((stat (system cmd)))
+    (if (zero? stat) 0
+      ;failed, actual code irrelevant
+      (exit 1) ) ) )
 
-(define *args* (argv))
-(define *current-directory* (cond-expand (unix "./") (else #f)))
-;no -disable-interrupts or -no-lambda-info
-(define *csc-init-options* '(-inline-global -local -inline -specialize
-  -optimize-leaf-routines -clustering -lfa2 -no-trace -unsafe -strict-types))
-(define *test-files-rx* (irregex '(: (+ graph) #\- "test" #\. "scm")))
+(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 (remq obj ls)
-  (let loop ((curr ls) (prev '()))
-    (cond
-      ((null? curr)
-        ls )
-      ((eq? obj (car curr))
-        (if (null? prev)
-          (cdr ls)
-          (begin
-            (set-cdr! prev (cdr curr))
-            ls ) ) )
-      (else
-        (loop (cdr curr) curr) ) ) ) )
+(define (remove/list os ls) (remove (cut member <> os) ls))
 
-(define (remqs os ls)
-  (let loop ((ls ls) (os os))
-    (cond
-      ((null? os)
-        ls )
-      (else
-        (loop (remq (car os) ls) (cdr os)) ) ) ) )
+;; Test Run Support
 
-(define (egg-name #!optional (args *args*) (def EGG-NAME))
+(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") ) ) )
-
-(define (as-csc-options ls)
-  (apply string-append (intersperse (map symbol->string ls) " ")) )
+      (error 'run "cannot determine egg-name")) ) )
 
 (define (csc-options)
-  (as-csc-options (remqs *csc-remv-options* *csc-init-options*)) )
+  (append *csc-incl-options* (remove/list *csc-excl-options* *csc-init-options*)) )
 
 (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-name)) (csc-options (csc-options)))
-  (let (
-    (source (ensure-test-source-name name)) )
+  (let ((source (ensure-test-pathname name)))
     (unless (file-exists? source)
       (error 'run "no such file" source) )
@@ -92 +100 @@
   (for-each (cut run-test <> csc-options) tests) )
 
-;; Do Test
+;; Do Tests
 
 (run-tests)