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

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

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

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

@ -8,6 +8,7 @@
(define original-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)
(define-signature stacktrace-imports^
@ -273,10 +274,16 @@
(syntax-property new 'inferred-name p2)
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)]
[rhss (syntax->list rhss-stx)]
[bodys (syntax->list bodys-stx)])
(parameterize ([maybe-undefined (if (and letrec?
(not (andmap (simple-rhs? phase) rhss)))
(add-identifiers
(apply append (map syntax->list varss))
(maybe-undefined))
(maybe-undefined))])
(let ([rhsl (map
(lambda (vars rhs)
(no-cache-annotate-named
@ -288,7 +295,25 @@
[bodyl (map (lambda (body) (no-cache-annotate body phase))
bodys)])
(rebuild expr (append (map cons bodys bodyl)
(map cons rhss rhsl))))))
(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)
(let* ([bodys (syntax->list bodys-stx)]
@ -362,10 +387,13 @@
(let ([b (identifier-binding expr phase)])
(cond
[(eq? 'lexical b)
;; lexical variable - no error possile
expr]
;; lexical variable; a use-before-defined error is possible
;; 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 base rel)))
(or base rel)))
;; from another module -- no error possible
expr]
[else
@ -485,14 +513,16 @@
(annotate-let disarmed-expr phase
(syntax (vars ...))
(syntax (rhs ...))
(syntax body))))]
(syntax body)
#f)))]
[(letrec-values ([vars rhs] ...) . body)
(let ([fm (rearm
expr
(annotate-let disarmed-expr phase
(syntax (vars ...))
(syntax (rhs ...))
(syntax body)))])
(syntax body)
#t))])
(kernel-syntax-case/phase expr phase
[(lv ([(var1) (#%plain-lambda . _)]) var2)
(and (identifier? #'var2)
@ -508,7 +538,8 @@
(annotate-let disarmed-expr phase
(syntax (vars ...))
(syntax (rhs ...))
(syntax body)))])
(syntax body)
#t))])
(with-mrk* expr fm))]
;; Wrap RHS