diff --git a/cover/cover.rkt b/cover/cover.rkt index 290476c..73b992a 100644 --- a/cover/cover.rkt +++ b/cover/cover.rkt @@ -197,25 +197,29 @@ Thus, In essence this module has three responsibilites: (define cover-compile (lambda (e immediate-eval?) (define file (get-source e)) - (define to-compile - (cond [(or (compiled-expression? (if (syntax? e) (syntax-e e) e)) - (not (eq? reg (namespace-module-registry (current-namespace)))) - (not file)) - e] - [else - (vprintf "compiling ~s with coverage annotations in enviornment ~s" - file - (get-topic)) - (let ([x ((annotate-top file) - (if (syntax? e) (expand-syntax e) (datum->syntax #f e)) - (namespace-base-phase (current-namespace)))]) - (vprintf "\ncurrently using ~aGB memory after file ~a\n" - (* 0.000000001 (current-memory-use)) - file) - x)])) - (compile to-compile immediate-eval?))) + (with-handlers ([void (lambda (e) (displayln file) (raise e))]) + (define to-compile + (cond [(or (compiled-expression? (if (syntax? e) (syntax-e e) e)) + (not (eq? reg (namespace-module-registry (current-namespace)))) + (not file)) + e] + [else + (vprintf "compiling ~s with coverage annotations in enviornment ~s" + file + (get-topic)) + (let ([x ((annotate-top file) + (if (syntax? e) (expand-syntax e) (datum->syntax #f e)) + (namespace-base-phase (current-namespace)))]) + (vprintf "\ncurrently using ~aGB memory after file ~a\n" + (* 0.000000001 (current-memory-use)) + file) + ;(pretty-print (syntax->datum x)) + x)])) + (compile to-compile immediate-eval?)))) cover-compile) +(require racket/pretty) + (define (get-source stx) (and (syntax? stx) (let loop ([e stx]) @@ -300,7 +304,8 @@ Thus, In essence this module has three responsibilites: (define vecmap (get-coverage-vector-mapping)) (define raw-coverage - (for/hash ([(srcloc loc) (in-hash (get-coverage-srcloc-mapping))]) + (for*/hash ([(_ filemap) (in-hash (get-coverage-srcloc-mapping))] + [(srcloc loc) (in-hash filemap)]) (values srcloc (vector-ref (hash-ref vecmap diff --git a/cover/strace.rkt b/cover/strace.rkt index 5acd311..b67197f 100644 --- a/cover/strace.rkt +++ b/cover/strace.rkt @@ -18,11 +18,15 @@ The module implements code coverage annotations as described in cover.rkt ;; symbol [Hash srcloclist index] [Hash pathstring vector] ;; -> (pathstring -> annotator) -(define (make-annotate-top topic loc->vecref vecmapping) +(define (make-annotate-top topic file->loc->vecref vecmapping) (define log-message-name #'log-message) (define current-logger-name #'current-logger) - (define unsafe-vector-set!-name #'unsafe-vector*-set!) - (define unsafe-vector-ref-name #'unsafe-vector*-ref) + (define unsafe-vector-set!-name #'vector-set! + #;#'unsafe-vector*-set! + ) + (define unsafe-vector-ref-name #'vector-ref + #;#'unsafe-vector*-ref + ) (define vector-name #'cover-coverage-vector) (define make-log-receiver-name #'make-log-receiver) (define sync-name #'sync) @@ -69,7 +73,7 @@ The module implements code coverage annotations as described in cover.rkt (define stx #'(m name lang (#%module-begin add ... body ...))) - (rebuild-syntax stx disarmed expr phase))])]))] + (rebuild-syntax stx disarmed expr phase-shift))])]))] [(b a ...) (or (eq? 'begin (syntax-e #'b)) @@ -127,8 +131,8 @@ The module implements code coverage annotations as described in cover.rkt (for-meta #,i (rename '#%kernel #%papp #%app)) (for-meta #,i (rename '#%kernel pdefine-values define-values)) (for-meta #,i (rename '#%kernel pbegin begin)) - (for-meta #,i (rename '#%unsafe unsafe-vector-ref unsafe-vector-ref)) - (for-meta #,i (rename '#%unsafe unsafe-vector-set! unsafe-vector-set!)))) + (for-meta #,i (rename '#%kernel unsafe-vector-ref unsafe-vector-ref)) + (for-meta #,i (rename '#%kernel unsafe-vector-set! unsafe-vector-set!)))) (pdefine-values (lgr) (#%papp current-logger)) (pdefine-values (rec) (#%papp make-log-receiver @@ -158,7 +162,10 @@ The module implements code coverage annotations as described in cover.rkt (lambda (file) - (define initialized? (hash-has-key? loc->vecref file)) + (define initialized? (hash-has-key? file->loc->vecref file)) + (unless initialized? + (hash-set! file->loc->vecref file (make-hash))) + (define loc->vecref (hash-ref file->loc->vecref file)) (define count 0) (define (make-cover-annotate-top annotate-top) diff --git a/cover/tests/do-bfs+module.rkt b/cover/tests/do-bfs+module.rkt index 6a1536c..9513954 100644 --- a/cover/tests/do-bfs+module.rkt +++ b/cover/tests/do-bfs+module.rkt @@ -3,9 +3,11 @@ (define-runtime-path-list fs (list "module.rkt" "bfs.rkt" - "bfs+module.rkt")) + "bfs+module.rkt" + "bfs+module-nolex.rkt" + "lazy-require.rkt")) (test-case - "begin-for-syntax with nexted modules should be okay" + "begin-for-syntax with modules should be okay" (parameterize ([current-cover-environment (make-cover-environment)]) (for-each (lambda (f)