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

removed halfway done fix for sexp movement keys

Browse Source 
svn: r4723
This commit is contained in:
Robby Findler 2006-10-31 23:05:23 +00:00
parent 5d2f80ab85
commit 80ca729b04
3 changed files with 162 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

140
collects/drscheme/syncheck.ss
View File

@ -1241,10 +1241,12 @@ If the namespace does not, they are colored the unbound color.
;; 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) (define (make-traversal)
(let* ([tl-binders (make-id-set)] (let* ([tl-low-binders (make-id-set)]
[tl-varrefs (make-id-set)] [tl-high-binders (make-id-set)]
[tl-low-varrefs (make-id-set)]
[tl-high-varrefs (make-id-set)] [tl-high-varrefs (make-id-set)]
[tl-tops (make-id-set)] [tl-low-tops (make-id-set)]
[tl-high-tops (make-id-set)]
[tl-requires (make-hash-table 'equal)] [tl-requires (make-hash-table 'equal)]
[tl-require-for-syntaxes (make-hash-table 'equal)] [tl-require-for-syntaxes (make-hash-table 'equal)]
[expanded-expression [expanded-expression
@ -1255,36 +1257,44 @@ If the namespace does not, they are colored the unbound color.
[else #f])]) [else #f])])
(cond (cond
[is-module? [is-module?
(let ([binders (make-id-set)] (let ([low-binders (make-id-set)]
[high-binders (make-id-set)]
[varrefs (make-id-set)] [varrefs (make-id-set)]
[high-varrefs (make-id-set)] [high-varrefs (make-id-set)]
[tops (make-id-set)] [low-tops (make-id-set)]
[high-tops (make-id-set)]
[requires (make-hash-table 'equal)] [requires (make-hash-table 'equal)]
[require-for-syntaxes (make-hash-table 'equal)]) [require-for-syntaxes (make-hash-table 'equal)])
(annotate-basic sexp user-namespace user-directory jump-to-id (annotate-basic sexp user-namespace user-directory jump-to-id
binders varrefs high-varrefs tops low-binders high-binders varrefs high-varrefs low-tops high-tops
requires require-for-syntaxes) requires require-for-syntaxes)
(annotate-variables user-namespace (annotate-variables user-namespace
user-directory user-directory
binders low-binders
high-binders
varrefs varrefs
high-varrefs high-varrefs
tops low-tops
high-tops
requires requires
require-for-syntaxes))] require-for-syntaxes))]
[else [else
(annotate-basic sexp user-namespace user-directory jump-to-id (annotate-basic sexp user-namespace user-directory jump-to-id
tl-binders tl-varrefs tl-high-varrefs tl-tops tl-low-binders tl-high-binders
tl-low-varrefs tl-high-varrefs
tl-low-tops tl-high-tops
tl-requires tl-require-for-syntaxes)]))))] tl-requires tl-require-for-syntaxes)]))))]
[expansion-completed [expansion-completed
(λ (user-namespace user-directory) (λ (user-namespace user-directory)
(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-binders tl-low-binders
tl-varrefs tl-high-binders
tl-low-varrefs
tl-high-varrefs tl-high-varrefs
tl-tops tl-low-tops
tl-high-tops
tl-requires tl-requires
tl-require-for-syntaxes)))]) tl-require-for-syntaxes)))])
(values expanded-expression expansion-completed))) (values expanded-expression expansion-completed)))
@ -1297,11 +1307,13 @@ If the namespace does not, they are colored the unbound color.
;; namespace ;; namespace
;; string[directory] ;; string[directory]
;; syntax[id] ;; syntax[id]
;; id-set (four of them) ;; id-set (six of them)
;; hash-table[require-spec -> syntax] (two of them) ;; hash-table[require-spec -> syntax] (two of them)
;; -> void ;; -> void
(define (annotate-basic sexp user-namespace user-directory jump-to-id (define (annotate-basic sexp user-namespace user-directory jump-to-id
binders low-varrefs high-varrefs tops low-binders high-binders
low-varrefs high-varrefs
low-tops high-tops
requires require-for-syntaxes) requires require-for-syntaxes)
(let ([tail-ht (make-hash-table)] (let ([tail-ht (make-hash-table)]
[maybe-jump [maybe-jump
@ -1319,6 +1331,8 @@ If the namespace does not, they are colored the unbound color.
[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)]
[tops (if high-level? high-tops low-tops)]
[collect-general-info [collect-general-info
(λ (stx) (λ (stx)
(add-origins stx varrefs) (add-origins stx varrefs)
@ -1328,7 +1342,7 @@ If the namespace does not, they are colored the unbound color.
(syntax-case* sexp (lambda case-lambda if begin begin0 let-values letrec-values set! (syntax-case* sexp (lambda case-lambda if begin begin0 let-values letrec-values set!
quote quote-syntax with-continuation-mark quote quote-syntax with-continuation-mark
#%app #%datum #%top #%plain-module-begin #%app #%datum #%top #%plain-module-begin
define-values define-syntaxes define-values-for-syntaxes module define-values define-syntaxes define-values-for-syntax module
require require-for-syntax provide) require require-for-syntax provide)
(if high-level? module-transformer-identifier=? module-identifier=?) (if high-level? module-transformer-identifier=? module-identifier=?)
[(lambda args bodies ...) [(lambda args bodies ...)
@ -1451,10 +1465,10 @@ If the namespace does not, they are colored the unbound color.
(add-binders (syntax names) binders) (add-binders (syntax names) binders)
(maybe-jump (syntax names)) (maybe-jump (syntax names))
(level-loop (syntax exp) #t))] (level-loop (syntax exp) #t))]
[(define-values-for-syntaxes names exp) [(define-values-for-syntax names exp)
(begin (begin
(annotate-raw-keyword sexp varrefs) (annotate-raw-keyword sexp varrefs)
(add-binders (syntax names) binders) (add-binders (syntax names) high-binders)
(maybe-jump (syntax names)) (maybe-jump (syntax names))
(level-loop (syntax exp) #t))] (level-loop (syntax exp) #t))]
[(module m-name lang (#%plain-module-begin bodies ...)) [(module m-name lang (#%plain-module-begin bodies ...))
@ -1503,12 +1517,13 @@ If the namespace does not, they are colored the unbound color.
(add-id varrefs sexp))] (add-id varrefs sexp))]
[_ [_
(begin (begin
'(printf "unknown stx: ~e (datum: ~e) (source: ~e)~n" #;
sexp (printf "unknown stx: ~e (datum: ~e) (source: ~e)~n"
(and (syntax? sexp) sexp
(syntax-object->datum sexp)) (and (syntax? sexp)
(and (syntax? sexp) (syntax-object->datum sexp))
(syntax-source sexp))) (and (syntax? sexp)
(syntax-source sexp)))
(void))]))) (void))])))
(add-tail-ht-links tail-ht))) (add-tail-ht-links tail-ht)))
@ -1561,10 +1576,12 @@ If the namespace does not, they are colored the unbound color.
;; in the various id-sets ;; in the various id-sets
(define (annotate-variables user-namespace (define (annotate-variables user-namespace
user-directory user-directory
binders low-binders
varrefs high-binders
low-varrefs
high-varrefs high-varrefs
tops low-tops
high-tops
requires requires
require-for-syntaxes) require-for-syntaxes)
@ -1573,7 +1590,7 @@ If the namespace does not, they are colored the unbound color.
(make-hash-table 'equal)] (make-hash-table 'equal)]
[unused-requires (make-hash-table 'equal)] [unused-requires (make-hash-table 'equal)]
[unused-require-for-syntaxes (make-hash-table 'equal)] [unused-require-for-syntaxes (make-hash-table 'equal)]
[id-sets (list binders varrefs high-varrefs tops)]) [id-sets (list low-binders high-binders low-varrefs high-varrefs low-tops high-tops)])
(hash-table-for-each requires (λ (k v) (hash-table-put! unused-requires k #t))) (hash-table-for-each requires (λ (k v) (hash-table-put! unused-requires k #t)))
(hash-table-for-each require-for-syntaxes (λ (k v) (hash-table-put! unused-require-for-syntaxes k #t))) (hash-table-for-each require-for-syntaxes (λ (k v) (hash-table-put! unused-require-for-syntaxes k #t)))
@ -1584,45 +1601,52 @@ If the namespace does not, they are colored the unbound color.
(color-variable var identifier-binding) (color-variable var identifier-binding)
(record-renamable-var rename-ht var))) (record-renamable-var rename-ht var)))
vars)) vars))
(get-idss binders)) (append (get-idss high-binders)
(get-idss low-binders)))
(for-each (λ (vars) (for-each (for-each (λ (vars) (for-each
(λ (var) (λ (var)
(color-variable var identifier-binding) (color-variable var identifier-binding)
(connect-identifier var (connect-identifier var
rename-ht rename-ht
binders low-binders
unused-requires unused-requires
requires requires
identifier-binding identifier-binding
id-sets user-namespace
user-namespace user-directory))
user-directory)) vars))
vars)) (get-idss low-varrefs))
(get-idss varrefs))
(for-each (λ (vars) (for-each (for-each (λ (vars) (for-each
(λ (var) (λ (var)
(color-variable var identifier-transformer-binding) (color-variable var identifier-transformer-binding)
(connect-identifier var (connect-identifier var
rename-ht rename-ht
binders high-binders
unused-require-for-syntaxes unused-require-for-syntaxes
require-for-syntaxes require-for-syntaxes
identifier-transformer-binding identifier-transformer-binding
id-sets user-namespace
user-namespace user-directory))
user-directory)) vars))
vars))
(get-idss high-varrefs)) (get-idss high-varrefs))
(for-each (for-each
(λ (vars) (λ (vars)
(for-each (for-each
(λ (var) (λ (var)
(color/connect-top rename-ht user-namespace user-directory binders var id-sets)) (color/connect-top rename-ht user-namespace user-directory low-binders var))
vars)) vars))
(get-idss tops)) (get-idss low-tops))
(for-each
(λ (vars)
(for-each
(λ (var)
(color/connect-top rename-ht user-namespace user-directory high-binders var))
vars))
(get-idss high-tops))
(color-unused require-for-syntaxes unused-require-for-syntaxes) (color-unused require-for-syntaxes unused-require-for-syntaxes)
(color-unused requires unused-requires) (color-unused requires unused-requires)
@ -1653,7 +1677,7 @@ If the namespace does not, they are colored the unbound color.
;; directory ;; directory
;; -> 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 unused requires get-binding id-sets user-namespace user-directory) (define (connect-identifier var rename-ht all-binders unused requires get-binding user-namespace user-directory)
(connect-identifier/arrow var all-binders unused requires get-binding user-namespace user-directory) (connect-identifier/arrow var all-binders unused requires get-binding user-namespace user-directory)
(when (get-ids all-binders var) (when (get-ids all-binders var)
(record-renamable-var rename-ht var))) (record-renamable-var rename-ht var)))
@ -1706,7 +1730,7 @@ If the namespace does not, they are colored the unbound color.
(cons mod-path #f)])))) (cons mod-path #f)]))))
;; 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 id-sets) (define (color/connect-top rename-ht user-namespace user-directory binders var)
(let ([top-bound? (let ([top-bound?
(or (get-ids binders var) (or (get-ids binders var)
(parameterize ([current-namespace user-namespace]) (parameterize ([current-namespace user-namespace])
@ -1716,7 +1740,7 @@ If the namespace does not, they are colored the unbound color.
(if top-bound? (if top-bound?
(color var lexically-bound-variable-style-name) (color var lexically-bound-variable-style-name)
(color var error-style-name)) (color var error-style-name))
(connect-identifier var rename-ht binders #f #f identifier-binding id-sets user-namespace user-directory))) (connect-identifier var rename-ht binders #f #f identifier-binding user-namespace user-directory)))
;; color-variable : syntax (union identifier-binding identifier-transformer-binding) -> void ;; color-variable : syntax (union identifier-binding identifier-transformer-binding) -> void
(define (color-variable var get-binding) (define (color-variable var get-binding)

2
collects/htdp/image.ss
View File

@ -490,7 +490,7 @@ plt/collects/tests/mzscheme/image-test.ss
(check 'star (check 'star
(lambda (x) (and (real? x) (< 3 x 10000))) (lambda (x) (and (real? x) (< 3 x 10000)))
points points
"positive real number bigger than 3" "positive real number bigger than or equal to 4"
"first") "first")
(check-size 'star inner-radius "second") (check-size 'star inner-radius "second")
(check-size 'star outer-radius "second") (check-size 'star outer-radius "second")

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

@ -237,7 +237,7 @@
("x" lexically-bound-variable) ("x" lexically-bound-variable)
(") " default-color) (") " default-color)
("x" lexically-bound-variable) ("x" lexically-bound-variable)
("))" default-color)) (")" default-color))
(list '((22 23) (25 26)))) (list '((22 23) (25 26))))
(build-test "(module m mzscheme)" (build-test "(module m mzscheme)"
@ -331,6 +331,83 @@
(list '((10 18) (20 38) (56 69)) (list '((10 18) (20 38) (56 69))
'((39 53) (73 76)))) '((39 53) (73 76))))
(build-test "(define-for-syntax (f x) x) (define (f x) x) f (define-syntax (m x) (f x))"
'(("(" default-color)
("define-for-syntax" imported-identifier)
(" (" default-color)
("f" lexically-bound-identifier)
(" " default-color)
("x" lexically-bound-identifier)
(") " default-color)
("x" lexically-bound-identifier)
(") (" default-color)
("define" imported-identifier)
(" (" default-color)
("f" lexically-bound-identifier)
(" " default-color)
("x" lexically-bound-identifier)
(") " default-color)
("x" lexically-bound-identifier)
(") " default-color)
("f" lexically-bound-identifier)
(" (" default-color)
("define-syntax" imported-identifier)
(" (" default-color)
("m" lexically-bound-identifier)
(" " default-color)
("x" lexically-bound-identifier)
(") (" default-color)
("f" lexically-bound-identifier)
(" " default-color)
("x" lexically-bound-identifier)
("))" default-color))
'(((20 21) (69 70))
((22 23) (25 26))
((37 38) (45 46))
((39 40) (42 43))
((65 66) (71 72))))
(build-test "(module m mzscheme (define-for-syntax (f x) x) (define (f x) x) f (define-syntax (m stx) (f stx)))"
'(("(" default-color)
("module" imported-identifier)
(" m mzscheme (" default-color)
("define-for-syntax" imported-identifier)
(" (" default-color)
("f" lexically-bound-identifier)
(" " default-color)
("x" lexically-bound-identifier)
(") " default-color)
("x" lexically-bound-identifier)
(") (" default-color)
("define" imported-identifier)
(" (" default-color)
("f" lexically-bound-identifier)
(" " default-color)
("x" lexically-bound-identifier)
(") " default-color)
("x" lexically-bound-identifier)
(") " default-color)
("f" lexically-bound-identifier)
(" (" default-color)
("define-syntax" imported-identifier)
(" (" default-color)
("m" lexically-bound-identifier)
(" " default-color)
("stx" lexically-bound-identifier)
(") (" default-color)
("f" lexically-bound-identifier)
(" " default-color)
("stx" lexically-bound-identifier)
(")))" default-color))
'(((10 18) (20 37) (48 54) (67 80))
((39 40) (90 91))
((41 42) (44 45))
((56 57) (64 65))
((58 59) (61 62))
((84 87) (92 95))))
(build-test "(define-syntax s (lambda (stx) (syntax-case stx () (_ 123))))" (build-test "(define-syntax s (lambda (stx) (syntax-case stx () (_ 123))))"
'(("(" default-color) '(("(" default-color)
("define-syntax" imported-syntax) ("define-syntax" imported-syntax)