fixed a problem with arrow-based requires
svn: r13808
This commit is contained in:
Robby Findler
parent
5a1f31668d
commit
ab47ac0f10
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user