155 lines
4.5 KiB
Scheme
155 lines
4.5 KiB
Scheme
(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 print 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 print (cdr in))))
|
|
(close-output-port in-port))
|
|
(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))))))
|
|
(call-with-values
|
|
(fn (process-wait pid))
|
|
(lambda (pid exited retcode)
|
|
(fmt #t "Ret code: " retcode nl))))))
|
|
|
|
(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))
|
|
(run-and-check
|
|
compiled-file
|
|
(assoc 'input settings)
|
|
(assoc 'output settings)
|
|
(assoc 'return settings))))))))
|
|
|
|
(main)
|