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

Abstract out OC sandboxing.

Browse Source
This commit is contained in:
Vincent St-Amour 2012-11-27 12:05:26 -05:00
parent 1a678bd5de
commit fa2cba1c5b
1 changed files with 20 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -10,7 +10,8 @@
(struct-out opt-report-entry)
(struct-out missed-opt-report-entry)
generate-report
collapse-report)
collapse-report
run-inside-optimization-coach-sandbox)
;; Similar to the log-entry family of structs, but geared towards GUI display.
;; Also designed to contain info for multiple overlapping log entries.
@ -31,6 +32,19 @@
(generate-log this))))
(define (run-inside-optimization-coach-sandbox this thunk)
(call-with-trusted-sandbox-configuration
(lambda ()
(define port-name (send this get-port-name))
(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])
(thunk)))))
(define (generate-log this)
(define portname (send this get-port-name))
(define input (open-input-text-editor this))
@ -63,22 +77,12 @@
[else ; different file
#f]))
(define log '())
(call-with-trusted-sandbox-configuration
(lambda ()
(with-intercepted-opt-logging
(lambda (l)
(set! log (cons l log)))
(lambda ()
(define port-name (send this get-port-name))
(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])
(void (compile (read-syntax portname input))))))))
(run-inside-optimization-coach-sandbox
this (lambda () (void (compile (read-syntax portname input)))))))
(filter right-file? (reverse log)))