suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

adjust Check Syntax so that it tries to point to the

Browse Source 
raw-module-path inside of a phaseless-spec (see
the #%require docs for the description of these).
Also, Rackety

in conjunction with commit 9047427 (and an earlier
commit in those files/dirs), this commit:
 closes PR 7815
 closes PR 10455
 closes PR 10788
This commit is contained in:
Robby Findler 2012-10-01 10:47:23 -05:00
parent 6a5f73d3d9
commit a4b79ccf66
2 changed files with 60 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

102
collects/drracket/private/syncheck/traversals.rkt
View File

@ -339,7 +339,7 @@
(let loop ([spec spec] (let loop ([spec spec]
[level level]) [level level])
(define (add-to-level n) (and n level (+ n level))) (define (add-to-level n) (and n level (+ n level)))
(syntax-case* spec (for-meta for-syntax for-template for-label just-meta) sym-eq? (syntax-case* spec (for-meta for-syntax for-template for-label just-meta) symbolic-compare?
[(for-meta phase specs ...) [(for-meta phase specs ...)
(for ([spec (in-list (syntax->list #'(specs ...)))]) (for ([spec (in-list (syntax->list #'(specs ...)))])
(loop spec (add-to-level (syntax-e #'phase))))] (loop spec (add-to-level (syntax-e #'phase))))]
@ -363,21 +363,13 @@
(define h (make-hash)) (define h (make-hash))
(hash-set! phase-to-requires level h) (hash-set! phase-to-requires level h)
h))) h)))
(define raw-module-path (define raw-module-path (phaseless-spec->raw-module-path stx))
(syntax-case* stx (only prefix all-expect prefix-all-except rename) sym-eq?
[(only raw-module-path id ...) #'raw-module-path]
[(prefix prefix-id raw-module-path) #'raw-module-path]
[(all-except raw-module-path id ...) #'raw-module-path]
[(prefix-all-except prefix-id raw-module-path id ...) #'raw-module-path]
[(rename raw-module-path local-id exported-id) #'raw-module-path]
[_ stx]))
(annotate-require-open user-namespace user-directory raw-module-path) (annotate-require-open user-namespace user-directory raw-module-path)
(when (syntax-original? raw-module-path) (when (syntax-original? raw-module-path)
(define key (syntax->datum raw-module-path)) (define key (syntax->datum raw-module-path))
(hash-set! require-ht (hash-set! require-ht
key key
(cons stx (hash-ref require-ht key '()))))) (cons stx (hash-ref require-ht key '())))))
(define (sym-eq? a b) (eq? (syntax-e a) (syntax-e b)))
(for ([spec (in-list (syntax->list #'(raw-require-specs ...)))]) (for ([spec (in-list (syntax->list #'(raw-require-specs ...)))])
(handle-raw-require-spec spec)))] (handle-raw-require-spec spec)))]
@ -574,45 +566,50 @@
(define (connect-identifier var all-binders unused/phases phase-to-requires (define (connect-identifier var all-binders unused/phases phase-to-requires
phase-level user-namespace user-directory actual? phase-level user-namespace user-directory actual?
connections) connections)
(let ([binders (get-ids all-binders var)]) (define binders (get-ids all-binders var))
(when binders (when binders
(for ([x (in-list binders)]) (for ([x (in-list binders)])
(connect-syntaxes x var actual? (id-level phase-level x) connections))) (connect-syntaxes x var actual? (id-level phase-level x) connections)))
(when (and unused/phases phase-to-requires) (when (and unused/phases phase-to-requires)
(let ([req-path/pr (get-module-req-path var phase-level)] (define req-path/pr (get-module-req-path var phase-level))
[source-req-path/pr (get-module-req-path var phase-level #:nominal? #f)]) (define source-req-path/pr (get-module-req-path var phase-level #:nominal? #f))
(when (and req-path/pr source-req-path/pr) (when (and req-path/pr source-req-path/pr)
(let* ([req-path (list-ref req-path/pr 0)] (define req-path (list-ref req-path/pr 0))
[id (list-ref req-path/pr 1)] (define id (list-ref req-path/pr 1))
[source-req-path (list-ref source-req-path/pr 3)] (define source-req-path (list-ref source-req-path/pr 3))
[source-id (list-ref source-req-path/pr 1)] (define source-id (list-ref source-req-path/pr 1))
[req-phase-level (list-ref req-path/pr 2)] (define req-phase-level (list-ref req-path/pr 2))
[unused (hash-ref! unused/phases req-phase-level (λ () (make-hash)))] (define require-ht (hash-ref! phase-to-requires req-phase-level #f))
[requires (hash-ref! phase-to-requires req-phase-level (λ () (make-hash)))] (when require-ht
[req-stxes (hash-ref requires req-path (λ () #f))]) (define req-stxes (hash-ref require-ht req-path #f))
(when req-stxes (when req-stxes
(hash-remove! unused req-path) (define unused (hash-ref! unused/phases req-phase-level #f))
(for ([req-stx (in-list req-stxes)]) (when unused (hash-remove! unused req-path))
(when (id/require-match? (syntax->datum var) (for ([req-stx (in-list req-stxes)])
id (when (id/require-match? (syntax->datum var)
(syntax->datum req-stx)) id
(when id (syntax->datum req-stx))
(define filename (get-require-filename source-req-path user-namespace user-directory)) (when id
(when filename (define filename (get-require-filename source-req-path user-namespace user-directory))
(add-jump-to-definition (when filename
var (add-jump-to-definition
source-id var
filename))) source-id
(add-mouse-over var filename)))
(format (define raw-module-path (phaseless-spec->raw-module-path req-stx))
(string-constant cs-mouse-over-import) (add-mouse-over var
(syntax-e var) (format
req-path)) (string-constant cs-mouse-over-import)
(connect-syntaxes req-stx var actual? (syntax-e var)
(id-level phase-level var) req-path))
connections)))))))))) (connect-syntaxes (if (syntax-source raw-module-path)
raw-module-path
req-stx)
var actual?
(id-level phase-level var)
connections))))))))
(define (id/require-match? var id req-stx) (define (id/require-match? var id req-stx)
(match req-stx (match req-stx
[`(only ,_ . ,ids) [`(only ,_ . ,ids)
@ -632,6 +629,15 @@
(eq? local-id var)] (eq? local-id var)]
[else (eq? var id)])) [else (eq? var id)]))
(define (phaseless-spec->raw-module-path stx)
(syntax-case* stx (only prefix all-expect prefix-all-except rename) symbolic-compare?
[(only raw-module-path id ...) #'raw-module-path]
[(prefix prefix-id raw-module-path) #'raw-module-path]
[(all-except raw-module-path id ...) #'raw-module-path]
[(prefix-all-except prefix-id raw-module-path id ...) #'raw-module-path]
[(rename raw-module-path local-id exported-id) #'raw-module-path]
[_ stx]))
;; get-module-req-path : binding number [#:nominal? boolean] -> (union #f (list require-sexp sym ?? module-path)) ;; get-module-req-path : binding number [#:nominal? boolean] -> (union #f (list require-sexp sym ?? module-path))
;; argument is the result of identifier-binding or identifier-transformer-binding ;; argument is the result of identifier-binding or identifier-transformer-binding

12
collects/tests/drracket/syncheck-test.rkt
View File

@ -730,7 +730,7 @@
("x:foldl" imported-variable) ("x:foldl" imported-variable)
(")" default-color)) (")" default-color))
(list '((10 18) (20 27)) (list '((10 18) (20 27))
'((28 50) (52 59)))) '((39 49) (52 59))))
(build-test "(module m mzscheme (require (prefix x: mzlib/list) mzlib/list) x:foldl foldl)" (build-test "(module m mzscheme (require (prefix x: mzlib/list) mzlib/list) x:foldl foldl)"
'(("(" default-color) '(("(" default-color)
@ -743,7 +743,7 @@
("foldl" imported-variable) ("foldl" imported-variable)
(")" default-color)) (")" default-color))
(list '((10 18) (20 27)) (list '((10 18) (20 27))
'((28 50) (63 70)) '((39 49) (63 70))
'((51 61) (71 76)))) '((51 61) (71 76))))
(build-test "(module m mzscheme (require (only mzlib/list foldr) (only mzlib/list foldl)) foldl foldr)" (build-test "(module m mzscheme (require (only mzlib/list foldr) (only mzlib/list foldl)) foldl foldr)"
@ -757,8 +757,8 @@
("foldr" imported-variable) ("foldr" imported-variable)
(")" default-color)) (")" default-color))
(list '((10 18) (20 27)) (list '((10 18) (20 27))
'((28 51) (83 88)) '((34 44) (83 88))
'((52 75) (77 82)))) '((58 68) (77 82))))
(build-test "(module m mzscheme (require (prefix x: mzscheme)) x:+ +)" (build-test "(module m mzscheme (require (prefix x: mzscheme)) x:+ +)"
'(("(" default-color) '(("(" default-color)
@ -771,8 +771,8 @@
("+" imported-variable) ("+" imported-variable)
(")" default-color)) (")" default-color))
(list '((10 18) (20 27) (54 55)) (list '((10 18) (20 27) (54 55))
'((28 48) (50 53)))) '((39 47) (50 53))))
(build-test "(module m mzscheme (require mzlib/etc) (rec f 1))" (build-test "(module m mzscheme (require mzlib/etc) (rec f 1))"
'(("(" default-color) '(("(" default-color)
("module" imported-syntax) ("module" imported-syntax)