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

Use DrRacket's program-expansion mechanisms instead of directly calling expand.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-07-21 13:39:00 -04:00
parent 860feb30ae
commit b305ea9c62
1 changed files with 34 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
collects/typed-scheme/optimizer/tool/report.rkt
View File

@ -38,22 +38,40 @@
(not f)] (not f)]
[else ; different file [else ; different file
#f])) #f]))
(with-intercepted-tr-logging
(lambda (l) ;; expand and capture log messages
(define log-entry-data (cdr (vector-ref l 2))) ; log-entry struct (define listener #f)
(define stx (log-entry-stx log-entry-data)) (define done-chan (make-channel))
(define path (if (and (syntax-source-directory stx) (drracket:eval:expand-program
(syntax-source-file-name stx)) (drracket:language:make-text/pos
(build-path (syntax-source-directory stx) this 0 (send this last-position))
(syntax-source-file-name stx)) (send this get-next-settings) #t
#f)) (lambda () (set! listener (start-recording #:level 'warning)))
(when (right-file? path) void ; kill
(set! log (cons log-entry-data log)))) (lambda (term k)
(lambda () (if (eof-object? term)
(parameterize ([current-namespace (make-base-namespace)] (begin (set! log (stop-recording listener)) ; done, stash the log
[read-accept-reader #t]) (channel-put done-chan 'done))
(expand (tr:read-syntax portname input))))) (k)))) ; not done, keep going
log) (channel-get done-chan) ; wait for expansion to finish
(define (post-process-log-entry l)
;; make sure the message is indeed from the optimizer
(cond [(log-message-from-tr-opt? l)
(define log-entry-data (cdr (vector-ref l 2))) ; log-entry struct
(define stx (log-entry-stx log-entry-data))
(define path (if (and (syntax-source-directory stx)
(syntax-source-file-name stx))
(build-path (syntax-source-directory stx)
(syntax-source-file-name stx))
#f))
;; it also needs to come from the right file
(if (right-file? path)
log-entry-data ; payload
#f)]
[else #f])) ; drop it
(filter values (map post-process-log-entry log)))
;; converts log-entry structs to report-entry structs for further ;; converts log-entry structs to report-entry structs for further
;; processing ;; processing