From 97db476a66c59e7bb1c067fe89478a1d201c949d Mon Sep 17 00:00:00 2001 From: Spencer Florence Date: Fri, 22 Apr 2016 15:49:07 -0500 Subject: [PATCH] using new errortrace to cover phases above 0 --- cover/strace.rkt | 70 +++++++++++++++++++++++++++--------------- cover/tests/bfs.rkt | 46 ++++++++++++++++++++++++++- cover/tests/syntax.rkt | 5 +-- info.rkt | 5 +-- 4 files changed, 94 insertions(+), 32 deletions(-) diff --git a/cover/strace.rkt b/cover/strace.rkt index c12c8b4..479eb70 100644 --- a/cover/strace.rkt +++ b/cover/strace.rkt @@ -24,7 +24,10 @@ The module implements code coverage annotations as described in cover.rkt (define vector-name #'cover-coverage-vector) (define make-log-receiver-name #'make-log-receiver) (define sync-name #'sync) +(define app-name #'#%app) (define hash-ref-name #'hash-ref) +(define bfs-name #'begin-for-syntax) +(define begin-name #'begin) ;; symbol [Hash srcloclist index] [Hash pathstring vector] ;; -> (pathstring -> annotator) @@ -43,7 +46,9 @@ The module implements code coverage annotations as described in cover.rkt (cond [(cross-phase-persist? stx) ;; special case: cross-phase-pesistant files ;; are not coverable, but immutable so basically always covered - (initialize-test-coverage-point stx) + (define loc (stx->srcloc stx)) + (when loc + (initialize-test-coverage-point stx loc)) (do-final-init! #t) stx] [else @@ -64,8 +69,8 @@ The module implements code coverage annotations as described in cover.rkt e #f [(begin e mod) (begin - (syntax-case #'e (#%plain-app) - [(#%plain-app vector-set vec loc #t) + (syntax-case #'e (quote) + [(_ #;#%app vector-set vec (quote loc) (quote #t)) (vector-set! (hash-ref vecmapping file) (syntax-e #'loc) #t)]) #'mod)] [_ e])) @@ -73,21 +78,27 @@ The module implements code coverage annotations as described in cover.rkt (define initialize-test-coverage-point (if initialized? void - (lambda (stx) - (define loc (stx->srcloc stx)) + (lambda (stx loc) (unless (hash-has-key? loc->vecref loc) (hash-set! loc->vecref loc (list file count)) (set! count (add1 count)))))) - (define (test-covered stx) - (define loc (stx->srcloc stx)) + (define (test-covered stx loc) (with-syntax ([vector-name vector-name] + [#%papp app-name] [unsafe-vector-set! unsafe-vector-set!-name] [vecloc (cadr (hash-ref loc->vecref loc))]) - #`(#%plain-app unsafe-vector-set! vector-name vecloc #t))) + #`(#%papp unsafe-vector-set! vector-name 'vecloc '#t))) + + (define (test-coverage-point body expr phase) + (define loc (stx->srcloc expr)) + (cond [loc + (initialize-test-coverage-point expr loc) + #`(#,begin-name #,(test-covered expr loc) #,body)] + [else body])) ;; ---- IN ---- - (define-values/invoke-unit/infer stacktrace@) + (define-values/invoke-unit/infer stacktrace/annotator@) (make-cover-annotate-top annotate-top)) ;; -------- Annotation Helpers -------------- @@ -166,6 +177,8 @@ The module implements code coverage annotations as described in cover.rkt (get-syntax-depth #'mb)] [(begin-for-syntax b ...) (add1 (apply max 1 (map get-syntax-depth (syntax->list #'(b ...)))))] + [(define-syntaxes a ...) + 2] [(b ...) (apply max 1 (map get-syntax-depth (syntax->list #'(b ...))))] [_ 1])) @@ -182,17 +195,32 @@ The module implements code coverage annotations as described in cover.rkt [sync sync-name] [file file] [hash-ref hash-ref-name] - [#%papp #'#%app] + [#%papp app-name] [pdefine-values #'define-values] - [pbegin #'begin] + [pbegin begin-name] [prequire '#%require] + [pbegin-for-syntax bfs-name] [send-name (format-symbol "~a~a" topic 'cover-internal-send-vector-mapping)] [req-name (format-symbol "~a~a" topic 'cover-internal-request-vector-mapping)]) + (define startup-code + #`(pbegin + (pdefine-values (lgr) (#%papp current-logger)) + (pdefine-values (rec) (#%papp make-log-receiver lgr 'info 'send-name)) + (pdefine-values (vector-name) + (pbegin + (#%papp log-message lgr 'info 'req-name '"" '#f) + (#%papp hash-ref + (#%papp unsafe-vector-ref + (#%papp sync rec) + '2) + 'file))))) #`(#,@(for/list ([i bfs-depth]) - #`(#%require (for-meta #,i (rename '#%kernel prequire #%require)))) + #`(#%require + (for-meta #,i (only '#%kernel quote)) + (for-meta #,i (rename '#%kernel prequire #%require)))) #,@(for/list ([i bfs-depth]) - #`(prequire (only '#%kernel quote) - (for-meta #,i (rename '#%kernel log-message log-message)) + #`(prequire (for-meta #,i (rename '#%kernel log-message log-message)) + (for-meta #,i (rename '#%kernel pbegin-for-syntax begin-for-syntax)) (for-meta #,i (rename '#%kernel current-logger current-logger)) (for-meta #,i (rename '#%kernel make-log-receiver make-log-receiver)) (for-meta #,i (rename '#%kernel sync sync)) @@ -202,16 +230,9 @@ The module implements code coverage annotations as described in cover.rkt (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!)))) - (pdefine-values (lgr) (#%papp current-logger)) - (pdefine-values (rec) (#%papp make-log-receiver lgr 'info 'send-name)) - (pdefine-values (vector-name) - (pbegin - (#%papp log-message lgr 'info 'req-name "" #f) - (#%papp hash-ref - (#%papp unsafe-vector-ref - (#%papp sync rec) - 2) - file)))))) + (prequire (for-meta #,bfs-depth (rename '#%kernel pbegin begin))) + #,(for/fold ([stx #'(pbegin)]) ([i bfs-depth]) + #`(pbegin #,startup-code (pbegin-for-syntax #,stx)))))) (define inspector (variable-reference->module-declaration-inspector (#%variable-reference))) @@ -242,7 +263,6 @@ The module implements code coverage annotations as described in cover.rkt ;; -------- Generic `stacktrace^` Imports -------------- (define (with-mark src dest phase) dest) -(define test-coverage-enabled (make-parameter #t)) (define profile-key (gensym)) (define profiling-enabled (make-parameter #f)) (define initialize-profile-point void) diff --git a/cover/tests/bfs.rkt b/cover/tests/bfs.rkt index 87e8e43..05d5017 100644 --- a/cover/tests/bfs.rkt +++ b/cover/tests/bfs.rkt @@ -1,2 +1,46 @@ #lang racket -(begin-for-syntax 1) +;; this is a comment +(+ 1 2) +(λ (x) 3) +(module+ test 20) +(λ (x) 3) +(module+ test 20) +(λ (x) 3) +(module+ test 20) + +(begin-for-syntax + (require (for-syntax (only-in racket/base require for-syntax #%app begin-for-syntax #%datum only-in))) + ;; this is a comment + (+ 1 2) + (λ (x) 3) + (module+ test1 20) + (λ (x) 3) + (module+ test1 20) + (λ (x) 3) + (module+ test1 20) + (begin-for-syntax + (require (only-in racket/base + λ module*)) + (require (for-syntax (only-in racket/base require for-syntax #%app begin-for-syntax #%datum only-in))) + (+ 1 2) + (λ (x) 3) + (λ (x) 3) + (λ (x) 3) + (module* test2 racket 20) + + (begin-for-syntax + (require (only-in racket/base + λ module*)) + (require (for-syntax (only-in racket/base require for-syntax #%app begin-for-syntax #%datum only-in))) + (+ 1 2) + (λ (x) 3) + (λ (x) 3) + (λ (x) 3) + (module* test3 racket 20) + + (begin-for-syntax + (require (only-in racket/base + λ module*)) + (require (for-syntax (only-in racket/base require for-syntax #%app begin-for-syntax #%datum only-in))) + (+ 1 2) + (λ (x) 3) + (λ (x) 3) + (λ (x) 3) + (module* test4 racket 20))))) diff --git a/cover/tests/syntax.rkt b/cover/tests/syntax.rkt index 5e2088e..979f86a 100644 --- a/cover/tests/syntax.rkt +++ b/cover/tests/syntax.rkt @@ -1,11 +1,8 @@ #lang racket ;; These tests modified from https://github.com/jackfirth/point-free -(provide define/compose - arg-count +(provide arg-count define/arg-count) -(define-syntax-rule (define/compose id f ...) - (define id (compose f ...))) (define-syntax-rule (arg-count n expr) (lambda args diff --git a/info.rkt b/info.rkt index 8d42d51..13dc1ab 100644 --- a/info.rkt +++ b/info.rkt @@ -5,8 +5,9 @@ (define version "3.0.3") -(define deps '(("base" #:version "6.1.1") "errortrace-lib" "rackunit-lib" - "syntax-color-lib" "compiler-lib" "custom-load" "data-lib")) +(define deps '(("base" #:version "6.1.1") ("errortrace-lib" #:version "1.1") + "rackunit-lib" "syntax-color-lib" "compiler-lib" + "custom-load" "data-lib")) (define build-deps '("racket-doc" "scribble-lib" "typed-racket-doc" "htdp-lib"