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

avoid adding bogus names to arguments of various contract combinators

Browse Source 
closes #1528
This commit is contained in:
Robby Findler 2016-12-01 09:33:10 -06:00
parent 3d63b76730
commit cbcbc6ae0c
2 changed files with 57 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
pkgs/racket-test/tests/racket/contract/flat-contracts.rkt
View File

@ -235,4 +235,48 @@
'(expected: "an even number"
given:
"something else")))])))
0 1))
0 1)
;; test that anonymous procedures passed to
;; various combinators don't get strange names
(define (test-anon-name name exp)
(define (anonymous-name-preserved? exn)
(define m
(regexp-match
#rx"\n *((expected)|(promised)): ([^\n]*)\n"
(exn-message exn)))
(define procs-name (and m (list-ref m 4)))
(define passed?
(and m (equal? "flat-contracts:1:0" procs-name)))
(unless passed?
(printf "~a: procs-name is ~s\n" name procs-name))
passed?)
(contract-error-test name
(datum->syntax #f exp
(vector "flat-contracts" 1 0 1 0))
anonymous-name-preserved?))
(test-anon-name 'anon-name->dom
'((contract (-> (λ (x) (even? x)) any) values 'pos 'neg) 1))
(test-anon-name 'anon-name->dom-kwd
'((contract (-> #:x (λ (x) (even? x)) any) (λ (#:x x) x) 'pos 'neg) #:x 1))
(test-anon-name 'anon-name->after-...
'((contract (-> any/c ... (λ (x) (even? x)) any) values 'pos 'neg) 1 3 5))
(test-anon-name 'anon-name->before-...
'((contract (-> (λ (x) (even? x)) ... any/c any) values 'pos 'neg) 1 3 5))
(test-anon-name 'anon-name->rng
'((contract (-> any/c (λ (x) (even? x))) values 'pos 'neg) 1))
(test-anon-name 'anon-name->values-rng
'((contract (-> any/c any/c (values (λ (x) (even? x)) (λ (x) (even? x)))) values 'pos 'neg) 1 3))
(test-anon-name 'anon-name->i-dom
'((contract (->i ([x (λ (x) (even? x))]) any) values 'pos 'neg) 1))
(test-anon-name 'anon-name->*-dom
'((contract (->* ((λ (x) (even? x))) any) values 'pos 'neg) 1))
(test-anon-name 'anon-name->*-dom
'((contract (->* (#:x (λ (x) (even? x))) any) (λ (#:x x) x) 'pos 'neg) #:x 1))
(test-anon-name 'anon-name-list/c
'(contract (listof (λ (x) (even? x))) '(1) 'pos 'neg))
(test-anon-name 'anon-name-and
'(contract (and/c real? (λ (x) (even? x))) 1 'pos 'neg))
)

19
racket/collects/racket/contract/private/arrow-val-first.rkt
View File

@ -589,9 +589,10 @@
(append (reverse let-bindings)
(for/list ([arg-exp (cdr args)]
[arg-x (in-list arg-xes)])
#`[#,arg-x #,(syntax-property arg-exp
'racket/contract:negative-position
this->)]))
#`[#,arg-x #,(syntax-property
(syntax-property arg-exp 'inferred-name (void))
'racket/contract:negative-position
this->)]))
(cons (car regular-args) arg-xes))]
[(keyword? (syntax-e (car args)))
(when (null? (cdr args))
@ -610,7 +611,9 @@
regular-args
(cons (car args) kwds)
(cons #'arg-x kwd-args)
(cons #`[arg-x #,(syntax-property (cadr args)
(cons #`[arg-x #,(syntax-property (syntax-property
(cadr args)
'inferred-name (void))
'racket/contract:negative-position
this->)]
let-bindings)
@ -621,7 +624,9 @@
(cons #'arg-x regular-args)
kwds
kwd-args
(cons #`[arg-x #,(syntax-property (car args)
(cons #`[arg-x #,(syntax-property (syntax-property
(car args)
'inferred-name (void))
'racket/contract:negative-position
this->)]
let-bindings)
@ -704,7 +709,7 @@
(loop #'rest
doms
(cons #'(kwd x) kwd-doms)
(cons #`[x #,(syntax-property #'arg
(cons #`[x #,(syntax-property (syntax-property #'arg 'inferred-name (void))
'racket/contract:negative-position
this->*)]
let-bindings)))]
@ -726,7 +731,7 @@
(loop #'rest
(cons #'t doms)
kwd-doms
(cons #`[t #,(syntax-property #'x
(cons #`[t #,(syntax-property (syntax-property #'x 'inferred-name (void))
'racket/contract:negative-position
this->*)]
let-bindings)))])))