fixed phase-shifted module issue
This commit is contained in:
Spencer Florence
parent
42291c3001
commit
a79be6ed6e
|
|
@ -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
|
||||
|
|
|
|||
183
cover/strace.rkt
183
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))
|
||||
|
||||
|
||||
|
|
|
|||
4
cover/tests/bfs+module.rkt
Normal file
4
cover/tests/bfs+module.rkt
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
#lang racket
|
||||
(begin-for-syntax
|
||||
(module* t #f
|
||||
1))
|
||||
2
cover/tests/bfs.rkt
Normal file
2
cover/tests/bfs.rkt
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
#lang racket
|
||||
(begin-for-syntax 1)
|
||||
15
cover/tests/do-bfs+module.rkt
Normal file
15
cover/tests/do-bfs+module.rkt
Normal file
|
|
@ -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)))
|
||||
3
cover/tests/module.rkt
Normal file
3
cover/tests/module.rkt
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
#lang racket
|
||||
(module* test #f
|
||||
1)
|
||||
Loading…
Reference in New Issue
Block a user