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

fix a bug in the arity checking for contracts

Browse Source
This commit is contained in:
Robby Findler 2011-07-15 07:59:17 -06:00
parent 072003f2f4
commit 7993d38e35
2 changed files with 51 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
collects/racket/contract/private/arrow.rkt
View File

@ -149,7 +149,8 @@ v4 todo:
(define (matches-arity-exactly? val min-arity max-arity contract-req-kwds contract-opt-kwds) (define (matches-arity-exactly? val min-arity max-arity contract-req-kwds contract-opt-kwds)
(define proc-arity (procedure-arity val)) (define proc-arity (procedure-arity val))
(and (let-values ([(vr va) (procedure-keywords val)]) (and (let-values ([(vr va) (procedure-keywords val)])
(and va (equal? vr contract-req-kwds) (equal? va contract-opt-kwds))) (and va (equal? vr contract-req-kwds)
(keywords-match? va contract-req-kwds contract-opt-kwds)))
(cond (cond
[(number? proc-arity) (and (number? max-arity) [(number? proc-arity) (and (number? max-arity)
(= min-arity max-arity) (= min-arity max-arity)
@ -173,6 +174,21 @@ v4 todo:
(loop (cdr arity) (loop (cdr arity)
(+ i 1)))))]))]))) (+ i 1)))))]))])))
(define (keywords-match? accepted-keywords contract-req-kwds contract-opt-kwds)
(let loop ([accepted accepted-keywords]
[req-kwds contract-req-kwds]
[opt-kwds contract-opt-kwds])
(cond
[(null? accepted) (and (null? opt-kwds) (null? req-kwds))]
[else
(let ([kwd (car accepted)])
(cond
[(and (pair? req-kwds) (eq? (car req-kwds) kwd))
(loop (cdr accepted) (cdr req-kwds) opt-kwds)]
[(and (pair? opt-kwds) (eq? (car opt-kwds) kwd))
(loop (cdr accepted) req-kwds (cdr opt-kwds))]
[else #f]))])))
(define-for-syntax (create-chaperone blame val pre post this-args doms opt-doms dom-rest req-kwds opt-kwds rngs) (define-for-syntax (create-chaperone blame val pre post this-args doms opt-doms dom-rest req-kwds opt-kwds rngs)
(with-syntax ([blame blame] (with-syntax ([blame blame]
[val val]) [val val])

34
collects/tests/racket/contract-helpers.rkt
View File

@ -35,3 +35,37 @@
1 #f '() '()) #t) 1 #f '() '()) #t)
(check-equal? (matches-arity-exactly? (lambda (x . y) x) (check-equal? (matches-arity-exactly? (lambda (x . y) x)
0 #f '() '()) #f) 0 #f '() '()) #f)
(check-equal? (matches-arity-exactly? (lambda (x #:y y) y)
1 1 '(#:y) '())
#t)
(check-equal? (matches-arity-exactly? (lambda (x #:y y #:z z) y)
1 1 '(#:y #:z) '())
#t)
(check-equal? (matches-arity-exactly? (lambda (x #:y y #:z z) y)
1 1 '(#:y) '())
#f)
(check-equal? (matches-arity-exactly? (lambda (x #:y y #:z z) y)
1 1 '(#:z) '())
#f)
(check-equal? (matches-arity-exactly? (lambda (x #:y y #:z z) y)
1 1 '() '())
#f)
(check-equal? (matches-arity-exactly? (lambda (x #:y y #:z z) y)
1 1 '() '(#:x))
#f)
(check-equal? (matches-arity-exactly? (lambda (x #:y y #:z [z 1]) y)
1 1 '(#:y) '(#:z))
#t)
(check-equal? (matches-arity-exactly? (lambda (x #:y y #:z [z 1]) y)
1 1 '(#:y) '())
#f)
(check-equal? (matches-arity-exactly? (lambda (x #:y y #:z [z 1]) y)
1 1 '() '(#:z))
#f)
(check-equal? (matches-arity-exactly? (lambda (x #:y y #:z [z 1]) y)
1 1 '(#:y #:z) '())
#f)
(check-equal? (matches-arity-exactly? (lambda (x #:y y #:z [z 1]) y)
1 1 '() '(#:y #:z))
#f)