From a79be6ed6e4379d939cb843d5c41e0b6bc47f8a3 Mon Sep 17 00:00:00 2001 From: Spencer Florence Date: Mon, 10 Aug 2015 10:52:40 -0500 Subject: [PATCH] fixed phase-shifted module issue --- cover/cover.rkt | 10 +- cover/strace.rkt | 183 ++++++++++++++++++++-------------- cover/tests/bfs+module.rkt | 4 + cover/tests/bfs.rkt | 2 + cover/tests/do-bfs+module.rkt | 15 +++ cover/tests/module.rkt | 3 + 6 files changed, 139 insertions(+), 78 deletions(-) create mode 100644 cover/tests/bfs+module.rkt create mode 100644 cover/tests/bfs.rkt create mode 100644 cover/tests/do-bfs+module.rkt create mode 100644 cover/tests/module.rkt diff --git a/cover/cover.rkt b/cover/cover.rkt index 822d77e..290476c 100644 --- a/cover/cover.rkt +++ b/cover/cover.rkt @@ -201,7 +201,7 @@ Thus, In essence this module has three responsibilites: (cond [(or (compiled-expression? (if (syntax? e) (syntax-e e) e)) (not (eq? reg (namespace-module-registry (current-namespace)))) (not file)) - e] + e] [else (vprintf "compiling ~s with coverage annotations in enviornment ~s" file @@ -225,10 +225,10 @@ Thus, In essence this module has three responsibilites: (and next (ormap loop next))) (if f - (if (path? f) - (path->string f) - f) - (do-loop))))) + (if (path? f) + (path->string f) + f) + (do-loop))))) #; (thread diff --git a/cover/strace.rkt b/cover/strace.rkt index bb9c9bc..5acd311 100644 --- a/cover/strace.rkt +++ b/cover/strace.rkt @@ -38,80 +38,120 @@ The module implements code coverage annotations as described in cover.rkt [_ #f])) (define (add-cover-require expr file) - (let loop ([expr expr] [top #t]) + (define bfs-depth (get-syntax-depth expr)) + + (define/with-syntax (add ...) + (build-adds bfs-depth file)) + + ;; -- IN -- + + (let loop ([expr expr] [phase 0] [top #t]) (define disarmed (disarm expr)) (kernel-syntax-case disarmed #f + [(m name lang mb) (or (eq? 'module (syntax-e #'m)) (eq? 'module* (syntax-e #'m))) - (with-syntax ([log-message log-message-name] - [current-logger current-logger-name] - [unsafe-vector-set! unsafe-vector-set!-name] - [unsafe-vector-ref unsafe-vector-ref-name] - [vector-name vector-name] - [make-log-receiver make-log-receiver-name] - [sync sync-name] - [file file] - [hash-ref hash-ref-name] - [#%papp #'#%app] - [pdefine-values #'define-values] - [pbegin #'begin] - [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 lexical? (eq? #f (syntax-e #'lang))) - (syntax-case (syntax-disarm #'mb inspector) () - [(#%module-begin b ...) - (let () - (define/with-syntax (body ...) - (map (lambda (e) (loop e #f)) - (syntax->list #'(b ...)))) - (define/with-syntax (add ...) - #'((#%require (rename '#%kernel log-message log-message) - (rename '#%kernel current-logger current-logger) - (rename '#%kernel make-log-receiver make-log-receiver) - (rename '#%kernel sync sync) - (rename '#%kernel hash-ref hash-ref) - (rename '#%kernel #%papp #%app) - (rename '#%kernel pdefine-values define-values) - (rename '#%kernel pbegin begin) - (rename '#%unsafe unsafe-vector-ref unsafe-vector-ref) - (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))))) - (define stx - #'(m name lang - (#%module-begin add ... body ...))) - (rebuild-syntax stx disarmed expr))]))] - [(b a ...) - (eq? 'begin (syntax-e #'b)) (let () + (define lexical? (eq? #f (syntax-e #'lang))) + (define phase-shift + (if lexical? phase 0)) + (define shifted (syntax-shift-phase-level disarmed (- phase-shift))) + (syntax-case shifted () + [(m name lang mb) + (syntax-case (syntax-disarm #'mb inspector) () + [(#%module-begin b ...) + (let () + (define/with-syntax (body ...) + (map (lambda (e) (loop e 0 #f)) + (syntax->list #'(b ...)))) + (define stx + #'(m name lang + (#%module-begin add ... body ...))) + (rebuild-syntax stx disarmed expr phase))])]))] + + [(b a ...) + (or (eq? 'begin (syntax-e #'b)) + (eq? 'begin-for-syntax (syntax-e #'b))) + (let () + (define new-phase + (if (eq? 'begin-for-syntax (syntax-e #'b)) + (add1 phase) + phase)) (define/with-syntax (body ...) - (map (lambda (e) (loop e #f)) + (map (lambda (e) (loop e new-phase #f)) (syntax->list #'(a ...)))) #'(b body ...))] + [_ (if top #f expr)]))) - (define inspector (variable-reference->module-declaration-inspector + (define (get-syntax-depth expr) + (kernel-syntax-case + (disarm expr) #f + [(module _ _ mb) + (get-syntax-depth #'mb)] + [(module* _ _ mb) + (get-syntax-depth #'mb)] + [(begin-for-syntax b ...) + (add1 (apply max 1 (map get-syntax-depth (syntax->list #'(b ...)))))] + [(b ...) + (apply max 1 (map get-syntax-depth (syntax->list #'(b ...))))] + [_ 1])) + + (define (build-adds bfs-depth file) + (with-syntax ([log-message log-message-name] + [current-logger current-logger-name] + [unsafe-vector-set! unsafe-vector-set!-name] + [unsafe-vector-ref unsafe-vector-ref-name] + [vector-name vector-name] + [make-log-receiver make-log-receiver-name] + [sync sync-name] + [file file] + [hash-ref hash-ref-name] + [#%papp #'#%app] + [pdefine-values #'define-values] + [pbegin #'begin] + [prequire '#%require] + [send-name (format-symbol "~a~a" topic 'cover-internal-send-vector-mapping)] + [req-name (format-symbol "~a~a" topic 'cover-internal-request-vector-mapping)]) + #`(#,@(for/list ([i bfs-depth]) + #`(#%require (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)) + (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)) + (for-meta #,i (rename '#%kernel hash-ref hash-ref)) + (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!)))) + (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)))))) + +(define inspector (variable-reference->module-declaration-inspector (#%variable-reference))) (define (disarm stx) (syntax-disarm stx inspector)) @@ -174,11 +214,6 @@ The module implements code coverage annotations as described in cover.rkt (define-values/invoke-unit/infer stacktrace@) (make-cover-annotate-top annotate-top))) - -(require racket/pretty) - - - ;; -------- Generic `stacktrace^` Imports -------------- (define (with-mark src dest phase) dest) (define test-coverage-enabled (make-parameter #t)) @@ -214,13 +249,15 @@ The module implements code coverage annotations as described in cover.rkt [span span]) #'(quote (src a b pos span)))))) -(define (rebuild-syntax stx disarmed armed) +(define (rebuild-syntax stx disarmed armed phase) (syntax-rearm - (datum->syntax - disarmed - (syntax-e stx) - disarmed - disarmed) + (syntax-shift-phase-level + (datum->syntax + disarmed + (syntax-e stx) + disarmed + disarmed) + phase) armed)) diff --git a/cover/tests/bfs+module.rkt b/cover/tests/bfs+module.rkt new file mode 100644 index 0000000..955bf11 --- /dev/null +++ b/cover/tests/bfs+module.rkt @@ -0,0 +1,4 @@ +#lang racket +(begin-for-syntax + (module* t #f + 1)) diff --git a/cover/tests/bfs.rkt b/cover/tests/bfs.rkt new file mode 100644 index 0000000..87e8e43 --- /dev/null +++ b/cover/tests/bfs.rkt @@ -0,0 +1,2 @@ +#lang racket +(begin-for-syntax 1) diff --git a/cover/tests/do-bfs+module.rkt b/cover/tests/do-bfs+module.rkt new file mode 100644 index 0000000..6a1536c --- /dev/null +++ b/cover/tests/do-bfs+module.rkt @@ -0,0 +1,15 @@ +#lang racket +(require cover rackunit racket/runtime-path) +(define-runtime-path-list fs + (list "module.rkt" + "bfs.rkt" + "bfs+module.rkt")) +(test-case + "begin-for-syntax with nexted modules should be okay" + (parameterize ([current-cover-environment (make-cover-environment)]) + (for-each + (lambda (f) + (check-not-exn + (lambda () (test-files! f)) + (path->string f))) + fs))) diff --git a/cover/tests/module.rkt b/cover/tests/module.rkt new file mode 100644 index 0000000..3e3bcbf --- /dev/null +++ b/cover/tests/module.rkt @@ -0,0 +1,3 @@ +#lang racket +(module* test #f + 1)