fixes for 459669f that were uncovered by drdr

Author: rfindler

drracket-test/tests/drracket/syncheck-test.rkt

@@ -579,7 +579,9 @@
         ("lam"              lexically-bound)
         ("))\n  ("          default-color)
         ("require"          imported)
-        (" 'm)\n  "         default-color)
+        (" "                default-color)
+        ("'m"               unused-require)
+        (")\n  "            default-color)
         ("lam"              imported)
         (")\n"              default-color))
       '(((10 16) (20 26) (92 99))
@@ -985,11 +987,13 @@
                    ("module" imported)
                    (" n racket " default-color)
                    ("list" imported)
-                   (") (module+ o " default-color)
+                   (") (" default-color)
+                   ("module+" imported)
+                   (" o " default-color)
                    ("list" imported)
                    ("))" default-color))
                  (list 
-                  '((10 16) (18 24) (51 55))
+                  '((10 16) (18 24) (41 48) (51 55))
                   '((27 33) (34 38))))
 
      ;; test case from Chongkai
@@ -1131,21 +1135,25 @@
                    ("define"               imported)
                    (" "                    default-color)
                    ("red"                  lexically-bound)
-                   (" 1)\n(module+ test "  default-color)
+                   (" 1)\n("               default-color)
+                   ("module+"              imported)
+                   (" test "               default-color)
                    ("red"                  imported)
                    (")"                    default-color))
                  '(((26 29) (47 50))
-                   ((6 17) (19 25) (30 30))))
+                   ((6 17) (19 25) (30 30) (34 41))))
      (build-test "#lang racket/base\n(define 🏴‍☠️🏴‍☠️🏴‍☠️ 1)\n(module+ test 🏴‍☠️🏴‍☠️🏴‍☠️)"
                  '(("#lang racket/base\n(" default-color)
                    ("define"               imported)
                    (" "                    default-color)
                    ("🏴‍☠️🏴‍☠️🏴‍☠️"                  lexically-bound)
-                   (" 1)\n(module+ test "  default-color)
+                   (" 1)\n("               default-color)
+                   ("module+"              imported)
+                   (" test "               default-color)
                    ("🏴‍☠️🏴‍☠️🏴‍☠️"                  imported)
                    (")"                    default-color))
                  '(((26 38) (56 68))
-                   ((6 17) (19 25) (39 39))))
+                   ((6 17) (19 25) (39 39) (43 50))))
 
      (build-test "#lang racket/base\n(require '#%kernel)\npair?"
                  '(("#lang racket/base\n(" default-color)

drracket-tool-text-lib/drracket/private/syncheck/contract-traversal.rkt

@@ -8,7 +8,7 @@
          string-constants)
 (provide annotate-contracts)
 
-(define (annotate-contracts stx low-binders binding-inits)
+(define (annotate-contracts stx low-binders binding-inits binder+mods-binder)
   (define boundary-start-map (make-hash))
   (define internal-start-map (make-hash))
   (define domain-map (make-hash))
@@ -35,7 +35,8 @@
                              coloring-plans already-jumped-ids
                              low-binders binding-inits
                              domain-map range-map
-                             #t)))
+                             #t
+                             binder+mods-binder)))
 
   ;; fill in the coloring-plans table for internal contracts
   (for ([(start-k start-val) (in-hash internal-start-map)])
@@ -44,7 +45,8 @@
                              coloring-plans already-jumped-ids
                              low-binders binding-inits
                              domain-map range-map
-                             #f)))
+                             #f
+                             binder+mods-binder)))
 
   ;; enact the coloring plans
   (for ([(stx colors) (in-hash coloring-plans)])
@@ -61,7 +63,8 @@
 
 (define (do-contract-traversal start-stx boundary-contract?
                                coloring-plans already-jumped-ids
-                               low-binders binding-inits domain-map range-map polarity)
+                               low-binders binding-inits domain-map range-map polarity
+                               binder+mods-binder)
   (let ploop ([stx start-stx]
               [polarity polarity])
 
@@ -87,11 +90,13 @@
             (for ([stx (in-list (hash-ref domain-map id '()))])
               (do-contract-traversal stx boundary-contract?
                                      coloring-plans already-jumped-ids
-                                     low-binders binding-inits domain-map range-map (not polarity)))
+                                     low-binders binding-inits domain-map range-map (not polarity)
+                                     binder+mods-binder))
             (for ([stx (in-list (hash-ref range-map id '()))])
               (do-contract-traversal stx boundary-contract?
                                      coloring-plans already-jumped-ids
-                                     low-binders binding-inits domain-map range-map polarity))]))]
+                                     low-binders binding-inits domain-map range-map polarity
+                                     binder+mods-binder))]))]
 
       [else
        ;; we didn't find a contract, but we might find one in a subexpression
@@ -125,7 +130,8 @@
              (cond
                [binders
                 (base-color #'id polarity boundary-contract? coloring-plans)
-                (for ([binder (in-list binders)])
+                (for ([binder+mod (in-list binders)])
+                  (define binder (binder+mods-binder binder+mod))
                   (base-color binder polarity boundary-contract? coloring-plans)
                   (define visited? (free-id-table-ref already-jumped-ids binder #f))
                   (unless visited?
@@ -164,10 +170,12 @@
           ;; on one side will not pollute the other side.
           (do-contract-traversal #'b boundary-contract?
                                  coloring-plans already-jumped-ids
-                                 low-binders binding-inits domain-map range-map polarity)
+                                 low-binders binding-inits domain-map range-map polarity
+                                 binder+mods-binder)
           (do-contract-traversal #'c boundary-contract?
                                  coloring-plans already-jumped-ids
-                                 low-binders binding-inits domain-map range-map polarity)]
+                                 low-binders binding-inits domain-map range-map polarity
+                                 binder+mods-binder)]
          ;; [(begin expr ...) (void)]
          [(begin0 fst rst ...)
           (ploop #'fst polarity)]
@@ -287,5 +295,5 @@
            (loop #'a)
            (loop #'b))]
         [x (void)]))
-    (annotate-contracts expanded low-binders binding-inits)))
+    (annotate-contracts expanded low-binders binding-inits values)))
 

drracket-tool-text-lib/drracket/private/syncheck/traversals.rkt

@@ -89,7 +89,8 @@
                                          sub-identifier-binding-directives)
                      (annotate-contracts sexp
                                          (hash-ref phase-to-binders 0 (λ () (make-id-set 0)))
-                                         (hash-ref binding-inits 0 (λ () (make-id-set 0))))
+                                         (hash-ref binding-inits 0 (λ () (make-id-set 0)))
+                                         binder+mods-binder)
                      (when print-extra-info?
                        (print-extra-info (list (list 'phase-to-binders phase-to-binders)
                                                (list 'phase-to-varrefs phase-to-varrefs)
@@ -913,17 +914,19 @@
     (for ([binder+mods (in-list binders)])
       (define binder (binder+mods-binder binder+mods))
       (define binder-is-outside-reference?
-        (let loop ([mods-where-var-is (reverse mods-where-var-is)]
-                   [mods-where-binder-is (reverse (binder+mods-mods binder+mods))])
-          (cond
-            [(null? mods-where-binder-is) #t]
-            [(null? mods-where-var-is) #f]
-            [else
-             (define mod (car mods-where-var-is))
-             (and (submodule-enclosing-bindings-visible? mod)
-                  (equal? mod (car mods-where-binder-is))
-                  (loop (cdr mods-where-var-is)
-                        (cdr mods-where-binder-is)))])))
+        (or (not mods-where-var-is)
+            (not (binder+mods-mods binder+mods))
+            (let loop ([mods-where-var-is (reverse mods-where-var-is)]
+                       [mods-where-binder-is (reverse (binder+mods-mods binder+mods))])
+              (cond
+                [(null? mods-where-binder-is) #t]
+                [(null? mods-where-var-is) #f]
+                [else
+                 (define mod (car mods-where-var-is))
+                 (and (submodule-enclosing-bindings-visible? mod)
+                      (equal? mod (car mods-where-binder-is))
+                      (loop (cdr mods-where-var-is)
+                            (cdr mods-where-binder-is)))]))))
       (when binder-is-outside-reference?
         (connect-syntaxes binder var actual? all-binders phase-level connections #f))))