diff --git a/collects/drscheme/syncheck.ss b/collects/drscheme/syncheck.ss index 42e2db6eba..2035a60a0f 100644 --- a/collects/drscheme/syncheck.ss +++ b/collects/drscheme/syncheck.ss @@ -1241,10 +1241,12 @@ If the namespace does not, they are colored the unbound color. ;; 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-binders (make-id-set)] - [tl-varrefs (make-id-set)] + (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-tops (make-id-set)] + [tl-low-tops (make-id-set)] + [tl-high-tops (make-id-set)] [tl-requires (make-hash-table 'equal)] [tl-require-for-syntaxes (make-hash-table 'equal)] [expanded-expression @@ -1255,36 +1257,44 @@ If the namespace does not, they are colored the unbound color. [else #f])]) (cond [is-module? - (let ([binders (make-id-set)] + (let ([low-binders (make-id-set)] + [high-binders (make-id-set)] [varrefs (make-id-set)] [high-varrefs (make-id-set)] - [tops (make-id-set)] + [low-tops (make-id-set)] + [high-tops (make-id-set)] [requires (make-hash-table 'equal)] [require-for-syntaxes (make-hash-table 'equal)]) (annotate-basic sexp user-namespace user-directory jump-to-id - binders varrefs high-varrefs tops + low-binders high-binders varrefs high-varrefs low-tops high-tops requires require-for-syntaxes) (annotate-variables user-namespace user-directory - binders + low-binders + high-binders varrefs high-varrefs - tops + low-tops + high-tops requires require-for-syntaxes))] [else (annotate-basic sexp user-namespace user-directory jump-to-id - tl-binders tl-varrefs tl-high-varrefs tl-tops + tl-low-binders tl-high-binders + tl-low-varrefs tl-high-varrefs + tl-low-tops tl-high-tops tl-requires tl-require-for-syntaxes)]))))] [expansion-completed (λ (user-namespace user-directory) (parameterize ([current-load-relative-directory user-directory]) (annotate-variables user-namespace user-directory - tl-binders - tl-varrefs + tl-low-binders + tl-high-binders + tl-low-varrefs tl-high-varrefs - tl-tops + tl-low-tops + tl-high-tops tl-requires tl-require-for-syntaxes)))]) (values expanded-expression expansion-completed))) @@ -1297,11 +1307,13 @@ If the namespace does not, they are colored the unbound color. ;; namespace ;; string[directory] ;; syntax[id] - ;; id-set (four of them) + ;; id-set (six of them) ;; hash-table[require-spec -> syntax] (two of them) ;; -> void (define (annotate-basic sexp user-namespace user-directory jump-to-id - binders low-varrefs high-varrefs tops + low-binders high-binders + low-varrefs high-varrefs + low-tops high-tops requires require-for-syntaxes) (let ([tail-ht (make-hash-table)] [maybe-jump @@ -1319,6 +1331,8 @@ If the namespace does not, they are colored the unbound color. [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) @@ -1328,7 +1342,7 @@ If the namespace does not, they are colored the unbound color. (syntax-case* sexp (lambda case-lambda if begin begin0 let-values letrec-values set! quote quote-syntax with-continuation-mark #%app #%datum #%top #%plain-module-begin - define-values define-syntaxes define-values-for-syntaxes module + define-values define-syntaxes define-values-for-syntax module require require-for-syntax provide) (if high-level? module-transformer-identifier=? module-identifier=?) [(lambda args bodies ...) @@ -1451,10 +1465,10 @@ If the namespace does not, they are colored the unbound color. (add-binders (syntax names) binders) (maybe-jump (syntax names)) (level-loop (syntax exp) #t))] - [(define-values-for-syntaxes names exp) + [(define-values-for-syntax names exp) (begin (annotate-raw-keyword sexp varrefs) - (add-binders (syntax names) binders) + (add-binders (syntax names) high-binders) (maybe-jump (syntax names)) (level-loop (syntax exp) #t))] [(module m-name lang (#%plain-module-begin bodies ...)) @@ -1503,12 +1517,13 @@ If the namespace does not, they are colored the unbound color. (add-id varrefs sexp))] [_ (begin - '(printf "unknown stx: ~e (datum: ~e) (source: ~e)~n" - sexp - (and (syntax? sexp) - (syntax-object->datum sexp)) - (and (syntax? sexp) - (syntax-source sexp))) + #; + (printf "unknown stx: ~e (datum: ~e) (source: ~e)~n" + sexp + (and (syntax? sexp) + (syntax-object->datum sexp)) + (and (syntax? sexp) + (syntax-source sexp))) (void))]))) (add-tail-ht-links tail-ht))) @@ -1561,10 +1576,12 @@ If the namespace does not, they are colored the unbound color. ;; in the various id-sets (define (annotate-variables user-namespace user-directory - binders - varrefs + low-binders + high-binders + low-varrefs high-varrefs - tops + low-tops + high-tops requires require-for-syntaxes) @@ -1573,7 +1590,7 @@ If the namespace does not, they are colored the unbound color. (make-hash-table 'equal)] [unused-requires (make-hash-table 'equal)] [unused-require-for-syntaxes (make-hash-table 'equal)] - [id-sets (list binders varrefs high-varrefs tops)]) + [id-sets (list low-binders high-binders low-varrefs high-varrefs low-tops high-tops)]) (hash-table-for-each requires (λ (k v) (hash-table-put! unused-requires k #t))) (hash-table-for-each require-for-syntaxes (λ (k v) (hash-table-put! unused-require-for-syntaxes k #t))) @@ -1584,45 +1601,52 @@ If the namespace does not, they are colored the unbound color. (color-variable var identifier-binding) (record-renamable-var rename-ht var))) vars)) - (get-idss binders)) + (append (get-idss high-binders) + (get-idss low-binders))) (for-each (λ (vars) (for-each - (λ (var) - (color-variable var identifier-binding) - (connect-identifier var - rename-ht - binders - unused-requires - requires - identifier-binding - id-sets - user-namespace - user-directory)) - vars)) - (get-idss varrefs)) + (λ (var) + (color-variable var identifier-binding) + (connect-identifier var + rename-ht + low-binders + unused-requires + requires + identifier-binding + user-namespace + user-directory)) + vars)) + (get-idss low-varrefs)) (for-each (λ (vars) (for-each - (λ (var) - (color-variable var identifier-transformer-binding) - (connect-identifier var - rename-ht - binders - unused-require-for-syntaxes - require-for-syntaxes - identifier-transformer-binding - id-sets - user-namespace - user-directory)) - vars)) + (λ (var) + (color-variable var identifier-transformer-binding) + (connect-identifier var + rename-ht + high-binders + unused-require-for-syntaxes + require-for-syntaxes + identifier-transformer-binding + user-namespace + user-directory)) + vars)) (get-idss high-varrefs)) (for-each (λ (vars) (for-each (λ (var) - (color/connect-top rename-ht user-namespace user-directory binders var id-sets)) + (color/connect-top rename-ht user-namespace user-directory low-binders var)) vars)) - (get-idss tops)) + (get-idss low-tops)) + + (for-each + (λ (vars) + (for-each + (λ (var) + (color/connect-top rename-ht user-namespace user-directory high-binders var)) + vars)) + (get-idss high-tops)) (color-unused require-for-syntaxes unused-require-for-syntaxes) (color-unused requires unused-requires) @@ -1653,7 +1677,7 @@ If the namespace does not, they are colored the unbound color. ;; directory ;; -> void ;; adds arrows and rename menus for binders/bindings - (define (connect-identifier var rename-ht all-binders unused requires get-binding id-sets user-namespace user-directory) + (define (connect-identifier var rename-ht all-binders unused requires get-binding user-namespace user-directory) (connect-identifier/arrow var all-binders unused requires get-binding user-namespace user-directory) (when (get-ids all-binders var) (record-renamable-var rename-ht var))) @@ -1706,7 +1730,7 @@ If the namespace does not, they are colored the unbound color. (cons mod-path #f)])))) ;; color/connect-top : namespace directory id-set syntax -> void - (define (color/connect-top rename-ht user-namespace user-directory binders var id-sets) + (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]) @@ -1716,7 +1740,7 @@ If the namespace does not, they are colored the unbound color. (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 id-sets user-namespace user-directory))) + (connect-identifier var rename-ht binders #f #f identifier-binding user-namespace user-directory))) ;; color-variable : syntax (union identifier-binding identifier-transformer-binding) -> void (define (color-variable var get-binding) diff --git a/collects/htdp/image.ss b/collects/htdp/image.ss index 333c8033b4..2170241e31 100644 --- a/collects/htdp/image.ss +++ b/collects/htdp/image.ss @@ -490,7 +490,7 @@ plt/collects/tests/mzscheme/image-test.ss (check 'star (lambda (x) (and (real? x) (< 3 x 10000))) points - "positive real number bigger than 3" + "positive real number bigger than or equal to 4" "first") (check-size 'star inner-radius "second") (check-size 'star outer-radius "second") diff --git a/collects/tests/drscheme/syncheck-test.ss b/collects/tests/drscheme/syncheck-test.ss index ea422d17b7..f942782f83 100644 --- a/collects/tests/drscheme/syncheck-test.ss +++ b/collects/tests/drscheme/syncheck-test.ss @@ -237,9 +237,9 @@ ("x" lexically-bound-variable) (") " default-color) ("x" lexically-bound-variable) - ("))" default-color)) + (")" default-color)) (list '((22 23) (25 26)))) - + (build-test "(module m mzscheme)" '(("(" default-color) ("module" imported-syntax) @@ -331,6 +331,83 @@ (list '((10 18) (20 38) (56 69)) '((39 53) (73 76)))) + + + (build-test "(define-for-syntax (f x) x) (define (f x) x) f (define-syntax (m x) (f x))" + '(("(" default-color) + ("define-for-syntax" imported-identifier) + (" (" default-color) + ("f" lexically-bound-identifier) + (" " default-color) + ("x" lexically-bound-identifier) + (") " default-color) + ("x" lexically-bound-identifier) + (") (" default-color) + ("define" imported-identifier) + (" (" default-color) + ("f" lexically-bound-identifier) + (" " default-color) + ("x" lexically-bound-identifier) + (") " default-color) + ("x" lexically-bound-identifier) + (") " default-color) + ("f" lexically-bound-identifier) + (" (" default-color) + ("define-syntax" imported-identifier) + (" (" default-color) + ("m" lexically-bound-identifier) + (" " default-color) + ("x" lexically-bound-identifier) + (") (" default-color) + ("f" lexically-bound-identifier) + (" " default-color) + ("x" lexically-bound-identifier) + ("))" default-color)) + '(((20 21) (69 70)) + ((22 23) (25 26)) + ((37 38) (45 46)) + ((39 40) (42 43)) + ((65 66) (71 72)))) + + (build-test "(module m mzscheme (define-for-syntax (f x) x) (define (f x) x) f (define-syntax (m stx) (f stx)))" + '(("(" default-color) + ("module" imported-identifier) + (" m mzscheme (" default-color) + ("define-for-syntax" imported-identifier) + (" (" default-color) + ("f" lexically-bound-identifier) + (" " default-color) + ("x" lexically-bound-identifier) + (") " default-color) + ("x" lexically-bound-identifier) + (") (" default-color) + ("define" imported-identifier) + (" (" default-color) + ("f" lexically-bound-identifier) + (" " default-color) + ("x" lexically-bound-identifier) + (") " default-color) + ("x" lexically-bound-identifier) + (") " default-color) + ("f" lexically-bound-identifier) + (" (" default-color) + ("define-syntax" imported-identifier) + (" (" default-color) + ("m" lexically-bound-identifier) + (" " default-color) + ("stx" lexically-bound-identifier) + (") (" default-color) + ("f" lexically-bound-identifier) + (" " default-color) + ("stx" lexically-bound-identifier) + (")))" default-color)) + '(((10 18) (20 37) (48 54) (67 80)) + ((39 40) (90 91)) + ((41 42) (44 45)) + ((56 57) (64 65)) + ((58 59) (61 62)) + ((84 87) (92 95)))) + (build-test "(define-syntax s (lambda (stx) (syntax-case stx () (_ 123))))" '(("(" default-color) ("define-syntax" imported-syntax)