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

PR 9300

Browse Source 
svn: r9343
This commit is contained in:
Robby Findler 2008-04-17 11:49:53 +00:00
parent 335449c7c5
commit c9e313648a
1 changed files with 44 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
collects/drscheme/syncheck.ss
View File

@ -1421,6 +1421,7 @@ If the namespace does not, they are colored the unbound color.
low-tops high-tops low-tops high-tops
templrefs templrefs
requires require-for-syntaxes require-for-templates require-for-labels) requires require-for-syntaxes require-for-templates require-for-labels)
(let ([tail-ht (make-hasheq)] (let ([tail-ht (make-hasheq)]
[maybe-jump [maybe-jump
(λ (vars) (λ (vars)
@ -1435,6 +1436,7 @@ If the namespace does not, they are colored the unbound color.
(let level-loop ([sexp sexp] (let level-loop ([sexp sexp]
[high-level? #f]) [high-level? #f])
(let* ([loop (λ (sexp) (level-loop sexp high-level?))] (let* ([loop (λ (sexp) (level-loop sexp high-level?))]
[varrefs (if high-level? high-varrefs low-varrefs)] [varrefs (if high-level? high-varrefs low-varrefs)]
[binders (if high-level? high-binders low-binders)] [binders (if high-level? high-binders low-binders)]
@ -1588,12 +1590,7 @@ If the namespace does not, they are colored the unbound color.
(annotate-raw-keyword sexp varrefs) (annotate-raw-keyword sexp varrefs)
((annotate-require-open user-namespace user-directory) (syntax lang)) ((annotate-require-open user-namespace user-directory) (syntax lang))
(hash-set! requires (hash-cons! requires (syntax->datum (syntax lang)) (syntax lang))
(syntax->datum (syntax lang))
(cons (syntax lang)
(hash-ref requires
(syntax->datum (syntax lang))
(λ () '()))))
(for-each loop (syntax->list (syntax (bodies ...)))))] (for-each loop (syntax->list (syntax (bodies ...)))))]
; top level or module top level only: ; top level or module top level only:
@ -1655,6 +1652,9 @@ If the namespace does not, they are colored the unbound color.
(void))]))) (void))])))
(add-tail-ht-links tail-ht))) (add-tail-ht-links tail-ht)))
(define (hash-cons! ht k v)
(hash-set! ht k (cons v (hash-ref ht k '()))))
;; add-disappeared-bindings : syntax id-set -> void ;; add-disappeared-bindings : syntax id-set -> void
(define (add-disappeared-bindings stx binders disappaeared-uses) (define (add-disappeared-bindings stx binders disappaeared-uses)
(let ([prop (syntax-property stx 'disappeared-binding)]) (let ([prop (syntax-property stx 'disappeared-binding)])
@ -2287,25 +2287,55 @@ If the namespace does not, they are colored the unbound color.
;; hash-table[syntax -o> (listof syntax)] -> void ;; hash-table[syntax -o> (listof syntax)] -> void
(define (add-tail-ht-links tail-ht) (define (add-tail-ht-links tail-ht)
(collapse-tail-links tail-ht)
(hash-for-each (hash-for-each
tail-ht tail-ht
(λ (stx-from stx-tos) (λ (stx-from stx-tos)
(for-each (λ (stx-to) (add-tail-ht-link stx-from stx-to)) (for-each (λ (stx-to) (add-tail-ht-link stx-from stx-to))
stx-tos)))) stx-tos))))
;; hash-table[syntax -o> (listof syntax)] -> void
;; take something like a transitive closure, except
;; only when there are non-original links in between
(define (collapse-tail-links tail-ht)
(hash-for-each
tail-ht
(λ (stx-from stx-tos)
(for-each
(λ (stx-to)
(let ([stx-to-tos (hash-ref tail-ht stx-to '())])
(for-each
(λ (stx-to-to)
(unless (and (add-tail-link? stx-from stx-to)
(add-tail-link? stx-to stx-to-to))
(hash-cons! tail-ht stx-from stx-to-to)))
stx-to-tos)))
stx-tos))))
;; add-tail-ht-link : syntax syntax -> void ;; add-tail-ht-link : syntax syntax -> void
(define (add-tail-ht-link from-stx to-stx) (define (add-tail-ht-link from-stx to-stx)
(when (add-tail-link? from-stx to-stx)
(let* ([to-src (find-source-editor to-stx)]
[from-src (find-source-editor from-stx)]
[from-pos (syntax-position from-stx)]
[to-pos (syntax-position to-stx)]
[defs-text (get-defs-text)])
(send defs-text syncheck:add-tail-arrow
from-src (- from-pos 1)
to-src (- to-pos 1)))))
(define (add-tail-link? from-stx to-stx)
(let* ([to-src (find-source-editor to-stx)] (let* ([to-src (find-source-editor to-stx)]
[from-src (find-source-editor from-stx)] [from-src (find-source-editor from-stx)]
[defs-text (get-defs-text)]) [defs-text (get-defs-text)])
(when (and to-src from-src defs-text) (and to-src from-src defs-text
(let ([from-pos (syntax-position from-stx)] (let ([from-pos (syntax-position from-stx)]
[to-pos (syntax-position to-stx)]) [to-pos (syntax-position to-stx)])
(when (and from-pos to-pos) (and from-pos to-pos)))))
(send defs-text syncheck:add-tail-arrow
from-src (- from-pos 1)
to-src (- to-pos 1)))))))
;; add-to-cleanup-texts : (is-a?/c editor<%>) -> void ;; add-to-cleanup-texts : (is-a?/c editor<%>) -> void
(define (add-to-cleanup-texts ed) (define (add-to-cleanup-texts ed)
(let ([ed (find-outermost-editor ed)]) (let ([ed (find-outermost-editor ed)])