suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Log output generated when OC expands/runs programs.

Browse Source 
To be consistent with Check Syntax.
This commit is contained in:
Vincent St-Amour 2012-08-16 16:47:04 -04:00
parent fa2cba1c5b
commit a65d7532f2
1 changed files with 35 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
collects/typed-racket/optimizer/tool/report.rkt
View File

@ -32,18 +32,44 @@
(generate-log this)))) (generate-log this))))
(define (log-output in done-chan)
(let loop ()
(sync (handle-evt
(read-line-evt in 'linefeed)
(lambda (line)
(cond [(eof-object? line) (channel-put done-chan 'done)]
[else
(log-warning
(format "Optimization Coach Program Output: ~a" line))
(loop)]))))))
(define (run-inside-optimization-coach-sandbox this thunk) (define (run-inside-optimization-coach-sandbox this thunk)
(call-with-trusted-sandbox-configuration (call-with-trusted-sandbox-configuration
(lambda () (lambda ()
(define port-name (send this get-port-name)) (define port-name (send this get-port-name))
(parameterize ([current-namespace (make-base-namespace)] ;; If the sandboxed program produces any output, log it as `warning'.
[current-load-relative-directory ;; Mimics what check-syntax does.
(if (path-string? port-name) (define log-output? (log-level? (current-logger) 'warning))
(let-values ([(base name _) (split-path port-name)]) (define-values (log-in log-out)
base) (if log-output? (make-pipe) (values #f (open-output-nowhere))))
(current-load-relative-directory))] (define log-done-chan (make-channel))
[read-accept-reader #t]) (when log-output? (thread (lambda () (log-output log-in log-done-chan))))
(thunk))))) ;; Set up the environment.
(begin0
(parameterize
([current-namespace (make-base-namespace)]
[current-load-relative-directory
(if (path-string? port-name)
(let-values ([(base name _) (split-path port-name)])
base)
(current-load-relative-directory))]
[read-accept-reader #t]
[current-output-port log-out]
[current-error-port log-out])
(thunk))
(when log-output?
(close-output-port log-out)
(sync log-done-chan))))))
(define (generate-log this) (define (generate-log this)
(define portname (send this get-port-name)) (define portname (send this get-port-name))