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

fixed a problem with arrow-based requires

Browse Source 
svn: r13808
This commit is contained in:
Robby Findler 2009-02-24 00:03:57 +00:00
parent 5a1f31668d
commit ab47ac0f10
2 changed files with 82 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

98
collects/drscheme/syncheck.ss
View File

@ -1499,7 +1499,7 @@ If the namespace does not, they are colored the unbound color.
(λ (vars) (λ (vars)
(when jump-to-id (when jump-to-id
(for-each (λ (id) (for-each (λ (id)
(let ([binding (identifier-binding id)]) (let ([binding (identifier-binding id 0)])
(when (pair? binding) (when (pair? binding)
(let ([nominal-source-id (list-ref binding 3)]) (let ([nominal-source-id (list-ref binding 3)])
(when (eq? nominal-source-id jump-to-id) (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 ;; tops are used here because a binding free use of a set!'d variable
;; is treated just the same as (#%top . x). ;; is treated just the same as (#%top . x).
(when (syntax-original? (syntax var)) (when (syntax-original? (syntax var))
(if (identifier-binding (syntax var)) (if (identifier-binding (syntax var) 0)
(add-id varrefs (syntax var)) (add-id varrefs (syntax var))
(add-id tops (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-syntaxes (make-hash)]
[unused-require-for-templates (make-hash)] [unused-require-for-templates (make-hash)]
[unused-require-for-labels (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 ;; there is no define-for-template form, thus no for-template binders
[template-binders (make-id-set)] [template-binders (make-id-set)]
[label-binders (make-id-set)] [label-binders (make-id-set)]
[id-sets (list low-binders high-binders low-varrefs high-varrefs low-tops high-tops)]) [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 (hash-for-each requires
(λ (k v) (hash-set! unused-requires k #t))) (λ (k v) (hash-set! unused-requires k #t)))
(hash-for-each require-for-syntaxes (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 (λ (vars)
(for-each (λ (var) (for-each (λ (var)
(when (syntax-original? var) (when (syntax-original? var)
(color-variable var identifier-binding) (color-variable var 0)
(document-variable var identifier-binding) (document-variable var 0)
(record-renamable-var rename-ht var))) (record-renamable-var rename-ht var)))
vars)) vars))
(append (get-idss high-binders) (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 (for-each (λ (vars) (for-each
(λ (var) (λ (var)
(color-variable var identifier-binding) (color-variable var 0)
(document-variable var identifier-binding) (document-variable var 0)
(connect-identifier var (connect-identifier var
rename-ht rename-ht
low-binders low-binders
unused-requires unused/phases
requires requires/phases
0 0
user-namespace user-namespace
user-directory user-directory
@ -1855,13 +1867,13 @@ If the namespace does not, they are colored the unbound color.
(for-each (λ (vars) (for-each (for-each (λ (vars) (for-each
(λ (var) (λ (var)
(color-variable var identifier-transformer-binding) (color-variable var 1)
(document-variable var identifier-transformer-binding) (document-variable var 1)
(connect-identifier var (connect-identifier var
rename-ht rename-ht
high-binders high-binders
unused-require-for-syntaxes unused/phases
require-for-syntaxes requires/phases
1 1
user-namespace user-namespace
user-directory user-directory
@ -1875,8 +1887,8 @@ If the namespace does not, they are colored the unbound color.
(connect-identifier var (connect-identifier var
rename-ht rename-ht
low-binders low-binders
unused-requires unused/phases
requires requires/phases
0 0
user-namespace user-namespace
user-directory user-directory
@ -1884,8 +1896,8 @@ If the namespace does not, they are colored the unbound color.
(connect-identifier var (connect-identifier var
rename-ht rename-ht
high-binders high-binders
unused-require-for-syntaxes unused/phases
require-for-syntaxes requires/phases
1 1
user-namespace user-namespace
user-directory user-directory
@ -1893,8 +1905,8 @@ If the namespace does not, they are colored the unbound color.
(connect-identifier var (connect-identifier var
rename-ht rename-ht
template-binders ;; dummy; always empty template-binders ;; dummy; always empty
unused-require-for-templates unused/phases
require-for-templates requires/phases
-1 -1
user-namespace user-namespace
user-directory user-directory
@ -1902,8 +1914,8 @@ If the namespace does not, they are colored the unbound color.
(connect-identifier var (connect-identifier var
rename-ht rename-ht
label-binders ;; dummy; always empty label-binders ;; dummy; always empty
unused-require-for-labels unused/phases
require-for-labels requires/phases
#f #f
user-namespace user-namespace
user-directory user-directory
@ -1960,9 +1972,11 @@ If the namespace does not, they are colored the unbound color.
;; -> void ;; -> void
;; adds arrows and rename menus for binders/bindings ;; adds arrows and rename menus for binders/bindings
(define (connect-identifier var rename-ht all-binders (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 (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)) (when (and actual? (get-ids all-binders var))
(record-renamable-var rename-ht var))) (record-renamable-var rename-ht var)))
@ -1987,7 +2001,7 @@ If the namespace does not, they are colored the unbound color.
;; boolean ;; boolean
;; -> void ;; -> void
;; adds the arrows that correspond to binders/bindings ;; 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)]) (let ([binders (get-ids all-binders var)])
(when binders (when binders
(for-each (λ (x) (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)))) (connect-syntaxes x var actual? (id-level phase-level x))))
binders)) binders))
(when (and unused requires) (when (and unused/phases requires/phases)
(let ([req-path/pr (get-module-req-path (identifier-binding var phase-level))]) (let ([req-path/pr (get-module-req-path (identifier-binding var phase-level)
phase-level)])
(when req-path/pr (when req-path/pr
(let* ([req-path (car req-path/pr)] (let* ([req-path (list-ref req-path/pr 0)]
[id (cdr req-path/pr)] [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))]) [req-stxes (hash-ref requires req-path (λ () #f))])
(when req-stxes (when req-stxes
(hash-remove! unused req-path) (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)) ;; get-module-req-path : binding -> (union #f (cons require-sexp sym))
;; argument is the result of identifier-binding or identifier-transformer-binding ;; 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) (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)]) (let ([mod-path (list-ref binding 2)])
(cond (cond
[(module-path-index? mod-path) [(module-path-index? mod-path)
(let-values ([(base offset) (module-path-index-split 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) [(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 ;; color/connect-top : namespace directory id-set syntax -> void
(define (color/connect-top rename-ht user-namespace user-directory binders var) (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)) (color var error-style-name))
(connect-identifier var rename-ht binders #f #f 0 user-namespace user-directory #t))) (connect-identifier var rename-ht binders #f #f 0 user-namespace user-directory #t)))
;; color-variable : syntax (union identifier-binding identifier-transformer-binding) -> void ;; color-variable : syntax phase-level -> void
(define (color-variable var get-binding) (define (color-variable var phase-level)
(let* ([b (get-binding var)] (let* ([b (identifier-binding var phase-level)]
[lexical? [lexical?
(or (not b) (or (not b)
(eq? b 'lexical) (eq? b 'lexical)
@ -2528,12 +2554,12 @@ If the namespace does not, they are colored the unbound color.
; ;
;; document-variable : stx identifier-binding -> void ;; document-variable : stx phase-level -> void
(define (document-variable stx get-binding) (define (document-variable stx phase-level)
(when (syntax-original? stx) (when (syntax-original? stx)
(let ([defs-text (currently-processing-definitions-text)]) (let ([defs-text (currently-processing-definitions-text)])
(when defs-text (when defs-text
(let ([binding-info (get-binding stx)]) (let ([binding-info (identifier-binding stx phase-level)])
(when (and (pair? binding-info) (when (and (pair? binding-info)
(syntax-position stx) (syntax-position stx)
(syntax-span stx)) (syntax-span stx))

21
collects/tests/drscheme/syncheck-test.ss
View File

@ -34,6 +34,7 @@ trigger runtime errors in check syntax.
;; tests : (listof test) ;; tests : (listof test)
(define tests (define tests
(list (list
(build-test "12345" (build-test "12345"
'(("12345" constant))) '(("12345" constant)))
(build-test "'abcdef" (build-test "'abcdef"
@ -829,7 +830,25 @@ trigger runtime errors in check syntax.
(" " default-color) (" " default-color)
("foldl" imported-variable) ("foldl" imported-variable)
(")" default-color)) (")" 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) (define (run-test)
(check-language-level #rx"Pretty") (check-language-level #rx"Pretty")