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))))
(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)]
[use-compiled-file-paths
(cons (build-path "compiled" "cover")
(use-compiled-file-paths))]
[current-output-port
(if (verbose) (current-output-port) (open-output-nowhere))])
(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 load/use-compiled (current-load/use-compiled))
(define load (current-load))
(define compile (current-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)
(define abs (->absolute path))
(define lst (explode-path abs))
(define dir-list (take lst (sub1 (length lst))))
(parameterize ([current-load-relative-directory (apply build-path dir-list)])
(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))
(parameterize ([current-compile compile])
(load/use-compiled path sym))))))
(load/use-compiled path sym)))))
;; -> 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 compile (current-compile))
(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)))
compiled)
(check-false (ormap file-exists? compiled))
(#;check-not-exn
(check-not-exn
(lambda ()
(parameterize ([current-compile (make-cover-compile)]
(parameterize ([current-load/use-compiled
(make-cover-load/use-compiled (list (->absolute prog.rkt)))]
[current-namespace ns])
(managed-compile-zo prog.rkt))))
(check-true (andmap file-exists? compiled))

10
strace.rkt
View File

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