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

Prohibit predicates, unions of tvars in contracts

Browse Source 
Add vector?

svn: r15701
This commit is contained in:
Sam Tobin-Hochstadt 2009-08-11 19:35:34 +00:00
parent aae1fb9508
commit b23016f86a
2 changed files with 11 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/typed-scheme/private/base-env.ss
View File

@ -183,6 +183,7 @@
[- (cl->* (->* (list -Integer) -Integer -Integer) (->* (list N) N N))] [- (cl->* (->* (list -Integer) -Integer -Integer) (->* (list N) N N))]
[max (->* (list N) N N)] [max (->* (list N) N N)]
[min (->* (list N) N N)] [min (->* (list N) N N)]
[vector? (make-pred-ty (-vec Univ))]
[vector-ref (-poly (a) ((-vec a) N . -> . a))] [vector-ref (-poly (a) ((-vec a) N . -> . a))]
[build-vector (-poly (a) (-Integer (-Integer . -> . a) . -> . (-vec a)))] [build-vector (-poly (a) (-Integer (-Integer . -> . a) . -> . (-vec a)))]
[build-list (-poly (a) (-Integer (-Integer . -> . a) . -> . (-lst a)))] [build-list (-poly (a) (-Integer (-Integer . -> . a) . -> . (-lst a)))]

13
collects/typed-scheme/private/type-contract.ss
View File

@ -4,7 +4,7 @@
(require (except-in "../utils/utils.ss" extend)) (require (except-in "../utils/utils.ss" extend))
(require (require
(rep type-rep) (rep type-rep filter-rep object-rep)
(typecheck internal-forms) (typecheck internal-forms)
(utils tc-utils require-contract) (utils tc-utils require-contract)
(env type-name-env) (env type-name-env)
@ -65,18 +65,21 @@
[(Refinement: par p? cert) [(Refinement: par p? cert)
#`(and/c #,(t->c par) (flat-contract #,(cert p?)))] #`(and/c #,(t->c par) (flat-contract #,(cert p?)))]
[(Union: elems) [(Union: elems)
(let-values ([(vars notvars)
(partition F? elems)])
(unless (>= 1 (length vars)) (exit (fail)))
(with-syntax (with-syntax
([cnts (map t->c elems)]) ([cnts (append (map t->c vars) (map t->c notvars))])
#;(printf "~a~n" (syntax-object->datum #'cnts)) #'(or/c . cnts)))]
#'(or/c . cnts))]
[(Function: arrs) [(Function: arrs)
(let () (let ()
(define (f a) (define (f a)
(define-values (dom* rngs* rst) (define-values (dom* rngs* rst)
(match a (match a
[(arr: dom (Values: (list (Result: rngs _ _) ...)) rst #f '()) [(arr: dom (Values: (list (Result: rngs (LFilterSet: '() '()) (LEmpty:)) ...)) rst #f '())
(values (map t->c/neg dom) (map t->c rngs) (and rst (t->c/neg rst)))] (values (map t->c/neg dom) (map t->c rngs) (and rst (t->c/neg rst)))]
[_ (exit (fail))])) [_ (exit (fail))]))
(trace f)
(with-syntax (with-syntax
([(dom* ...) dom*] ([(dom* ...) dom*]
[rng* (match rngs* [rng* (match rngs*