adjusted check syntax to record the right-hand side of binding forms (when they are there)
This commit is contained in:
Robby Findler
parent
5a5da11314
commit
e7bd94f2d2
|
|
@ -6,7 +6,7 @@
|
|||
syntax/kerncase)
|
||||
(provide annotate-contracts)
|
||||
|
||||
(define (annotate-contracts stx low-binders varrefs)
|
||||
(define (annotate-contracts stx low-binders binding-inits)
|
||||
(define start-map (make-hash))
|
||||
(define arrow-map (make-hash))
|
||||
(define domain-map (make-hash))
|
||||
|
|
@ -28,7 +28,8 @@
|
|||
(for ([(start-k start-val) (in-hash start-map)])
|
||||
(for ([start-stx (in-list start-val)])
|
||||
(do-contract-traversal start-stx
|
||||
coloring-plans low-binders
|
||||
coloring-plans
|
||||
low-binders binding-inits
|
||||
arrow-map domain-map range-map
|
||||
#t)))
|
||||
|
||||
|
|
@ -45,7 +46,7 @@
|
|||
[(member unk-obligation-style-name colors)
|
||||
(color stx unk-obligation-style-name 'contract-mode)])))
|
||||
|
||||
(define (do-contract-traversal start-stx coloring-plans low-binders arrow-map domain-map range-map polarity)
|
||||
(define (do-contract-traversal start-stx coloring-plans low-binders binding-inits arrow-map domain-map range-map polarity)
|
||||
(let ploop ([stx start-stx]
|
||||
[polarity polarity])
|
||||
|
||||
|
|
@ -62,9 +63,9 @@
|
|||
[to-color (vector-ref prop 1)])
|
||||
(base-color to-color polarity coloring-plans)
|
||||
(for ((stx (in-list (hash-ref domain-map id '()))))
|
||||
(do-contract-traversal stx coloring-plans low-binders arrow-map domain-map range-map (not polarity)))
|
||||
(do-contract-traversal stx coloring-plans low-binders binding-inits arrow-map domain-map range-map (not polarity)))
|
||||
(for ((stx (in-list (hash-ref range-map id '()))))
|
||||
(do-contract-traversal stx coloring-plans low-binders arrow-map domain-map range-map polarity)))]))]
|
||||
(do-contract-traversal stx coloring-plans low-binders binding-inits arrow-map domain-map range-map polarity)))]))]
|
||||
|
||||
[else
|
||||
;; we didn't find a contract, but we might find one in a subexpression
|
||||
|
|
@ -91,7 +92,10 @@
|
|||
(if (known-predicate? #'id)
|
||||
(base-color #'id polarity coloring-plans)
|
||||
(begin
|
||||
;(printf "mapped to ~s\n" (module-identifier-mapping-get low-binders #'id))
|
||||
(for ((binder (in-list (module-identifier-mapping-get low-binders #'id))))
|
||||
(printf "~s => ~s\n"
|
||||
#'id
|
||||
(module-identifier-mapping-get binding-inits binder)))
|
||||
(give-up start-stx coloring-plans)))]
|
||||
[(#%plain-lambda formals expr ...)
|
||||
(give-up start-stx coloring-plans)]
|
||||
|
|
@ -106,8 +110,8 @@
|
|||
;; on the other hand, recurring like this will mean that the two
|
||||
;; branches are considered separately and thus calling give-up
|
||||
;; on one side will not pollute the other side.
|
||||
(do-contract-traversal #'b coloring-plans low-binders arrow-map domain-map range-map polarity)
|
||||
(do-contract-traversal #'c coloring-plans low-binders arrow-map domain-map range-map polarity)]
|
||||
(do-contract-traversal #'b coloring-plans low-binders binding-inits arrow-map domain-map range-map polarity)
|
||||
(do-contract-traversal #'c coloring-plans low-binders binding-inits arrow-map domain-map range-map polarity)]
|
||||
;; [(begin expr ...) (void)]
|
||||
[(begin0 fst rst ...)
|
||||
(ploop #'fst polarity)]
|
||||
|
|
|
|||
|
|
@ -66,6 +66,7 @@
|
|||
[tl-high-varsets (make-id-set)]
|
||||
[tl-low-tops (make-id-set)]
|
||||
[tl-high-tops (make-id-set)]
|
||||
[tl-binding-inits (make-id-set)]
|
||||
[tl-templrefs (make-id-set)]
|
||||
[tl-requires (make-hash)]
|
||||
[tl-require-for-syntaxes (make-hash)]
|
||||
|
|
@ -87,6 +88,7 @@
|
|||
[high-varsets (make-id-set)]
|
||||
[low-tops (make-id-set)]
|
||||
[high-tops (make-id-set)]
|
||||
[binding-inits (make-id-set)]
|
||||
[templrefs (make-id-set)]
|
||||
[requires (make-hash)]
|
||||
[require-for-syntaxes (make-hash)]
|
||||
|
|
@ -98,6 +100,7 @@
|
|||
varrefs high-varrefs
|
||||
varsets high-varsets
|
||||
low-tops high-tops
|
||||
binding-inits
|
||||
templrefs
|
||||
requires require-for-syntaxes require-for-templates require-for-labels)
|
||||
(annotate-variables user-namespace
|
||||
|
|
@ -115,7 +118,7 @@
|
|||
require-for-syntaxes
|
||||
require-for-templates
|
||||
require-for-labels)
|
||||
(annotate-contracts sexp low-binders varrefs))]
|
||||
(annotate-contracts sexp low-binders binding-inits))]
|
||||
[else
|
||||
(annotate-basic sexp
|
||||
user-namespace user-directory jump-to-id
|
||||
|
|
@ -123,6 +126,7 @@
|
|||
tl-low-varrefs tl-high-varrefs
|
||||
tl-low-varsets tl-high-varsets
|
||||
tl-low-tops tl-high-tops
|
||||
tl-binding-inits
|
||||
tl-templrefs
|
||||
tl-requires
|
||||
tl-require-for-syntaxes
|
||||
|
|
@ -165,6 +169,7 @@
|
|||
low-varrefs high-varrefs
|
||||
low-varsets high-varsets
|
||||
low-tops high-tops
|
||||
binding-inits
|
||||
templrefs
|
||||
requires require-for-syntaxes require-for-templates require-for-labels)
|
||||
|
||||
|
|
@ -204,7 +209,7 @@
|
|||
(begin
|
||||
(annotate-raw-keyword sexp varrefs)
|
||||
(annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht)
|
||||
(add-binders (syntax args) binders)
|
||||
(add-binders (syntax args) binders #f #f)
|
||||
(for-each loop (syntax->list (syntax (bodies ...)))))]
|
||||
[(case-lambda [argss bodiess ...]...)
|
||||
(begin
|
||||
|
|
@ -215,7 +220,7 @@
|
|||
(syntax->list (syntax ((bodiess ...) ...))))
|
||||
(for-each
|
||||
(λ (args bodies)
|
||||
(add-binders args binders)
|
||||
(add-binders args binders #f #f)
|
||||
(for-each loop (syntax->list bodies)))
|
||||
(syntax->list (syntax (argss ...)))
|
||||
(syntax->list (syntax ((bodiess ...) ...)))))]
|
||||
|
|
@ -252,8 +257,9 @@
|
|||
(for-each collect-general-info (syntax->list (syntax (bindings ...))))
|
||||
(annotate-tail-position/last sexp (syntax->list (syntax (bs ...))) tail-ht)
|
||||
(with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))])
|
||||
(for-each (λ (x) (add-binders x binders))
|
||||
(syntax->list (syntax ((xss ...) ...))))
|
||||
(for-each (λ (x es) (add-binders x binders binding-inits es))
|
||||
(syntax->list (syntax ((xss ...) ...)))
|
||||
(syntax->list (syntax (es ...))))
|
||||
(for-each loop (syntax->list (syntax (es ...))))
|
||||
(for-each loop (syntax->list (syntax (bs ...))))))]
|
||||
[(letrec-values (bindings ...) bs ...)
|
||||
|
|
@ -262,8 +268,9 @@
|
|||
(for-each collect-general-info (syntax->list (syntax (bindings ...))))
|
||||
(annotate-tail-position/last sexp (syntax->list (syntax (bs ...))) tail-ht)
|
||||
(with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))])
|
||||
(for-each (λ (x) (add-binders x binders))
|
||||
(syntax->list (syntax ((xss ...) ...))))
|
||||
(for-each (λ (x es) (add-binders x binders binding-inits es))
|
||||
(syntax->list (syntax ((xss ...) ...)))
|
||||
(syntax->list (syntax (es ...))))
|
||||
(for-each loop (syntax->list (syntax (es ...))))
|
||||
(for-each loop (syntax->list (syntax (bs ...))))))]
|
||||
[(set! var e)
|
||||
|
|
@ -318,19 +325,19 @@
|
|||
[(define-values vars b)
|
||||
(begin
|
||||
(annotate-raw-keyword sexp varrefs)
|
||||
(add-binders (syntax vars) binders)
|
||||
(add-binders (syntax vars) binders binding-inits #'b)
|
||||
(maybe-jump (syntax vars))
|
||||
(loop (syntax b)))]
|
||||
[(define-syntaxes names exp)
|
||||
(begin
|
||||
(annotate-raw-keyword sexp varrefs)
|
||||
(add-binders (syntax names) binders)
|
||||
(add-binders (syntax names) binders binding-inits #'exp)
|
||||
(maybe-jump (syntax names))
|
||||
(level-loop (syntax exp) #t))]
|
||||
[(define-values-for-syntax names exp)
|
||||
(begin
|
||||
(annotate-raw-keyword sexp varrefs)
|
||||
(add-binders (syntax names) high-binders)
|
||||
(add-binders (syntax names) high-binders binding-inits #'exp)
|
||||
(maybe-jump (syntax names))
|
||||
(level-loop (syntax exp) #t))]
|
||||
[(module m-name lang (#%plain-module-begin bodies ...))
|
||||
|
|
@ -1029,11 +1036,11 @@
|
|||
|
||||
(define (symbolic-compare? x y) (eq? (syntax-e x) (syntax-e y)))
|
||||
|
||||
;; add-binders : syntax id-set -> void
|
||||
;; add-binders : syntax id-set (or/c #f id-set) (or/c #f syntax) -> void
|
||||
;; transforms an argument list into a bunch of symbols/symbols
|
||||
;; and puts them into the id-set
|
||||
;; effect: colors the identifiers
|
||||
(define (add-binders stx id-set)
|
||||
(define (add-binders stx id-set binding-to-init init-exp)
|
||||
(let loop ([stx stx])
|
||||
(let ([e (if (syntax? stx) (syntax-e stx) stx)])
|
||||
(cond
|
||||
|
|
@ -1043,13 +1050,17 @@
|
|||
(if (syntax? fst)
|
||||
(begin
|
||||
(when (syntax-original? fst)
|
||||
(when binding-to-init
|
||||
(add-init-exp binding-to-init fst init-exp))
|
||||
(add-id id-set fst))
|
||||
(loop rst))
|
||||
(loop rst)))]
|
||||
[(null? e) (void)]
|
||||
[else
|
||||
(when (syntax-original? stx)
|
||||
(add-id id-set stx))]))))
|
||||
(when binding-to-init
|
||||
(add-init-exp binding-to-init stx init-exp))
|
||||
(add-id id-set stx))]))))
|
||||
|
||||
;; annotate-raw-keyword : syntax id-map -> void
|
||||
;; annotates keywords when they were never expanded. eg.
|
||||
|
|
@ -1430,6 +1441,12 @@
|
|||
;; make-id-set : -> id-set
|
||||
(define (make-id-set) (make-module-identifier-mapping))
|
||||
|
||||
;; add-init-exp : id-set identifier stx -> void
|
||||
(define (add-init-exp mapping id init-exp)
|
||||
(let* ([old (module-identifier-mapping-get mapping id (λ () '()))]
|
||||
[new (cons init-exp old)])
|
||||
(module-identifier-mapping-put! mapping id new)))
|
||||
|
||||
;; add-id : id-set identifier -> void
|
||||
(define (add-id mapping id)
|
||||
(let* ([old (module-identifier-mapping-get mapping id (λ () '()))]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user