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

fix keyword argument order bug in ->i

Browse Source 
the bug required all mandatory arguments to manifest

closes PR 15267
This commit is contained in:
Robby Findler 2016-03-08 21:15:43 -06:00
parent 26d28a28fe
commit 0f73870a1b
2 changed files with 44 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -929,6 +929,14 @@
3 2 1) 3 2 1)
3) 3)
(test/spec-passed/result
'->i54
'((contract (->i (#:one [one any/c] #:two [two any/c] #:three [three any/c]) any)
(λ (#:one one #:two two #:three three) (list one two three))
'pos 'neg)
#:one 1 #:two 2 #:three 3)
'(1 2 3))
(test/pos-blame (test/pos-blame
'->i-arity1 '->i-arity1
'(contract (->i ([x number?]) () any) (λ () 1) 'pos 'neg)) '(contract (->i ([x number?]) () any) (λ () 1) 'pos 'neg))

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

@ -480,31 +480,33 @@ evaluted left-to-right.)
(define-for-syntax (args/vars->arg-checker result-checkers args rst vars this-param) (define-for-syntax (args/vars->arg-checker result-checkers args rst vars this-param)
(let ([opts? (ormap arg-optional? args)] (let ([opts? (ormap arg-optional? args)]
[this-params (if this-param (list this-param) '())]) [this-params (if this-param (list this-param) '())])
(cond
[(and opts? (ormap arg-kwd args)) (define arg->var (make-hash))
(let* ([arg->var (make-hash)] (define kwd-args (filter arg-kwd args))
[kwd-args (filter arg-kwd args)] (define non-kwd-args (filter (λ (x) (not (arg-kwd x))) args))
[non-kwd-args (filter (λ (x) (not (arg-kwd x))) args)])
(for ([arg (in-list args)] (for ([arg (in-list args)]
[var (in-vector vars)]) [var (in-vector vars)])
(hash-set! arg->var arg var)) (hash-set! arg->var arg var))
(let ([sorted-kwd/arg-pairs (define sorted-kwd/arg-pairs
(sort (sort
(map (λ (arg) (cons (arg-kwd arg) (hash-ref arg->var arg))) kwd-args) (map (λ (arg) (cons (arg-kwd arg) (hash-ref arg->var arg))) kwd-args)
(λ (x y) (keyword<? (syntax-e (car x)) (syntax-e (car y)))))]) (λ (x y) (keyword<? (syntax-e (car x)) (syntax-e (car y))))))
(define keyword-arguments (map cdr sorted-kwd/arg-pairs))
(define regular-arguments (map (λ (arg) (hash-ref arg->var arg)) non-kwd-args))
(cond
[(and opts? (ormap arg-kwd args))
;; has both optional and keyword args ;; has both optional and keyword args
#`(keyword-return/no-unsupplied #`(keyword-return/no-unsupplied
#,(if (null? result-checkers) #f (car result-checkers)) #,(if (null? result-checkers) #f (car result-checkers))
'#,(map car sorted-kwd/arg-pairs) '#,(map car sorted-kwd/arg-pairs)
(list #,@(map cdr sorted-kwd/arg-pairs)) (list #,@keyword-arguments)
#,(if rst #,(if rst
#'rest-args #'rest-args
#''()) #''())
#,@this-params #,@this-params
#,@(map (λ (arg) (hash-ref arg->var arg)) non-kwd-args))))] #,@regular-arguments)]
[opts? [opts?
;; has optional args, but no keyword args ;; has optional args, but no keyword args
#`(return/no-unsupplied #,(if (null? result-checkers) #f (car result-checkers)) #`(return/no-unsupplied #,(if (null? result-checkers) #f (car result-checkers))
@ -516,16 +518,6 @@ evaluted left-to-right.)
(all-but-last (vector->list vars)) (all-but-last (vector->list vars))
(vector->list vars)))] (vector->list vars)))]
[else [else
(let*-values ([(rev-regs rev-kwds)
(for/fold ([regs null]
[kwds null])
([arg (in-list args)]
[i (in-naturals)])
(if (arg-kwd arg)
(values regs (cons (vector-ref vars i) kwds))
(values (cons (vector-ref vars i) regs) kwds)))]
[(regular-arguments keyword-arguments)
(values (reverse rev-regs) (reverse rev-kwds))])
(cond (cond
[(and (null? keyword-arguments) rst) [(and (null? keyword-arguments) rst)
#`(apply values #,@result-checkers #,@this-params #,@regular-arguments rest-args)] #`(apply values #,@result-checkers #,@this-params #,@regular-arguments rest-args)]
@ -536,7 +528,7 @@ evaluted left-to-right.)
#,@this-params #,@regular-arguments rest-args)] #,@this-params #,@regular-arguments rest-args)]
[else [else
#`(values #,@result-checkers (list #,@keyword-arguments) #`(values #,@result-checkers (list #,@keyword-arguments)
#,@this-params #,@regular-arguments)]))]))) #,@this-params #,@regular-arguments)])])))
(define (return/no-unsupplied res-checker rest-args . args) (define (return/no-unsupplied res-checker rest-args . args)
(if res-checker (if res-checker