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

Have optimizer test harness look only at log messages that came from the optimizer.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-06-01 16:53:27 -04:00
parent 641dd731ab
commit 28692786b3
1 changed files with 18 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
collects/tests/typed-scheme/optimizer/run.rkt
View File

@ -1,6 +1,7 @@
#lang racket #lang racket
(require racket/runtime-path (require racket/runtime-path
rackunit rackunit/text-ui rackunit rackunit/text-ui
typed-scheme/optimizer/utils
unstable/logging) unstable/logging)
(provide optimization-tests missed-optimization-tests (provide optimization-tests missed-optimization-tests
@ -8,23 +9,25 @@
(define (generate-log name dir) (define (generate-log name dir)
;; some tests require other tests, so some fiddling is required ;; some tests require other tests, so some fiddling is required
(let* ([log-port (open-output-string)] (let ([out-string
[out-string (with-output-to-string
(with-output-to-string (lambda ()
(lambda () (with-intercepted-logging ; catch opt logs
(with-logging-to-port log-port ; catch opt logs (lambda (l)
(lambda () (when (eq? (vector-ref l 2) ; look only for optimizer messages
(parameterize optimization-log-key)
([current-namespace (make-base-empty-namespace)] (displayln (vector-ref l 1)))) ; print log message
[current-load-relative-directory dir]) (lambda ()
(dynamic-require (parameterize
(build-path (current-load-relative-directory) name) ([current-namespace (make-base-empty-namespace)]
#f))) [current-load-relative-directory dir])
#:level 'warning)))]) (dynamic-require
(build-path (current-load-relative-directory) name)
#f)))
#:level 'warning)))])
;; have the log as an sexp, since that's what the expected log is ;; have the log as an sexp, since that's what the expected log is
(with-input-from-string (with-input-from-string
(string-append "(" (get-output-string log-port) ; join log and results (string-append "(" out-string ")")
" " out-string ")")
read))) read)))
;; we log optimizations and compare to an expected log to make sure that all ;; we log optimizations and compare to an expected log to make sure that all