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

adjust check syntax to work with the new begin-for-syntax

Browse Source
This commit is contained in:
Robby Findler 2011-09-10 10:56:49 -05:00
parent c589e1890f
commit cd1c96d596
3 changed files with 296 additions and 317 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/drracket/private/syncheck/online-comp.rkt
View File

@ -50,6 +50,16 @@
(void (get-xref)) ;; do this now so that it doesn't get killed during a call to 'go' (void (get-xref)) ;; do this now so that it doesn't get killed during a call to 'go'
(define (go expanded path the-source) (define (go expanded path the-source)
(with-handlers ((exn:fail? (λ (x)
(printf "~a\n" (exn-message x))
(printf "---\n")
(for ([x (in-list
(continuation-mark-set->context
(exn-continuation-marks
x)))])
(printf " ~s\n" x))
(printf "===\n")
(raise x))))
(define obj (new obj% [src the-source])) (define obj (new obj% [src the-source]))
(define-values (expanded-expression expansion-completed) (define-values (expanded-expression expansion-completed)
(make-traversal (current-namespace) (make-traversal (current-namespace)
@ -60,4 +70,4 @@
(parameterize ([current-annotations obj]) (parameterize ([current-annotations obj])
(expanded-expression expanded) (expanded-expression expanded)
(expansion-completed)) (expansion-completed))
(send obj get-trace)) (send obj get-trace)))

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

@ -11,8 +11,7 @@
racket/list racket/list
syntax/boundmap syntax/boundmap
scribble/xref scribble/xref
scribble/manual-struct scribble/manual-struct)
(for-syntax racket/base))
(provide make-traversal) (provide make-traversal)
@ -43,21 +42,14 @@
;; is called once for each top-level expression and the second ;; is called once for each top-level expression and the second
;; value is called once, after all expansion is complete. ;; value is called once, after all expansion is complete.
(define (make-traversal user-namespace user-directory) (define (make-traversal user-namespace user-directory)
(let* ([tl-low-binders (make-id-set)] (let* ([tl-phase-to-binders (make-hash)]
[tl-high-binders (make-id-set)] [tl-phase-to-varrefs (make-hash)]
[tl-low-varrefs (make-id-set)] [tl-phase-to-varsets (make-hash)]
[tl-high-varrefs (make-id-set)] [tl-phase-to-tops (make-hash)]
[tl-low-varsets (make-id-set)]
[tl-high-varsets (make-id-set)]
[tl-low-tops (make-id-set)]
[tl-high-tops (make-id-set)]
[tl-binding-inits (make-id-set)] [tl-binding-inits (make-id-set)]
[tl-templrefs (make-id-set)] [tl-templrefs (make-id-set)]
[tl-requires (make-hash)] [tl-phase-to-requires (make-hash)]
[tl-module-lang-requires (make-hash)] [tl-module-lang-requires (make-hash)]
[tl-require-for-syntaxes (make-hash)]
[tl-require-for-templates (make-hash)]
[tl-require-for-labels (make-hash)]
[expanded-expression [expanded-expression
(λ (sexp [visit-id void]) (λ (sexp [visit-id void])
(parameterize ([current-load-relative-directory user-directory]) (parameterize ([current-load-relative-directory user-directory])
@ -66,14 +58,11 @@
[else #f])]) [else #f])])
(cond (cond
[is-module? [is-module?
(let ([low-binders (make-id-set)] (let ([phase-to-binders (make-hash)]
[high-binders (make-id-set)] [phase-to-varrefs (make-hash)]
[varrefs (make-id-set)] [phase-to-varsets (make-hash)]
[high-varrefs (make-id-set)] [phase-to-tops (make-hash)]
[varsets (make-id-set)] [phase-to-requires (make-hash)]
[high-varsets (make-id-set)]
[low-tops (make-id-set)]
[high-tops (make-id-set)]
[binding-inits (make-id-set)] [binding-inits (make-id-set)]
[templrefs (make-id-set)] [templrefs (make-id-set)]
[module-lang-requires (make-hash)] [module-lang-requires (make-hash)]
@ -83,64 +72,49 @@
[require-for-labels (make-hash)]) [require-for-labels (make-hash)])
(annotate-basic sexp (annotate-basic sexp
user-namespace user-directory visit-id user-namespace user-directory visit-id
low-binders high-binders phase-to-binders
varrefs high-varrefs phase-to-varrefs
varsets high-varsets phase-to-varsets
low-tops high-tops phase-to-tops
binding-inits binding-inits
templrefs templrefs
module-lang-requires module-lang-requires
requires require-for-syntaxes require-for-templates require-for-labels) phase-to-requires)
(annotate-variables user-namespace (annotate-variables user-namespace
user-directory user-directory
low-binders phase-to-binders
high-binders phase-to-varrefs
varrefs phase-to-varsets
high-varrefs phase-to-tops
varsets
high-varsets
low-tops
high-tops
templrefs templrefs
module-lang-requires module-lang-requires
requires phase-to-requires)
require-for-syntaxes (annotate-contracts sexp
require-for-templates (hash-ref phase-to-binders 0 (λ () (make-id-set)))
require-for-labels) binding-inits))]
(annotate-contracts sexp low-binders binding-inits))]
[else [else
(annotate-basic sexp (annotate-basic sexp
user-namespace user-directory visit-id user-namespace user-directory visit-id
tl-low-binders tl-high-binders tl-phase-to-binders
tl-low-varrefs tl-high-varrefs tl-phase-to-varrefs
tl-low-varsets tl-high-varsets tl-phase-to-varsets
tl-low-tops tl-high-tops tl-phase-to-tops
tl-binding-inits tl-binding-inits
tl-templrefs tl-templrefs
tl-module-lang-requires tl-module-lang-requires
tl-requires tl-phase-to-requires)]))))]
tl-require-for-syntaxes
tl-require-for-templates
tl-require-for-labels)]))))]
[expansion-completed [expansion-completed
(λ () (λ ()
(parameterize ([current-load-relative-directory user-directory]) (parameterize ([current-load-relative-directory user-directory])
(annotate-variables user-namespace (annotate-variables user-namespace
user-directory user-directory
tl-low-binders tl-phase-to-binders
tl-high-binders tl-phase-to-varrefs
tl-low-varrefs tl-phase-to-varsets
tl-high-varrefs tl-phase-to-tops
tl-low-varsets
tl-high-varsets
tl-low-tops
tl-high-tops
tl-templrefs tl-templrefs
tl-module-lang-requires tl-module-lang-requires
tl-requires tl-phase-to-requires)))])
tl-require-for-syntaxes
tl-require-for-templates
tl-require-for-labels)))])
(values expanded-expression expansion-completed))) (values expanded-expression expansion-completed)))
@ -156,26 +130,26 @@
;; -> void ;; -> void
(define (annotate-basic sexp (define (annotate-basic sexp
user-namespace user-directory visit-id user-namespace user-directory visit-id
low-binders high-binders phase-to-binders
low-varrefs high-varrefs phase-to-varrefs
low-varsets high-varsets phase-to-varsets
low-tops high-tops phase-to-tops
binding-inits binding-inits
templrefs templrefs
module-lang-requires module-lang-requires
requires require-for-syntaxes require-for-templates require-for-labels) phase-to-requires)
(let ([tail-ht (make-hasheq)] (let ([tail-ht (make-hasheq)]
[maybe-jump (λ (vars) (visit-id vars))]) [maybe-jump (λ (vars) (visit-id vars))])
(let level-loop ([sexp sexp] (let level-loop ([sexp sexp]
[high-level? #f]) [level 0])
(let* ([loop (λ (sexp) (level-loop sexp level))]
(let* ([loop (λ (sexp) (level-loop sexp high-level?))] [varrefs (lookup-phase-to-mapping phase-to-varrefs level)]
[varrefs (if high-level? high-varrefs low-varrefs)] [varsets (lookup-phase-to-mapping phase-to-varsets level)]
[varsets (if high-level? high-varsets low-varsets)] [binders (lookup-phase-to-mapping phase-to-binders level)]
[binders (if high-level? high-binders low-binders)] [tops (lookup-phase-to-mapping phase-to-tops level)]
[tops (if high-level? high-tops low-tops)] [requires (hash-ref! phase-to-requires level (λ () (make-hash)))]
[collect-general-info [collect-general-info
(λ (stx) (λ (stx)
(add-origins stx varrefs) (add-origins stx varrefs)
@ -187,7 +161,7 @@
#%plain-app #%top #%plain-module-begin #%plain-app #%top #%plain-module-begin
define-values define-syntaxes begin-for-syntax module define-values define-syntaxes begin-for-syntax module
#%require #%provide #%expression) #%require #%provide #%expression)
(if high-level? free-transformer-identifier=? free-identifier=?) (λ (x y) (free-identifier=?/phases x level y 0))
[(#%plain-lambda args bodies ...) [(#%plain-lambda args bodies ...)
(begin (begin
(annotate-raw-keyword sexp varrefs) (annotate-raw-keyword sexp varrefs)
@ -316,11 +290,11 @@
(annotate-raw-keyword sexp varrefs) (annotate-raw-keyword sexp varrefs)
(add-binders (syntax names) binders binding-inits #'exp) (add-binders (syntax names) binders binding-inits #'exp)
(maybe-jump (syntax names)) (maybe-jump (syntax names))
(level-loop (syntax exp) #t))] (level-loop (syntax exp) (+ level 1)))]
[(begin-for-syntax exp ...) [(begin-for-syntax exp ...)
(begin (begin
(annotate-raw-keyword sexp varrefs) (annotate-raw-keyword sexp varrefs)
(for-each (lambda (e) (level-loop e #t)) (syntax->list (syntax (exp ...)))))] (for-each (lambda (e) (level-loop e (+ level 1))) (syntax->list (syntax (exp ...)))))]
[(module m-name lang (#%plain-module-begin bodies ...)) [(module m-name lang (#%plain-module-begin bodies ...))
(begin (begin
(annotate-raw-keyword sexp varrefs) (annotate-raw-keyword sexp varrefs)
@ -333,7 +307,8 @@
; top level or module top level only: ; top level or module top level only:
[(#%require require-specs ...) [(#%require require-specs ...)
(let ([at-phase (let ([at-phase
(lambda (stx requires) (lambda (stx level)
(define requires (hash-ref! phase-to-requires level (λ () (make-hash))))
(syntax-case stx () (syntax-case stx ()
[(_ require-specs ...) [(_ require-specs ...)
(with-syntax ([((require-specs ...) ...) (with-syntax ([((require-specs ...) ...)
@ -352,31 +327,27 @@
(for-each (add-require-spec requires) (for-each (add-require-spec requires)
new-specs new-specs
(syntax->list (syntax (require-specs ... ...))))))]))]) (syntax->list (syntax (require-specs ... ...))))))]))])
(for-each (lambda (spec) (for ([spec (in-list (syntax->list #'(require-specs ...)))])
(let loop ([spec spec]) (let loop ([spec spec]
[level level])
(define (add-to-level n) (and n level (+ n level)))
(syntax-case* spec (for-syntax for-template for-label for-meta just-meta) (syntax-case* spec (for-syntax for-template for-label for-meta just-meta)
(lambda (a b) (lambda (a b)
(eq? (syntax-e a) (syntax-e b))) (eq? (syntax-e a) (syntax-e b)))
[(just-meta phase specs ...) [(just-meta phase specs ...)
(for-each loop (syntax->list #'(specs ...)))] (for ([spec (in-list (syntax->list #'(specs ...)))])
(loop spec (add-to-level (syntax-e #'phase))))]
[(for-meta phase specs ...)
(for ([spec (in-list (syntax->list #'(specs ...)))])
(loop spec (add-to-level (syntax-e #'phase))))]
[(for-syntax specs ...) [(for-syntax specs ...)
(at-phase spec require-for-syntaxes)] (at-phase spec (add-to-level 1))]
[(for-meta 1 specs ...)
(at-phase #'(for-syntax specs ...) require-for-syntaxes)]
[(for-template specs ...) [(for-template specs ...)
(at-phase spec require-for-templates)] (at-phase spec (add-to-level -1))]
[(for-meta -1 specs ...)
(at-phase #'(for-template specs ...) require-for-templates)]
[(for-label specs ...) [(for-label specs ...)
(at-phase spec require-for-labels)] (at-phase spec #f)]
[(for-meta #f specs ...)
(at-phase #'(for-label specs ...) require-for-labels)]
[(for-meta 0 specs ...)
(at-phase #'(for-run specs ...) requires)]
[(for-meta . _) (void)]
[else [else
(at-phase (list #f spec) requires)]))) (at-phase (list #f spec) level)]))))]
(syntax->list #'(require-specs ...))))]
; module top level only: ; module top level only:
[(#%provide provide-specs ...) [(#%provide provide-specs ...)
@ -411,6 +382,33 @@
(void))]))) (void))])))
(add-tail-ht-links tail-ht))) (add-tail-ht-links tail-ht)))
;; free-identifier=?/phases : id phase-level id phase-level -> boolean
;; Determines whether x has the same binding at phase-level phase-x
;; that y has at phase-level y.
;; At least one of the identifiers MUST have a binding (module or lexical)
(define (free-identifier=?/phases x phase-x y phase-y)
(cond [(eqv? phase-x phase-y)
(free-identifier=? x y phase-x)]
[else
(let ([bx (identifier-binding x phase-x)]
[by (identifier-binding y phase-y)])
(cond [(and (pair? bx) (pair? by))
(let ([mpix (first bx)]
[namex (second bx)]
[defphasex (fifth bx)]
[mpiy (first by)]
[namey (second by)]
[defphasey (fifth by)])
(and (eq? namex namey)
;; resolved-module-paths are interned
(eq? (module-path-index-resolve mpix)
(module-path-index-resolve mpiy))
(eqv? defphasex defphasey)))]
[else
;; Module is only way to get phase-shift; phases differ, so
;; if not module-bound names, no way can refer to same binding.
#f]))]))
(define (hash-cons! ht k v) (define (hash-cons! ht k v)
(hash-set! ht k (cons v (hash-ref ht k '())))) (hash-set! ht k (cons v (hash-ref ht k '()))))
@ -459,149 +457,102 @@
;; in the various id-sets ;; in the various id-sets
(define (annotate-variables user-namespace (define (annotate-variables user-namespace
user-directory user-directory
low-binders phase-to-binders
high-binders phase-to-varrefs
low-varrefs phase-to-varsets
high-varrefs phase-to-tops
low-varsets
high-varsets
low-tops
high-tops
templrefs templrefs
module-lang-requires module-lang-requires
requires phase-to-requires)
require-for-syntaxes
require-for-templates
require-for-labels)
(let ([unused-requires (make-hash)] (let ([unused-requires (make-hash)]
[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)])
[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) (for ([(level hash) (in-hash phase-to-requires)])
(hash-set! requires/phases 1 require-for-syntaxes) (define new-hash (make-hash))
(hash-set! requires/phases -1 require-for-templates) (hash-set! unused/phases level new-hash)
(hash-set! requires/phases #f require-for-labels) (for ([(k v) (in-hash hash)])
(hash-set! new-hash k #t)))
(hash-set! unused/phases 0 unused-requires) (for ([(level binders) (in-hash phase-to-binders)])
(hash-set! unused/phases 1 unused-require-for-syntaxes) (for ([vars (in-list (get-idss binders))])
(hash-set! unused/phases -1 unused-require-for-templates) (for ([var (in-list vars)])
(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
(λ (k v) (hash-set! unused-require-for-syntaxes k #t)))
(hash-for-each require-for-templates
(lambda (k v) (hash-set! unused-require-for-templates k #t)))
(hash-for-each require-for-labels
(lambda (k v) (hash-set! unused-require-for-labels k #t)))
(let ([handle-var-bind
(λ (var varsets)
(when (syntax-original? var) (when (syntax-original? var)
(color-variable var 0 varsets) (define varset (lookup-phase-to-mapping phase-to-varsets level))
(document-variable var 0)))]) (color-variable var 0 varset)
(for-each (λ (vars) (document-variable var 0)))))
(for-each (λ (var) (handle-var-bind var high-varsets))
vars))
(get-idss high-binders))
(for-each (λ (vars)
(for-each (λ (var) (handle-var-bind var low-varsets))
vars))
(get-idss low-binders)))
(for ([(level varrefs) (in-hash phase-to-varrefs)])
(let ([handle-var-ref (define binders (lookup-phase-to-mapping phase-to-binders level))
(λ (var index binders varsets) (define varsets (lookup-phase-to-mapping phase-to-varsets level))
(color-variable var index varsets) (for ([vars (in-list (get-idss varrefs))])
(for ([var (in-list vars)])
(color-variable var level varsets)
(when (syntax-original? var) (when (syntax-original? var)
(document-variable var index)) (document-variable var level))
(connect-identifier var (connect-identifier var
binders binders
unused/phases unused/phases
requires/phases phase-to-requires
index level
user-namespace user-namespace
user-directory user-directory
#t))]) #t))))
(for-each (λ (vars) (for-each
(λ (var) (handle-var-ref var 0 low-binders low-varsets))
vars))
(get-idss low-varrefs))
(for-each (λ (vars) (for-each (for ([vars (in-list (get-idss templrefs))])
(λ (var) (handle-var-ref var 1 high-binders high-varsets)) (for ([var (in-list vars)])
vars))
(get-idss high-varrefs)))
(for-each (lambda (vars) (for-each ;; build a set of all of the known phases
(lambda (var) (define phases (set))
;; no color variable (for ([phase (in-list (hash-keys phase-to-binders))])
(set! phases (set-add phases phase)))
(for ([phase (in-list (hash-keys phase-to-requires))])
(set! phases (set-add phases phase)))
;; connect every identifier inside a quote-syntax to each binder at any phase
(for ([phase (in-set phases)])
(connect-identifier var (connect-identifier var
low-binders (lookup-phase-to-mapping phase-to-binders phase)
unused/phases unused/phases
requires/phases phase-to-requires
0 phase
user-namespace user-namespace
user-directory user-directory
#f) #f))
#;
(connect-identifier var (connect-identifier var
high-binders (make-id-set) ;; dummy; always empty
unused/phases unused/phases
requires/phases phase-to-requires
1
user-namespace
user-directory
#f)
(connect-identifier var
template-binders ;; dummy; always empty
unused/phases
requires/phases
-1 -1
user-namespace user-namespace
user-directory user-directory
#f) #f)
#;
(connect-identifier var (connect-identifier var
label-binders ;; dummy; always empty (make-id-set) ;; dummy; always empty
unused/phases unused/phases
requires/phases phase-to-requires
#f #f
user-namespace user-namespace
user-directory user-directory
#f)) #f)))
vars))
(get-idss templrefs))
(for-each (for ([(level tops) (in-hash phase-to-tops)])
(λ (vars) (define binders (lookup-phase-to-mapping phase-to-binders level))
(for-each (for ([vars (in-list (get-idss tops))])
(λ (var) (for ([var (in-list vars)])
(color/connect-top user-namespace user-directory low-binders var)) (color/connect-top user-namespace user-directory binders var))))
vars))
(get-idss low-tops))
(for-each (for ([(level require-hash) (in-hash phase-to-requires)])
(λ (vars) (define unused-hash (hash-ref unused/phases level))
(for-each (color-unused require-hash unused-hash module-lang-requires))
(λ (var)
(color/connect-top user-namespace user-directory high-binders var))
vars))
(get-idss high-tops))
(color-unused require-for-labels unused-require-for-labels module-lang-requires) (make-rename-menus (list phase-to-binders phase-to-varrefs phase-to-tops))))
(color-unused require-for-templates unused-require-for-templates module-lang-requires)
(color-unused require-for-syntaxes unused-require-for-syntaxes module-lang-requires)
(color-unused requires unused-requires module-lang-requires)
(make-rename-menus id-sets)))
;; color-unused : hash-table[sexp -o> syntax] hash-table[sexp -o> #f] hash-table[syntax -o> #t] -> void ;; color-unused : hash-table[sexp -o> syntax] hash-table[sexp -o> #f] hash-table[syntax -o> #t] -> void
(define (color-unused requires unused module-lang-requires) (define (color-unused requires unused module-lang-requires)
@ -621,25 +572,9 @@
(send defs-text syncheck:add-background-color (send defs-text syncheck:add-background-color
source-editor start fin "firebrick"))) source-editor start fin "firebrick")))
(color stx unused-require-style-name 'default-mode))) (color stx unused-require-style-name 'default-mode)))
(hash-ref requires k))))) (hash-ref requires k
(λ ()
;; connect-identifier : syntax (error 'syncheck/traversals.rkt "requires doesn't have a mapping for ~s" k)))))))
;; id-set
;; (union #f hash-table)
;; (union #f hash-table)
;; integer or 'lexical or #f
;; (listof id-set)
;; namespace
;; directory
;; boolean
;; -> void
;; adds arrows and rename menus for binders/bindings
(define (connect-identifier var all-binders
unused/phases requires/phases
phase-level user-namespace user-directory actual?)
(connect-identifier/arrow var all-binders
unused/phases requires/phases
phase-level user-namespace user-directory actual?))
;; id-level : integer-or-#f-or-'lexical identifier -> symbol ;; id-level : integer-or-#f-or-'lexical identifier -> symbol
(define (id-level phase-level id) (define (id-level phase-level id)
@ -654,7 +589,7 @@
[(eq? binding 'lexical) 'lexical] [(eq? binding 'lexical) 'lexical]
[else 'top-level]))) [else 'top-level])))
;; connect-identifier/arrow : syntax ;; connect-identifier : syntax
;; id-set ;; id-set
;; (union #f hash-table) ;; (union #f hash-table)
;; (union #f hash-table) ;; (union #f hash-table)
@ -662,7 +597,8 @@
;; 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/phases requires/phases phase-level user-namespace user-directory actual?) (define (connect-identifier var all-binders unused/phases phase-to-requires
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)
@ -670,7 +606,7 @@
(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/phases requires/phases) (when (and unused/phases phase-to-requires)
(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)] phase-level)]
[source-req-path/pr (get-module-req-path (identifier-binding var phase-level) [source-req-path/pr (get-module-req-path (identifier-binding var phase-level)
@ -682,8 +618,8 @@
[source-req-path (list-ref source-req-path/pr 3)] [source-req-path (list-ref source-req-path/pr 3)]
[source-id (list-ref source-req-path/pr 1)] [source-id (list-ref source-req-path/pr 1)]
[req-phase-level (list-ref req-path/pr 2)] [req-phase-level (list-ref req-path/pr 2)]
[unused (hash-ref unused/phases req-phase-level)] [unused (hash-ref! unused/phases req-phase-level (λ () (make-hash)))]
[requires (hash-ref requires/phases req-phase-level)] [requires (hash-ref! phase-to-requires req-phase-level (λ () (make-hash)))]
[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)
@ -763,7 +699,7 @@
(color var free-variable-style-name 'default-mode)) (color var free-variable-style-name 'default-mode))
(connect-identifier var binders #f #f 0 user-namespace user-directory #t))) (connect-identifier var binders #f #f 0 user-namespace user-directory #t)))
;; color-variable : syntax phase-level module-identifier-mapping -> void ;; color-variable : syntax phase-level identifier-mapping -> void
(define (color-variable var phase-level varsets) (define (color-variable var phase-level varsets)
(let* ([b (identifier-binding var phase-level)] (let* ([b (identifier-binding var phase-level)]
[lexical? [lexical?
@ -1212,12 +1148,13 @@
; ;;; ; ;;;
;; make-rename-menus : (listof id-set) -> void ;; make-rename-menus : (listof phase-to-mapping) -> void
(define (make-rename-menus id-sets) (define (make-rename-menus phase-tos)
(define id-to-sets (make-module-identifier-mapping)) (define id-to-sets (make-free-identifier-mapping))
(let ([defs-text (current-annotations)]) (let ([defs-text (current-annotations)])
(when defs-text (when defs-text
(for ([id-set (in-list id-sets)]) (for ([phase-to-mapping (in-list phase-tos)])
(for ([(level id-set) (in-hash phase-to-mapping)])
(for-each-ids (for-each-ids
id-set id-set
(λ (vars) (λ (vars)
@ -1230,20 +1167,22 @@
(define start (- pos 1)) (define start (- pos 1))
(define fin (+ start span)) (define fin (+ start span))
(define loc (list ed start fin)) (define loc (list ed start fin))
(module-identifier-mapping-put! (free-identifier-mapping-put!
id-to-sets id-to-sets
var var
(set-add (module-identifier-mapping-get id-to-sets var set) (set-add (free-identifier-mapping-get id-to-sets var set)
loc)))))))) loc)))))))))
(module-identifier-mapping-for-each (free-identifier-mapping-for-each
id-to-sets id-to-sets
(λ (id locs) (λ (id locs)
(define (name-dup? new-str) (define (name-dup? new-str)
(and (for/or ([id-set (in-list id-sets)]) (and (for/or ([phase-to-map (in-list phase-tos)])
(for/or ([(level id-set) (in-hash phase-to-map)])
(for/or ([id (in-list (or (get-ids id-set id) '()))]) (for/or ([id (in-list (or (get-ids id-set id) '()))])
(let ([new-id (datum->syntax id (string->symbol new-str))]) (let ([new-id (datum->syntax id (string->symbol new-str))])
(for/or ([id-set (in-list id-sets)]) (for/or ([phase-to-map (in-list phase-tos)])
(get-ids id-set new-id))))) (for/or ([(level id-set) (in-hash phase-to-map)])
(get-ids id-set new-id)))))))
#t)) #t))
(define loc-lst (set->list locs)) (define loc-lst (set->list locs))
(define id-as-sym (syntax-e id)) (define id-as-sym (syntax-e id))
@ -1286,33 +1225,33 @@
; ;
; ;
(define (lookup-phase-to-mapping phase-to n)
(hash-ref! phase-to n (λ () (make-id-set))))
;; make-id-set : -> id-set ;; make-id-set : -> id-set
(define (make-id-set) (make-module-identifier-mapping)) (define (make-id-set) (make-free-identifier-mapping))
;; add-init-exp : id-set identifier stx -> void ;; add-init-exp : id-set identifier stx -> void
(define (add-init-exp mapping id init-exp) (define (add-init-exp mapping id init-exp)
(let* ([old (module-identifier-mapping-get mapping id (λ () '()))] (let* ([old (free-identifier-mapping-get mapping id (λ () '()))]
[new (cons init-exp old)]) [new (cons init-exp old)])
(module-identifier-mapping-put! mapping id new))) (free-identifier-mapping-put! mapping id new)))
;; add-id : id-set identifier -> void ;; add-id : id-set identifier -> void
(define (add-id mapping id) (define (add-id mapping id)
(let* ([old (module-identifier-mapping-get mapping id (λ () '()))] (let* ([old (free-identifier-mapping-get mapping id (λ () '()))]
[new (cons id old)]) [new (cons id old)])
(module-identifier-mapping-put! mapping id new))) (free-identifier-mapping-put! mapping id new)))
;; get-idss : id-set -> (listof (listof identifier)) ;; get-idss : id-set -> (listof (listof identifier))
(define (get-idss mapping) (define (get-idss mapping)
(module-identifier-mapping-map mapping (λ (x y) y))) (free-identifier-mapping-map mapping (λ (x y) y)))
;; get-ids : id-set identifier -> (union (listof identifier) #f) ;; get-ids : id-set identifier -> (union (listof identifier) #f)
(define (get-ids mapping var) (define (get-ids mapping var)
(module-identifier-mapping-get mapping var (λ () #f))) (free-identifier-mapping-get mapping var (λ () #f)))
;; for-each-ids : id-set ((listof identifier) -> void) -> void ;; for-each-ids : id-set ((listof identifier) -> void) -> void
(define (for-each-ids mapping f) (define (for-each-ids mapping f)
(module-identifier-mapping-for-each mapping (λ (x y) (f y)))) (free-identifier-mapping-for-each mapping (λ (x y) (f y))))

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

@ -876,6 +876,30 @@ trigger runtime errors in check syntax.
("1))" default-color)) ("1))" default-color))
(list '((27 33) (19 26) (36 49) (53 59) (64 66)))) (list '((27 33) (19 26) (36 49) (53 59) (64 66))))
(build-test "#lang racket (begin-for-syntax (require (for-syntax racket)) (define x 1) (begin-for-syntax (define x 2) x))"
'(("#lang racket (" default-color)
("begin-for-syntax" imported)
(" (" default-color)
("require" imported)
(" (for-syntax " default-color)
("racket" default-color)
(")) (" default-color)
("define" imported)
(" " default-color)
("x" lexically-bound)
(" 1) (" default-color)
("begin-for-syntax" imported)
(" (" default-color)
("define" imported)
(" " default-color)
("x" lexically-bound)
(" 2) " default-color)
("x" lexically-bound)
("))" default-color))
(list '((6 12) (14 30) (32 39) (62 68) (75 91))
'((52 58) (93 99))
'((100 101) (105 106))))
(rename-test "(lambda (x) x)" (rename-test "(lambda (x) x)"
9 9
"x" "x"
@ -976,7 +1000,13 @@ trigger runtime errors in check syntax.
(fire-up-drscheme-and-run-tests (fire-up-drscheme-and-run-tests
(λ () (λ ()
(let ([drs (wait-for-drscheme-frame)]) (let ([drs (wait-for-drscheme-frame)])
(set-language-level! (list "Pretty Big")) ;(set-language-level! (list "Pretty Big"))
(begin
(set-language-level! (list "Pretty Big") #f)
(test:set-radio-box-item! "No debugging or profiling")
(let ([f (test:get-active-top-level-window)])
(test:button-push "OK")
(wait-for-new-frame f)))
(do-execute drs) (do-execute drs)
(let* ([defs (queue-callback/res (λ () (send drs get-definitions-text)))] (let* ([defs (queue-callback/res (λ () (send drs get-definitions-text)))]
[filename (make-temporary-file "syncheck-test~a")]) [filename (make-temporary-file "syncheck-test~a")])