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

@ -928,6 +928,14 @@
'pos 'neg)
3 2 1)
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
'->i-arity1

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