From e7bd94f2d2fbba7f222c0c94cf025d8c6b585098 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 12 Jul 2010 11:38:56 -0500 Subject: [PATCH] adjusted check syntax to record the right-hand side of binding forms (when they are there) --- .../private/syncheck/contract-traversal.rkt | 20 +++++---- .../drracket/private/syncheck/traversals.rkt | 43 +++++++++++++------ 2 files changed, 42 insertions(+), 21 deletions(-) diff --git a/collects/drracket/private/syncheck/contract-traversal.rkt b/collects/drracket/private/syncheck/contract-traversal.rkt index 3f89740433..31017c0919 100644 --- a/collects/drracket/private/syncheck/contract-traversal.rkt +++ b/collects/drracket/private/syncheck/contract-traversal.rkt @@ -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)] diff --git a/collects/drracket/private/syncheck/traversals.rkt b/collects/drracket/private/syncheck/traversals.rkt index f8a29df9e0..d5cc2b04b8 100644 --- a/collects/drracket/private/syncheck/traversals.rkt +++ b/collects/drracket/private/syncheck/traversals.rkt @@ -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 (λ () '()))]