diff --git a/collects/drscheme/syncheck.ss b/collects/drscheme/syncheck.ss index a8e7d00dfd..370b2bb615 100644 --- a/collects/drscheme/syncheck.ss +++ b/collects/drscheme/syncheck.ss @@ -1499,7 +1499,7 @@ If the namespace does not, they are colored the unbound color. (λ (vars) (when jump-to-id (for-each (λ (id) - (let ([binding (identifier-binding id)]) + (let ([binding (identifier-binding id 0)]) (when (pair? binding) (let ([nominal-source-id (list-ref binding 3)]) (when (eq? nominal-source-id jump-to-id) @@ -1598,7 +1598,7 @@ If the namespace does not, they are colored the unbound color. ;; 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)) + (if (identifier-binding (syntax var) 0) (add-id varrefs (syntax var)) (add-id tops (syntax var)))) @@ -1813,11 +1813,23 @@ If the namespace does not, they are colored the unbound color. [unused-require-for-syntaxes (make-hash)] [unused-require-for-templates (make-hash)] [unused-require-for-labels (make-hash)] + [requires/phases (make-hash)] + [unused/phases (make-hash)] ;; there is no define-for-template form, thus no for-template binders [template-binders (make-id-set)] [label-binders (make-id-set)] [id-sets (list low-binders high-binders low-varrefs high-varrefs low-tops high-tops)]) + (hash-set! requires/phases 0 requires) + (hash-set! requires/phases 1 require-for-syntaxes) + (hash-set! requires/phases -1 require-for-templates) + (hash-set! requires/phases #f require-for-labels) + + (hash-set! unused/phases 0 unused-requires) + (hash-set! unused/phases 1 unused-require-for-syntaxes) + (hash-set! unused/phases -1 unused-require-for-templates) + (hash-set! unused/phases #f unused-require-for-labels) + (hash-for-each requires (λ (k v) (hash-set! unused-requires k #t))) (hash-for-each require-for-syntaxes @@ -1830,8 +1842,8 @@ If the namespace does not, they are colored the unbound color. (for-each (λ (vars) (for-each (λ (var) (when (syntax-original? var) - (color-variable var identifier-binding) - (document-variable var identifier-binding) + (color-variable var 0) + (document-variable var 0) (record-renamable-var rename-ht var))) vars)) (append (get-idss high-binders) @@ -1839,13 +1851,13 @@ If the namespace does not, they are colored the unbound color. (for-each (λ (vars) (for-each (λ (var) - (color-variable var identifier-binding) - (document-variable var identifier-binding) + (color-variable var 0) + (document-variable var 0) (connect-identifier var rename-ht low-binders - unused-requires - requires + unused/phases + requires/phases 0 user-namespace user-directory @@ -1855,13 +1867,13 @@ If the namespace does not, they are colored the unbound color. (for-each (λ (vars) (for-each (λ (var) - (color-variable var identifier-transformer-binding) - (document-variable var identifier-transformer-binding) + (color-variable var 1) + (document-variable var 1) (connect-identifier var rename-ht high-binders - unused-require-for-syntaxes - require-for-syntaxes + unused/phases + requires/phases 1 user-namespace user-directory @@ -1875,8 +1887,8 @@ If the namespace does not, they are colored the unbound color. (connect-identifier var rename-ht low-binders - unused-requires - requires + unused/phases + requires/phases 0 user-namespace user-directory @@ -1884,8 +1896,8 @@ If the namespace does not, they are colored the unbound color. (connect-identifier var rename-ht high-binders - unused-require-for-syntaxes - require-for-syntaxes + unused/phases + requires/phases 1 user-namespace user-directory @@ -1893,8 +1905,8 @@ If the namespace does not, they are colored the unbound color. (connect-identifier var rename-ht template-binders ;; dummy; always empty - unused-require-for-templates - require-for-templates + unused/phases + requires/phases -1 user-namespace user-directory @@ -1902,8 +1914,8 @@ If the namespace does not, they are colored the unbound color. (connect-identifier var rename-ht label-binders ;; dummy; always empty - unused-require-for-labels - require-for-labels + unused/phases + requires/phases #f user-namespace user-directory @@ -1960,9 +1972,11 @@ If the namespace does not, they are colored the unbound color. ;; -> void ;; adds arrows and rename menus for binders/bindings (define (connect-identifier var rename-ht all-binders - unused requires phase-level user-namespace user-directory actual?) + unused/phases requires/phases + phase-level user-namespace user-directory actual?) (connect-identifier/arrow var all-binders - unused requires phase-level user-namespace user-directory actual?) + unused/phases requires/phases + phase-level user-namespace user-directory actual?) (when (and actual? (get-ids all-binders var)) (record-renamable-var rename-ht var))) @@ -1987,7 +2001,7 @@ If the namespace does not, they are colored the unbound color. ;; boolean ;; -> void ;; adds the arrows that correspond to binders/bindings - (define (connect-identifier/arrow var all-binders unused requires phase-level user-namespace user-directory actual?) + (define (connect-identifier/arrow var all-binders unused/phases requires/phases phase-level user-namespace user-directory actual?) (let ([binders (get-ids all-binders var)]) (when binders (for-each (λ (x) @@ -1995,11 +2009,15 @@ If the namespace does not, they are colored the unbound color. (connect-syntaxes x var actual? (id-level phase-level x)))) binders)) - (when (and unused requires) - (let ([req-path/pr (get-module-req-path (identifier-binding var phase-level))]) + (when (and unused/phases requires/phases) + (let ([req-path/pr (get-module-req-path (identifier-binding var phase-level) + phase-level)]) (when req-path/pr - (let* ([req-path (car req-path/pr)] - [id (cdr req-path/pr)] + (let* ([req-path (list-ref req-path/pr 0)] + [id (list-ref req-path/pr 1)] + [req-phase-level (list-ref req-path/pr 2)] + [unused (hash-ref unused/phases req-phase-level)] + [requires (hash-ref requires/phases req-phase-level)] [req-stxes (hash-ref requires req-path (λ () #f))]) (when req-stxes (hash-remove! unused req-path) @@ -2043,15 +2061,23 @@ If the namespace does not, they are colored the unbound color. ;; get-module-req-path : binding -> (union #f (cons require-sexp sym)) ;; argument is the result of identifier-binding or identifier-transformer-binding - (define (get-module-req-path binding) + (define (get-module-req-path binding phase-level) (and (pair? binding) + (or (not (number? phase-level)) + (= phase-level + (+ (list-ref binding 5) + (list-ref binding 6)))) (let ([mod-path (list-ref binding 2)]) (cond [(module-path-index? mod-path) (let-values ([(base offset) (module-path-index-split mod-path)]) - (cons base (list-ref binding 3)))] + (list base + (list-ref binding 3) + (list-ref binding 5)))] [(symbol? mod-path) - (cons mod-path (list-ref binding 3))])))) + (list mod-path + (list-ref binding 3) + (list-ref binding 5))])))) ;; color/connect-top : namespace directory id-set syntax -> void (define (color/connect-top rename-ht user-namespace user-directory binders var) @@ -2066,9 +2092,9 @@ If the namespace does not, they are colored the unbound color. (color var error-style-name)) (connect-identifier var rename-ht binders #f #f 0 user-namespace user-directory #t))) - ;; color-variable : syntax (union identifier-binding identifier-transformer-binding) -> void - (define (color-variable var get-binding) - (let* ([b (get-binding var)] + ;; color-variable : syntax phase-level -> void + (define (color-variable var phase-level) + (let* ([b (identifier-binding var phase-level)] [lexical? (or (not b) (eq? b 'lexical) @@ -2528,12 +2554,12 @@ If the namespace does not, they are colored the unbound color. ; - ;; document-variable : stx identifier-binding -> void - (define (document-variable stx get-binding) + ;; document-variable : stx phase-level -> void + (define (document-variable stx phase-level) (when (syntax-original? stx) (let ([defs-text (currently-processing-definitions-text)]) (when defs-text - (let ([binding-info (get-binding stx)]) + (let ([binding-info (identifier-binding stx phase-level)]) (when (and (pair? binding-info) (syntax-position stx) (syntax-span stx)) diff --git a/collects/tests/drscheme/syncheck-test.ss b/collects/tests/drscheme/syncheck-test.ss index 875ee2c736..4c13e3f2d2 100644 --- a/collects/tests/drscheme/syncheck-test.ss +++ b/collects/tests/drscheme/syncheck-test.ss @@ -34,6 +34,7 @@ trigger runtime errors in check syntax. ;; tests : (listof test) (define tests (list + (build-test "12345" '(("12345" constant))) (build-test "'abcdef" @@ -829,7 +830,25 @@ trigger runtime errors in check syntax. (" " default-color) ("foldl" imported-variable) (")" default-color)) - #f))) + #f) + + (build-test "#lang scheme/base\n(require scheme)\n(define-syntax m (lambda (x) #'1))" + '(("#lang " default-color) + ("scheme/base" error) + ("\n(" default-color) + ("require" imported) + (" scheme)\n(" default-color) + ("define-syntax" imported) + (" " default-color) + ("m" lexically-bound) + (" (" default-color) + ("lambda" imported) + (" (" default-color) + ("x" lexically-bound) + (") " default-color) + ("#'" imported) + ("1))" default-color)) + (list '((27 33) (19 26) (36 49) (53 59) (64 66)))))) (define (run-test) (check-language-level #rx"Pretty")