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

change expansion of ->i to make renaming work better in check syntax

Browse Source 
Specifically, when expanding in the body of a dependent argument, put
the original variable for the dependened on field into that code, but
changing the expansion so that the binder becomes the original field's
x, not the x in the dependent declaration list.

This means that, for example, in this program:

(->i ([x any/c]
      [y (x) (begin x any/c)]
      [z (x) (begin x any/c)]) any)

the first x will be the binder and the other four now count as
bound occurrences.

Also, rip off Casey's redex check syntax tests to add tests

closes PR 13559
This commit is contained in:
Robby Findler 2013-02-26 18:25:36 -06:00
parent 76421ee786
commit 9621a58c4c
2 changed files with 167 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
collects/racket/contract/private/arr-i.rkt
View File

@ -783,6 +783,16 @@
(istx-ress an-istx))) (istx-ress an-istx)))
'())]) '())])
(define (find-orig-vars arg arg/ress-to-look-in)
(for/list ([an-id (in-list (arg/res-vars arg))])
(define ans
(for/or ([o-arg (in-list arg/ress-to-look-in)])
(and (free-identifier=? an-id (arg/res-var o-arg))
(arg/res-var o-arg))))
(unless ans
(error 'contract/arr-i.rkt:find-orig-vars "could not find ~s in ~s\n" an-id arg/ress-to-look-in))
ans))
#`(let ([arg-exp-xs (coerce-contract '->i arg-exps)] ... #`(let ([arg-exp-xs (coerce-contract '->i arg-exps)] ...
[res-exp-xs (coerce-contract '->i res-exps)] ...) [res-exp-xs (coerce-contract '->i res-exps)] ...)
#,(syntax-property #,(syntax-property
@ -794,16 +804,18 @@
;; all of the dependent argument contracts ;; all of the dependent argument contracts
(list #,@(filter values (map (λ (arg) (list #,@(filter values (map (λ (arg)
(and (arg/res-vars arg) (and (arg/res-vars arg)
#`(λ (#,@(arg/res-vars arg) val blame) (let ([orig-vars (find-orig-vars arg args+rst)])
;; this used to use opt/direct, but opt/direct duplicates code (bad!) #`(λ (#,@orig-vars val blame)
(un-dep #,(syntax-property #,@(arg/res-vars arg)
(syntax-property ;; this used to use opt/direct, but opt/direct duplicates code (bad!)
(arg/res-ctc arg) (un-dep #,(syntax-property
'racket/contract:negative-position (syntax-property
this->i) (arg/res-ctc arg)
'racket/contract:contract-on-boundary 'racket/contract:negative-position
(gensym '->i-indy-boundary)) this->i)
val blame)))) 'racket/contract:contract-on-boundary
(gensym '->i-indy-boundary))
val blame)))))
args+rst))) args+rst)))
;; then the non-dependent argument contracts that are themselves dependend on ;; then the non-dependent argument contracts that are themselves dependend on
(list #,@(filter values (list #,@(filter values
@ -818,28 +830,34 @@
#`(list (cons 'res-names res-exp-xs) ...) #`(list (cons 'res-names res-exp-xs) ...)
#''()) #''())
#,(if (istx-ress an-istx) #,(if (istx-ress an-istx)
#`(list #,@(filter values (map (λ (arg) #`(list #,@(filter values
(and (arg/res-vars arg) (map (λ (arg)
(if (eres? arg) (and (arg/res-vars arg)
#`(λ #,(arg/res-vars arg) (let ([orig-vars (find-orig-vars
(opt/c #,(syntax-property arg
(syntax-property (append (istx-ress an-istx) args+rst))])
(arg/res-ctc arg) (if (eres? arg)
'racket/contract:positive-position #`(λ #,orig-vars
this->i) #,@(arg/res-vars arg)
'racket/contract:contract-on-boundary (opt/c #,(syntax-property
(gensym '->i-indy-boundary)))) (syntax-property
#`(λ (#,@(arg/res-vars arg) val blame) (arg/res-ctc arg)
;; this used to use opt/direct, but opt/direct duplicates code (bad!) 'racket/contract:positive-position
(un-dep #,(syntax-property this->i)
(syntax-property 'racket/contract:contract-on-boundary
(arg/res-ctc arg) (gensym '->i-indy-boundary))))
'racket/contract:positive-position #`(λ (#,@orig-vars val blame)
this->i) ;; this used to use opt/direct, but opt/direct duplicates code (bad!)
'racket/contract:contract-on-boundary #,@(arg/res-vars arg)
(gensym '->i-indy-boundary)) (un-dep #,(syntax-property
val blame))))) (syntax-property
(istx-ress an-istx)))) (arg/res-ctc arg)
'racket/contract:positive-position
this->i)
'racket/contract:contract-on-boundary
(gensym '->i-indy-boundary))
val blame))))))
(istx-ress an-istx))))
#''()) #''())
#,(if (istx-ress an-istx) #,(if (istx-ress an-istx)
#`(list #,@(filter values #`(list #,@(filter values

117
collects/tests/racket/contract-check-syntax.rkt Normal file
View File

@ -0,0 +1,117 @@
#lang racket
(require drracket/check-syntax
rackunit
(for-syntax setup/path-to-relative)
setup/path-to-relative)
(define-syntax (identifier stx)
(syntax-case stx ()
[(_ x)
(identifier? #'x)
#`(let ([p (open-input-string (format "~s" 'x))])
(port-count-lines! p)
(set-port-next-location!
p
#,(syntax-line #'x)
#,(syntax-column #'x)
#,(syntax-position #'x))
(read-syntax '#,(and (path? (syntax-source #'x))
(path->relative-string/library (syntax-source #'x)))
p))]))
(define (source stx)
(list (and (path? (syntax-source stx))
(path->relative-string/library (syntax-source stx)))
(syntax-line stx)
(syntax-column stx)))
(define collector%
(class (annotations-mixin object%)
(super-new)
(define/override (syncheck:find-source-object stx)
stx)
(define/override (syncheck:add-rename-menu id
all-ids
new-name-interferes?)
(match all-ids
[(list (list ids _ _) ...)
(set! renames (cons ids renames))]))
(define renames '())
(define/public (collected-rename-class stx)
(for/fold ([class (set)]) ([ids renames])
(if (for/or ([id ids])
(equal? (source stx) (source id)))
(set-union class (apply set (map source ids)))
class)))
(define/override (syncheck:add-arrow start-source-obj
start-left
start-right
end-source-obj
end-left
end-right
actual?
phase-level)
(set! arrows
(set-add arrows
(list (source start-source-obj)
(source end-source-obj)))))
(define arrows (set))
(define/public (collected-arrows) arrows)))
(define-namespace-anchor module-anchor)
(define module-namespace
(namespace-anchor->namespace module-anchor))
(let ([annotations (new collector%)])
(define-values (add-syntax done)
(make-traversal module-namespace #f))
(define x1 (identifier x))
(define x2 (identifier x))
(define x3 (identifier x))
(define y1 (identifier y))
(define y2 (identifier y))
(define z1 (identifier z))
(parameterize ([current-annotations annotations]
[current-namespace module-namespace])
(add-syntax
(expand #`(->i ([#,x1 any/c]
[#,y1 (#,x2) any/c]
[#,z1 (#,x3 #,y2) any/c])
any)))
(done))
(check-equal? (send annotations collected-arrows)
(set (list (source x1) (source x2))
(list (source x1) (source x3))
(list (source y1) (source y2))))
(check-equal? (send annotations collected-rename-class x1)
(set (source x1) (source x2) (source x3)))
(check-equal? (send annotations collected-rename-class y1)
(set (source y1) (source y2))))
(let ([annotations (new collector%)])
(define-values (add-syntax done)
(make-traversal module-namespace #f))
(define x1 (identifier x))
(define x2 (identifier x))
(define x3 (identifier x))
(define y1 (identifier y))
(define y2 (identifier y))
(define z1 (identifier z))
(parameterize ([current-annotations annotations]
[current-namespace module-namespace])
(add-syntax
(expand #`(->i ([#,x1 any/c])
[r (#,x2) #,x3])))
(done))
(check-equal? (send annotations collected-arrows)
(set (list (source x1) (source x2))
(list (source x1) (source x3))))
(check-equal? (send annotations collected-rename-class x1)
(set (source x1) (source x2) (source x3))))