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

fix errortrace

Browse Source 
The `eq?'ness of syntax objects used to reconstruct the result
 was broken by disarming. The solution is to reconstruct based
 on the disarmed syntax object instead of the original.

 Merge to 5.1.2.
This commit is contained in:
Matthew Flatt 2011-07-15 19:39:50 -06:00
parent f40dc87c29
commit 0f61d62ea1
2 changed files with 45 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
collects/errortrace/stacktrace.rkt
View File

@ -306,8 +306,9 @@
(define (make-annotate top? name) (define (make-annotate top? name)
(lambda (expr phase) (lambda (expr phase)
(define disarmed-expr (disarm expr))
(test-coverage-point (test-coverage-point
(kernel-syntax-case/phase (disarm expr) phase (kernel-syntax-case/phase disarmed-expr phase
[_ [_
(identifier? expr) (identifier? expr)
(let ([b (identifier-binding expr phase)]) (let ([b (identifier-binding expr phase)])
@ -354,13 +355,13 @@
(rearm (rearm
expr expr
(rebuild (rebuild
expr disarmed-expr
(list (cons #'rhs with-coverage)))))] (list (cons #'rhs with-coverage)))))]
[(begin . exprs) [(begin . exprs)
top? top?
(rearm (rearm
expr expr
(annotate-seq expr (annotate-seq disarmed-expr
(syntax exprs) (syntax exprs)
annotate-top phase))] annotate-top phase))]
[(define-syntaxes (name ...) rhs) [(define-syntaxes (name ...) rhs)
@ -372,7 +373,7 @@
(add1 phase)))]) (add1 phase)))])
(rearm (rearm
expr expr
(rebuild expr (list (cons #'rhs marked)))))] (rebuild disarmed-expr (list (cons #'rhs marked)))))]
[(define-values-for-syntax (name ...) rhs) [(define-values-for-syntax (name ...) rhs)
top? top?
@ -383,7 +384,7 @@
(add1 phase)))]) (add1 phase)))])
(rearm (rearm
expr expr
(rebuild expr (list (cons #'rhs marked)))))] (rebuild disarmed-expr (list (cons #'rhs marked)))))]
[(module name init-import mb) [(module name init-import mb)
(syntax-case (disarm #'mb) () (syntax-case (disarm #'mb) ()
@ -397,7 +398,7 @@
(rearm (rearm
expr expr
(rebuild (rebuild
expr disarmed-expr
(list (cons (list (cons
mb mb
(rearm (rearm
@ -442,21 +443,21 @@
expr expr
(keep-lambda-properties (keep-lambda-properties
expr expr
(rebuild expr (map cons clauses clausel))))))] (rebuild disarmed-expr (map cons clauses clausel))))))]
;; Wrap RHSs and body ;; Wrap RHSs and body
[(let-values ([vars rhs] ...) . body) [(let-values ([vars rhs] ...) . body)
(with-mark expr (with-mark expr
(rearm (rearm
expr expr
(annotate-let expr phase (annotate-let disarmed-expr phase
(syntax (vars ...)) (syntax (vars ...))
(syntax (rhs ...)) (syntax (rhs ...))
(syntax body))))] (syntax body))))]
[(letrec-values ([vars rhs] ...) . body) [(letrec-values ([vars rhs] ...) . body)
(let ([fm (rearm (let ([fm (rearm
expr expr
(annotate-let expr phase (annotate-let disarmed-expr phase
(syntax (vars ...)) (syntax (vars ...))
(syntax (rhs ...)) (syntax (rhs ...))
(syntax body)))]) (syntax body)))])
@ -478,7 +479,7 @@
(with-mark expr (with-mark expr
(rearm (rearm
expr expr
(rebuild expr (list (cons #'rhs new-rhs))))))] (rebuild disarmed-expr (list (cons #'rhs new-rhs))))))]
;; Wrap subexpressions only ;; Wrap subexpressions only
[(begin e) [(begin e)
@ -490,12 +491,12 @@
(with-mark expr (with-mark expr
(rearm (rearm
expr expr
(annotate-seq expr #'body annotate phase)))] (annotate-seq disarmed-expr #'body annotate phase)))]
[(begin0 . body) [(begin0 . body)
(with-mark expr (with-mark expr
(rearm (rearm
expr expr
(annotate-seq expr #'body annotate phase)))] (annotate-seq disarmed-expr #'body annotate phase)))]
[(if tst thn els) [(if tst thn els)
(let ([w-tst (annotate (syntax tst) phase)] (let ([w-tst (annotate (syntax tst) phase)]
[w-thn (annotate (syntax thn) phase)] [w-thn (annotate (syntax thn) phase)]
@ -503,7 +504,7 @@
(with-mark expr (with-mark expr
(rearm (rearm
expr expr
(rebuild expr (list (cons #'tst w-tst) (rebuild disarmed-expr (list (cons #'tst w-tst)
(cons #'thn w-thn) (cons #'thn w-thn)
(cons #'els w-els))))))] (cons #'els w-els))))))]
[(if tst thn) [(if tst thn)
@ -512,13 +513,13 @@
(with-mark expr (with-mark expr
(rearm (rearm
expr expr
(rebuild expr (list (cons #'tst w-tst) (rebuild disarmed-expr (list (cons #'tst w-tst)
(cons #'thn w-thn))))))] (cons #'thn w-thn))))))]
[(with-continuation-mark . body) [(with-continuation-mark . body)
(with-mark expr (with-mark expr
(rearm (rearm
expr expr
(annotate-seq expr (syntax body) (annotate-seq disarmed-expr (syntax body)
annotate phase)))] annotate phase)))]
;; Wrap whole application, plus subexpressions ;; Wrap whole application, plus subexpressions
@ -538,7 +539,7 @@
[else [else
(with-mark expr (rearm (with-mark expr (rearm
expr expr
(annotate-seq expr (syntax body) (annotate-seq disarmed-expr (syntax body)
annotate phase)))])] annotate phase)))])]
[_else [_else

25
collects/tests/errortrace/wrap.rkt Normal file
View File

@ -0,0 +1,25 @@
#lang racket/base
(define err-stx #'(error '"bad"))
(define (try expr)
(define out-str
(parameterize ([current-namespace (make-base-namespace)])
(parameterize ([current-compile (dynamic-require 'errortrace/errortrace-lib
'errortrace-compile-handler)]
[error-display-handler (dynamic-require 'errortrace/errortrace-lib
'errortrace-error-display-handler)])
(let ([o (open-output-string)])
(parameterize ([current-error-port o])
(call-with-continuation-prompt
(lambda ()
(eval expr))))
(get-output-string o)))))
(unless (regexp-match? (regexp-quote (format "~s" (syntax->datum err-stx)))
out-str)
(error 'test "not in context for: ~s" (syntax->datum expr))))
(try #`(begin (module m racket/base #,err-stx) (require 'm)))
(try err-stx)
(try #`(syntax-case 'a ()
(_ #,err-stx)))