sex/tools/sextest/sextest.scm

(import scheme
        (scheme base)                   ; let-values
        brev-separate
        (chicken base)
        (chicken file)
        (chicken io)
        (chicken pathname)
        (chicken port)
        (chicken process)
        (chicken process-context)
        (chicken string)                ; string-split
        fmt
        getopt-long
        reader                          ; read-raw-forms, shared with sexc
        srfi-1
        srfi-13)                        ; string-prefix?

(define (print-help)
  (fmt #t "Usage: sextest [options] filename" nl
       "Options:" nl
       (usage opts-grammar) nl))

(define (split-settings contents)
  (foldl (lambda (acc elt)
           (case (car elt)
             ((compilation input output return)
              (cons
               (append (car acc) (list elt))
               (cdr acc)))
             (else
              (cons
               (car acc)
               (append (cdr acc) (list elt))))))
         (cons (list) (list))
         contents))

;;; The feature flags of the (compilation ...) form, which we have to
;;; honour ourselves: the program is read here and printed back out for
;;; sexc, so #+ and #- are resolved on this side.
;;;
;;; Returns the named features and whether the host's own are in play
(define (compilation-features settings)
  (let ((compilation (assoc 'compilation settings)))
    (let loop ((flags (if compilation
                          (string-split (cadr compilation))
                          (list)))
               (features (list))
               (platform #t))
      (define (add names rest)
        (loop rest
              (append features (map string->symbol (string-split names ",")))
              platform))
      (cond
       ((null? flags) (values features platform))
       ;; past `--' the flags are the C compiler's
       ((string=? (car flags) "--") (values features platform))
       ((string=? (car flags) "--no-platform-features")
        (loop (cdr flags) features #f))
       ((and (member (car flags) '("-f" "--features")) (pair? (cdr flags)))
        (add (cadr flags) (cddr flags)))
       ((string-prefix? "--features=" (car flags))
        (add (substring (car flags) 11) (cdr flags)))
       ((string-prefix? "-f" (car flags))
        (add (substring (car flags) 2) (cdr flags)))
       (else (loop (cdr flags) features platform))))))

(define (process-file target-path)
  (let ((first-pass (split-settings (read-raw-forms target-path))))
    (let-values (((features platform?) (compilation-features (car first-pass))))
      (if (and (null? features) platform?)
          first-pass
          (parameterize ((current-features
                          (append (if platform? (platform-features) (list))
                                  features)))
            (split-settings (read-raw-forms target-path)))))))

(define (compile src compilation sexc)
  (let ((compiler (or
                   (and sexc (cdr sexc))
                   (get-environment-variable "SEXC")
                   "sexc"))
        ;; (compilation "--features=x -- -O2") -- one string
        (flags (if compilation
                   (string-split (cadr compilation))
                   (list)))
        (compiled-file (create-temporary-file)))
    ;; `process' returns one record; `process-input-port' is named from
    ;; the child's side, so it is the port we write to.
    (let* ((proc (process compiler (append (list "-o" compiled-file) flags)))
           (sexc-stdin (process-input-port proc)))
      (with-output-to-port sexc-stdin
        (fn (map (fn (fmt #t x)) src)))
      (close-output-port sexc-stdin)
      (call-with-values
          (fn (process-wait proc))
        (lambda (pid exited retcode)
          (if (= 0 retcode)
              compiled-file
              #f))))))

(define (run-and-check file in out ret)
  (let* ((proc (process file))
         (out-port (process-output-port proc))   ; the program's stdout
         (in-port  (process-input-port proc)))   ; the program's stdin
    (let ()
      (when in
        (with-output-to-port in-port
          (fn (map (fn (fmt #t x))
                   (cdr in))))
        (close-output-port in-port))
      (let ((out-lines
             (with-input-from-port out-port
               (fn
                (let loop ((line (read-line))
                           (lines (list)))
                  (if (eof-object? line)
                      (reverse lines)
                      (loop (read-line)
                            (cons line lines)))))))
            (ret-code
             (call-with-values
                 ;; TODO: what if the program hangs
                 ;; we need some kind of timeout mechanism
                 (fn
                  (process-wait proc))
               (lambda (pid exited retcode)
                 retcode))))
        (and
         (if (not (= ret-code (cadr ret)))
             (begin
               (fmt #t "Retcode differs. Got " ret-code ", expected " (cadr ret) nl)
               #f)
             #t)

         (if (not (equal? out-lines (cdr out)))
             (begin
               (fmt #t "Output differs. Got " out-lines " expected " (cdr out) nl)
               #f)
             #t))))))

(define opts-grammar
  `((sexc ,(fmt #f "Path to sexc compiler. Defaults to value of SEXC" nl
                (pad 26) "environment variable, ot if it's empty, to sexc" nl )
          (required #f)
          (value #t))
    (help "Show this help"
          (required #f)
          (value #f)
          (single-char #\h))))

(define (process-test-file sexc path)
  (set-environment-variable! "SEX_MODULE_PATH"
                             (normalize-pathname (make-absolute-pathname
                                                  (current-directory)
                                                  (pathname-directory path))))
  (let* ((settings-and-src (process-file path))
         (settings (car settings-and-src))
         (src (cdr settings-and-src))
         (compiled-file (compile src (assoc 'compilation settings) sexc)))
    (if (not compiled-file)
        (begin (fmt #t "Failed to compile " path nl)
               #f)
        (if (run-and-check
             compiled-file
             (assoc 'input settings)
             (assoc 'output settings)
             (assoc 'return settings))
            (begin (fmt #t ".")
                   #t)
            (begin (fmt #t ",")
                   #f)))))

(define (main)
  (let ((args (getopt-long (command-line-arguments)
                           opts-grammar)))
    (when (assoc 'help args)
      (print-help)
      (exit 0))
    (when (null? (cdr (assoc '@ args)))
      (fmt #t "Missing target file" nl)
      (print-help)
      (exit 1))
    (unless
        (foldl (lambda (a b) (and a b))
               #t
               (map (fn (process-test-file (assoc 'sexc args) x))
                    (cdr (assoc '@ args))))
      ;; TODO: add more verbose and human readable output and reporting
      (fmt #t nl)
      (exit 2))
    (fmt #t nl)
    (exit 0)))

(main)