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

Ensure that identifiers defined by struct are registered as being defined in the correct module.

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2012-09-27 16:21:51 -04:00
parent cf4d43c04f
commit c07852eaf1
2 changed files with 71 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

111
collects/typed-racket/typecheck/tc-structs.rkt
View File

@ -35,6 +35,28 @@
(pattern (name:id par:id)) (pattern (name:id par:id))
(pattern name:id #:attr par #f)) (pattern name:id #:attr par #f))
;; sty : Struct?
;; names : Listof[Identifier]
;; desc : struct-desc
;; type-only : Boolean
(struct parsed-struct (sty names desc struct-info type-only) #:transparent)
;; type-name : Id
;; struct-type : Id
;; constructor : Id
;; predicate : Id
;; getters : Listof[Id]
;; setters : Listof[Id] or #f
(struct struct-names (type-name struct-type constructor predicate getters setters) #:transparent)
;;struct-fields: holds all the relevant information about a struct type's types
(struct struct-desc (parent-fields self-fields tvars mutable proc-ty) #:transparent)
(define (struct-desc-all-fields fields)
(append (struct-desc-parent-fields fields) (struct-desc-self-fields fields)))
(define (struct-desc-parent-count fields)
(length (struct-desc-parent-fields fields)))
;; TODO make this not return a list ;; TODO make this not return a list
(define (names-of-struct stx) (define (names-of-struct stx)
@ -74,7 +96,6 @@
(values #'v.name #f #f))])) (values #'v.name #f #f))]))
(struct struct-names (type-name struct-type constructor predicate getters setters) #:transparent)
;; generate struct names given type name, field names ;; generate struct names given type name, field names
;; and optional constructor name ;; and optional constructor name
;; all have syntax loc of name ;; all have syntax loc of name
@ -91,15 +112,6 @@
(let-values ([(getters setters) (split getters/setters)]) (let-values ([(getters setters) (split getters/setters)])
(struct-names nm sty (or maker* maker) pred getters setters))])) (struct-names nm sty (or maker* maker) pred getters setters))]))
;;struct-fields: holds all the relevant information about a struct type's types
(struct struct-desc (parent-fields self-fields tvars mutable proc-ty) #:transparent)
(define (struct-desc-all-fields fields)
(append (struct-desc-parent-fields fields) (struct-desc-self-fields fields)))
(define (struct-desc-parent-count fields)
(length (struct-desc-parent-fields fields)))
;; gets the fields of the parent type, if they exist ;; gets the fields of the parent type, if they exist
;; Option[Struct-Ty] -> Listof[Type] ;; Option[Struct-Ty] -> Listof[Type]
(define/cond-contract (get-flds p) (define/cond-contract (get-flds p)
@ -137,8 +149,8 @@
;; Register the approriate types to the struct bindings. ;; Register the approriate types to the struct bindings.
(define/cond-contract (register-struct-bindings! sty names desc) (define/cond-contract (register-struct-bindings! sty names desc si)
(c-> Struct? struct-names? struct-desc? void?) (c-> Struct? struct-names? struct-desc? (or/c #f struct-info?) void?)
(define tvars (struct-desc-tvars desc)) (define tvars (struct-desc-tvars desc))
@ -163,44 +175,53 @@
(and (not mutable) (eq? variance Covariant)))))) (and (not mutable) (eq? variance Covariant))))))
(define (poly-wrapper t) (make-Poly tvars t)) (define (poly-wrapper t) (make-Poly tvars t))
;; the list of names w/ types (define bindings
(register-type (struct-names-struct-type names) (make-StructType sty)) (list*
(register-type (struct-names-constructor names) (poly-wrapper (->* all-fields poly-base))) ;; the list of names w/ types
(register-type (struct-names-predicate names) (cons (struct-names-struct-type names) (make-StructType sty))
(make-pred-ty (if (not covariant?) (cons (struct-names-constructor names) (poly-wrapper (->* all-fields poly-base)))
(make-StructTop sty) (cons (struct-names-predicate names)
(subst-all (make-simple-substitution (make-pred-ty (if (not covariant?)
tvars (map (const Univ) tvars)) poly-base)))) (make-StructTop sty)
(subst-all (make-simple-substitution
(for ([g (in-list (struct-names-getters names))] tvars (map (const Univ) tvars)) poly-base))))
[t (in-list self-fields)] (append
[i (in-naturals parent-count)]) (for/list ([g (in-list (struct-names-getters names))]
(let* ([path (make-StructPE poly-base i)] [t (in-list self-fields)]
[func (poly-wrapper [i (in-naturals parent-count)])
(if mutable (let* ([path (make-StructPE poly-base i)]
(->* (list poly-base) t) [func (poly-wrapper
(->acc (list poly-base) t (list path))))]) (if mutable
(add-struct-fn! g path #f) (->* (list poly-base) t)
(register-type g func))) (->acc (list poly-base) t (list path))))])
(when mutable (add-struct-fn! g path #f)
(for ([s (in-list (struct-names-setters names))] (cons g func)))
[t (in-list self-fields)] (if mutable
[i (in-naturals parent-count)]) (for/list ([s (in-list (struct-names-setters names))]
(add-struct-fn! s (make-StructPE poly-base i) #t) [t (in-list self-fields)]
(register-type s (poly-wrapper (->* (list poly-base t) -Void)))))) [i (in-naturals parent-count)])
(add-struct-fn! s (make-StructPE poly-base i) #t)
(struct parsed-struct (sty names desc type-only) #:transparent) (cons s (poly-wrapper (->* (list poly-base t) -Void))))
null))))
(cons
(and si (make-def-struct-stx-binding (struct-names-type-name names) si))
(for/list ([b bindings])
(define id (car b))
(define t (cdr b))
(register-type id t)
(make-def-binding id t))))
(define (register-parsed-struct-sty! ps) (define (register-parsed-struct-sty! ps)
(match ps (match ps
((parsed-struct sty names desc type-only) ((parsed-struct sty names desc si type-only)
(register-sty! sty names desc)))) (register-sty! sty names desc))))
(define (register-parsed-struct-bindings! ps) (define (register-parsed-struct-bindings! ps)
(match ps (match ps
((parsed-struct sty names desc type-only) ((parsed-struct sty names desc si type-only)
(unless type-only (if type-only
(register-struct-bindings! sty names desc))))) null
(register-struct-bindings! sty names desc si)))))
(define (refine-struct-variance! parsed-structs) (define (refine-struct-variance! parsed-structs)
(define stys (map parsed-struct-sty parsed-structs)) (define stys (map parsed-struct-sty parsed-structs))
@ -264,7 +285,7 @@
(and proc-ty (parse-type proc-ty)))) (and proc-ty (parse-type proc-ty))))
(define sty (mk/inner-struct-type names desc concrete-parent)) (define sty (mk/inner-struct-type names desc concrete-parent))
(parsed-struct sty names desc type-only)) (parsed-struct sty names desc (syntax-property nm/par 'struct-info) type-only))
;; register a struct type ;; register a struct type
@ -285,7 +306,7 @@
(define sty (mk/inner-struct-type names desc parent-type)) (define sty (mk/inner-struct-type names desc parent-type))
(register-sty! sty names desc) (register-sty! sty names desc)
(register-struct-bindings! sty names desc) (register-struct-bindings! sty names desc #f)
(when kernel-maker (when kernel-maker
(register-type kernel-maker (λ () (->* (struct-desc-all-fields desc) sty))))) (register-type kernel-maker (λ () (->* (struct-desc-all-fields desc) sty)))))

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

@ -323,14 +323,15 @@
(refine-struct-variance! parsed-structs) (refine-struct-variance! parsed-structs)
;; register the bindings of the structs ;; register the bindings of the structs
(for-each register-parsed-struct-bindings! parsed-structs) (define struct-bindings (map register-parsed-struct-bindings! parsed-structs))
;(printf "after resolving type aliases~n") ;(printf "after resolving type aliases~n")
;(displayln "Starting pass1") ;(displayln "Starting pass1")
;; do pass 1, and collect the defintions ;; do pass 1, and collect the defintions
(define defs (apply append (filter list? (map tc-toplevel/pass1 forms)))) (define defs (apply append
(append
struct-bindings
(filter list? (map tc-toplevel/pass1 forms)))))
;(displayln "Finished pass1") ;(displayln "Finished pass1")
;; separate the definitions into structures we'll handle for provides ;; separate the definitions into structures we'll handle for provides
(define def-tbl (define def-tbl