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

fix arity checking for -> contract with ellipses

Browse Source 
closes #1266
This commit is contained in:
Robby Findler 2016-02-26 08:05:32 -06:00
parent d9971292a6
commit 990555cd8d
2 changed files with 13 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -367,6 +367,11 @@
(λ args args)
'pos 'neg)
1 2 3 4 #f 6 7))
(test/spec-passed
'contract->...5
'(contract (-> procedure? any/c ... list? any)
(λ (proc last . stuff) stuff)
'pos 'neg))
(test/spec-passed

11
racket/collects/racket/contract/private/arity-checking.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require "blame.rkt"
"kwd-info-struct.rkt")
"kwd-info-struct.rkt"
"list.rkt")
(provide do-arity-checking
@ -24,7 +25,11 @@
(define arity (if (list? (procedure-arity val))
(procedure-arity val)
(list (procedure-arity val))))
(define expected-number-of-non-keyword-args (length ->stct-doms))
(define exra-required-args (if (ellipsis-rest-arg-ctc? ->stct-rest)
(length (*list-ctc-suffix ->stct-rest))
0))
(define expected-number-of-non-keyword-args (+ (length ->stct-doms) exra-required-args))
(define matching-arity?
(and (for/or ([a (in-list arity)])
(or (equal? expected-number-of-non-keyword-args a)
@ -33,7 +38,7 @@
(if ->stct-rest
(let ([lst (car (reverse arity))])
(and (arity-at-least? lst)
(<= (arity-at-least-value lst) ->stct-min-arity)))
(<= (arity-at-least-value lst) (+ exra-required-args ->stct-min-arity))))
#t)))
(unless matching-arity?
(k