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

Some minor cleanup

Browse Source
This commit is contained in:
Eli Barzilay 2010-10-04 17:24:14 -04:00
parent 2189957b6f
commit 2f56b23b21
1 changed files with 51 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

126
collects/errortrace/stacktrace.rkt
View File

@ -10,7 +10,7 @@
(with-mark (with-mark
test-coverage-enabled test-coverage-enabled
test-covered test-covered
initialize-test-coverage-point initialize-test-coverage-point
profile-key profile-key
@ -73,30 +73,28 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Test case coverage instrumenter ;; Test case coverage instrumenter
;; The next procedure is called by `annotate' and `annotate-top' to wrap ;; The next procedure is called by `annotate' and `annotate-top' to wrap
;; expressions with test suite coverage information. Returning the ;; expressions with test suite coverage information. Returning the
;; first argument means no tests coverage information is collected. ;; first argument means no tests coverage information is collected.
;; test-coverage-point : syntax syntax phase -> syntax ;; test-coverage-point : syntax syntax phase -> syntax
;; sets a test coverage point for a single expression ;; sets a test coverage point for a single expression
(define (test-coverage-point body expr phase) (define (test-coverage-point body expr phase)
(if (and (test-coverage-enabled) (if (and (test-coverage-enabled)
(zero? phase) (zero? phase)
(syntax-position expr)) (syntax-position expr))
(begin (initialize-test-coverage-point expr) (begin (initialize-test-coverage-point expr)
(let ([thunk (test-covered expr)]) (let ([thunk (test-covered expr)])
(cond [(procedure? thunk) (cond [(procedure? thunk)
(with-syntax ([body body] (with-syntax ([body body] [thunk thunk])
[thunk thunk]) #'(begin (#%plain-app thunk) body))]
#'(begin (#%plain-app thunk) body))] [(syntax? thunk)
[(syntax? thunk) (with-syntax ([body body] [thunk thunk])
(with-syntax ([body body] #'(begin thunk body))]
[thunk thunk]) [else body])))
#'(begin thunk body))] body))
[else body])))
body))
@ -224,39 +222,32 @@
(let ([p (syntax-property orig 'method-arity-error)] (let ([p (syntax-property orig 'method-arity-error)]
[p2 (syntax-property orig 'inferred-name)]) [p2 (syntax-property orig 'inferred-name)])
(let ([new (if p (let ([new (if p
(syntax-property new 'method-arity-error p) (syntax-property new 'method-arity-error p)
new)]) new)])
(if p2 (if p2
(syntax-property new 'inferred-name p2) (syntax-property new 'inferred-name p2)
new)))) new))))
(define (annotate-let expr phase varss-stx rhss-stx bodys-stx) (define (annotate-let expr phase varss-stx rhss-stx bodys-stx)
(let ([varss (syntax->list varss-stx)] (let ([varss (syntax->list varss-stx)]
[rhss (syntax->list rhss-stx)] [rhss (syntax->list rhss-stx)]
[bodys (syntax->list bodys-stx)]) [bodys (syntax->list bodys-stx)])
(let ([rhsl (map (let ([rhsl (map
(lambda (vars rhs) (lambda (vars rhs)
(annotate-named (annotate-named
(syntax-case vars () (syntax-case vars () [(id) (syntax id)] [_else #f])
[(id)
(syntax id)]
[_else #f])
rhs rhs
phase)) phase))
varss varss
rhss)] rhss)]
[bodyl (map [bodyl (map (lambda (body) (annotate body phase))
(lambda (body) bodys)])
(annotate body phase))
bodys)])
(rebuild expr (append (map cons bodys bodyl) (rebuild expr (append (map cons bodys bodyl)
(map cons rhss rhsl)))))) (map cons rhss rhsl))))))
(define (annotate-seq expr bodys-stx annotate phase) (define (annotate-seq expr bodys-stx annotate phase)
(let* ([bodys (syntax->list bodys-stx)] (let* ([bodys (syntax->list bodys-stx)]
[bodyl (map (lambda (b) [bodyl (map (lambda (b) (annotate b phase)) bodys)])
(annotate b phase))
bodys)])
(rebuild expr (map cons bodys bodyl)))) (rebuild expr (map cons bodys bodyl))))
(define orig-inspector (current-code-inspector)) (define orig-inspector (current-code-inspector))
@ -265,45 +256,30 @@
(syntax-recertify new orig orig-inspector #f)) (syntax-recertify new orig orig-inspector #f))
(define (rebuild expr replacements) (define (rebuild expr replacements)
(let loop ([expr expr] (let loop ([expr expr] [same-k (lambda () expr)] [diff-k (lambda (x) x)])
[same-k (lambda () expr)]
[diff-k (lambda (x) x)])
(let ([a (assq expr replacements)]) (let ([a (assq expr replacements)])
(if a (cond
(diff-k (cdr a)) [a (diff-k (cdr a))]
(cond [(pair? expr)
[(pair? expr) (loop (car expr) (loop (car expr)
(lambda () (lambda ()
(loop (cdr expr) (loop (cdr expr) same-k
same-k (lambda (y) (diff-k (cons (car expr) y)))))
(lambda (y) (lambda (x)
(diff-k (cons (car expr) y))))) (loop (cdr expr)
(lambda (x) (lambda () (diff-k (cons x (cdr expr))))
(loop (cdr expr) (lambda (y) (diff-k (cons x y))))))]
(lambda () [(vector? expr)
(diff-k (cons x (cdr expr)))) (loop (vector->list expr) same-k
(lambda (y) (lambda (x) (diff-k (list->vector x))))]
(diff-k (cons x y))))))] [(box? expr)
[(vector? expr) (loop (unbox expr) same-k (lambda (x) (diff-k (box x))))]
(loop (vector->list expr) [(syntax? expr)
same-k (if (identifier? expr)
(lambda (x) (diff-k (list->vector x))))] (same-k)
[(box? expr) (loop (unbox expr) (loop (syntax-e expr) same-k
same-k (lambda (x) (diff-k (datum->syntax expr x expr expr)))))]
(lambda (x) [else (same-k)]))))
(diff-k (box x))))]
[(syntax? expr) (if (identifier? expr)
(same-k)
(loop (syntax-e expr)
same-k
(lambda (x)
(diff-k
(datum->syntax
expr
x
expr
expr)))))]
[else (same-k)])))))
(define (append-rebuild expr end) (define (append-rebuild expr end)
(cond (cond