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

Fix polymorphic structs with mutability.

Browse Source 
original commit: 6130f3551c1019c1bc035d802378c29bf574a0c1
This commit is contained in:
Sam Tobin-Hochstadt 2010-09-07 10:39:13 -04:00
parent 617496f14e
commit 4bf64acde5
2 changed files with 20 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
collects/typed-scheme/private/type-contract.rkt
View File

@ -117,7 +117,9 @@
[(Univ:) (if from-typed? #'any-wrap/c #'any/c)]
;; we special-case lists:
[(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var)))))
#`(listof #,(t->c elem-ty))]
(if (and (not from-typed?) (type-equal? elem-ty t:Univ))
#'list?
#`(listof #,(t->c elem-ty)))]
[(? (lambda (e) (eq? t:Any-Syntax e))) #'syntax?]
[(Base: sym cnt) #`(flat-named-contract '#,sym (flat-contract-predicate #,cnt))]
[(Refinement: par p? cert)
@ -168,7 +170,6 @@
[(name ...) name]
[(by-name-cnt ...) (for/list ([t by-name-init-ty]) (t->c/neg t))]
[(by-name-init ...) by-name-init])
#;#'class?
#'(class/c (name fcn-cnt) ... (init [by-name-init by-name-cnt] ...)))]
[(Value: '()) #'null?]
[(Struct: nm par (list (fld: flds acc-ids mut?) ...) proc poly? pred? cert maker-id)
@ -185,21 +186,21 @@
(for/list ([fty flds]
[f-acc acc-ids]
[m? mut?])
#`(((contract-projection
#,(t->c fty #:seen (cons (cons ty #'(recursive-contract rec)) structs-seen)))
blame)
(#,f-acc val)))])
#`(letrec ([rec
(make-contract
#:name 'cnt-name
#:first-order #,pred?
#:projection
(lambda (blame)
(lambda (val)
(unless (#,pred? val)
(raise-blame-error blame val "expected ~a value, got ~v" 'cnt-name val))
(maker fld-cnts ...))))])
rec))]
#`(((contract-projection
#,(t->c fty #:seen (cons (cons ty #'(recursive-contract rec)) structs-seen)))
blame)
(#,f-acc val)))])
#`(letrec ([rec
(make-contract
#:name 'cnt-name
#:first-order #,pred?
#:projection
(lambda (blame)
(lambda (val)
(unless (#,pred? val)
(raise-blame-error blame val "expected ~a value, got ~v" 'cnt-name val))
(maker fld-cnts ...))))])
rec))]
[else #`(flat-named-contract '#,(syntax-e pred?) #,(cert pred?))])]
[(Syntax: (Base: 'Symbol _)) #'identifier?]
[(Syntax: t) #`(syntax/c #,(t->c t))]

3
collects/typed-scheme/typecheck/tc-structs.rkt
View File

@ -211,7 +211,7 @@
;; check and register types for a polymorphic define struct
;; tc/poly-struct : Listof[identifier] (U identifier (list identifier identifier)) Listof[identifier] Listof[syntax] -> void
(define (tc/poly-struct vars nm/par flds tys #:maker [maker #f])
(define (tc/poly-struct vars nm/par flds tys #:maker [maker #f] #:mutable [mutable #f])
;; parent field types can't actually be determined here
(define-values (nm parent-name parent name name-tvar) (parse-parent nm/par))
;; create type variables for the new type parameters
@ -236,6 +236,7 @@
;; then register them
(mk/register-sty nm flds parent-name parent-field-types types
#:maker maker
#:mutable mutable
;; wrap everything in the approriate forall
#:wrapper (λ (t) (make-Poly tvars t))
#:type-wrapper (λ (t) (make-App t new-tvars #f))