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

adjust errortrace to record potential use-before-definition sites

Browse Source 
Formerly, reference to a local variable could never raise an
exception.
This commit is contained in:
Matthew Flatt 2014-04-16 07:01:31 -06:00
parent 6ce5e3d34a
commit 50bea642b2
2 changed files with 58 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
pkgs/errortrace-pkgs/errortrace-lib/errortrace/lang/body.rkt
View File

@ -3,6 +3,7 @@
syntax/strip-context syntax/strip-context
racket/pretty racket/pretty
"../errortrace-lib.rkt" "../errortrace-lib.rkt"
"../stacktrace.rkt"
"../private/utils.rkt")) "../private/utils.rkt"))
(provide (rename-out [module-begin #%module-begin])) (provide (rename-out [module-begin #%module-begin]))
@ -10,12 +11,13 @@
(define-syntax (module-begin stx) (define-syntax (module-begin stx)
(syntax-case stx () (syntax-case stx ()
[(_ lang . body) [(_ lang . body)
(let ([e (annotate-top (let ([e (let ([expanded-e
(values ; syntax-local-introduce (local-expand #`(module . #,(strip-context #`(n lang . body)))
(local-expand #`(module . #,(strip-context #`(n lang . body))) 'top-level
'top-level null)])
null)) (parameterize ([original-stx stx]
0)]) [expanded-stx expanded-e])
(annotate-top expanded-e 0)))])
(collect-garbage) (collect-garbage)
(syntax-case e () (syntax-case e ()
[(mod nm lang (mb . body)) [(mod nm lang (mb . body))

69
pkgs/errortrace-pkgs/errortrace-lib/errortrace/stacktrace.rkt
View File

@ -8,6 +8,7 @@
(define original-stx (make-parameter #f)) (define original-stx (make-parameter #f))
(define expanded-stx (make-parameter #f)) (define expanded-stx (make-parameter #f))
(define maybe-undefined (make-parameter #hasheq()))
(provide stacktrace@ stacktrace^ stacktrace-imports^ original-stx expanded-stx) (provide stacktrace@ stacktrace^ stacktrace-imports^ original-stx expanded-stx)
(define-signature stacktrace-imports^ (define-signature stacktrace-imports^
@ -273,22 +274,46 @@
(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 letrec?)
(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 (parameterize ([maybe-undefined (if (and letrec?
(lambda (vars rhs) (not (andmap (simple-rhs? phase) rhss)))
(no-cache-annotate-named (add-identifiers
(syntax-case vars () [(id) (syntax id)] [_else #f]) (apply append (map syntax->list varss))
rhs (maybe-undefined))
phase)) (maybe-undefined))])
varss (let ([rhsl (map
rhss)] (lambda (vars rhs)
[bodyl (map (lambda (body) (no-cache-annotate body phase)) (no-cache-annotate-named
bodys)]) (syntax-case vars () [(id) (syntax id)] [_else #f])
(rebuild expr (append (map cons bodys bodyl) rhs
(map cons rhss rhsl)))))) phase))
varss
rhss)]
[bodyl (map (lambda (body) (no-cache-annotate body phase))
bodys)])
(rebuild expr (append (map cons bodys bodyl)
(map cons rhss rhsl)))))))
(define ((simple-rhs? phase) expr)
(kernel-syntax-case/phase expr phase
[(quote _) #t]
[(quote-syntax _) #t]
[(#%plain-lambda . _) #t]
[(case-lambda . _) #t]
[_else #f]))
(define (add-identifiers ids ht)
(for/fold ([ht ht]) ([id (in-list ids)])
(define l (hash-ref ht (syntax-e id) null))
(hash-set ht (syntax-e id) (cons id l))))
(define (maybe-undefined? id phase)
(define l (hash-ref (maybe-undefined) (syntax-e id) null))
(for/or ([mu-id (in-list l)])
(free-identifier=? mu-id id phase)))
(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)]
@ -362,10 +387,13 @@
(let ([b (identifier-binding expr phase)]) (let ([b (identifier-binding expr phase)])
(cond (cond
[(eq? 'lexical b) [(eq? 'lexical b)
;; lexical variable - no error possile ;; lexical variable; a use-before-defined error is possible
expr] ;; for letrec-bound variables
(if (maybe-undefined? expr phase)
(with-mrk* expr expr)
expr)]
[(and (pair? b) (let-values ([(base rel) (module-path-index-split (car b))]) [(and (pair? b) (let-values ([(base rel) (module-path-index-split (car b))])
(and base rel))) (or base rel)))
;; from another module -- no error possible ;; from another module -- no error possible
expr] expr]
[else [else
@ -485,14 +513,16 @@
(annotate-let disarmed-expr phase (annotate-let disarmed-expr phase
(syntax (vars ...)) (syntax (vars ...))
(syntax (rhs ...)) (syntax (rhs ...))
(syntax body))))] (syntax body)
#f)))]
[(letrec-values ([vars rhs] ...) . body) [(letrec-values ([vars rhs] ...) . body)
(let ([fm (rearm (let ([fm (rearm
expr expr
(annotate-let disarmed-expr phase (annotate-let disarmed-expr phase
(syntax (vars ...)) (syntax (vars ...))
(syntax (rhs ...)) (syntax (rhs ...))
(syntax body)))]) (syntax body)
#t))])
(kernel-syntax-case/phase expr phase (kernel-syntax-case/phase expr phase
[(lv ([(var1) (#%plain-lambda . _)]) var2) [(lv ([(var1) (#%plain-lambda . _)]) var2)
(and (identifier? #'var2) (and (identifier? #'var2)
@ -508,7 +538,8 @@
(annotate-let disarmed-expr phase (annotate-let disarmed-expr phase
(syntax (vars ...)) (syntax (vars ...))
(syntax (rhs ...)) (syntax (rhs ...))
(syntax body)))]) (syntax body)
#t))])
(with-mrk* expr fm))] (with-mrk* expr fm))]
;; Wrap RHS ;; Wrap RHS