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

Fix polymorphic structs with mutability.

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2010-09-07 10:39:13 -04:00
parent 91fefa055e
commit 6130f3551c
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)] [(Univ:) (if from-typed? #'any-wrap/c #'any/c)]
;; we special-case lists: ;; we special-case lists:
[(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var))))) [(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?] [(? (lambda (e) (eq? t:Any-Syntax e))) #'syntax?]
[(Base: sym cnt) #`(flat-named-contract '#,sym (flat-contract-predicate #,cnt))] [(Base: sym cnt) #`(flat-named-contract '#,sym (flat-contract-predicate #,cnt))]
[(Refinement: par p? cert) [(Refinement: par p? cert)
@ -168,7 +170,6 @@
[(name ...) name] [(name ...) name]
[(by-name-cnt ...) (for/list ([t by-name-init-ty]) (t->c/neg t))] [(by-name-cnt ...) (for/list ([t by-name-init-ty]) (t->c/neg t))]
[(by-name-init ...) by-name-init]) [(by-name-init ...) by-name-init])
#;#'class?
#'(class/c (name fcn-cnt) ... (init [by-name-init by-name-cnt] ...)))] #'(class/c (name fcn-cnt) ... (init [by-name-init by-name-cnt] ...)))]
[(Value: '()) #'null?] [(Value: '()) #'null?]
[(Struct: nm par (list (fld: flds acc-ids mut?) ...) proc poly? pred? cert maker-id) [(Struct: nm par (list (fld: flds acc-ids mut?) ...) proc poly? pred? cert maker-id)
@ -185,21 +186,21 @@
(for/list ([fty flds] (for/list ([fty flds]
[f-acc acc-ids] [f-acc acc-ids]
[m? mut?]) [m? mut?])
#`(((contract-projection #`(((contract-projection
#,(t->c fty #:seen (cons (cons ty #'(recursive-contract rec)) structs-seen))) #,(t->c fty #:seen (cons (cons ty #'(recursive-contract rec)) structs-seen)))
blame) blame)
(#,f-acc val)))]) (#,f-acc val)))])
#`(letrec ([rec #`(letrec ([rec
(make-contract (make-contract
#:name 'cnt-name #:name 'cnt-name
#:first-order #,pred? #:first-order #,pred?
#:projection #:projection
(lambda (blame) (lambda (blame)
(lambda (val) (lambda (val)
(unless (#,pred? val) (unless (#,pred? val)
(raise-blame-error blame val "expected ~a value, got ~v" 'cnt-name val)) (raise-blame-error blame val "expected ~a value, got ~v" 'cnt-name val))
(maker fld-cnts ...))))]) (maker fld-cnts ...))))])
rec))] rec))]
[else #`(flat-named-contract '#,(syntax-e pred?) #,(cert pred?))])] [else #`(flat-named-contract '#,(syntax-e pred?) #,(cert pred?))])]
[(Syntax: (Base: 'Symbol _)) #'identifier?] [(Syntax: (Base: 'Symbol _)) #'identifier?]
[(Syntax: t) #`(syntax/c #,(t->c t))] [(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 ;; check and register types for a polymorphic define struct
;; tc/poly-struct : Listof[identifier] (U identifier (list identifier identifier)) Listof[identifier] Listof[syntax] -> void ;; 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 ;; parent field types can't actually be determined here
(define-values (nm parent-name parent name name-tvar) (parse-parent nm/par)) (define-values (nm parent-name parent name name-tvar) (parse-parent nm/par))
;; create type variables for the new type parameters ;; create type variables for the new type parameters
@ -236,6 +236,7 @@
;; then register them ;; then register them
(mk/register-sty nm flds parent-name parent-field-types types (mk/register-sty nm flds parent-name parent-field-types types
#:maker maker #:maker maker
#:mutable mutable
;; wrap everything in the approriate forall ;; wrap everything in the approriate forall
#:wrapper (λ (t) (make-Poly tvars t)) #:wrapper (λ (t) (make-Poly tvars t))
#:type-wrapper (λ (t) (make-App t new-tvars #f)) #:type-wrapper (λ (t) (make-App t new-tvars #f))