Fix syntax depth calculation
This commit is contained in:
parent
2c5bf77f1c
commit
83f6f11496
|
@ -168,19 +168,21 @@ The module implements code coverage annotations as described in cover.rkt
|
||||||
|
|
||||||
;; Syntax -> Natural
|
;; Syntax -> Natural
|
||||||
;; Maxiumum depth of begin-for-syntaxes
|
;; Maxiumum depth of begin-for-syntaxes
|
||||||
(define (get-syntax-depth expr)
|
(define (get-syntax-depth expr [phase 0])
|
||||||
(kernel-syntax-case
|
(kernel-syntax-case/phase
|
||||||
(disarm expr) #f
|
(disarm expr) phase
|
||||||
[(module _ _ mb)
|
[(module _ _ mb)
|
||||||
(get-syntax-depth #'mb)]
|
(get-syntax-depth #'mb)]
|
||||||
[(module* _ _ mb)
|
[(module* _ _ mb)
|
||||||
(get-syntax-depth #'mb)]
|
(get-syntax-depth #'mb)]
|
||||||
[(begin-for-syntax b ...)
|
[(begin-for-syntax b ...)
|
||||||
(add1 (apply max 1 (map get-syntax-depth (syntax->list #'(b ...)))))]
|
(add1 (apply max 1 (for/list ([b (in-list (syntax->list #'(b ...)))])
|
||||||
|
(get-syntax-depth b (add1 phase)))))]
|
||||||
[(define-syntaxes a ...)
|
[(define-syntaxes a ...)
|
||||||
2]
|
2]
|
||||||
[(b ...)
|
[(b ...)
|
||||||
(apply max 1 (map get-syntax-depth (syntax->list #'(b ...))))]
|
(apply max 1 (for/list ([b (in-list (syntax->list #'(b ...)))])
|
||||||
|
(get-syntax-depth b phase)))]
|
||||||
[_ 1]))
|
[_ 1]))
|
||||||
|
|
||||||
;; Natural PathString Symbol -> Syntax
|
;; Natural PathString Symbol -> Syntax
|
||||||
|
|
6
cover/tests/bfs+define-syntax.rkt
Normal file
6
cover/tests/bfs+define-syntax.rkt
Normal file
|
@ -0,0 +1,6 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(require (for-meta 1 racket/base)
|
||||||
|
(for-meta 2 racket/base))
|
||||||
|
|
||||||
|
(begin-for-syntax (define-syntax x #f))
|
|
@ -6,6 +6,7 @@
|
||||||
(define-runtime-path-list others
|
(define-runtime-path-list others
|
||||||
(list "bfs+module-nolex.rkt"
|
(list "bfs+module-nolex.rkt"
|
||||||
"bfs+module.rkt"
|
"bfs+module.rkt"
|
||||||
|
"bfs+define-syntax.rkt"
|
||||||
"lazy-require.rkt"))
|
"lazy-require.rkt"))
|
||||||
(test-case
|
(test-case
|
||||||
"begin-for-syntax with modules should be okay"
|
"begin-for-syntax with modules should be okay"
|
||||||
|
|
Loading…
Reference in New Issue
Block a user