suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

PR 10237

Browse Source 
svn: r14822
This commit is contained in:
Robby Findler 2009-05-14 20:23:31 +00:00
parent 34c2dfe021
commit 6551dbfaa0
1 changed files with 22 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/errortrace/stacktrace.ss
View File

@ -80,7 +80,7 @@
;; expressions with test suite coverage information. Returning the
;; first argument means no tests coverage information is collected.
;; test-coverage-point : syntax syntax -> syntax
;; test-coverage-point : syntax syntax phase -> syntax
;; sets a test coverage point for a single expression
(define (test-coverage-point body expr phase)
(if (and (test-coverage-enabled)
@ -353,14 +353,29 @@
[(define-values names rhs)
top?
;; Can't put annotation on the outside
(let ([marked (with-mark expr
(annotate-named
(one-name #'names)
(syntax rhs)
phase))])
(let* ([marked
(with-mark expr
(annotate-named
(one-name #'names)
(syntax rhs)
phase))]
[with-coverage
(let loop ([stx #'names]
[obj marked])
(cond
[(not (syntax? stx)) obj]
[(identifier? stx)
(test-coverage-point obj stx phase)]
[(pair? (syntax-e stx))
(loop (car (syntax-e stx))
(loop (cdr (syntax-e stx))
obj))]
[else obj]))])
(certify
expr
(rebuild expr (list (cons #'rhs marked)))))]
(rebuild
expr
(list (cons #'rhs with-coverage)))))]
[(begin . exprs)
top?
(certify