;;;; run.scm  -*- Scheme -*-

;chicken-install invokes as "<csi> -s run.scm <eggnam>"

(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")

;; 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
    ((not (null? args)) (car args))
    (def                def)
    (else
      (error 'run "cannot determine egg-name")) ) )

(define (csc-options)
  (append *csc-incl-options* (remove/list *csc-excl-options* *csc-init-options*)) )

(define (test-filename name) (string-append name "-test"))

(define (make-test-pathname name)
  (make-pathname *test-directory* (test-filename name) *test-extension*) )

(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-test-pathname name)) )

;; Run Tests

(define (run-test-evaluated source)
  (format #t "*** csi ~A ***~%" (pathname-file source))
  (system-must (string-append "csi -s " source)) )

(define (run-test-compiled source csc-options)
  (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-pathname name)))
    (unless (file-exists? source)
      (error 'run "no such file" source) )
    (run-test-evaluated source)
    (newline)
    (run-test-compiled source csc-options) ) )

(define (run-tests #!optional (tests (test-files)) (csc-options (csc-options)))
  (for-each (cut run-test <> csc-options) tests) )

;; Do Tests

(run-tests)