add command line options to sextest

A tool for testing Sex programs. Details in tools/sextest/README.org

reader.scm

@@ -22,19 +22,6 @@
     (with-input-from-file (pathname-strip-directory file)
       (fn (read-forms (list))))))
 
-(define (read-bracket port)
-  (let loop ((c (read-char port))
-             (str (string)))
-    (cond ((char=? c #\])
-           (cons '¤
-                 (with-input-from-string str
-                   (fn (port-map identity read)))))
-          ((char=? c #\[)
-           (loop port (conc )))
-          (else
-           (loop (read-char port)
-                 (conc str c))))))
-
 (define open-bracket-counter (make-parameter 0))
 
 (define (read-raw-forms input-source)

sexc.scm

@@ -155,7 +155,9 @@
          (return #f))
        (load-persistent-module-paths)
 
-       (sex-fmt-current-file (to-absolute-pathname input))
+       (if (eq? input 'stdin)
+           (sex-fmt-current-file "stdin")
+           (sex-fmt-current-file (to-absolute-pathname input)))
        (let* ((raw-forms (append prelude (read-raw-forms input)))
               (sex-forms (semantic-process-forms raw-forms input)))
          (if (or (get-arg args 'macro-expand #f)

tools/sextest/Makefile

@@ -0,0 +1,5 @@
+CHICKEN_C = csc
+CSC_FLAGS += -K prefix -static
+
+sextest: sextest.scm
+	$(CHICKEN_C) $(CSC_FLAGS) sextest.scm -o sextest

tools/sextest/README.org

@@ -0,0 +1,26 @@
+* Sextest
+A tool for testing Sex compiler by using test programs.
+The tools compiles test programs, then runs with provided
+input, checking the output and return code.
+
+* Test format
+The test program is just a regular Sex program, which may contain
+additional toplevel forms, to define compilation parameters, input to
+the program, and expected output and return code. Default value for
+compilation, input and output is an empty strings. For the return code
+it is 0.
+
+* Example
+some-test.sex:
+#+begin_src
+(compilation "-- -O2")
+(input "")
+(output "Hello world!")
+(return 123)
+
+(include stdio.h)
+
+(pub fn main () int
+  (puts "Hello World!")
+  (return 123))
+#+end_src

tools/sextest/hello-sextest.sex

@@ -0,0 +1,13 @@
+(input "Sextest")
+(output "Hello from Sex!" "What is your name?" "Hello, Sextest!")
+(return 255)
+
+(include stdio.h)
+
+(pub fn main ((argc int) (argv  [* const char])) int
+  (puts "Hello from Sex!")
+  (var name [char 512])
+  (puts "What is your name?")
+  (scanf "%s" (cast (& name) (* char)))
+  (printf "Hello, %s!\n" name)
+  (return 255))

tools/sextest/sextest.scm

@@ -0,0 +1,207 @@
+(import scheme
+        brev-separate
+        (chicken base)
+        (chicken file)
+        (chicken io)
+        (chicken pathname)
+        (chicken port)
+        (chicken process)
+        (chicken process-context)
+        (chicken read-syntax)
+        (chicken syntax)
+        fmt
+        getopt-long
+        srfi-1)
+
+(define-syntax prog1
+  (syntax-rules ()
+    ((prog1 form . forms)
+     (let ((res form))
+       (begin . forms)
+       res))))
+
+(define-syntax with-directory
+  (syntax-rules ()
+    ((with-directory path form . forms)
+     (let ((current-dir (current-directory)))
+       (set-working-directory path)
+       (prog1
+        (begin form . forms)
+        (change-directory current-dir))))))
+
+(define (set-working-directory file)
+  (change-directory
+   (normalize-pathname
+    (if (absolute-pathname? file)
+        (pathname-directory file)
+        (make-absolute-pathname
+         (current-directory)
+         (pathname-directory file))))))
+
+;;; TODO: use sexc reader code i.e. link with sex reader
+(define open-bracket-counter (make-parameter 0))
+
+(define (read-raw-forms input-source)
+  (let ((bracket-end (gensym)))
+    (set-read-syntax!
+     #\]
+     (lambda (port)
+       (when (= 0 (open-bracket-counter))
+         (error "Unmatched closing bracket"))
+       (open-bracket-counter (- (open-bracket-counter) 1))
+       bracket-end))
+
+    (set-read-syntax!
+     #\[
+     (lambda (port)
+       (open-bracket-counter (+ (open-bracket-counter) 1))
+       (let loop ((r (read port))
+                  (acc (list)))
+         (if (eq? r bracket-end)
+             (cons '¤ (reverse acc))
+             (loop (read port)
+                   (cons r acc)))))))
+  (read-from-file input-source))
+
+(define (read-from-file file)
+  (with-directory file
+    (with-input-from-file (pathname-strip-directory file)
+      (fn (read-forms (list))))))
+
+(define (read-forms acc)
+  (let ((r (read-with-source-info (current-input-port))))
+    (if (eof-object? r) (reverse acc)
+        (read-forms (cons r acc)))))
+
+(define (print-help)
+  (fmt #t "Usage: sextest [options] filename" nl
+       "Options:" nl
+       (usage opts-grammar) nl))
+
+(define (process-file target-path)
+  (let ((contents (read-raw-forms target-path)))
+    (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)))
+
+(define (compile src flags sexc)
+  (let ((compiler (or
+                   (and sexc (cdr sexc))
+                   (get-environment-variable "SEXC")
+                   "sexc"))
+        (compiled-file (create-temporary-file)))
+    (call-with-values
+        (fn
+         (process compiler
+                  (append (list "-o" compiled-file)
+                          flags)))
+      (lambda (out-port in-port pid)
+        (with-output-to-port in-port
+          (fn (map (fn (fmt #t x)) src)))
+        (close-output-port in-port)
+
+        (call-with-values
+            (fn (process-wait pid))
+          (lambda (pid exited retcode)
+            (if (= 0 retcode)
+                compiled-file
+                #f)))))))
+
+(define (run-and-check file in out ret)
+  (call-with-values
+      (fn (process file))
+    (lambda (out-port in-port pid)
+      (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 pid))
+               (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)
+  (let* ((settings-and-src (process-file path))
+         (settings (car settings-and-src))
+         (src (cdr settings-and-src))
+         (compiled-file (compile src (assoc 'compile 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 and
+               #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)