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

fixed compile looping. Final fix for Issue #21

Browse Source
This commit is contained in:
Spencer Florence 2015-01-24 10:40:01 -05:00
parent 0499f7e653
commit 163915100a
2 changed files with 17 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
cover.rkt
View File

@ -40,9 +40,7 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
(->absolute p)))) (->absolute p))))
(define abs-paths (map (lambda (p) (if (list? p) (first p) p)) abs)) (define abs-paths (map (lambda (p) (if (list? p) (first p) p)) abs))
(parameterize ([current-load/use-compiled (make-cover-load/use-compiled abs-paths)] (parameterize ([current-load/use-compiled (make-cover-load/use-compiled abs-paths)]
[use-compiled-file-paths
(cons (build-path "compiled" "cover")
(use-compiled-file-paths))]
[current-output-port [current-output-port
(if (verbose) (current-output-port) (open-output-nowhere))]) (if (verbose) (current-output-port) (open-output-nowhere))])
(define tests-failed #f) (define tests-failed #f)
@ -88,20 +86,25 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
(define (make-cover-load/use-compiled paths) (define (make-cover-load/use-compiled paths)
(define load/use-compiled (current-load/use-compiled)) (define load/use-compiled (current-load/use-compiled))
(define load (current-load)) (define load (current-load))
(define compile (current-compile))
(define cover-compile (make-cover-compile)) (define cover-compile (make-cover-compile))
(define cover-use-compiled-file-paths
(cons (build-path "compiled" "cover")
(use-compiled-file-paths)))
(lambda (path sym) (lambda (path sym)
(define abs (->absolute path)) (define abs (->absolute path))
(define lst (explode-path abs)) (define lst (explode-path abs))
(define dir-list (take lst (sub1 (length lst)))) (define dir-list (take lst (sub1 (length lst))))
(parameterize ([current-load-relative-directory (apply build-path dir-list)]) (parameterize ([current-load-relative-directory (apply build-path dir-list)])
(if (member abs paths) (if (member abs paths)
(parameterize ([current-compile cover-compile]) (parameterize ([current-compile cover-compile]
[use-compiled-file-paths
cover-use-compiled-file-paths])
(load path sym)) (load path sym))
(parameterize ([current-compile compile]) (load/use-compiled path sym)))))
(load/use-compiled path sym))))))
;; -> Compiler ;; -> Compiler
;; makes a value sutable for current-compile, such that compile
;; annotates the source code. should only be used by `make-cover-load/uze-compiled`
(define (make-cover-compile) (define (make-cover-compile)
(define compile (current-compile)) (define compile (current-compile))
(define reg (namespace-module-registry ns)) (define reg (namespace-module-registry ns))
@ -238,9 +241,10 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
(for-each (lambda (f) (when (file-exists? f) (delete-file f))) (for-each (lambda (f) (when (file-exists? f) (delete-file f)))
compiled) compiled)
(check-false (ormap file-exists? compiled)) (check-false (ormap file-exists? compiled))
(#;check-not-exn (check-not-exn
(lambda () (lambda ()
(parameterize ([current-compile (make-cover-compile)] (parameterize ([current-load/use-compiled
(make-cover-load/use-compiled (list (->absolute prog.rkt)))]
[current-namespace ns]) [current-namespace ns])
(managed-compile-zo prog.rkt)))) (managed-compile-zo prog.rkt))))
(check-true (andmap file-exists? compiled)) (check-true (andmap file-exists? compiled))

10
strace.rkt
View File

@ -3,8 +3,8 @@
(require errortrace/stacktrace (require errortrace/stacktrace
racket/function racket/function
racket/syntax racket/syntax
syntax/parse
racket/unit racket/unit
syntax/kerncase
racket/runtime-path racket/runtime-path
"private/file-utils.rkt" "private/file-utils.rkt"
"private/shared.rkt" "private/shared.rkt"
@ -69,12 +69,11 @@
(define inspector (variable-reference->module-declaration-inspector (define inspector (variable-reference->module-declaration-inspector
(#%variable-reference))) (#%variable-reference)))
(let loop ([expr expr] [top #t]) (let loop ([expr expr] [top #t])
(syntax-parse (syntax-disarm expr inspector) (kernel-syntax-case (syntax-disarm expr inspector) #f
#:literal-sets (kernel-literals)
[(module name lang mb) [(module name lang mb)
(with-syntax ([cover cover-name] (with-syntax ([cover cover-name]
[srcloc srcloc-name]) [srcloc srcloc-name])
(syntax-parse (syntax-disarm #'mb inspector) (syntax-case (syntax-disarm #'mb inspector) ()
[(#%module-begin b ...) [(#%module-begin b ...)
(with-syntax ([(body ...) (with-syntax ([(body ...)
(map (lambda (e) (loop e #f)) (syntax->list #'(b ...)))]) (map (lambda (e) (loop e #f)) (syntax->list #'(b ...)))])
@ -92,8 +91,7 @@
;; in order to write modules to disk the top level needs to ;; in order to write modules to disk the top level needs to
;; be a module. so we trust that the module is loaded and trim the expression ;; be a module. so we trust that the module is loaded and trim the expression
(define (annotate-clean e) (define (annotate-clean e)
(syntax-parse e (kernel-syntax-case e #f
#:literal-sets (kernel-literals)
[(begin e mod) [(begin e mod)
(eval #'e) (eval #'e)
#'mod] #'mod]