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

fix bug in ->

Browse Source 
Specifically, in the case when the arrow is of the shape
(-> any/c ... any), then the predicate didn't ensure that
there were no mandatory keywords in the given function
This commit is contained in:
Robby Findler 2013-07-16 08:36:16 -05:00
parent 6bda269ae7
commit 05ce59c54e
2 changed files with 26 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow.rkt
View File

@ -295,8 +295,24 @@
(test/pos-blame
'contract-arrow-non-function
'(contract (-> integer? any) 1 'pos 'neg))
(test/pos-blame
'contract-any/c-arrow1
'(contract (-> any/c any) 1 'pos 'neg))
(test/spec-passed
'contract-any/c-arrow2
'(contract (-> any/c any) (λ (x) 1) 'pos 'neg))
(test/pos-blame
'contract-any/c-arrow3
'(contract (-> any/c any) (λ (x y) x) 'pos 'neg))
(test/pos-blame
'contract-any/c-arrow4
'(contract (-> any/c any) (λ (x #:y y) x) 'pos 'neg))
(test/spec-passed
'contract-arrow-all-kwds2
'((contract (-> #:a string? void?)

13
racket/lib/collects/racket/contract/private/arrow.rkt
View File

@ -2097,9 +2097,10 @@
[(_ any/c ... any)
(not (syntax-parameter-value #'making-a-method))
;; special case the (-> any/c ... any) contracts to be first-order checks only
(with-syntax ([dom-len (- (length (syntax->list stx)) 2)]
[name (syntax->datum stx)])
#'(flat-named-contract 'name (λ (x) (and (procedure? x) (procedure-arity-includes? x dom-len #t)))))]
(let ([dom-len (- (length (syntax->list stx)) 2)])
#`(flat-named-contract
'(-> #,@(build-list dom-len (λ (x) 'any/c)) any)
(λ (x) (procedure-arity-includes?/no-kwds x #,dom-len))))]
[(_ any/c boolean?)
;; special case (-> any/c boolean?) to use predicate/c
(not (syntax-parameter-value #'making-a-method))
@ -2107,6 +2108,12 @@
[_
#`(syntax-parameterize ((making-a-method #f)) #,(->/proc/main stx))]))
(define (procedure-arity-includes?/no-kwds val dom-len)
(and (procedure? val)
(procedure-arity-includes? val dom-len)
(let-values ([(man opt) (procedure-keywords val)])
(null? man))))
;; this is to make the expanded versions a little easier to read
(define-syntax (values/drop stx)
(syntax-case stx ()