diff --git a/cover.rkt b/cover.rkt index 9c032cd..6c8d718 100644 --- a/cover.rkt +++ b/cover.rkt @@ -117,8 +117,7 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b (or (syntax-source-file-name e) (syntax-source e) (syntax->datum e)))) - (annotate-top (namespace-syntax-introduce - (if (syntax? e) (expand-syntax e) (datum->syntax #f e))) + (annotate-top (if (syntax? e) (expand-syntax e) (datum->syntax #f e)) phase)])) (compile to-compile immediate-eval?))) @@ -179,17 +178,8 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b ;; #f => code was not run ;; remove those that cannot be annotated (define can-annotate - (filter values - (for/list ([(stx covered?) (in-hash (get-raw-coverage))]) - (and (syntax? stx) - (let* ([orig-src (syntax-source stx)] - [src (if (path? orig-src) (path->string orig-src) orig-src)] - [pos (syntax-position stx)] - [span (syntax-span stx)]) - (and pos - span - (list (mcar covered?) - (make-srcloc src #f #f pos span)))))))) + (hash-map (get-raw-coverage) + (lambda (x y) (list y x)))) ;; actions-ht : (list src number number) -> (list boolean syntax) (define actions-ht (make-hash)) @@ -236,13 +226,14 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b "tests/compiled/prog_rkt.zo" "tests/compiled/prog_rkt.dep")) (test-begin - (for-each (lambda (f) (when (file-exists? f) (delete-file f))) - compiled) - (check-false (ormap file-exists? compiled)) - (check-not-exn - (lambda () - (parameterize ([current-compile (make-cover-compile)] - [current-namespace ns]) - (managed-compile-zo prog.rkt)))) - (check-true (andmap file-exists? compiled))) - ) + (after + (for-each (lambda (f) (when (file-exists? f) (delete-file f))) + compiled) + (check-false (ormap file-exists? compiled)) + (check-not-exn + (lambda () + (parameterize ([current-compile (make-cover-compile)] + [current-namespace ns]) + (managed-compile-zo prog.rkt)))) + (check-true (andmap file-exists? compiled)) + (clear-coverage!)))) diff --git a/strace.rkt b/strace.rkt index 2491474..adca28d 100644 --- a/strace.rkt +++ b/strace.rkt @@ -1,21 +1,29 @@ #lang racket/base -(provide annotate-top test-coverage-enabled) +(provide (rename-out [in:annotate-top annotate-top])) (require errortrace/stacktrace racket/function + racket/syntax + syntax/parse racket/unit + racket/runtime-path "coverage.rkt") +(define cover-name (generate-temporary #'coverage)) +(define srcloc-name (generate-temporary #'make-srcloc)) + (define (with-mark src dest phase) dest) (define test-coverage-enabled (make-parameter #t)) (define (initialize-test-coverage-point stx) - (hash-set! coverage stx (mcons #f #f))) + (define srcloc (stx->srcloc stx)) + (when srcloc + (hash-set! coverage srcloc #f))) (define (test-covered stx) - (define v (hash-ref coverage stx #f)) - (and v - (with-syntax ([v v]) - #'(#%plain-app set-mcar! v #t)))) + (define loc/stx (stx->srcloc/stx stx)) + (with-syntax ([c cover-name] + [loc loc/stx]) + #'(#%plain-app hash-set! c loc #t))) (define profile-key (gensym)) @@ -25,3 +33,43 @@ (define register-profile-done void) (define-values/invoke-unit/infer stacktrace@) + +(define (make-srcloc-maker f) + (lambda (stx) + (and (syntax? stx) + (let* ([orig-src (syntax-source stx)] + [src (if (path? orig-src) (path->string orig-src) orig-src)] + [pos (syntax-position stx)] + [span (syntax-span stx)]) + (and pos + span + (f src #f #f pos span)))))) + +(define stx->srcloc + (make-srcloc-maker make-srcloc)) + +(define stx->srcloc/stx + (make-srcloc-maker + (lambda (src a b pos span) + (with-syntax ([src src] + [pos pos] + [a a] + [b b] + [span span] + [make-srcloc srcloc-name]) + #'(make-srcloc src a b pos span))))) + +(define (in:annotate-top stx phase) + (define e + (syntax-parse stx + #:literal-sets (kernel-literals) + [((~and a module) name lang b ...) + (with-syntax ([cover cover-name] [srcloc srcloc-name]) + (namespace-syntax-introduce + #'(a name lang + (#%require (rename cover/coverage cover coverage)) + (#%require (rename racket/base srcloc make-srcloc)) + r1 r2 + b ...)))] + [_ #f])) + (if e (annotate-top e phase) stx))