branch

svn: r13579

collects/drscheme/private/mred-typed.ss

@@ -0,0 +1,103 @@
+#lang planet plt typed-scheme.plt 3 1
+             
+;(require mred/mred)
+(provide (all-defined-out))
+
+(define-type-alias Bitmap% (Class (Number Number Boolean)
+                                  () 
+                                  ([get-width (-> Number)]
+                                   [get-height (-> Number)])))
+(define-type-alias Font-List% (Class () () ([find-or-create-font (Any .. -> (Instance Font%))])))
+(define-type-alias Font% (Class () () ([get-face (-> (Option String))]
+                                       [get-point-size (-> Number)])))
+(define-type-alias Dialog% (Class () 
+                                  ([parent Any] [width Number] [label String]) 
+                                  ([show (Any -> Void)])))
+(define-type-alias Text-Field% (Class () 
+                                      ([parent Any] [callback Any] [label String])
+                                      ([get-value (-> String)]
+                                       [focus (-> String)])))
+(define-type-alias Horizontal-Panel% (Class ()
+                                            ([parent Any] 
+                                             [stretchable-height Any #t]
+                                             [alignment (List Symbol Symbol) #t])
+                                            ()))
+(define-type-alias Choice% (Class ()
+                                  ([parent Any] [label String] [choices List] [callback Any])
+                                  ([get-string-selection (-> (Option String))]
+                                   [set-string-selection (String -> Void)])))
+(define-type-alias Message% (Class ()
+                                   ([parent Any] [label String])
+                                   ([set-label ((U String (Instance Bitmap%)) -> Void)])))
+(define-type-alias Horizontal-Pane% (Class ()
+                                           ([parent Any])
+                                           ()))
+(define-type-alias Editor-Canvas% (Class ()
+                                         ([parent Any] [editor Any])
+                                         ([set-line-count (Number -> Void)])))
+(define-type-alias Bitmap-DC% (Class ((Instance Bitmap%))
+                                     ()
+                                     ([get-text-extent (String (Instance Font%) -> (values Number Number Number Number))]
+                                      [get-pixel (Number Number (Instance Color%) -> Boolean)]
+                                      [set-bitmap ((Option (Instance Bitmap%)) -> Void)]
+                                      [clear (-> Void)]
+                                      [set-font ((Instance Font%) -> Void)]
+                                      [draw-text (String Number Number -> Void)])))
+(define-type-alias Color% (Class () () ([red (-> Number)])))
+(define-type-alias Style-List% (Class () 
+                                      ()
+                                      ([find-named-style 
+                                        (String -> (Instance (Class ()
+                                                                    () 
+                                                                    ([get-font (-> (Instance Font%))]))))])))
+
+(define-type-alias Scheme:Text% (Class ()
+                                       ()
+                                       ([begin-edit-sequence (-> Void)]
+                                        [end-edit-sequence (-> Void)]
+                                        [lock (Boolean -> Void)]
+                                        [last-position (-> Number)]
+                                        [last-paragraph (-> Number)]
+                                        [delete (Number Number -> Void)]
+                                        [auto-wrap (Any -> Void)]
+                                        [paragraph-end-position (Number -> Number)]
+                                        [paragraph-start-position (Number -> Number)]
+                                        [get-start-position (-> Number)]
+                                        [get-end-position (-> Number)]
+                                        [insert (String Number Number -> Void)])))
+
+(require/typed mred/mred
+               [the-font-list (Instance Font-List%)]
+               [dialog% Dialog%]
+               [text-field% Text-Field%]
+               [horizontal-panel% Horizontal-Panel%]
+               [choice% Choice%]
+               [get-face-list (-> (Listof String))]
+               [message% Message%]
+               [horizontal-pane% Horizontal-Pane%]
+               [editor-canvas% Editor-Canvas%]
+               [bitmap-dc% Bitmap-DC%]
+               [bitmap% Bitmap%]
+               [color% Color%])
+
+(require/typed framework/framework
+               [preferences:set-default (Symbol Any Any -> Void)]
+               [preferences:set (Symbol Any -> Void)]
+               [editor:get-standard-style-list 
+                (-> (Instance Style-List%))]
+               [scheme:text% Scheme:Text%]
+               [gui-utils:ok/cancel-buttons (Any (Any Any -> Any) (Any Any -> Any) -> (values Any Any))])
+
+(require/typed "prefs-contract.ss"
+               [preferences:get-drscheme:large-letters-font (-> (Pair Symbol Number))])
+
+(require (only-in "prefs-contract.ss" preferences:get))
+(provide preferences:get preferences:get-drscheme:large-letters-font)
+
+(define-type-alias Bitmap-Message% (Class () 
+                                          ([parent Any])
+                                          ([set-bm ((Instance Bitmap%) -> Void)])))
+               
+
+(require/typed "bitmap-message.ss"
+               [bitmap-message% Bitmap-Message%])

collects/drscheme/private/prefs-contract.ss

@@ -1,16 +0,0 @@
-#lang scheme/base
-
-(require (for-syntax scheme/base)
-         framework/framework)
-
-(provide (rename-out [-preferences:get preferences:get])
-         preferences:get-drscheme:large-letters-font)
-
-(define (preferences:get-drscheme:large-letters-font)
-  (preferences:get 'drscheme:large-letters-font))
-
-(define-syntax (-preferences:get stx)
-  (syntax-case stx (quote)
-    [(_ (quote sym))
-     (with-syntax ([nm (datum->syntax stx (string->symbol (string-append "preferences:get" "-" (symbol->string (syntax-e #'sym)))))])
-       (syntax/loc stx (nm)))]))

collects/drscheme/syncheck/annotate.ss

@@ -0,0 +1,634 @@
+#lang scheme/base
+
+(provide (all-defined-out))
+
+(require string-constants/string-constant
+         scheme/unit
+         scheme/contract
+         scheme/class
+         drscheme/tool
+         mzlib/list
+         syntax/toplevel
+         syntax/boundmap
+         mrlib/bitmap-label
+         (prefix-in drscheme:arrow: drscheme/arrow)
+         (prefix-in fw: framework/framework)
+         mred/mred
+         setup/xref
+         scribble/xref
+         scribble/manual-struct
+         net/url
+         net/uri-codec
+         browser/external
+         (for-syntax scheme/base)
+         "extra-stxcase.ss"
+         "id-sets.ss"
+         "extra-typed.ss"
+         "utils.ss")
+
+
+    ;                                                                                                             
+    ;                                                                                                             
+    ;                                                                                                             
+    ;                                                                                                   ;         
+    ;                                                                                                   ;         
+    ;                         ;                       ;                                                 ;         
+    ;    ;;;  ;     ; ; ;;   ;;;;  ;;;   ;     ;     ;;;;  ; ;  ;;;   ;     ;  ;;;   ; ;   ;;;   ;;;    ;    ;;;  
+    ;   ;     ;     ; ;;  ;   ;   ;   ;   ;   ;       ;    ;;  ;   ;   ;   ;  ;   ;  ;;   ;     ;   ;   ;   ;     
+    ;   ;;     ;   ;  ;   ;   ;       ;    ; ;        ;    ;       ;   ;   ; ;    ;  ;    ;;        ;   ;   ;;    
+    ;    ;;    ;   ;  ;   ;   ;    ;;;;     ;         ;    ;    ;;;;    ; ;  ;;;;;;  ;     ;;    ;;;;   ;    ;;   
+    ;      ;    ; ;   ;   ;   ;   ;   ;    ; ;        ;    ;   ;   ;    ; ;  ;       ;       ;  ;   ;   ;      ;  
+    ;      ;    ; ;   ;   ;   ;   ;   ;   ;   ;       ;    ;   ;   ;     ;    ;      ;       ;  ;   ;   ;      ;  
+    ;   ;;;      ;    ;   ;    ;;  ;;;;; ;     ;       ;;  ;    ;;;;;    ;     ;;;;  ;    ;;;    ;;;;;  ;   ;;;   
+    ;            ;                                                                                                
+    ;            ;                                                                                                
+    ;           ;                                                                                                 
+    
+            
+    
+    ;; annotate-basic : syntax 
+    ;;                  namespace
+    ;;                  string[directory]
+    ;;                  syntax[id]
+    ;;                  id-set (six of them)
+    ;;                  hash-table[require-spec -> syntax] (three of them)
+    ;;               -> void
+    (define (annotate-basic sexp user-namespace user-directory jump-to-id
+                            low-binders high-binders 
+                            low-varrefs high-varrefs 
+                            low-tops high-tops
+                            templrefs
+                            requires require-for-syntaxes require-for-templates require-for-labels)
+      (let ([tail-ht (make-hash-table)]
+            [maybe-jump
+             (λ (vars)
+               (when jump-to-id
+                 (for-each (λ (id)
+                             (let ([binding (identifier-binding id)])
+                               (when (pair? binding)
+                                 (let ([nominal-source-id (list-ref binding 3)])
+                                   (when (eq? nominal-source-id jump-to-id)
+                                     (jump-to id))))))
+                           (syntax->list vars))))])
+        
+        (let level-loop ([sexp sexp]
+                         [high-level? #f])
+          (let* ([loop (λ (sexp) (level-loop sexp high-level?))]
+                 [varrefs (if high-level? high-varrefs low-varrefs)]
+                 [binders (if high-level? high-binders low-binders)]
+                 [tops (if high-level? high-tops low-tops)]
+                 [collect-general-info
+                  (λ (stx)
+                    (add-origins stx varrefs)
+                    (add-disappeared-bindings stx binders varrefs)
+                    (add-disappeared-uses stx varrefs))])
+            (collect-general-info sexp)
+            (syntax-case* sexp (#%plain-lambda case-lambda if begin begin0 let-values letrec-values set!
+                                 quote quote-syntax with-continuation-mark 
+                                 #%plain-app #%top #%plain-module-begin
+                                 define-values define-syntaxes define-values-for-syntax module
+                                 #%require #%provide #%expression)
+              (if high-level? free-transformer-identifier=? free-identifier=?)
+              [(#%plain-lambda args bodies ...)
+               (begin
+                 (annotate-raw-keyword sexp varrefs)
+                 (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht)
+                 (add-binders (syntax args) binders)
+                 (for-each loop (syntax->list (syntax (bodies ...)))))]
+              [(case-lambda [argss bodiess ...]...)
+               (begin
+                 (annotate-raw-keyword sexp varrefs)
+                 (for-each (λ (bodies/stx) (annotate-tail-position/last sexp 
+                                                                        (syntax->list bodies/stx)
+                                                                        tail-ht))
+                           (syntax->list (syntax ((bodiess ...) ...))))
+                 (for-each
+                  (λ (args bodies)
+                    (add-binders args binders)
+                    (for-each loop (syntax->list bodies)))
+                  (syntax->list (syntax (argss ...)))
+                  (syntax->list (syntax ((bodiess ...) ...)))))]
+              [(if test then else)
+               (begin
+                 (annotate-raw-keyword sexp varrefs)
+                 (annotate-tail-position sexp (syntax then) tail-ht)
+                 (annotate-tail-position sexp (syntax else) tail-ht)
+                 (loop (syntax test))
+                 (loop (syntax else))
+                 (loop (syntax then)))]
+              [(begin bodies ...)
+               (begin
+                 (annotate-raw-keyword sexp varrefs)
+                 (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht)
+                 (for-each loop (syntax->list (syntax (bodies ...)))))]
+              
+              ;; treat a single body expression specially, since this has
+              ;; different tail behavior.
+              [(begin0 body)
+               (begin
+                 (annotate-raw-keyword sexp varrefs)
+                 (annotate-tail-position sexp (syntax body) tail-ht)
+                 (loop (syntax body)))]
+              
+              [(begin0 bodies ...)
+               (begin
+                 (annotate-raw-keyword sexp varrefs)
+                 (for-each loop (syntax->list (syntax (bodies ...)))))]
+              
+              [(let-values (bindings ...) bs ...)
+               (begin
+                 (annotate-raw-keyword sexp varrefs)
+                 (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 loop (syntax->list (syntax (es ...))))
+                   (for-each loop (syntax->list (syntax (bs ...))))))]
+              [(letrec-values (bindings ...) bs ...)
+               (begin
+                 (annotate-raw-keyword sexp varrefs)
+                 (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 loop (syntax->list (syntax (es ...))))
+                   (for-each loop (syntax->list (syntax (bs ...))))))]
+              [(set! var e)
+               (begin
+                 (annotate-raw-keyword sexp varrefs)
+                 
+                 ;; tops are used here because a binding free use of a set!'d variable
+                 ;; is treated just the same as (#%top . x).
+                 (when (syntax-original? (syntax var))
+                   (if (identifier-binding (syntax var))
+                       (add-id varrefs (syntax var))
+                       (add-id tops (syntax var))))
+                 
+                 (loop (syntax e)))]
+              [(quote datum)
+               ;(color-internal-structure (syntax datum) constant-style-name)
+               (annotate-raw-keyword sexp varrefs)]
+              [(quote-syntax datum)
+               ;(color-internal-structure (syntax datum) constant-style-name)
+               (annotate-raw-keyword sexp varrefs)
+               (let loop ([stx #'datum])
+                 (cond [(identifier? stx)
+                        (when (syntax-original? stx)
+                          (add-id templrefs stx))]
+                       [(syntax? stx)
+                        (loop (syntax-e stx))]
+                       [(pair? stx)
+                        (loop (car stx))
+                        (loop (cdr stx))]
+                       [(vector? stx)
+                        (for-each loop (vector->list stx))]
+                       [(box? stx)
+                        (loop (unbox stx))]
+                       [else (void)]))]
+              [(with-continuation-mark a b c)
+               (begin
+                 (annotate-raw-keyword sexp varrefs)
+                 (annotate-tail-position sexp (syntax c) tail-ht)
+                 (loop (syntax a))
+                 (loop (syntax b))
+                 (loop (syntax c)))]
+              [(#%plain-app pieces ...)
+               (begin
+                 (annotate-raw-keyword sexp varrefs)
+                 (for-each loop (syntax->list (syntax (pieces ...)))))]
+              [(#%top . var)
+               (begin
+                 (annotate-raw-keyword sexp varrefs)
+                 (when (syntax-original? (syntax var))
+                   (add-id tops (syntax var))))]
+              [(define-values vars b)
+               (begin
+                 (annotate-raw-keyword sexp varrefs)
+                 (add-binders (syntax vars) binders)
+                 (maybe-jump (syntax vars))
+                 (loop (syntax b)))]
+              [(define-syntaxes names exp)
+               (begin
+                 (annotate-raw-keyword sexp varrefs)
+                 (add-binders (syntax names) binders)
+                 (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)
+                 (maybe-jump (syntax names))
+                 (level-loop (syntax exp) #t))]
+              [(module m-name lang (#%plain-module-begin bodies ...))
+               (begin
+                 (annotate-raw-keyword sexp varrefs)
+                 ((annotate-require-open user-namespace user-directory) (syntax lang))
+                 
+                  ;; temporarily removed until Matthew fixes whatever.
+                 #;
+                 (hash-table-put! requires 
+                                  (syntax->datum (syntax lang))
+                                  (cons (syntax lang)
+                                        (hash-table-get requires 
+                                                        (syntax->datum (syntax lang))
+                                                        (λ () '()))))
+                 (for-each loop (syntax->list (syntax (bodies ...)))))]
+              
+              ; top level or module top level only:
+              [(#%require require-specs ...)
+               (let ([at-phase
+                      (lambda (stx requires)
+                        (syntax-case stx ()
+                          [(_ require-specs ...)
+                           (let ([new-specs (map trim-require-prefix
+                                                 (syntax->list (syntax (require-specs ...))))])
+                             (annotate-raw-keyword sexp varrefs)
+                             (for-each (annotate-require-open user-namespace user-directory) new-specs)
+                             (for-each (add-require-spec requires)
+                                       new-specs
+                                       (syntax->list (syntax (require-specs ...)))))]))])
+                 (for-each (lambda (spec)
+                             (syntax-case* spec (for-syntax for-template for-label) (lambda (a b)
+                                                                                      (eq? (syntax-e a) (syntax-e b)))
+                               [(for-syntax specs ...)
+                                (at-phase spec require-for-syntaxes)]
+                               [(for-template specs ...)
+                                (at-phase spec require-for-templates)]
+                               [(for-label specs ...)
+                                (at-phase spec require-for-labels)]
+                               [else
+                                (at-phase (list #f spec) requires)]))
+                           (syntax->list #'(require-specs ...))))]
+              
+              ; module top level only:
+              [(#%provide provide-specs ...)
+               (let ([provided-varss (map extract-provided-vars
+                                          (syntax->list (syntax (provide-specs ...))))])
+                 (annotate-raw-keyword sexp varrefs)
+                 (for-each (λ (provided-vars)
+                             (for-each
+                              (λ (provided-var)
+                                (when (syntax-original? provided-var)
+                                  (add-id varrefs provided-var)))
+                              provided-vars))
+                           provided-varss))]
+              
+              [(#%expression arg)
+               (begin
+                 (annotate-raw-keyword sexp varrefs)
+                 (loop #'arg))]
+              [id
+               (identifier? (syntax id))
+               (when (syntax-original? sexp)
+                 (add-id varrefs sexp))]
+              [_
+               (begin
+                #;
+                 (printf "unknown stx: ~e datum: ~e source: ~e\n"
+                         sexp
+                         (and (syntax? sexp)
+                              (syntax->datum sexp))
+                         (and (syntax? sexp)
+                              (syntax-source sexp)))
+                 (void))])))
+        (add-tail-ht-links tail-ht)))
+    
+    ;; jump-to : syntax -> void
+    (define (jump-to stx)
+      (let ([src (find-source-editor stx)]
+            [pos (syntax-position stx)]
+            [span (syntax-span stx)])
+        (when (and (is-a? src text%)
+                   pos
+                   span)
+          (send src set-position (- pos 1) (+ pos span -1)))))
+    
+    
+    ;; annotate-require-open : namespace string -> (stx -> void)
+    ;; relies on current-module-name-resolver, which in turn depends on
+    ;; current-directory and current-namespace
+    (define (annotate-require-open user-namespace user-directory)
+      (λ (require-spec)
+        (when (syntax-original? require-spec)
+          (let ([source (find-source-editor require-spec)])
+            (when (and (is-a? source text%)
+                       (syntax-position require-spec)
+                       (syntax-span require-spec))
+              (let ([defs-text (get-defs-text)])
+                (when defs-text
+                  (let* ([start (- (syntax-position require-spec) 1)]
+                         [end (+ start (syntax-span require-spec))]
+                         [file (get-require-filename (syntax->datum require-spec)
+                                                     user-namespace
+                                                     user-directory)])
+                    (when file
+                      (send defs-text syncheck:add-menu
+                            source
+                            start end 
+                            #f
+                            (make-require-open-menu file)))))))))))
+    
+    ;; hash-table[syntax -o> (listof syntax)] -> void
+    (define (add-tail-ht-links tail-ht)
+      (hash-table-for-each
+       tail-ht
+       (λ (stx-from stx-tos)
+         (for-each (λ (stx-to) (add-tail-ht-link stx-from stx-to))
+                   stx-tos))))
+    
+    ;; add-tail-ht-link : syntax syntax -> void
+    (define (add-tail-ht-link from-stx to-stx)
+      (let* ([to-src (find-source-editor to-stx)]
+             [from-src (find-source-editor from-stx)]
+             [defs-text (get-defs-text)])
+        (when (and to-src from-src defs-text)
+          (let ([from-pos (syntax-position from-stx)]
+                [to-pos (syntax-position to-stx)])
+            (when (and from-pos to-pos)
+              (send defs-text syncheck:add-tail-arrow
+                    from-src (- from-pos 1)
+                    to-src (- to-pos 1)))))))
+    
+    ;; find-source : definitions-text source -> editor or false
+    (define (find-source-editor stx)
+      (let ([defs-text (get-defs-text)])
+        (and defs-text 
+             (let txt-loop ([text defs-text])
+               (cond
+                 [(and (is-a? text fw:text:basic<%>)
+                       (send text port-name-matches? (syntax-source stx)))
+                  text]
+                 [else
+                  (let snip-loop ([snip (send text find-first-snip)])
+                    (cond
+                      [(not snip)
+                       #f]
+                      [(and (is-a? snip editor-snip%)
+                            (send snip get-editor))
+                       (or (txt-loop (send snip get-editor))
+                           (snip-loop (send snip next)))]
+                      [else 
+                       (snip-loop (send snip next))]))])))))
+    
+    ;; get-defs-text : -> text or false
+    (define (get-defs-text)
+      (let ([drs-frame (currently-processing-drscheme-frame)])
+        (and drs-frame
+             (send drs-frame get-definitions-text))))
+    
+    
+    
+    
+    ;; record-renamable-var : rename-ht syntax -> void
+    (define (record-renamable-var rename-ht stx)
+      (let ([key (list (syntax-source stx) (syntax-position stx) (syntax-span stx))])
+        (hash-table-put! rename-ht
+                         key
+                         (cons stx (hash-table-get rename-ht key (λ () '()))))))
+    
+    
+    ;; connect-identifier : syntax
+    ;;                      id-set 
+    ;;                      (union #f hash-table)
+    ;;                      (union #f hash-table)
+    ;;                      (union identifier-binding identifier-transformer-binding)
+    ;;                      (listof id-set)
+    ;;                      namespace
+    ;;                      directory
+    ;;                      boolean
+    ;;                   -> void
+    ;; adds arrows and rename menus for binders/bindings
+    (define (connect-identifier var rename-ht all-binders unused requires get-binding user-namespace user-directory actual?)
+      (connect-identifier/arrow var all-binders unused requires get-binding user-namespace user-directory actual?)
+      (when (and actual? (get-ids all-binders var))
+        (record-renamable-var rename-ht var)))
+    
+    ;; connect-identifier/arrow : syntax
+    ;;                            id-set 
+    ;;                            (union #f hash-table)
+    ;;                            (union #f hash-table)
+    ;;                            (union identifier-binding identifier-transformer-binding)
+    ;;                            boolean
+    ;;                         -> void
+    ;; adds the arrows that correspond to binders/bindings
+    (define (connect-identifier/arrow var all-binders unused requires get-binding user-namespace user-directory actual?)
+      (let ([binders (get-ids all-binders var)])
+        (when binders
+          (for-each (λ (x)
+                      (when (syntax-original? x)
+                        (connect-syntaxes x var actual?)))
+                    binders))
+        
+        (when (and unused requires)
+          (let ([req-path/pr (get-module-req-path (get-binding var))])
+            (when req-path/pr
+              (let* ([req-path (car req-path/pr)]
+                     [id (cdr req-path/pr)]
+                     [req-stxes (hash-table-get requires req-path (λ () #f))])
+                (when req-stxes
+                  (hash-table-remove! unused req-path)
+                  (for-each (λ (req-stx) 
+                              (when (id/require-match? (syntax->datum var) 
+                                                       id 
+                                                       (syntax->datum req-stx))
+                                (when id
+                                  (add-jump-to-definition
+                                   var
+                                   id
+                                   (get-require-filename req-path user-namespace user-directory)))
+                                (add-mouse-over var (fw:gui-utils:format-literal-label (string-constant cs-mouse-over-import)
+                                                            (syntax-e var)
+                                                            req-path))
+                                (connect-syntaxes req-stx var actual?)))
+                            req-stxes))))))))
+    
+    (define (id/require-match? var id req-stx)
+      (cond
+        [(and (pair? req-stx)
+              (eq? (list-ref req-stx 0) 'prefix))
+         (let ([prefix (list-ref req-stx 1)])
+           (equal? (format "~a~a" prefix id)
+                   (symbol->string var)))]
+        [(and (pair? req-stx)
+              (eq? (list-ref req-stx 0) 'prefix-all-except))
+         (let ([prefix (list-ref req-stx 1)])
+           (and (not (memq id (cdddr req-stx)))
+                (equal? (format "~a~a" prefix id)
+                        (symbol->string var))))]
+        [(and (pair? req-stx)
+              (eq? (list-ref req-stx 0) 'rename))
+         (eq? (list-ref req-stx 2)
+              var)]
+        [else (eq? var id)]))
+    
+    
+    ;; color/connect-top : namespace directory id-set syntax -> void
+    (define (color/connect-top rename-ht user-namespace user-directory binders var)
+      (let ([top-bound?
+             (or (get-ids binders var)
+                 (parameterize ([current-namespace user-namespace])
+                   (let/ec k
+                     (namespace-variable-value (syntax-e var) #t (λ () (k #f)))
+                     #t)))])
+        (if top-bound?
+            (color var lexically-bound-variable-style-name)
+            (color var error-style-name))
+        (connect-identifier var rename-ht binders #f #f identifier-binding user-namespace user-directory #t)))
+    
+    
+    ;; color-unused : hash-table[sexp -o> syntax] hash-table[sexp -o> #f] -> void
+    (define (color-unused requires unused)
+      (hash-table-for-each
+       unused
+       (λ (k v)
+         (for-each (λ (stx) (color stx error-style-name))
+                   (hash-table-get requires k)))))
+    
+       
+    
+    
+    ;                                                          
+    ;                                                          
+    ;                                                          
+    ;                                        ;                 
+    ;                                        ;                 
+    ;                                                          
+    ;   ; ;;    ;;;   ;;;;    ;;;;  ;;;;;    ;    ;;;;    ;;;; 
+    ;   ;;  ;  ;   ;  ;   ;  ;   ;  ; ; ;    ;    ;   ;  ;   ; 
+    ;   ;   ;  ;;;;;  ;   ;  ;   ;  ; ; ;    ;    ;   ;  ;   ; 
+    ;   ;      ;      ;   ;  ;   ;  ; ; ;    ;    ;   ;  ;   ; 
+    ;   ;      ;   ;  ;   ;  ;  ;;  ; ; ;    ;    ;   ;  ;   ; 
+    ;   ;       ;;;   ;   ;   ;; ;  ; ; ;    ;    ;   ;   ;;;; 
+    ;                                                        ; 
+    ;                                                    ;   ; 
+    ;                                                     ;;;  
+    
+    
+    ;; make-rename-menu : (cons stx[original,id] (listof stx[original,id])) (listof id-set) -> void
+    (define (make-rename-menu stxs id-sets)
+      (let ([defs-frame (currently-processing-drscheme-frame)])
+        (when defs-frame
+          (let* ([defs-text (send defs-frame get-definitions-text)]
+                 [source (syntax-source (car stxs))]) ;; all stxs in the list must have the same source
+            (when (and (send defs-text port-name-matches? source)
+                       (send defs-text port-name-matches? source))
+              (let* ([name-to-offer (format "~a" (syntax->datum (car stxs)))]
+                     [start (- (syntax-position (car stxs)) 1)]
+                     [fin (+ start (syntax-span (car stxs)))])
+                (send defs-text syncheck:add-menu
+                      defs-text
+                      start 
+                      fin 
+                      (syntax-e (car stxs))
+                      (λ (menu)
+                        (instantiate menu-item% ()
+                          (parent menu)
+                          (label (fw:gui-utils:format-literal-label (string-constant cs-rename-var) name-to-offer))
+                          (callback
+                           (λ (x y)
+                             (let ([frame-parent (find-menu-parent menu)])
+                               (rename-callback name-to-offer
+                                                defs-text
+                                                stxs
+                                                id-sets
+                                                frame-parent)))))))))))))
+    
+    ;; find-parent : menu-item-container<%> -> (union #f (is-a?/c top-level-window<%>)
+    (define (find-menu-parent menu)
+      (let loop ([menu menu])
+        (cond
+          [(is-a? menu menu-bar%) (send menu get-frame)]
+          [(is-a? menu popup-menu%)
+           (let ([target (send menu get-popup-target)])
+             (cond
+               [(is-a? target editor<%>) 
+                (let ([canvas (send target get-canvas)])
+                  (and canvas
+                       (send canvas get-top-level-window)))]
+               [(is-a? target window<%>) 
+                (send target get-top-level-window)]
+               [else #f]))]
+          [(is-a? menu menu-item<%>) (loop (send menu get-parent))]
+          [else #f])))
+    
+    ;; rename-callback : string 
+    ;;                   (and/c syncheck-text<%> definitions-text<%>)
+    ;;                   (listof syntax[original])
+    ;;                   (listof id-set) 
+    ;;                   (union #f (is-a?/c top-level-window<%>)) 
+    ;;                -> void
+    ;; callback for the rename popup menu item
+    (define (rename-callback name-to-offer defs-text stxs id-sets parent)
+      (let ([new-str
+             (fw:keymap:call/text-keymap-initializer
+              (λ ()
+                (get-text-from-user
+                 (string-constant cs-rename-id)
+                 (fw:gui-utils:format-literal-label (string-constant cs-rename-var-to) name-to-offer)
+                 parent
+                 name-to-offer)))])
+        (when new-str
+          (let ([new-sym (format "~s" (string->symbol new-str))])
+            (let* ([to-be-renamed 
+                    (remove-duplicates
+                     (sort 
+                      (apply 
+                       append
+                       (map (λ (id-set) 
+                              (apply
+                               append
+                               (map (λ (stx) (or (get-ids id-set stx) '())) stxs)))
+                            id-sets))
+                      (λ (x y) 
+                        ((syntax-position x) . >= . (syntax-position y)))))]
+                   [do-renaming?
+                    (or (not (name-duplication? to-be-renamed id-sets new-sym))
+                        (equal?
+                         (message-box/custom
+                          (string-constant check-syntax)
+                          (fw:gui-utils:format-literal-label (string-constant cs-name-duplication-error) 
+                                  new-sym)
+                          (string-constant cs-rename-anyway)
+                          (string-constant cancel)
+                          #f
+                          parent
+                          '(stop default=2))
+                         1))])
+              (when do-renaming?
+                (unless (null? to-be-renamed)
+                  (send defs-text begin-edit-sequence)
+                  (for-each (λ (stx) 
+                              (let ([source (syntax-source stx)])
+                                (when (send defs-text port-name-matches? source)
+                                  (let* ([start (- (syntax-position stx) 1)]
+                                         [end (+ start (syntax-span stx))])
+                                    (send defs-text delete start end #f)
+                                    (send defs-text insert new-sym start start #f)))))
+                            to-be-renamed)
+                  (send defs-text invalidate-bitmap-cache)
+                  (send defs-text end-edit-sequence))))))))
+    
+       ;; get-require-filename : sexp namespace string[directory] -> filename
+    ;; finds the filename corresponding to the require in stx
+    (define (get-require-filename datum user-namespace user-directory)
+      (let ([mp
+             (parameterize ([current-namespace user-namespace]
+                            [current-directory user-directory]
+                            [current-load-relative-directory user-directory])
+               (with-handlers ([exn:fail? (λ (x) #f)])
+                 ((current-module-name-resolver) datum #f #f)))])
+        (and (resolved-module-path? mp)
+             (resolved-module-path-name mp))))
+    
+    
+    ;; make-require-open-menu : path -> menu -> void
+    (define (make-require-open-menu file)
+      (λ (menu)
+        (let-values ([(base name dir?) (split-path file)])
+          (instantiate menu-item% ()
+            (label (fw:gui-utils:format-literal-label (string-constant cs-open-file) (path->string name)))
+            (parent menu)
+            (callback (λ (x y) (fw:handler:edit-file file))))
+          (void))))

collects/drscheme/syncheck/color.ss

@@ -0,0 +1,84 @@
+#lang scheme/base
+
+(require string-constants/string-constant
+         scheme/unit
+         scheme/contract
+         scheme/class
+         drscheme/tool
+         mzlib/list
+         syntax/toplevel
+         syntax/boundmap
+         mrlib/bitmap-label
+         (prefix-in drscheme:arrow: drscheme/arrow)
+         (prefix-in fw: framework/framework)
+         mred/mred
+         setup/xref
+         scribble/xref
+         scribble/manual-struct
+         net/url
+         net/uri-codec
+         browser/external
+         (for-syntax scheme/base)
+         "extra-stxcase.ss"
+         "id-sets.ss"
+         "extra-typed.ss")
+;; color : syntax[original] str -> void
+;; colors the syntax with style-name's style
+(define (color stx style-name)
+  (let ([source (find-source-editor stx)])
+    (when (is-a? source text%)
+      (let ([pos (- (syntax-position stx) 1)]
+            [span (syntax-span stx)])
+        (color-range source pos (+ pos span) style-name)))))
+
+;; color-range : text start finish style-name 
+;; colors a range in the text based on `style-name'
+(define (color-range source start finish style-name)
+  (let ([style (send (send source get-style-list)
+                     find-named-style
+                     style-name)])
+    (add-to-cleanup-texts source)
+    (send source change-style style start finish #f)))
+
+   ;; find-source : definitions-text source -> editor or false
+    (define (find-source-editor stx)
+      (let ([defs-text (get-defs-text)])
+        (and defs-text 
+             (let txt-loop ([text defs-text])
+               (cond
+                 [(and (is-a? text fw:text:basic<%>)
+                       (send text port-name-matches? (syntax-source stx)))
+                  text]
+                 [else
+                  (let snip-loop ([snip (send text find-first-snip)])
+                    (cond
+                      [(not snip)
+                       #f]
+                      [(and (is-a? snip editor-snip%)
+                            (send snip get-editor))
+                       (or (txt-loop (send snip get-editor))
+                           (snip-loop (send snip next)))]
+                      [else 
+                       (snip-loop (send snip next))]))])))))
+ 
+;; add-to-cleanup-texts : (is-a?/c editor<%>) -> void
+    (define (add-to-cleanup-texts ed)
+      (let ([ed (find-outermost-editor ed)])
+        (when (is-a? ed drscheme:unit:definitions-text<%>)
+          (let ([tab (send ed get-tab)])
+            (send tab syncheck:add-to-cleanup-texts ed)))))
+    
+        ;; get-defs-text : -> text or false
+    (define (get-defs-text)
+      (let ([drs-frame (currently-processing-drscheme-frame)])
+        (and drs-frame
+             (send drs-frame get-definitions-text))))
+    
+      (define (find-outermost-editor ed)
+      (let loop ([ed ed])
+        (let ([admin (send ed get-admin)])
+          (if (is-a? admin editor-snip-editor-admin<%>)
+              (let* ([enclosing-snip (send admin get-snip)]
+                     [enclosing-snip-admin (send enclosing-snip get-admin)])
+                (loop (send enclosing-snip-admin get-editor)))
+              ed))))

collects/drscheme/syncheck/extra-stxcase.ss

@@ -0,0 +1,44 @@
+#lang scheme/base
+
+(require (only-in "extra-typed.ss" symbolic-compare?))
+
+(provide (all-defined-out))
+             
+;; FIXME: handle for-template and for-label
+;; extract-provided-vars : syntax -> (listof syntax[identifier])
+(define (extract-provided-vars stx)
+  (syntax-case* stx (rename struct all-from all-from-except all-defined-except) symbolic-compare?
+    [identifier
+     (identifier? (syntax identifier))
+     (list (syntax identifier))]
+    
+    [(rename local-identifier export-identifier) 
+     (list (syntax local-identifier))]
+    
+    ;; why do I even see this?!?
+    [(struct struct-identifier (field-identifier ...))
+     null]
+    
+    [(all-from module-name) null] 
+    [(all-from-except module-name identifier ...)
+     null]
+    [(all-defined-except identifier ...)
+     (syntax->list #'(identifier ...))]
+    [_ 
+     null]))
+
+
+;; trim-require-prefix : syntax -> syntax
+(define (trim-require-prefix require-spec)
+  (syntax-case* require-spec (only prefix all-except prefix-all-except rename) symbolic-compare?
+    [(only module-name identifer ...)
+     (syntax module-name)]
+    [(prefix identifier module-name) 
+     (syntax module-name)]
+    [(all-except module-name identifer ...)
+     (syntax module-name)]
+    [(prefix-all-except module-name identifer ...)
+     (syntax module-name)]
+    [(rename module-name local-identifer exported-identifer)
+     (syntax module-name)]
+    [_ require-spec]))

collects/drscheme/syncheck/extra-typed.ss

@@ -0,0 +1,453 @@
+#lang typed-scheme
+           
+(require (except-in scheme/list remove-duplicates)
+         "id-sets.ss")
+
+(define-type-alias (MaybeList a) (Rec x (U a '() (Pair a x))))
+
+(provide (all-defined-out))
+
+;; remove-duplicates : (listof syntax[original]) -> (listof syntax[original])
+;; removes duplicates, based on the source locations of the identifiers
+;; assumes the list is ordered by source location
+(: remove-duplicates ((Listof Syntax) -> (Listof Syntax)))         
+(define (remove-duplicates ids)
+  (cond
+    [(null? ids) null]
+    [else (let: loop : (Listof Syntax)
+                ([fst : Syntax (car ids)]
+                 [rst : (Listof Syntax) (cdr ids)])
+            (cond
+              [(null? rst) (list fst)]
+              [else (if (and (eq? (syntax-source fst)
+                                  (syntax-source (car rst)))                             
+                             ;; CHANGE - used eqv? instead of =, since these might be #f
+                             (eqv? (syntax-position fst)
+                                   (syntax-position (car rst))))
+                        (loop fst (cdr rst))
+                        (cons fst (loop (car rst) (cdr rst))))]))]))
+
+
+;; name-duplication? : (listof syntax) (listof id-set) symbol -> boolean
+;; returns #t if the name chosen would be the same as another name in this scope.
+(: name-duplication? ((Listof Identifier) (Listof Id-Set) String -> Any))
+(define (name-duplication? to-be-renamed id-sets new-str)
+  (let ([new-ids (map (λ: ([id : Identifier]) (datum->syntax id (string->symbol new-str)))
+                      to-be-renamed)])
+    (ormap (λ: ([id-set : Id-Set])
+             (ormap (λ: ([new-id : Identifier]) (get-ids id-set new-id)) 
+                    new-ids))
+           id-sets)))
+
+
+;; annotate-raw-keyword : syntax id-map -> void
+;; annotates keywords when they were never expanded. eg.
+;; if someone just types `(λ (x) x)' it has no 'origin
+;; field, but there still are keywords.
+(: annotate-raw-keyword (Syntax Id-Set -> Any))
+(define (annotate-raw-keyword stx id-map)
+  (let ([lst (syntax-e stx)])
+    (when (pair? lst)
+      (let ([f-stx (car lst)])
+        (when (and (syntax-original? f-stx)
+                   (identifier? f-stx))
+          (add-id id-map f-stx))))))
+
+
+;; add-binders : syntax id-set -> void
+;; transforms an argument list into a bunch of symbols/symbols
+;; and puts them into the id-set
+;; effect: colors the identifiers
+(: add-binders (Syntax Id-Set -> Void))
+(define (add-binders stx id-set)
+  (let: loop : Void ([stx : (MaybeList Syntax) stx])
+    (let ([e (if (syntax? stx) (syntax-e stx) stx)])
+      (cond
+        [(cons? e)
+         (let ([fst (car e)]
+               [rst (cdr e)])
+           (if (identifier? fst) ;; CHANGE - was (syntax? fst)
+               (begin
+                 (when (syntax-original? fst)
+                   (add-id id-set fst))
+                 (loop rst))
+               (loop rst)))]
+        [(null? e) (void)]
+        [(identifier? stx) ;; CHANGE -- used to be else
+         (when (syntax-original? stx)
+           (add-id id-set stx))]))))
+
+(define-type-alias TailHT (HashTable Syntax (Listof Syntax)))
+
+;; annotate-tail-position/last : (listof syntax) -> void
+(: annotate-tail-position/last (Syntax (Listof Syntax) TailHT -> Void))
+(define (annotate-tail-position/last orig-stx stxs tail-ht)
+  (unless (null? stxs)
+    (annotate-tail-position orig-stx (car (last-pair stxs)) tail-ht)))
+
+;; annotate-tail-position : syntax -> void
+;; colors the parens (if any) around the argument
+;; to indicate this is a tail call.
+(: annotate-tail-position (Syntax Syntax TailHT -> Void))
+(define (annotate-tail-position orig-stx tail-stx tail-ht)
+  (hash-set!
+   tail-ht 
+   orig-stx 
+   (cons
+    tail-stx
+    (hash-ref 
+     tail-ht
+     orig-stx
+     (λ () null)))))
+
+;; add-disappeared-uses : syntax id-set -> void
+(: add-disappeared-uses (Syntax Id-Set -> Void))
+(define (add-disappeared-uses stx id-set)
+  (let ([prop (syntax-property stx 'disappeared-use)])
+    (when prop
+      (let loop ([prop prop])
+        (cond
+          [(pair? prop)
+           (loop (car prop))
+           (loop (cdr prop))]
+          [(identifier? prop)
+           (add-id id-set prop)])))))
+
+;; add-require-spec : hash-table[sexp[require-spec] -o> (listof syntax)]
+;;                 -> require-spec
+;;                    syntax
+;;                 -> void
+(: add-require-spec ((HashTable Any (Listof Syntax)) -> (Syntax Syntax -> Void)))
+(define (add-require-spec require-ht)
+  (λ (raw-spec syntax)
+    (when (syntax-original? syntax)
+      (let ([key (syntax->datum raw-spec)])
+        (hash-set! require-ht
+                   key
+                   (cons syntax
+                         (hash-ref require-ht
+                                   key
+                                   (λ () '()))))))))
+
+;; possible-suffixes : (listof string)
+;; these are the suffixes that are checked for the reverse 
+;; module-path mapping.
+(: possible-suffixes (Listof String))
+(define possible-suffixes '(".ss" ".scm" ""))
+
+;; add-origins : sexp id-set -> void
+(: add-origins (Syntax Id-Set -> Void))
+(define (add-origins sexp id-set)
+  (let ([origin (syntax-property sexp 'origin)])
+    (when (syntax? origin) ;; CHANGE - was (when origin ...)
+      (let loop ([ct origin])
+        (cond
+          [(pair? ct) 
+           (loop (car ct))
+           (loop (cdr ct))]
+          [(identifier? ct) ;; CHANGE - was (syntax? ct)
+           (when (syntax-original? ct)
+             (add-id id-set ct))]
+          [else (void)])))))
+
+
+;; add-disappeared-bindings : syntax id-set -> void
+(: add-disappeared-bindings (Syntax Id-Set Id-Set -> Void))
+(define (add-disappeared-bindings stx binders disappaeared-uses)
+  (let ([prop (syntax-property stx 'disappeared-binding)])
+    (when prop
+      (let loop ([prop prop])
+        (cond
+          [(pair? prop)
+           (loop (car prop))
+           (loop (cdr prop))]
+          [(identifier? prop)
+           (add-origins prop disappaeared-uses)
+           (add-id binders prop)])))))
+
+;; module-name-sym->filename : symbol -> (union #f string)
+(: module-name-sym->filename (Symbol -> (Option Path)))
+(define (module-name-sym->filename sym)
+  (let ([str (symbol->string sym)])
+    (and ((string-length str) . > . 1)
+         (char=? (string-ref str 0) #\,)
+         (let ([fn (substring str 1 (string-length str))])
+           (ormap (λ: ([x : String])
+                    (let ([test (string->path (string-append fn x))])
+                      (and (file-exists? test)
+                           test)))
+                  possible-suffixes)))))
+
+(: symbolic-compare? (Syntax Syntax -> Boolean))
+(define (symbolic-compare? x y) (eq? (syntax-e x) (syntax-e y)))
+
+;; type req/tag = (make-req/tag syntax sexp boolean)
+(define-typed-struct req/tag ([req-stx : Syntax] [req-sexp : Any] [used? : Boolean]))
+
+;; add-var : hash-table -> syntax -> void
+;; adds the variable to the hash table.
+(: add-var ((HashTable Any (Listof Any)) -> (Syntax -> Void)))
+(define (add-var ht)
+  (λ (var)
+    (let* ([key (syntax-e var)]
+           [prev (hash-ref ht #{key :: Any} (λ () #{null :: (Listof Any)}))])
+      (hash-set! ht #{key :: Any} #{(cons var prev) :: (Listof Any)}))))
+
+
+
+#|
+;; annotate-basic : syntax 
+;;                  namespace
+;;                  string[directory]
+;;                  syntax[id]
+;;                  id-set (six of them)
+;;                  hash-table[require-spec -> syntax] (three of them)
+;;               -> void
+(: annotate-basic (Syntax 
+                   Any String Syntax
+                   Id-Set Id-Set Id-Set Id-Set Id-Set Id-Set 
+                   Any
+                   (HashTable Syntax Syntax) (HashTable Syntax Syntax) (HashTable Syntax Syntax) (HashTable Syntax Syntax)
+                   -> Void))
+(define (annotate-basic sexp user-namespace user-directory jump-to-id
+                        low-binders high-binders 
+                        low-varrefs high-varrefs 
+                        low-tops high-tops
+                        templrefs
+                        requires require-for-syntaxes require-for-templates require-for-labels)
+  (let ([tail-ht (make-hash-table)]
+        [maybe-jump
+         (λ: ([vars : Syntax])
+           (when jump-to-id
+             (for-each (λ: ([id : Identifier])
+                         (let ([binding (identifier-binding id)])
+                           (when (pair? binding)
+                             (let ([nominal-source-id (list-ref binding 3)])
+                               (when (eq? nominal-source-id jump-to-id)
+                                 (jump-to id))))))
+                       (syntax->list vars))))])
+    
+    (let level-loop ([sexp sexp]
+                     [high-level? #f])
+      (let* ([loop (λ (sexp) (level-loop sexp high-level?))]
+             [varrefs (if high-level? high-varrefs low-varrefs)]
+             [binders (if high-level? high-binders low-binders)]
+             [tops (if high-level? high-tops low-tops)]
+             [collect-general-info
+              (λ (stx)
+                (add-origins stx varrefs)
+                (add-disappeared-bindings stx binders varrefs)
+                (add-disappeared-uses stx varrefs))])
+        (collect-general-info sexp)
+        (syntax-case* sexp (#%plain-lambda case-lambda if begin begin0 let-values letrec-values set!
+                                           quote quote-syntax with-continuation-mark 
+                                           #%plain-app #%top #%plain-module-begin
+                                           define-values define-syntaxes define-values-for-syntax module
+                                           #%require #%provide #%expression)
+          (if high-level? free-transformer-identifier=? free-identifier=?)
+          [(#%plain-lambda args bodies ...)
+           (begin
+             (annotate-raw-keyword sexp varrefs)
+             (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht)
+             (add-binders (syntax args) binders)
+             (for-each loop (syntax->list (syntax (bodies ...)))))]
+          [(case-lambda [argss bodiess ...]...)
+           (begin
+             (annotate-raw-keyword sexp varrefs)
+             (for-each (λ (bodies/stx) (annotate-tail-position/last sexp 
+                                                                    (syntax->list bodies/stx)
+                                                                    tail-ht))
+                       (syntax->list (syntax ((bodiess ...) ...))))
+             (for-each
+              (λ (args bodies)
+                (add-binders args binders)
+                (for-each loop (syntax->list bodies)))
+              (syntax->list (syntax (argss ...)))
+              (syntax->list (syntax ((bodiess ...) ...)))))]
+          [(if test then else)
+           (begin
+             (annotate-raw-keyword sexp varrefs)
+             (annotate-tail-position sexp (syntax then) tail-ht)
+             (annotate-tail-position sexp (syntax else) tail-ht)
+             (loop (syntax test))
+             (loop (syntax else))
+             (loop (syntax then)))]
+          [(begin bodies ...)
+           (begin
+             (annotate-raw-keyword sexp varrefs)
+             (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht)
+             (for-each loop (syntax->list (syntax (bodies ...)))))]
+          
+          ;; treat a single body expression specially, since this has
+          ;; different tail behavior.
+          [(begin0 body)
+           (begin
+             (annotate-raw-keyword sexp varrefs)
+             (annotate-tail-position sexp (syntax body) tail-ht)
+             (loop (syntax body)))]
+          
+          [(begin0 bodies ...)
+           (begin
+             (annotate-raw-keyword sexp varrefs)
+             (for-each loop (syntax->list (syntax (bodies ...)))))]
+          
+          [(let-values (bindings ...) bs ...)
+           (begin
+             (annotate-raw-keyword sexp varrefs)
+             (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 loop (syntax->list (syntax (es ...))))
+               (for-each loop (syntax->list (syntax (bs ...))))))]
+          [(letrec-values (bindings ...) bs ...)
+           (begin
+             (annotate-raw-keyword sexp varrefs)
+             (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 loop (syntax->list (syntax (es ...))))
+               (for-each loop (syntax->list (syntax (bs ...))))))]
+          [(set! var e)
+           (begin
+             (annotate-raw-keyword sexp varrefs)
+             
+             ;; tops are used here because a binding free use of a set!'d variable
+             ;; is treated just the same as (#%top . x).
+             (when (syntax-original? (syntax var))
+               (if (identifier-binding (syntax var))
+                   (add-id varrefs (syntax var))
+                   (add-id tops (syntax var))))
+             
+             (loop (syntax e)))]
+          [(quote datum)
+           ;(color-internal-structure (syntax datum) constant-style-name)
+           (annotate-raw-keyword sexp varrefs)]
+          [(quote-syntax datum)
+           ;(color-internal-structure (syntax datum) constant-style-name)
+           (annotate-raw-keyword sexp varrefs)
+           (let loop ([stx #'datum])
+             (cond [(identifier? stx)
+                    (when (syntax-original? stx)
+                      (add-id templrefs stx))]
+                   [(syntax? stx)
+                    (loop (syntax-e stx))]
+                   [(pair? stx)
+                    (loop (car stx))
+                    (loop (cdr stx))]
+                   [(vector? stx)
+                    (for-each loop (vector->list stx))]
+                   [(box? stx)
+                    (loop (unbox stx))]
+                   [else (void)]))]
+          [(with-continuation-mark a b c)
+           (begin
+             (annotate-raw-keyword sexp varrefs)
+             (annotate-tail-position sexp (syntax c) tail-ht)
+             (loop (syntax a))
+             (loop (syntax b))
+             (loop (syntax c)))]
+          [(#%plain-app pieces ...)
+           (begin
+             (annotate-raw-keyword sexp varrefs)
+             (for-each loop (syntax->list (syntax (pieces ...)))))]
+          [(#%top . var)
+           (begin
+             (annotate-raw-keyword sexp varrefs)
+             (when (syntax-original? (syntax var))
+               (add-id tops (syntax var))))]
+          [(define-values vars b)
+           (begin
+             (annotate-raw-keyword sexp varrefs)
+             (add-binders (syntax vars) binders)
+             (maybe-jump (syntax vars))
+             (loop (syntax b)))]
+          [(define-syntaxes names exp)
+           (begin
+             (annotate-raw-keyword sexp varrefs)
+             (add-binders (syntax names) binders)
+             (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)
+             (maybe-jump (syntax names))
+             (level-loop (syntax exp) #t))]
+          [(module m-name lang (#%plain-module-begin bodies ...))
+           (begin
+             (annotate-raw-keyword sexp varrefs)
+             ((annotate-require-open user-namespace user-directory) (syntax lang))
+             
+             ;; temporarily removed until Matthew fixes whatever.
+             #;
+             (hash-table-put! requires 
+                              (syntax->datum (syntax lang))
+                              (cons (syntax lang)
+                                    (hash-table-get requires 
+                                                    (syntax->datum (syntax lang))
+                                                    (λ () '()))))
+             (for-each loop (syntax->list (syntax (bodies ...)))))]
+          
+          ; top level or module top level only:
+          [(#%require require-specs ...)
+           (let ([at-phase
+                  (lambda (stx requires)
+                    (syntax-case stx ()
+                      [(_ require-specs ...)
+                       (let ([new-specs (map trim-require-prefix
+                                             (syntax->list (syntax (require-specs ...))))])
+                         (annotate-raw-keyword sexp varrefs)
+                         (for-each (annotate-require-open user-namespace user-directory) new-specs)
+                         (for-each (add-require-spec requires)
+                                   new-specs
+                                   (syntax->list (syntax (require-specs ...)))))]))])
+             (for-each (lambda (spec)
+                         (syntax-case* spec (for-syntax for-template for-label) (lambda (a b)
+                                                                                  (eq? (syntax-e a) (syntax-e b)))
+                           [(for-syntax specs ...)
+                            (at-phase spec require-for-syntaxes)]
+                           [(for-template specs ...)
+                            (at-phase spec require-for-templates)]
+                           [(for-label specs ...)
+                            (at-phase spec require-for-labels)]
+                           [else
+                            (at-phase (list #f spec) requires)]))
+                       (syntax->list #'(require-specs ...))))]
+          
+          ; module top level only:
+          [(#%provide provide-specs ...)
+           (let ([provided-varss (map extract-provided-vars
+                                      (syntax->list (syntax (provide-specs ...))))])
+             (annotate-raw-keyword sexp varrefs)
+             (for-each (λ (provided-vars)
+                         (for-each
+                          (λ (provided-var)
+                            (when (syntax-original? provided-var)
+                              (add-id varrefs provided-var)))
+                          provided-vars))
+                       provided-varss))]
+          
+          [(#%expression arg)
+           (begin
+             (annotate-raw-keyword sexp varrefs)
+             (loop #'arg))]
+          [id
+           (identifier? (syntax id))
+           (when (syntax-original? sexp)
+             (add-id varrefs sexp))]
+          [_
+           (begin
+             #;
+             (printf "unknown stx: ~e datum: ~e source: ~e\n"
+                     sexp
+                     (and (syntax? sexp)
+                          (syntax->datum sexp))
+                     (and (syntax? sexp)
+                          (syntax-source sexp)))
+             (void))])))
+    (add-tail-ht-links tail-ht)))
+|#

collects/drscheme/syncheck/extra.ss

@@ -0,0 +1,21 @@
+#lang scheme/base
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

collects/drscheme/syncheck/id-sets.ss

@@ -0,0 +1,41 @@
+#lang typed-scheme
+
+(provide (rename-out [make-module-identifier-mapping make-id-set]
+		     [module-identifier-mapping? id-set?])
+         add-id get-idss get-ids for-each-ids
+         Id-Set)
+
+(require/opaque-type Id-Set module-identifier-mapping? syntax/boundmap)
+
+;; FIXME - need polymorphic imports
+(require/typed [module-identifier-mapping-get module-identifier-mapping-get/f]
+  (Id-Set Identifier (-> #f) -> (U (Listof Identifier) #f))
+  syntax/boundmap)
+
+(require/typed syntax/boundmap
+  [make-module-identifier-mapping (-> Id-Set)]
+  [module-identifier-mapping-get 
+     (Id-Set Identifier (-> '()) -> (Listof Identifier))]
+  [module-identifier-mapping-put! (Id-Set Identifier (Listof Identifier) -> Void)]
+  [module-identifier-mapping-for-each (Id-Set (Identifier (Listof Identifier) -> Void) -> Void)]
+  [module-identifier-mapping-map 
+   (Id-Set (Identifier (Listof Identifier) -> (Listof Identifier)) -> (Listof (Listof Identifier)))])                    
+
+
+(: add-id (Id-Set Identifier -> Void))
+(define (add-id mapping id)
+  (let* ([old (module-identifier-mapping-get mapping id (λ () '()))]
+         [new (cons id old)])
+    (module-identifier-mapping-put! mapping id new)))
+
+(: get-idss (Id-Set -> (Listof (Listof Identifier))))
+(define (get-idss mapping)
+  (module-identifier-mapping-map mapping (λ: ([x : Identifier] [y : (Listof Identifier)]) y)))
+
+(: get-ids (Id-Set Identifier -> (U (Listof Identifier) #f)))
+(define (get-ids mapping var)
+  (module-identifier-mapping-get/f mapping var (λ () #f)))
+
+(: for-each-ids (Id-Set ((Listof Identifier) -> Void) -> Void))
+(define (for-each-ids mapping f)
+  (module-identifier-mapping-for-each mapping (λ: ([x : Identifier] [y : (Listof Identifier)]) (f y))))

collects/drscheme/syncheck/make-traversal.ss

@@ -0,0 +1,86 @@
+#lang scheme/base
+
+(require "id-sets.ss"
+         "annotate.ss")
+
+;; make-traversal : -> (values (namespace syntax (union #f syntax) -> void)
+;;                             (namespace string[directory] -> void))
+;; returns a pair of functions that close over some state that
+;; represents the top-level of a single program. The first value
+;; is called once for each top-level expression and the second
+;; value is called once, after all expansion is complete.
+(define (make-traversal)
+  (let* ([tl-low-binders (make-id-set)]
+         [tl-high-binders (make-id-set)]
+         [tl-low-varrefs (make-id-set)]
+         [tl-high-varrefs (make-id-set)]
+         [tl-low-tops (make-id-set)]
+         [tl-high-tops (make-id-set)]
+         [tl-templrefs (make-id-set)]
+         [tl-requires (make-hash-table 'equal)]
+         [tl-require-for-syntaxes (make-hash-table 'equal)]
+         [tl-require-for-templates (make-hash-table 'equal)]
+         [tl-require-for-labels (make-hash-table 'equal)]
+         [expanded-expression
+          (λ (user-namespace user-directory sexp jump-to-id)
+            (parameterize ([current-load-relative-directory user-directory])
+              (let ([is-module? (syntax-case sexp (module)
+                                  [(module . rest) #t]
+                                  [else #f])])
+                (cond
+                  [is-module?
+                   (let ([low-binders (make-id-set)]
+                         [high-binders (make-id-set)]
+                         [varrefs (make-id-set)]
+                         [high-varrefs (make-id-set)]
+                         [low-tops (make-id-set)]
+                         [high-tops (make-id-set)]
+                         [templrefs (make-id-set)]
+                         [requires (make-hash-table 'equal)]
+                         [require-for-syntaxes (make-hash-table 'equal)]
+                         [require-for-templates (make-hash-table 'equal)]
+                         [require-for-labels (make-hash-table 'equal)])
+                     (annotate-basic sexp user-namespace user-directory jump-to-id
+                                     low-binders high-binders varrefs high-varrefs low-tops high-tops
+                                     templrefs
+                                     requires require-for-syntaxes require-for-templates require-for-labels) 
+                     (annotate-variables user-namespace
+                                         user-directory
+                                         low-binders
+                                         high-binders
+                                         varrefs
+                                         high-varrefs
+                                         low-tops
+                                         high-tops
+                                         templrefs
+                                         requires
+                                         require-for-syntaxes
+                                         require-for-templates
+                                         require-for-labels))]
+                  [else
+                   (annotate-basic sexp user-namespace user-directory jump-to-id
+                                   tl-low-binders tl-high-binders
+                                   tl-low-varrefs tl-high-varrefs 
+                                   tl-low-tops tl-high-tops
+                                   tl-templrefs
+                                   tl-requires
+                                   tl-require-for-syntaxes
+                                   tl-require-for-templates
+                                   tl-require-for-labels)]))))]
+         [expansion-completed
+          (λ (user-namespace user-directory)
+            (parameterize ([current-load-relative-directory user-directory])
+              (annotate-variables user-namespace
+                                  user-directory
+                                  tl-low-binders
+                                  tl-high-binders
+                                  tl-low-varrefs
+                                  tl-high-varrefs
+                                  tl-low-tops
+                                  tl-high-tops
+                                  tl-templrefs
+                                  tl-requires
+                                  tl-require-for-syntaxes
+                                  tl-require-for-templates
+                                  tl-require-for-labels)))])
+    (values expanded-expression expansion-completed)))

collects/drscheme/syncheck/utils.ss

@@ -0,0 +1,8 @@
+#lang scheme/base
+
+(provide (all-defined-out))
+
+;; use this to communicate the frame being
+;; syntax checked w/out having to add new
+;; parameters to all of the functions
+(define currently-processing-drscheme-frame (make-parameter #f))