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

Now migrate vector/c and vector-immutable/c.

Browse Source 
Also add old-style vector/c to mzlib/contract.

original commit: b416b7e5bbac1c75dba6611cc96d7f821d0ec4f2
This commit is contained in:
Stevie Strickland 2010-05-17 13:52:01 -04:00
parent a4087991e3
commit f3f84db494
1 changed files with 28 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/mzlib/private/contract-mutable.rkt
View File

@ -2,7 +2,7 @@
(require (only-in racket/contract/private/box box-immutable/c)
(only-in racket/contract/private/vector
vector/c vector-immutableof vector-immutable/c)
vector-immutableof vector-immutable/c)
racket/contract/private/blame
racket/contract/private/guts)
@ -44,3 +44,30 @@
(for ([v (in-vector val)])
(proj v))
val))))))
(define/subexpression-pos-prop (vector/c . ctcs)
(let ([ctcs (for/list ([ctc (in-list ctcs)])
(coerce-flat-contract 'vector/c ctc))])
(make-flat-contract
#:name (apply build-compound-type-name 'vector/c ctcs)
#:first-order
(λ (val)
(and (vector? val)
(= (vector-length val) (length ctcs))
(for/and ([v (in-vector val)]
[c (in-list ctcs)])
(contract-first-order-passes? c v))))
#:projection
(λ (blame)
(λ (val)
(let ([projs (for/list ([ctc (in-list ctcs)])
((contract-projection ctc) blame))])
(unless (vector? val)
(raise-blame-error blame val "not a vector"))
(unless (= (vector-length val) (length ctcs))
(raise-blame-error blame val "expected vector of length ~a, got length ~a"
(length ctcs) (vector-length val)))
(for ([v (in-vector val)]
[p (in-list projs)])
(p v))
val))))))