adjust check syntax to deal properly with submodules at non-zero phases
Thanks to Matthew for sorting this out. (Also removed a bunch of line-ended space chars since git yelled at me.)
This commit is contained in:
Robby Findler
parent
30a4b481dd
commit
f166934700
|
|
@ -149,6 +149,7 @@
|
|||
|
||||
(let level+tail+mod-loop ([stx-obj stx-obj]
|
||||
[level 0]
|
||||
[level-of-enclosing-module 0]
|
||||
[tail-parent-src #f]
|
||||
[tail-parent-pos #f]
|
||||
;; mods: (or/f #f ; => outside a module
|
||||
|
|
@ -170,23 +171,29 @@
|
|||
(values child-src child-pos)]
|
||||
[else
|
||||
(values tail-parent-src tail-parent-pos)])))
|
||||
(let* ([level-loop (λ (sexp level) (level+tail+mod-loop sexp level #f #f mods))]
|
||||
[tail-loop (λ (sexp) (level+tail+mod-loop sexp level next-tail-parent-src next-tail-parent-pos mods))]
|
||||
[mod-loop (λ (sexp mod) (level+tail+mod-loop sexp level #f #f
|
||||
(let* ([level-loop (λ (sexp level) (level+tail+mod-loop sexp level level-of-enclosing-module
|
||||
#f #f
|
||||
mods))]
|
||||
[tail-loop (λ (sexp) (level+tail+mod-loop sexp level level-of-enclosing-module
|
||||
next-tail-parent-src next-tail-parent-pos
|
||||
mods))]
|
||||
[mod-loop (λ (sexp mod) (level+tail+mod-loop sexp 0
|
||||
(+ level level-of-enclosing-module)
|
||||
#f #f
|
||||
(if mods
|
||||
(cons mod mods)
|
||||
'())))]
|
||||
[loop (λ (sexp) (level+tail+mod-loop sexp level #f #f mods))]
|
||||
[varrefs (lookup-phase-to-mapping phase-to-varrefs level)]
|
||||
[varsets (lookup-phase-to-mapping phase-to-varsets level)]
|
||||
[binders (lookup-phase-to-mapping phase-to-binders level)]
|
||||
[tops (lookup-phase-to-mapping phase-to-tops level)]
|
||||
[requires (hash-ref! phase-to-requires level (λ () (make-hash)))]
|
||||
[loop (λ (sexp) (level+tail+mod-loop sexp level level-of-enclosing-module #f #f mods))]
|
||||
[varrefs (lookup-phase-to-mapping phase-to-varrefs (+ level level-of-enclosing-module))]
|
||||
[varsets (lookup-phase-to-mapping phase-to-varsets (+ level level-of-enclosing-module))]
|
||||
[binders (lookup-phase-to-mapping phase-to-binders (+ level level-of-enclosing-module))]
|
||||
[tops (lookup-phase-to-mapping phase-to-tops (+ level level-of-enclosing-module))]
|
||||
[requires (hash-ref! phase-to-requires (+ level level-of-enclosing-module) (λ () (make-hash)))]
|
||||
[collect-general-info
|
||||
(λ (stx)
|
||||
(add-origins stx varrefs)
|
||||
(add-disappeared-bindings stx binders varrefs)
|
||||
(add-disappeared-uses stx varrefs))])
|
||||
(add-origins stx varrefs level-of-enclosing-module)
|
||||
(add-disappeared-bindings stx binders varrefs level-of-enclosing-module)
|
||||
(add-disappeared-uses stx varrefs level-of-enclosing-module))])
|
||||
(collect-general-info stx-obj)
|
||||
|
||||
(define (list-loop/tail-last bodies)
|
||||
|
|
@ -209,81 +216,81 @@
|
|||
(λ (x y) (free-identifier=? x y level 0))
|
||||
[(#%plain-lambda args bodies ...)
|
||||
(begin
|
||||
(annotate-raw-keyword stx-obj varrefs)
|
||||
(add-binders (syntax args) binders #f #f)
|
||||
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
||||
(add-binders (syntax args) binders #f #f level-of-enclosing-module)
|
||||
(list-loop/tail-last (syntax->list (syntax (bodies ...)))))]
|
||||
[(case-lambda [argss bodiess ...]...)
|
||||
(begin
|
||||
(annotate-raw-keyword stx-obj varrefs)
|
||||
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
||||
(for-each
|
||||
(λ (args bodies)
|
||||
(add-binders args binders #f #f)
|
||||
(add-binders args binders #f #f level-of-enclosing-module)
|
||||
(list-loop/tail-last (syntax->list bodies)))
|
||||
(syntax->list (syntax (argss ...)))
|
||||
(syntax->list (syntax ((bodiess ...) ...)))))]
|
||||
[(if test then else)
|
||||
(begin
|
||||
(annotate-raw-keyword stx-obj varrefs)
|
||||
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
||||
(loop (syntax test))
|
||||
(tail-loop (syntax then))
|
||||
(tail-loop (syntax else)))]
|
||||
[(begin bodies ...)
|
||||
(begin
|
||||
(annotate-raw-keyword stx-obj varrefs)
|
||||
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
||||
(list-loop/tail-last (syntax->list (syntax (bodies ...)))))]
|
||||
|
||||
;; treat a single body expression specially, since this has
|
||||
;; different tail behavior.
|
||||
[(begin0 body)
|
||||
(begin
|
||||
(annotate-raw-keyword stx-obj varrefs)
|
||||
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
||||
(tail-loop (syntax body)))]
|
||||
|
||||
[(begin0 bodies ...)
|
||||
(begin
|
||||
(annotate-raw-keyword stx-obj varrefs)
|
||||
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
||||
(for-each loop (syntax->list (syntax (bodies ...)))))]
|
||||
|
||||
[(let-values (bindings ...) bs ...)
|
||||
(begin
|
||||
(annotate-raw-keyword stx-obj varrefs)
|
||||
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
||||
(for-each collect-general-info (syntax->list (syntax (bindings ...))))
|
||||
(with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))])
|
||||
(for-each (λ (x es) (add-binders x binders binding-inits es))
|
||||
(for-each (λ (x es) (add-binders x binders binding-inits es level-of-enclosing-module))
|
||||
(syntax->list (syntax ((xss ...) ...)))
|
||||
(syntax->list (syntax (es ...))))
|
||||
(for-each loop (syntax->list (syntax (es ...))))
|
||||
(list-loop/tail-last (syntax->list (syntax (bs ...))))))]
|
||||
[(letrec-values (bindings ...) bs ...)
|
||||
(begin
|
||||
(annotate-raw-keyword stx-obj varrefs)
|
||||
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
||||
(for-each collect-general-info (syntax->list (syntax (bindings ...))))
|
||||
(with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))])
|
||||
(for-each (λ (x es) (add-binders x binders binding-inits es))
|
||||
(for-each (λ (x es) (add-binders x binders binding-inits es level-of-enclosing-module))
|
||||
(syntax->list (syntax ((xss ...) ...)))
|
||||
(syntax->list (syntax (es ...))))
|
||||
(for-each loop (syntax->list (syntax (es ...))))
|
||||
(list-loop/tail-last (syntax->list (syntax (bs ...))))))]
|
||||
[(set! var e)
|
||||
(begin
|
||||
(annotate-raw-keyword stx-obj varrefs)
|
||||
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
||||
|
||||
;; tops are used here because a binding free use of a set!'d variable
|
||||
;; is treated just the same as (#%top . x).
|
||||
(add-id varsets (syntax var))
|
||||
(add-id varsets (syntax var) level-of-enclosing-module)
|
||||
(if (identifier-binding (syntax var) 0)
|
||||
(add-id varrefs (syntax var))
|
||||
(add-id tops (syntax var)))
|
||||
(add-id varrefs (syntax var) level-of-enclosing-module)
|
||||
(add-id tops (syntax var) level-of-enclosing-module))
|
||||
|
||||
(loop (syntax e)))]
|
||||
[(quote datum)
|
||||
(annotate-raw-keyword stx-obj varrefs)]
|
||||
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)]
|
||||
[(quote-syntax datum)
|
||||
(begin
|
||||
(annotate-raw-keyword stx-obj varrefs)
|
||||
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
||||
(let loop ([stx #'datum])
|
||||
(cond [(identifier? stx)
|
||||
(add-id templrefs stx)]
|
||||
(add-id templrefs stx level-of-enclosing-module)]
|
||||
[(syntax? stx)
|
||||
(loop (syntax-e stx))]
|
||||
[(pair? stx)
|
||||
|
|
@ -296,37 +303,37 @@
|
|||
[else (void)])))]
|
||||
[(with-continuation-mark a b c)
|
||||
(begin
|
||||
(annotate-raw-keyword stx-obj varrefs)
|
||||
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
||||
(loop (syntax a))
|
||||
(loop (syntax b))
|
||||
(tail-loop (syntax c)))]
|
||||
[(#%plain-app pieces ...)
|
||||
(begin
|
||||
(annotate-raw-keyword stx-obj varrefs)
|
||||
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
||||
(for-each loop (syntax->list (syntax (pieces ...)))))]
|
||||
[(#%top . var)
|
||||
(begin
|
||||
(annotate-raw-keyword stx-obj varrefs)
|
||||
(add-id tops (syntax var)))]
|
||||
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
||||
(add-id tops (syntax var) level-of-enclosing-module))]
|
||||
[(define-values vars b)
|
||||
(begin
|
||||
(annotate-raw-keyword stx-obj varrefs)
|
||||
(add-binders (syntax vars) binders binding-inits #'b)
|
||||
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
||||
(add-binders (syntax vars) binders binding-inits #'b level-of-enclosing-module)
|
||||
(add-definition-target (syntax vars) mods)
|
||||
(loop (syntax b)))]
|
||||
[(define-syntaxes names exp)
|
||||
(begin
|
||||
(annotate-raw-keyword stx-obj varrefs)
|
||||
(add-binders (syntax names) binders binding-inits #'exp)
|
||||
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
||||
(add-binders (syntax names) binders binding-inits #'exp level-of-enclosing-module)
|
||||
(add-definition-target (syntax names) mods)
|
||||
(level-loop (syntax exp) (+ level 1)))]
|
||||
[(begin-for-syntax exp ...)
|
||||
(begin
|
||||
(annotate-raw-keyword stx-obj varrefs)
|
||||
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
||||
(for-each (lambda (e) (level-loop e (+ level 1))) (syntax->list (syntax (exp ...)))))]
|
||||
[(module m-name lang (#%plain-module-begin bodies ...))
|
||||
(begin
|
||||
(annotate-raw-keyword stx-obj varrefs)
|
||||
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
||||
(hash-set! module-lang-requires (syntax lang) #t)
|
||||
(annotate-require-open user-namespace user-directory (syntax lang))
|
||||
(hash-cons! requires (syntax->datum (syntax lang)) (syntax lang))
|
||||
|
|
@ -334,7 +341,7 @@
|
|||
(mod-loop body (syntax-e #'m-name))))]
|
||||
[(module* m-name lang (#%plain-module-begin bodies ...))
|
||||
(begin
|
||||
(annotate-raw-keyword stx-obj varrefs)
|
||||
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
||||
(when (syntax-e #'lang)
|
||||
(hash-set! module-lang-requires (syntax lang) #t)
|
||||
(annotate-require-open user-namespace user-directory (syntax lang))
|
||||
|
|
@ -370,10 +377,10 @@
|
|||
[else
|
||||
(handle-phaseless-spec spec level)])))
|
||||
(define (handle-phaseless-spec stx level)
|
||||
(define require-ht (hash-ref! phase-to-requires level
|
||||
(define require-ht (hash-ref! phase-to-requires (+ level level-of-enclosing-module)
|
||||
(λ ()
|
||||
(define h (make-hash))
|
||||
(hash-set! phase-to-requires level h)
|
||||
(hash-set! phase-to-requires (+ level level-of-enclosing-module) h)
|
||||
h)))
|
||||
(define raw-module-path (phaseless-spec->raw-module-path stx))
|
||||
(annotate-require-open user-namespace user-directory raw-module-path)
|
||||
|
|
@ -390,18 +397,18 @@
|
|||
[(#%provide provide-specs ...)
|
||||
(let ([provided-varss (map extract-provided-vars
|
||||
(syntax->list (syntax (provide-specs ...))))])
|
||||
(annotate-raw-keyword stx-obj varrefs)
|
||||
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
||||
(for ([provided-vars (in-list provided-varss)])
|
||||
(for ([provided-var (in-list provided-vars)])
|
||||
(add-id varrefs provided-var))))]
|
||||
(add-id varrefs provided-var level-of-enclosing-module))))]
|
||||
|
||||
[(#%expression arg)
|
||||
(begin
|
||||
(annotate-raw-keyword stx-obj varrefs)
|
||||
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
||||
(tail-loop #'arg))]
|
||||
[id
|
||||
(identifier? (syntax id))
|
||||
(add-id varrefs stx-obj)]
|
||||
(add-id varrefs stx-obj level-of-enclosing-module)]
|
||||
[_
|
||||
(begin
|
||||
#;
|
||||
|
|
@ -416,8 +423,8 @@
|
|||
(define (hash-cons! ht k v)
|
||||
(hash-set! ht k (cons v (hash-ref ht k '()))))
|
||||
|
||||
;; add-disappeared-bindings : syntax id-set -> void
|
||||
(define (add-disappeared-bindings stx binders disappaeared-uses)
|
||||
;; add-disappeared-bindings : syntax id-set integer -> void
|
||||
(define (add-disappeared-bindings stx binders disappaeared-uses level-of-enclosing-module)
|
||||
(let ([prop (syntax-property stx 'disappeared-binding)])
|
||||
(when prop
|
||||
(let loop ([prop prop])
|
||||
|
|
@ -426,11 +433,11 @@
|
|||
(loop (car prop))
|
||||
(loop (cdr prop))]
|
||||
[(identifier? prop)
|
||||
(add-origins prop disappaeared-uses)
|
||||
(add-id binders prop)])))))
|
||||
(add-origins prop disappaeared-uses level-of-enclosing-module)
|
||||
(add-id binders prop level-of-enclosing-module)])))))
|
||||
|
||||
;; add-disappeared-uses : syntax id-set -> void
|
||||
(define (add-disappeared-uses stx id-set)
|
||||
;; add-disappeared-uses : syntax id-set integer -> void
|
||||
(define (add-disappeared-uses stx id-set level-of-enclosing-module)
|
||||
(let ([prop (syntax-property stx 'disappeared-use)])
|
||||
(when prop
|
||||
(let loop ([prop prop])
|
||||
|
|
@ -439,7 +446,7 @@
|
|||
(loop (car prop))
|
||||
(loop (cdr prop))]
|
||||
[(identifier? prop)
|
||||
(add-id id-set prop)])))))
|
||||
(add-id id-set prop level-of-enclosing-module)])))))
|
||||
|
||||
;; annotate-variables : namespace directory string id-set[four of them] (listof syntax) (listof syntax) -> void
|
||||
;; colors in and draws arrows for variables, according to their classifications
|
||||
|
|
@ -883,8 +890,8 @@
|
|||
test)))
|
||||
possible-suffixes)))))
|
||||
|
||||
;; add-origins : sexp id-set -> void
|
||||
(define (add-origins sexp id-set)
|
||||
;; add-origins : sexp id-set integer -> void
|
||||
(define (add-origins sexp id-set level-of-enclosing-module)
|
||||
(let ([origin (syntax-property sexp 'origin)])
|
||||
(when origin
|
||||
(let loop ([ct origin])
|
||||
|
|
@ -893,7 +900,7 @@
|
|||
(loop (car ct))
|
||||
(loop (cdr ct))]
|
||||
[(syntax? ct)
|
||||
(add-id id-set ct)]
|
||||
(add-id id-set ct level-of-enclosing-module)]
|
||||
[else (void)])))))
|
||||
|
||||
;; FIXME: handle for-template and for-label
|
||||
|
|
@ -937,11 +944,11 @@
|
|||
|
||||
(define (symbolic-compare? x y) (eq? (syntax-e x) (syntax-e y)))
|
||||
|
||||
;; add-binders : syntax id-set (or/c #f id-set) (or/c #f syntax) -> void
|
||||
;; add-binders : syntax id-set (or/c #f id-set) (or/c #f syntax) integer -> void
|
||||
;; transforms an argument list into a bunch of symbols/symbols
|
||||
;; and puts them into the id-set
|
||||
;; effect: colors the identifiers
|
||||
(define (add-binders stx id-set binding-to-init init-exp)
|
||||
(define (add-binders stx id-set binding-to-init init-exp level-of-enclosing-module)
|
||||
(let loop ([stx stx])
|
||||
(let ([e (if (syntax? stx) (syntax-e stx) stx)])
|
||||
(cond
|
||||
|
|
@ -952,14 +959,14 @@
|
|||
(begin
|
||||
(when binding-to-init
|
||||
(add-init-exp binding-to-init fst init-exp))
|
||||
(add-id id-set fst)
|
||||
(add-id id-set fst level-of-enclosing-module)
|
||||
(loop rst))
|
||||
(loop rst)))]
|
||||
[(null? e) (void)]
|
||||
[else
|
||||
(when binding-to-init
|
||||
(add-init-exp binding-to-init stx init-exp))
|
||||
(add-id id-set stx)]))))
|
||||
(add-id id-set stx level-of-enclosing-module)]))))
|
||||
|
||||
;; add-definition-target : syntax[(sequence of identifiers)] (listof symbol) -> void
|
||||
(define (add-definition-target stx mods)
|
||||
|
|
@ -980,16 +987,16 @@
|
|||
(syntax-e id)
|
||||
mods))))))
|
||||
|
||||
;; annotate-raw-keyword : syntax id-map -> void
|
||||
;; annotate-raw-keyword : syntax id-map integer -> void
|
||||
;; annotates keywords when they were never expanded. eg.
|
||||
;; if someone just types `(λ (x) x)' it has no 'origin
|
||||
;; field, but there still are keywords.
|
||||
(define (annotate-raw-keyword stx id-map)
|
||||
(define (annotate-raw-keyword stx id-map level-of-enclosing-module)
|
||||
(let ([lst (syntax-e stx)])
|
||||
(when (pair? lst)
|
||||
(let ([f-stx (car lst)])
|
||||
(when (identifier? f-stx)
|
||||
(add-id id-map f-stx))))))
|
||||
(add-id id-map f-stx level-of-enclosing-module))))))
|
||||
|
||||
;
|
||||
;
|
||||
|
|
@ -1245,9 +1252,10 @@
|
|||
(free-identifier-mapping-put! mapping id new))))
|
||||
|
||||
;; add-id : id-set identifier -> void
|
||||
(define (add-id mapping id)
|
||||
(define (add-id mapping id level-of-enclosing-module)
|
||||
(when (syntax-original? id)
|
||||
(let* ([old (free-identifier-mapping-get mapping id (λ () '()))]
|
||||
(let* ([id (syntax-shift-phase-level id level-of-enclosing-module)]
|
||||
[old (free-identifier-mapping-get mapping id (λ () '()))]
|
||||
[new (cons id old)])
|
||||
(free-identifier-mapping-put! mapping id new))))
|
||||
|
||||
|
|
|
|||
|
|
@ -1011,7 +1011,35 @@
|
|||
(list '((6 17) (19 26))
|
||||
'((27 36) (38 43))))
|
||||
|
||||
(build-test "#lang racket\n(begin-for-syntax (module m racket/base (let ([x 1]) x)))"
|
||||
'(("#lang racket\n(" default-color)
|
||||
("begin-for-syntax" imported)
|
||||
(" (" default-color)
|
||||
("module" imported)
|
||||
(" m racket/base (" default-color)
|
||||
("let" imported)
|
||||
(" ([" default-color)
|
||||
("x" lexically-bound)
|
||||
(" 1]) " default-color)
|
||||
("x" lexically-bound)
|
||||
(")))" default-color))
|
||||
(list '((60 61) (66 67))
|
||||
'((6 12) (14 30) (32 38))))
|
||||
|
||||
(build-test "#lang racket\n(define-for-syntax x 1)\n(begin-for-syntax (module* m #f x))"
|
||||
'(("#lang racket\n(" default-color)
|
||||
("define-for-syntax" imported)
|
||||
(" " default-color)
|
||||
("x" lexically-bound)
|
||||
(" 1)\n(" default-color)
|
||||
("begin-for-syntax" imported)
|
||||
(" (" default-color)
|
||||
("module*" imported)
|
||||
(" m #f " default-color)
|
||||
("x" imported)
|
||||
("))" default-color))
|
||||
(list '((6 12) (14 31) (38 54) (56 63))
|
||||
'((32 33) ((69 70)))))
|
||||
|
||||
(build-rename-test "(lambda (x) x)"
|
||||
9
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user