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

66
collects/errortrace/stacktrace.rkt
View File

@ -88,12 +88,10 @@
(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] (with-syntax ([body body] [thunk thunk])
[thunk thunk])
#'(begin thunk body))] #'(begin thunk body))]
[else body]))) [else body])))
body)) body))
@ -237,26 +235,19 @@
(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)
(annotate body phase))
bodys)]) 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
(diff-k (cdr a))
(cond (cond
[(pair? expr) (loop (car expr) [a (diff-k (cdr a))]
[(pair? 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)
(diff-k (cons (car expr) y)))))
(lambda (x) (lambda (x)
(loop (cdr expr) (loop (cdr expr)
(lambda () (lambda () (diff-k (cons x (cdr expr))))
(diff-k (cons x (cdr expr)))) (lambda (y) (diff-k (cons x y))))))]
(lambda (y)
(diff-k (cons x y))))))]
[(vector? expr) [(vector? expr)
(loop (vector->list expr) (loop (vector->list expr) same-k
same-k
(lambda (x) (diff-k (list->vector x))))] (lambda (x) (diff-k (list->vector x))))]
[(box? expr) (loop (unbox expr) [(box? expr)
same-k (loop (unbox expr) same-k (lambda (x) (diff-k (box x))))]
(lambda (x) [(syntax? expr)
(diff-k (box x))))] (if (identifier? expr)
[(syntax? expr) (if (identifier? expr)
(same-k) (same-k)
(loop (syntax-e 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
(datum->syntax
expr
x
expr
expr)))))]
[else (same-k)])))))
(define (append-rebuild expr end) (define (append-rebuild expr end)
(cond (cond