From 9621a58c4c4ca48e4453a38bd9243d76861f64b6 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 26 Feb 2013 18:25:36 -0600 Subject: [PATCH] change expansion of ->i to make renaming work better in check syntax 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 --- collects/racket/contract/private/arr-i.rkt | 82 +++++++----- .../tests/racket/contract-check-syntax.rkt | 117 ++++++++++++++++++ 2 files changed, 167 insertions(+), 32 deletions(-) create mode 100644 collects/tests/racket/contract-check-syntax.rkt diff --git a/collects/racket/contract/private/arr-i.rkt b/collects/racket/contract/private/arr-i.rkt index ad7c5b2274..5ac72f0a60 100644 --- a/collects/racket/contract/private/arr-i.rkt +++ b/collects/racket/contract/private/arr-i.rkt @@ -783,6 +783,16 @@ (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)] ... [res-exp-xs (coerce-contract '->i res-exps)] ...) #,(syntax-property @@ -794,16 +804,18 @@ ;; all of the dependent argument contracts (list #,@(filter values (map (λ (arg) (and (arg/res-vars arg) - #`(λ (#,@(arg/res-vars arg) val blame) - ;; this used to use opt/direct, but opt/direct duplicates code (bad!) - (un-dep #,(syntax-property - (syntax-property - (arg/res-ctc arg) - 'racket/contract:negative-position - this->i) - 'racket/contract:contract-on-boundary - (gensym '->i-indy-boundary)) - val blame)))) + (let ([orig-vars (find-orig-vars arg args+rst)]) + #`(λ (#,@orig-vars val blame) + #,@(arg/res-vars arg) + ;; this used to use opt/direct, but opt/direct duplicates code (bad!) + (un-dep #,(syntax-property + (syntax-property + (arg/res-ctc arg) + 'racket/contract:negative-position + this->i) + 'racket/contract:contract-on-boundary + (gensym '->i-indy-boundary)) + val blame))))) args+rst))) ;; then the non-dependent argument contracts that are themselves dependend on (list #,@(filter values @@ -818,28 +830,34 @@ #`(list (cons 'res-names res-exp-xs) ...) #''()) #,(if (istx-ress an-istx) - #`(list #,@(filter values (map (λ (arg) - (and (arg/res-vars arg) - (if (eres? arg) - #`(λ #,(arg/res-vars arg) - (opt/c #,(syntax-property - (syntax-property - (arg/res-ctc arg) - 'racket/contract:positive-position - this->i) - 'racket/contract:contract-on-boundary - (gensym '->i-indy-boundary)))) - #`(λ (#,@(arg/res-vars arg) val blame) - ;; this used to use opt/direct, but opt/direct duplicates code (bad!) - (un-dep #,(syntax-property - (syntax-property - (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)))) + #`(list #,@(filter values + (map (λ (arg) + (and (arg/res-vars arg) + (let ([orig-vars (find-orig-vars + arg + (append (istx-ress an-istx) args+rst))]) + (if (eres? arg) + #`(λ #,orig-vars + #,@(arg/res-vars arg) + (opt/c #,(syntax-property + (syntax-property + (arg/res-ctc arg) + 'racket/contract:positive-position + this->i) + 'racket/contract:contract-on-boundary + (gensym '->i-indy-boundary)))) + #`(λ (#,@orig-vars val blame) + ;; this used to use opt/direct, but opt/direct duplicates code (bad!) + #,@(arg/res-vars arg) + (un-dep #,(syntax-property + (syntax-property + (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) #`(list #,@(filter values diff --git a/collects/tests/racket/contract-check-syntax.rkt b/collects/tests/racket/contract-check-syntax.rkt new file mode 100644 index 0000000000..d9949940e2 --- /dev/null +++ b/collects/tests/racket/contract-check-syntax.rkt @@ -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))))