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

Store contract in Base type representation.

Browse Source 
Fix tests, pattern matches.
Contract is *ignored* in equality testing.

svn: r12227

original commit: 477fa5581e1c9923df030e0eea86a62c367f014f
This commit is contained in:
Sam Tobin-Hochstadt 2008-11-03 23:58:29 +00:00
parent ea2ca9402c
commit 2a450f220f
8 changed files with 44 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/tests/typed-scheme/unit-tests/subtype-tests.ss
View File

@ -111,8 +111,8 @@
(cl-> [() (-pair N (-v b))]
[(N) (-pair N (-v b))])]
[(-poly (a) ((Un (-base 'foo) (-struct 'bar #f (list N a) #f #f #f values)) . -> . (-lst a)))
((Un (-base 'foo) (-struct 'bar #f (list N (-pair N (-v a))) #f #f #f values)) . -> . (-lst (-pair N (-v a))))]
[(-poly (a) ((Un (make-Base 'foo #f) (-struct 'bar #f (list N a) #f #f #f values)) . -> . (-lst a)))
((Un (make-Base 'foo #f) (-struct 'bar #f (list N (-pair N (-v a))) #f #f #f values)) . -> . (-lst (-pair N (-v a))))]
[(-poly (a) ((-struct 'bar #f (list N a) #f #f #f values) . -> . (-lst a)))
((-struct 'bar #f (list N (-pair N (-v a))) #f #f #f values) . -> . (-lst (-pair N (-v a))))]

2
collects/tests/typed-scheme/unit-tests/type-equal-tests.ss
View File

@ -7,6 +7,8 @@
(provide type-equal-tests)
(define (-base x) (make-Base x #f))
(define-syntax (te-tests stx)
(define (single-test stx)

1
collects/typed-scheme/env/init-envs.ss vendored
View File

@ -23,6 +23,7 @@
(string->symbol (string-append "make-" (substring (symbol->string sym) 7))))
(match v
[(Union: elems) `(make-Union (list ,@(map sub elems)))]
[(Base: n cnt) `(make-Base ',n (quote-syntax ,cnt))]
[(Name: stx) `(make-Name (quote-syntax ,stx))]
[(Struct: name parent flds proc poly? pred-id cert)
`(make-Struct ,(sub name) ,(sub parent) ,(sub flds) ,(sub proc) ,(sub poly?) (quote-syntax ,pred-id) (syntax-local-certifier))]

10
collects/typed-scheme/private/remove-intersect.ss
View File

@ -23,16 +23,16 @@
(ormap (lambda (t*) (overlap t t*)) e)]
[(or (list _ (? Poly?)) (list (? Poly?) _))
#t] ;; these can have overlap, conservatively
[(list (Base: s1) (Base: s2)) (eq? s1 s2)]
[(list (Base: _) (Value: _)) (subtype t2 t1)] ;; conservative
[(list (Value: _) (Base: _)) (subtype t1 t2)] ;; conservative
[(list (Base: s1 _) (Base: s2 _)) (eq? s1 s2)]
[(list (Base: _ _) (Value: _)) (subtype t2 t1)] ;; conservative
[(list (Value: _) (Base: _ _)) (subtype t1 t2)] ;; conservative
[(list (Syntax: t) (Syntax: t*))
(overlap t t*)]
[(or (list (Syntax: _) _)
(list _ (Syntax: _)))
#f]
[(list (Base: _) _) #f]
[(list _ (Base: _)) #f]
[(list (Base: _ _) _) #f]
[(list _ (Base: _ _)) #f]
[(list (Value: (? pair? v)) (Pair: _ _)) #t]
[(list (Pair: _ _) (Value: (? pair? v))) #t]
[(list (Pair: a b) (Pair: a* b*))

12
collects/typed-scheme/private/subtype.ss
View File

@ -177,13 +177,13 @@
;; value types
[(list (Value: v1) (Value: v2)) (=> unmatch) (if (equal? v1 v2) A0 (unmatch))]
;; integers are numbers too
[(list (Base: 'Integer) (Base: 'Number)) A0]
[(list (Base: 'Integer _) (Base: 'Number _)) A0]
;; values are subtypes of their "type"
[(list (Value: (? integer? n)) (Base: 'Integer)) A0]
[(list (Value: (? number? n)) (Base: 'Number)) A0]
[(list (Value: (? boolean? n)) (Base: 'Boolean)) A0]
[(list (Value: (? symbol? n)) (Base: 'Symbol)) A0]
[(list (Value: (? string? n)) (Base: 'String)) A0]
[(list (Value: (? integer? n)) (Base: 'Integer _)) A0]
[(list (Value: (? number? n)) (Base: 'Number _)) A0]
[(list (Value: (? boolean? n)) (Base: 'Boolean _)) A0]
[(list (Value: (? symbol? n)) (Base: 'Symbol _)) A0]
[(list (Value: (? string? n)) (Base: 'String _)) A0]
;; tvars are equal if they are the same variable
[(list (F: t) (F: t*)) (if (eq? t t*) A0 (fail! s t))]
;; case-lambda

44
collects/typed-scheme/private/type-effect-convenience.ss
View File

@ -11,7 +11,8 @@
"type-utils.ss"
scheme/promise
(for-syntax macro-debugger/stxclass/stxclass)
(for-syntax scheme/base))
(for-syntax scheme/base)
(for-template scheme/base scheme/contract))
(provide (all-defined-out)
;; these should all eventually go away
@ -114,27 +115,27 @@
(lambda (t)
(make-Struct s #f (list t) #f #f #'promise? values))))
(define N (make-Base 'Number))
(define -Integer (make-Base 'Integer))
(define B (make-Base 'Boolean))
(define Sym (make-Base 'Symbol))
(define -Void (make-Base 'Void))
(define -Bytes (make-Base 'Bytes))
(define -Regexp (make-Base 'Regexp))
(define -PRegexp (make-Base 'PRegexp))
(define -Byte-Regexp (make-Base 'Byte-Regexp))
(define -Byte-PRegexp (make-Base 'Byte-PRegexp))
(define -String (make-Base 'String))
(define -Keyword (make-Base 'Keyword))
(define -Char (make-Base 'Char))
(define -Syntax make-Syntax)
(define -Prompt-Tag (make-Base 'Prompt-Tag))
(define -Cont-Mark-Set (make-Base 'Continuation-Mark-Set))
(define -Path (make-Base 'Path))
(define -Namespace (make-Base 'Namespace))
(define -Output-Port (make-Base 'Output-Port))
(define -Input-Port (make-Base 'Input-Port))
(define N (make-Base 'Number #'number?))
(define -Integer (make-Base 'Integer #'integer?))
(define B (make-Base 'Boolean #'boolean?))
(define Sym (make-Base 'Symbol #'symbol?))
(define -Void (make-Base 'Void #'void?))
(define -Bytes (make-Base 'Bytes #'bytes?))
(define -Regexp (make-Base 'Regexp #'(and/c regexp? (not/c pregexp?) (not/c byte-regexp?))))
(define -PRegexp (make-Base 'PRegexp #'(and/c pregexp? (not/c byte-pregexp?))))
(define -Byte-Regexp (make-Base 'Byte-Regexp #'(and/c byte-regexp? (not/c byte-pregexp?))))
(define -Byte-PRegexp (make-Base 'Byte-PRegexp #'byte-pregexp?))
(define -String (make-Base 'String #'string?))
(define -Keyword (make-Base 'Keyword #'keyword?))
(define -Char (make-Base 'Char #'char?))
(define -Prompt-Tag (make-Base 'Prompt-Tag #'continuation-prompt-tag?))
(define -Cont-Mark-Set (make-Base 'Continuation-Mark-Set #'continuation-mark-set?))
(define -Path (make-Base 'Path #'path?))
(define -Namespace (make-Base 'Namespace #'namespace?))
(define -Output-Port (make-Base 'Output-Port #'output-port?))
(define -Input-Port (make-Base 'Input-Port #'input-port?))
(define -Syntax make-Syntax)
(define -HT make-Hashtable)
(define -Promise make-promise-ty)
@ -173,7 +174,6 @@
(define -pair make-Pair)
(define -base make-Base)
(define -struct make-Struct)
(define -val make-Value)

10
collects/typed-scheme/private/type-effect-printer.ss
View File

@ -95,7 +95,7 @@
[else (fp "~a" v)])]
[(? tuple? t)
(fp "~a" (cons 'List (tuple-elems t)))]
[(Base: n) (fp "~a" n)]
[(Base: n cnt) (fp "~a" n)]
[(Opaque: pred _) (fp "(Opaque ~a)" (syntax->datum pred))]
[(Struct: 'Promise par (list fld) proc _ _ _) (fp "(Promise ~a)" fld)]
[(Struct: nm par flds proc _ _ _)
@ -138,10 +138,10 @@
#;
[(Mu-unsafe: b) (fp "(unsafe-mu ~a ~a)" (Type-seq c) b)]
[(Mu: x (Syntax: (Union: (list
(Base: 'Number)
(Base: 'Boolean)
(Base: 'Symbol)
(Base: 'String)
(Base: 'Number _)
(Base: 'Boolean _)
(Base: 'Symbol _)
(Base: 'String _)
(Mu: var (Union: (list (Value: '()) (Pair: (F: x) (F: var)))))
(Mu: y (Union: (list (F: x) (Pair: (F: x) (F: y)))))
(Vector: (F: x))

2
collects/typed-scheme/rep/type-rep.ss
View File

@ -50,7 +50,7 @@
(dt Box (elem) [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))])
;; name is a Symbol (not a Name)
(dt Base (name) [#:frees #f] [#:fold-rhs #:base])
(dt Base (name contract) [#:frees #f] [#:fold-rhs #:base] [#:intern name])
;; body is a Scope
(dt Mu (body) #:no-provide [#:frees (free-vars* body) (without-below 1 (free-idxs* body))]