diff --git a/reader.scm b/reader.scm index 9c53411..6ec4545 100644 --- a/reader.scm +++ b/reader.scm @@ -19,21 +19,8 @@ (define (read-from-file file) (with-directory file - (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)))))) + (with-input-from-file (pathname-strip-directory file) + (fn (read-forms (list)))))) (define open-bracket-counter (make-parameter 0)) diff --git a/sexc.scm b/sexc.scm index 7deb677..8da7052 100644 --- a/sexc.scm +++ b/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) diff --git a/tools/sextest/Makefile b/tools/sextest/Makefile new file mode 100644 index 0000000..02f977a --- /dev/null +++ b/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 diff --git a/tools/sextest/README.org b/tools/sextest/README.org new file mode 100644 index 0000000..c3411fb --- /dev/null +++ b/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 diff --git a/tools/sextest/hello-sextest.sex b/tools/sextest/hello-sextest.sex new file mode 100644 index 0000000..02452c2 --- /dev/null +++ b/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)) diff --git a/tools/sextest/sextest.scm b/tools/sextest/sextest.scm new file mode 100644 index 0000000..df00050 --- /dev/null +++ b/tools/sextest/sextest.scm @@ -0,0 +1,178 @@ +(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 + 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 ./path/to/test-file.sex\n")) + +(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) + (let ((compiler (or (get-environment-variable "SEXC") + ;; TODO: pass compiler in args + ;; (get-arg args 'sex-compiler #f) + "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 (main) + (let ((args (command-line-arguments))) + (if (not (= 1 (length args))) + (print-help) + (let ((settings-and-src + (process-file (first args)))) + (let ((settings (car settings-and-src)) + (src (cdr settings-and-src))) + (let ((compiled-file (compile src (assoc 'compile settings)))) + (unless compiled-file + (fmt #t "Compilation failed." nl) + (exit 1)) + (if (run-and-check + compiled-file + (assoc 'input settings) + (assoc 'output settings) + (assoc 'return settings)) + (fmt #t "PASS" nl) + (begin + (fmt #t "FAIL" nl) + (exit 2))) + (exit 0))))))) + +(main)