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

fix the obvious bug wrt to procedures returned from make-keyword-procedure, but something is still wrong

Browse Source 
related to PR 11833
This commit is contained in:
Robby Findler 2011-04-01 09:09:52 -05:00
parent c677932baf
commit b926b17d7e
2 changed files with 15 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1866,8 +1866,9 @@ v4 todo:
(define (keywords-match mandatory-kwds optional-kwds val) (define (keywords-match mandatory-kwds optional-kwds val)
(let-values ([(proc-mandatory proc-all) (procedure-keywords val)]) (let-values ([(proc-mandatory proc-all) (procedure-keywords val)])
(and ;; proc accepts all ctc's mandatory keywords (and ;; proc accepts all ctc's mandatory keywords
(or (not proc-all)
(andmap (λ (kwd) (member kwd proc-all)) (andmap (λ (kwd) (member kwd proc-all))
mandatory-kwds) mandatory-kwds))
;; proc's mandatory keywords are still mandatory in ctc ;; proc's mandatory keywords are still mandatory in ctc
(andmap (λ (kwd) (member kwd mandatory-kwds)) (andmap (λ (kwd) (member kwd mandatory-kwds))
proc-mandatory) proc-mandatory)

12
collects/tests/racket/contract-test.rktl
View File

@ -1070,6 +1070,18 @@
'contract-arrow-any3 'contract-arrow-any3
'((contract (integer? . -> . any) (lambda (x) #f) 'pos 'neg) #t)) '((contract (integer? . -> . any) (lambda (x) #f) 'pos 'neg) #t))
(test/spec-passed
'contract-arrow-all-kwds
'(contract (-> #:a string? string?)
(make-keyword-procedure void)
'pos 'neg))
(test/spec-passed
'contract-arrow-all-kwds2
'((contract (-> #:a string? void?)
(make-keyword-procedure void)
'pos 'neg)
#:a "abcdef"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;