135 lines
4.3 KiB
Scheme
135 lines
4.3 KiB
Scheme
(use-modules (ice-9 pretty-print)
|
|
(ice-9 rdelim)
|
|
(ice-9 textual-ports)
|
|
(language tree-il))
|
|
|
|
(define (->string obj)
|
|
(call-with-output-string
|
|
(lambda (port)
|
|
(write obj port))))
|
|
|
|
(define (read-text path)
|
|
(call-with-input-file path get-string-all))
|
|
|
|
(define (write-text path text)
|
|
(call-with-output-file path
|
|
(lambda (port)
|
|
(display text port))))
|
|
|
|
(define (split-tabs line)
|
|
(let ((n (string-length line)))
|
|
(let loop ((i 0) (start 0) (parts '()))
|
|
(if (= i n)
|
|
(reverse (cons (substring line start i) parts))
|
|
(if (char=? (string-ref line i) #\tab)
|
|
(loop (+ i 1) (+ i 1) (cons (substring line start i) parts))
|
|
(loop (+ i 1) start parts))))))
|
|
|
|
(define (module-spec-from-string raw)
|
|
(if (or (string=? raw "-") (string-null? raw))
|
|
#f
|
|
(call-with-input-string raw read)))
|
|
|
|
(define (reply text)
|
|
(display text)
|
|
(newline)
|
|
(force-output))
|
|
|
|
(define (handle-eval parts)
|
|
(if (< (length parts) 6)
|
|
(reply "DONE\tERR")
|
|
(let* ((expr-path (list-ref parts 1))
|
|
(module-raw (list-ref parts 2))
|
|
(stdout-path (list-ref parts 3))
|
|
(value-path (list-ref parts 4))
|
|
(error-path (list-ref parts 5)))
|
|
(catch #t
|
|
(lambda ()
|
|
(let ((module-spec (module-spec-from-string module-raw)))
|
|
(when module-spec
|
|
(set-current-module (resolve-interface module-spec))))
|
|
|
|
(let* ((expr-source (read-text expr-path))
|
|
(expr (call-with-input-string expr-source read))
|
|
(stdout-port (open-output-string))
|
|
(value (parameterize ((current-output-port stdout-port))
|
|
(eval expr (current-module))))
|
|
(stdout (get-output-string stdout-port))
|
|
(value-port (open-output-string)))
|
|
(pretty-print value value-port)
|
|
(write-text stdout-path stdout)
|
|
(write-text value-path (get-output-string value-port))
|
|
(write-text error-path "")
|
|
(reply "DONE\tOK")))
|
|
(lambda (key . args)
|
|
(write-text stdout-path "")
|
|
(write-text value-path "")
|
|
(write-text error-path (string-append (symbol->string key) " " (->string args) "\n"))
|
|
(reply "DONE\tERR"))))))
|
|
|
|
(define (handle-mexp parts)
|
|
(if (< (length parts) 5)
|
|
(reply "DONE\tERR")
|
|
(let* ((expr-path (list-ref parts 1))
|
|
(module-raw (list-ref parts 2))
|
|
(value-path (list-ref parts 3))
|
|
(error-path (list-ref parts 4)))
|
|
(catch #t
|
|
(lambda ()
|
|
(let ((module-spec (module-spec-from-string module-raw)))
|
|
(when module-spec
|
|
(set-current-module (resolve-interface module-spec))))
|
|
|
|
(let* ((expr-source (read-text expr-path))
|
|
(datum (call-with-input-string expr-source read))
|
|
(expanded (tree-il->scheme (macroexpand datum)))
|
|
(value-port (open-output-string)))
|
|
(pretty-print expanded value-port)
|
|
(write-text value-path (get-output-string value-port))
|
|
(write-text error-path "")
|
|
(reply "DONE\tOK")))
|
|
(lambda (key . args)
|
|
(write-text value-path "")
|
|
(write-text error-path (string-append (symbol->string key) " " (->string args) "\n"))
|
|
(reply "DONE\tERR"))))))
|
|
|
|
(define (handle-reset)
|
|
(set-current-module (resolve-module '(guile-user) #:ensure #t))
|
|
(reply "DONE\tOK"))
|
|
|
|
(define (dispatch line)
|
|
(let* ((parts (split-tabs line))
|
|
(command (if (null? parts) "" (car parts))))
|
|
(cond
|
|
((string=? command "EVAL")
|
|
(handle-eval parts)
|
|
#t)
|
|
((string=? command "MEXP")
|
|
(handle-mexp parts)
|
|
#t)
|
|
((string=? command "RESET")
|
|
(handle-reset)
|
|
#t)
|
|
((string=? command "PING")
|
|
(reply "PONG")
|
|
#t)
|
|
((string=? command "QUIT")
|
|
(reply "BYE")
|
|
#f)
|
|
(else
|
|
(reply "DONE\tERR")
|
|
#t))))
|
|
|
|
(define (main)
|
|
(set-current-module (resolve-module '(guile-user) #:ensure #t))
|
|
(reply "READY")
|
|
|
|
(let loop ()
|
|
(let ((line (read-line)))
|
|
(if (eof-object? line)
|
|
(primitive-exit 0)
|
|
(when (dispatch line)
|
|
(loop))))))
|
|
|
|
(main)
|