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)
(let ([thunk (test-covered expr)])
(cond [(procedure? thunk)
(with-syntax ([body body]
[thunk thunk])
(with-syntax ([body body] [thunk thunk])
#'(begin (#%plain-app thunk) body))]
[(syntax? thunk)
(with-syntax ([body body]
[thunk thunk])
(with-syntax ([body body] [thunk thunk])
#'(begin thunk body))]
[else body])))
body))
@ -237,26 +235,19 @@
(let ([rhsl (map
(lambda (vars rhs)
(annotate-named
(syntax-case vars ()
[(id)
(syntax id)]
[_else #f])
(syntax-case vars () [(id) (syntax id)] [_else #f])
rhs
phase))
varss
rhss)]
[bodyl (map
(lambda (body)
(annotate body phase))
[bodyl (map (lambda (body) (annotate body phase))
bodys)])
(rebuild expr (append (map cons bodys bodyl)
(map cons rhss rhsl))))))
(define (annotate-seq expr bodys-stx annotate phase)
(let* ([bodys (syntax->list bodys-stx)]
[bodyl (map (lambda (b)
(annotate b phase))
bodys)])
[bodyl (map (lambda (b) (annotate b phase)) bodys)])
(rebuild expr (map cons bodys bodyl))))
(define orig-inspector (current-code-inspector))
@ -265,45 +256,30 @@
(syntax-recertify new orig orig-inspector #f))
(define (rebuild expr replacements)
(let loop ([expr expr]
[same-k (lambda () expr)]
[diff-k (lambda (x) x)])
(let loop ([expr expr] [same-k (lambda () expr)] [diff-k (lambda (x) x)])
(let ([a (assq expr replacements)])
(if a
(diff-k (cdr a))
(cond
[(pair? expr) (loop (car expr)
[a (diff-k (cdr a))]
[(pair? expr)
(loop (car expr)
(lambda ()
(loop (cdr expr)
same-k
(lambda (y)
(diff-k (cons (car expr) y)))))
(loop (cdr expr) same-k
(lambda (y) (diff-k (cons (car expr) y)))))
(lambda (x)
(loop (cdr expr)
(lambda ()
(diff-k (cons x (cdr expr))))
(lambda (y)
(diff-k (cons x y))))))]
(lambda () (diff-k (cons x (cdr expr))))
(lambda (y) (diff-k (cons x y))))))]
[(vector? expr)
(loop (vector->list expr)
same-k
(loop (vector->list expr) same-k
(lambda (x) (diff-k (list->vector x))))]
[(box? expr) (loop (unbox expr)
same-k
(lambda (x)
(diff-k (box x))))]
[(syntax? expr) (if (identifier? expr)
[(box? expr)
(loop (unbox expr) same-k (lambda (x) (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)])))))
(loop (syntax-e expr) same-k
(lambda (x) (diff-k (datum->syntax expr x expr expr)))))]
[else (same-k)]))))
(define (append-rebuild expr end)
(cond