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

fixed naming bugs and added a test suite to ensure that I preserve backwards compatibility with the old version of mzlib's contract system

Browse Source 
svn: r8050

original commit: 49f198dad7ce77fa7c421cab3342a8d39295f530
This commit is contained in:
Robby Findler 2007-12-18 20:49:33 +00:00
parent 1e8e36b48f
commit 7e8aee13c4
3 changed files with 5151 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/scheme/private/contract-arrow.ss
View File

@ -109,6 +109,8 @@ Add both optional and mandatory keywords to opt-> and friends.
(name-prop (λ (ctc) (single-arrow-name-maker
(->-doms ctc)
(->-dom-rest ctc)
(->-kwds ctc)
(->-quoted-kwds ctc)
(->-rng-any? ctc)
(->-rngs ctc))))
(first-order-prop
@ -136,12 +138,12 @@ Add both optional and mandatory keywords to opt-> and friends.
(->-rngs this)
(->-rngs that)))))))
(define (single-arrow-name-maker doms/c doms-rest rng-any? rngs)
(define (single-arrow-name-maker doms/c doms-rest kwds/c kwds rng-any? rngs)
(cond
[doms-rest
(build-compound-type-name
'->*
(apply build-compound-type-name doms/c)
(apply build-compound-type-name (append doms/c (apply append (map list kwds kwds/c))))
doms-rest
(cond
[rng-any? 'any]
@ -153,7 +155,11 @@ Add both optional and mandatory keywords to opt-> and friends.
[(null? rngs) '(values)]
[(null? (cdr rngs)) (car rngs)]
[else (apply build-compound-type-name 'values rngs)])])
(apply build-compound-type-name '-> (append doms/c (list rng-name))))]))
(apply build-compound-type-name
'->
(append doms/c
(apply append (map list kwds kwds/c))
(list rng-name))))]))
(define-for-syntax (sort-keywords stx kwd/ctc-pairs)
(define (insert x lst)

5140
collects/tests/mzscheme/contract-mzlib-test.ss Normal file
View File

File diff suppressed because it is too large Load Diff

2
collects/tests/mzscheme/contract-test.ss
View File

@ -4315,8 +4315,10 @@ so that propagation occurs.
(test-name '(-> integer? (values boolean? char?)) (-> integer? (values boolean? char?)))
(test-name '(-> integer? boolean? (values char? any/c)) (->* (integer? boolean?) (char? any/c)))
(test-name '(-> integer? boolean? any) (->* (integer? boolean?) any))
(test-name '(-> integer? boolean? #:x string? any) (-> integer? #:x string? boolean? any))
(test-name '(->* (integer?) boolean? (char? any/c)) (->* (integer?) boolean? (char? any/c)))
(test-name '(->* (integer? char?) boolean? any) (->* (integer? char?) boolean? any))
(test-name '(->* (integer? char? #:z string? ) boolean? any) (->* (#:z string? integer? char?) boolean? any))
(test-name '(->d integer? boolean? ...) (->d integer? boolean? (lambda (x y) char?)))
(test-name '(->d* (integer? boolean?) ...) (->d* (integer? boolean?) (lambda (x y) char?)))
(test-name '(->d* (integer? boolean?) any/c ...) (->d* (integer? boolean?) any/c (lambda (x y . z) char?)))