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

Make structs initialize to constant instead of covariant.

Browse Source 
(cherry picked from commit 7735aa5799)
This commit is contained in:
Eric Dobson 2013-01-20 16:21:43 -08:00 committed by Ryan Culpepper
parent aa025b9c56
commit 64d66d3b9a
3 changed files with 18 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/tests/typed-racket/succeed/structs-variance2.rkt Normal file
View File

@ -0,0 +1,7 @@
#lang typed/racket
(struct: (a) foo ((v : ((baz a) -> Symbol))))
(struct: (a) bar ((v : ((foo a) -> Symbol))))
(struct: (a) baz ((v : ((bar a) -> Symbol))))
(ann (ann (foo (lambda (x) 'x)) (foo String)) (foo Symbol))

17
collects/typed-racket/typecheck/tc-toplevel.rkt
View File

@ -74,19 +74,20 @@
[(define-values () (begin (quote-syntax (define-typed-struct/exec-internal ~! nm ([fld : ty] ...) proc-ty)) (#%plain-app values))) [(define-values () (begin (quote-syntax (define-typed-struct/exec-internal ~! nm ([fld : ty] ...) proc-ty)) (#%plain-app values)))
(tc/struct null #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:proc-ty #'proc-ty)]))) (tc/struct null #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:proc-ty #'proc-ty)])))
(define (add-constant-variance! form) (define (type-vars-of-struct form)
(parameterize ([current-orig-stx form]) (parameterize ([current-orig-stx form])
(syntax-parse form (syntax-parse form
#:literals (values define-typed-struct-internal quote-syntax #%plain-app) #:literals (values define-typed-struct-internal quote-syntax #%plain-app)
;; define-typed-struct ;; define-typed-struct
[(define-values () (begin (quote-syntax (define-typed-struct-internal ~! . dts:define-typed-struct)) (#%plain-app values))) [(define-values () (begin (quote-syntax (define-typed-struct-internal ~! . dts:define-typed-struct)) (#%plain-app values)))
;; TODO make constant (attribute dts.tvars)]
(unless (null? (attribute dts.tvars))
(register-type-variance! #'dts.name (map (lambda (_) Covariant) (attribute dts.tvars))))]
[(define-values () (begin (quote-syntax (define-typed-struct/exec-internal ~! nm ([fld : ty] ...) proc-ty)) (#%plain-app values))) [(define-values () (begin (quote-syntax (define-typed-struct/exec-internal ~! nm ([fld : ty] ...) proc-ty)) (#%plain-app values)))
;; Not polymorphic ;; Not polymorphic
(void)]))) null])))
(define (add-constant-variance! name vars)
(unless (null? vars)
(register-type-variance! name (map (lambda (_) Constant) vars))))
@ -305,8 +306,10 @@
(for-each (compose register-type-alias parse-type-alias) type-aliases) (for-each (compose register-type-alias parse-type-alias) type-aliases)
;; Add the struct names to the type table, but not with a type ;; Add the struct names to the type table, but not with a type
;(printf "before adding type names~n") ;(printf "before adding type names~n")
(for-each (compose register-type-name name-of-struct) struct-defs) (let ((names (map name-of-struct struct-defs))
(for-each add-constant-variance! struct-defs) (type-vars (map type-vars-of-struct struct-defs)))
(for-each register-type-name names)
(for-each add-constant-variance! names type-vars))
;(printf "after adding type names~n") ;(printf "after adding type names~n")
;; resolve all the type aliases, and error if there are cycles ;; resolve all the type aliases, and error if there are cycles
(resolve-type-aliases parse-type) (resolve-type-aliases parse-type)