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

Removed unused fields in Struct

Browse Source
This commit is contained in:
Eric Dobson 2012-09-01 15:49:05 -07:00 committed by Sam Tobin-Hochstadt
parent 745403a88e
commit 2a8512ed72
12 changed files with 43 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/typed-racket/env/init-envs.rkt vendored
View File

@ -28,11 +28,10 @@
[(Base: n cnt pred marshaled _) marshaled] [(Base: n cnt pred marshaled _) marshaled]
[(Name: stx) `(make-Name (quote-syntax ,stx))] [(Name: stx) `(make-Name (quote-syntax ,stx))]
[(fld: t acc mut) `(make-fld ,(sub t) (quote-syntax ,acc) ,mut)] [(fld: t acc mut) `(make-fld ,(sub t) (quote-syntax ,acc) ,mut)]
[(Struct: name parent flds proc poly? pred-id cert maker-id) [(Struct: name parent flds proc poly? pred-id)
`(make-Struct (quote-syntax ,name) ,(sub parent) `(make-Struct (quote-syntax ,name) ,(sub parent)
,(sub flds) ,(sub proc) ,(sub poly?) ,(sub flds) ,(sub proc) ,(sub poly?)
(quote-syntax ,pred-id) (syntax-local-certifier) (quote-syntax ,pred-id))]
(quote-syntax ,maker-id))]
[(App: rator rands stx) `(make-App ,(sub rator) ,(sub rands) (quote-syntax ,stx))] [(App: rator rands stx) `(make-App ,(sub rator) ,(sub rands) (quote-syntax ,stx))]
[(Opaque: pred cert) `(make-Opaque (quote-syntax ,pred) (syntax-local-certifier))] [(Opaque: pred cert) `(make-Opaque (quote-syntax ,pred) (syntax-local-certifier))]
[(Refinement: parent pred cert) `(make-Refinement ,(sub parent) [(Refinement: parent pred cert) `(make-Refinement ,(sub parent)

4
collects/typed-racket/infer/infer-unit.rkt
View File

@ -423,7 +423,7 @@
;; two structs with the same name ;; two structs with the same name
;; just check pairwise on the fields ;; just check pairwise on the fields
[((Struct: nm _ flds proc _ _ _ _) (Struct: nm* _ flds* proc* _ _ _ _)) (=> nevermind) [((Struct: nm _ flds proc _ _) (Struct: nm* _ flds* proc* _ _)) (=> nevermind)
(unless (free-identifier=? nm nm*) (nevermind)) (unless (free-identifier=? nm nm*) (nevermind))
(let ([proc-c (let ([proc-c
(cond [(and proc proc*) (cond [(and proc proc*)
@ -520,7 +520,7 @@
;; If the struct names don't match, try the parent of S ;; If the struct names don't match, try the parent of S
;; Needs to be done after App and Mu in case T is actually the current struct ;; Needs to be done after App and Mu in case T is actually the current struct
;; but not currently visible ;; but not currently visible
[((Struct: nm (? Type? parent) _ _ _ _ _ _) other) [((Struct: nm (? Type? parent) _ _ _ _) other)
(cg parent other)] (cg parent other)]
;; vectors are invariant - generate constraints *both* ways ;; vectors are invariant - generate constraints *both* ways

2
collects/typed-racket/private/parse-type.rkt
View File

@ -166,7 +166,7 @@
(add-disappeared-use #'kw) (add-disappeared-use #'kw)
(let ([v (parse-type #'t)]) (let ([v (parse-type #'t)])
(match (resolve v) (match (resolve v)
[(and s (Struct: _ _ _ _ _ _ _ _)) (make-StructTop s)] [(and s Struct?) (make-StructTop s)]
[_ (tc-error/delayed "Argument to Struct must be a structure type, got ~a" v) [_ (tc-error/delayed "Argument to Struct must be a structure type, got ~a" v)
(make-Instance (Un))]))] (make-Instance (Un))]))]
[((~and kw t:Instance) t) [((~and kw t:Instance) t)

4
collects/typed-racket/private/type-contract.rkt
View File

@ -313,7 +313,7 @@
[(by-name-init ...) by-name-init]) [(by-name-init ...) by-name-init])
#'(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?)
(cond (cond
[(assf (λ (t) (type-equal? t ty)) structs-seen) [(assf (λ (t) (type-equal? t ty)) structs-seen)
=> =>
@ -334,7 +334,7 @@
#`(let ((rec (recursive-contract struct-ctc #,(contract-kind->keyword (current-contract-kind))))) #`(let ((rec (recursive-contract struct-ctc #,(contract-kind->keyword (current-contract-kind)))))
#,fld-ctc)))))) #,fld-ctc))))))
#`(letrec ((struct-ctc (struct/c #,nm #,@field-contracts))) struct-ctc))] #`(letrec ((struct-ctc (struct/c #,nm #,@field-contracts))) struct-ctc))]
[else #`(flat-named-contract '#,(syntax-e pred?) (lambda (x) (#,(cert pred?) x)))])] [else #`(flat-named-contract '#,(syntax-e pred?) #,pred?)])]
[(Syntax: (Base: 'Symbol _ _ _ _)) #'identifier?] [(Syntax: (Base: 'Symbol _ _ _ _)) #'identifier?]
[(Syntax: t) [(Syntax: t)
#`(syntax/c #,(t->c t #:kind flat-sym))] #`(syntax/c #,(t->c t #:kind flat-sym))]

9
collects/typed-racket/rep/type-rep.rkt
View File

@ -311,12 +311,9 @@
[flds (listof fld?)] [flds (listof fld?)]
[proc (or/c #f Function?)] [proc (or/c #f Function?)]
[poly? (or/c #f (listof symbol?))] [poly? (or/c #f (listof symbol?))]
[pred-id identifier?] [pred-id identifier?])
[cert procedure?]
[maker-id identifier?])
[#:intern (list (hash-id name) [#:intern (list (hash-id name)
(hash-id pred-id) (hash-id pred-id)
(hash-id maker-id)
(and parent (Rep-seq parent)) (and parent (Rep-seq parent))
(map Rep-seq flds) (map Rep-seq flds)
(and proc (Rep-seq proc)))] (and proc (Rep-seq proc)))]
@ -328,9 +325,7 @@
(map type-rec-id flds) (map type-rec-id flds)
(and proc (type-rec-id proc)) (and proc (type-rec-id proc))
poly? poly?
pred-id pred-id)]
cert
maker-id)]
[#:key 'struct]) [#:key 'struct])
;; A structure type descriptor ;; A structure type descriptor

4
collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt
View File

@ -85,7 +85,7 @@
vector-immutable vector) vector-immutable vector)
(pattern (~and form ((~or unsafe-struct-ref unsafe-struct*-ref) struct:expr index:expr)) (pattern (~and form ((~or unsafe-struct-ref unsafe-struct*-ref) struct:expr index:expr))
(match (single-value #'struct) (match (single-value #'struct)
[(tc-result1: (and struct-t (app resolve (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _)))) [(tc-result1: (and struct-t (app resolve (Struct: _ _ (list (fld: flds _ _) ...) _ _ _))))
(tc/hetero-ref #'index flds struct-t expected "struct")] (tc/hetero-ref #'index flds struct-t expected "struct")]
[s-ty (tc/app-regular #'form expected)])) [s-ty (tc/app-regular #'form expected)]))
;; vector-ref on het vectors ;; vector-ref on het vectors
@ -97,7 +97,7 @@
;; unsafe struct-set! ;; unsafe struct-set!
(pattern (~and form ((~or unsafe-struct-set! unsafe-struct*-set!) s:expr index:expr val:expr)) (pattern (~and form ((~or unsafe-struct-set! unsafe-struct*-set!) s:expr index:expr val:expr))
(match (single-value #'s) (match (single-value #'s)
[(tc-result1: (and struct-t (app resolve (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _)))) [(tc-result1: (and struct-t (app resolve (Struct: _ _ (list (fld: flds _ _) ...) _ _ _))))
(tc/hetero-set! #'index flds #'val struct-t expected "struct")] (tc/hetero-set! #'index flds #'val struct-t expected "struct")]
[s-ty (tc/app-regular #'form expected)])) [s-ty (tc/app-regular #'form expected)]))
;; vector-set! on het vectors ;; vector-set! on het vectors

8
collects/typed-racket/typecheck/tc-envops.rkt
View File

@ -39,7 +39,7 @@
(make-Syntax (update t (-not-filter u x rst)))] (make-Syntax (update t (-not-filter u x rst)))]
;; struct ops ;; struct ops
[((Struct: nm par flds proc poly pred cert maker-id) [((Struct: nm par flds proc poly pred)
(TypeFilter: u (list rst ... (StructPE: (? (lambda (s) (subtype t s)) s) idx)) x)) (TypeFilter: u (list rst ... (StructPE: (? (lambda (s) (subtype t s)) s) idx)) x))
(make-Struct nm par (make-Struct nm par
(list-update flds idx (list-update flds idx
@ -48,8 +48,8 @@
(update e (-filter u x rst)) (update e (-filter u x rst))
acc-id #f)] acc-id #f)]
[_ (int-err "update on mutable struct field")])) [_ (int-err "update on mutable struct field")]))
proc poly pred cert maker-id)] proc poly pred)]
[((Struct: nm par flds proc poly pred cert maker-id) [((Struct: nm par flds proc poly pred)
(NotTypeFilter: u (list rst ... (StructPE: (? (lambda (s) (subtype t s)) s) idx)) x)) (NotTypeFilter: u (list rst ... (StructPE: (? (lambda (s) (subtype t s)) s) idx)) x))
(make-Struct nm par (list-update flds idx (make-Struct nm par (list-update flds idx
(match-lambda [(fld: e acc-id #f) (match-lambda [(fld: e acc-id #f)
@ -57,7 +57,7 @@
(update e (-not-filter u x rst)) (update e (-not-filter u x rst))
acc-id #f)] acc-id #f)]
[_ (int-err "update on mutable struct field")])) [_ (int-err "update on mutable struct field")]))
proc poly pred cert maker-id)] proc poly pred)]
;; otherwise ;; otherwise
[(t (TypeFilter: u (list) _)) [(t (TypeFilter: u (list) _))

2
collects/typed-racket/typecheck/tc-funapp.rkt
View File

@ -127,7 +127,7 @@
(and expected (tc-results->values expected)))) (and expected (tc-results->values expected))))
t argtys expected)] t argtys expected)]
;; procedural structs ;; procedural structs
[((tc-result1: (and sty (Struct: _ _ _ (? Function? proc-ty) _ _ _ _))) _) [((tc-result1: (and sty (Struct: _ _ _ (? Function? proc-ty) _ _))) _)
(tc/funapp f-stx #`(#,(syntax/loc f-stx dummy) . #,args-stx) (ret proc-ty) (tc/funapp f-stx #`(#,(syntax/loc f-stx dummy) . #,args-stx) (ret proc-ty)
(cons ftype0 argtys) expected)] (cons ftype0 argtys) expected)]
;; parameters are functions too ;; parameters are functions too

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

@ -83,7 +83,7 @@
;; Option[Struct-Ty] -> Listof[Type] ;; Option[Struct-Ty] -> Listof[Type]
(define (get-parent-flds p) (define (get-parent-flds p)
(match p (match p
[(Struct: _ _ flds _ _ _ _ _) flds] [(Struct: _ _ flds _ _ _) flds]
[(Name: n) (get-parent-flds (lookup-type-name n))] [(Name: n) (get-parent-flds (lookup-type-name n))]
[#f null])) [#f null]))
@ -122,10 +122,7 @@
[g (in-list getters)]) [g (in-list getters)])
(make-fld t g setters?))] (make-fld t g setters?))]
[flds (append parent-fields this-flds)] [flds (append parent-fields this-flds)]
[sty (make-Struct nm parent flds proc-ty poly? pred [sty (make-Struct nm parent flds proc-ty poly? pred)]
;; this check is so that the tests work
(if (syntax-transforming?) (syntax-local-certifier) values)
(or maker* maker))]
[external-fld-types/no-parent types] [external-fld-types/no-parent types]
[external-fld-types (map fld-t flds)]) [external-fld-types (map fld-t flds)])
(if type-only (if type-only

4
collects/typed-racket/types/printer.rkt
View File

@ -213,7 +213,7 @@
[(Name: stx) (fp "~a" (syntax-e stx))] [(Name: stx) (fp "~a" (syntax-e stx))]
[(app has-name? (? values name)) [(app has-name? (? values name))
(fp "~a" name)] (fp "~a" name)]
[(StructTop: (Struct: nm _ _ _ _ _ _ _)) (fp "(Struct ~a)" (syntax-e nm))] [(StructTop: (Struct: nm _ _ _ _ _)) (fp "(Struct ~a)" (syntax-e nm))]
[(BoxTop:) (fp "Box")] [(BoxTop:) (fp "Box")]
[(ChannelTop:) (fp "Channel")] [(ChannelTop:) (fp "Channel")]
[(ThreadCellTop:) (fp "ThreadCell")] [(ThreadCellTop:) (fp "ThreadCell")]
@ -237,7 +237,7 @@
(fp "~a" (cons 'List (tuple-elems t)))] (fp "~a" (cons 'List (tuple-elems t)))]
[(Base: n cnt _ _ _) (fp "~s" n)] [(Base: n cnt _ _ _) (fp "~s" n)]
[(Opaque: pred _) (fp "(Opaque ~a)" (syntax->datum pred))] [(Opaque: pred _) (fp "(Opaque ~a)" (syntax->datum pred))]
[(Struct: nm par (list (fld: t _ _) ...) proc _ _ _ _) [(Struct: nm par (list (fld: t _ _) ...) proc _ _)
(fp "#(struct:~a ~a" nm t) (fp "#(struct:~a ~a" nm t)
(when proc (when proc
(fp " ~a" proc)) (fp " ~a" proc))

24
collects/typed-racket/types/remove-intersect.rkt
View File

@ -67,29 +67,29 @@
(list _ (Pair: _ _))) (list _ (Pair: _ _)))
#f] #f]
[(or (list (Value: (? (λ (e) (or (null? e) (symbol? e) (number? e) (boolean? e) (pair? e) (keyword? e))))) [(or (list (Value: (? (λ (e) (or (null? e) (symbol? e) (number? e) (boolean? e) (pair? e) (keyword? e)))))
(Struct: n _ flds _ _ _ _ _)) (Struct: n _ flds _ _ _))
(list (Struct: n _ flds _ _ _ _ _) (list (Struct: n _ flds _ _ _)
(Value: (? (λ (e) (or (null? e) (symbol? e) (number? e) (boolean? e) (pair? e) (keyword? e))))))) (Value: (? (λ (e) (or (null? e) (symbol? e) (number? e) (boolean? e) (pair? e) (keyword? e)))))))
#f] #f]
[(list (Struct: n _ flds _ _ _ _ _) [(list (Struct: n _ flds _ _ _)
(Struct: n* _ flds* _ _ _ _ _)) (=> nevermind) (Struct: n* _ flds* _ _ _)) (=> nevermind)
(unless (free-identifier=? n n*) (nevermind)) (unless (free-identifier=? n n*) (nevermind))
(for/and ([f flds] [f* flds*]) (for/and ([f flds] [f* flds*])
(match* (f f*) (match* (f f*)
[((fld: t _ _) (fld: t* _ _)) (overlap t t*)]))] [((fld: t _ _) (fld: t* _ _)) (overlap t t*)]))]
[(list (Struct: n #f _ _ _ _ _ _) [(list (Struct: n #f _ _ _ _)
(StructTop: (Struct: n* #f _ _ _ _ _ _))) (=> nevermind) (StructTop: (Struct: n* #f _ _ _ _))) (=> nevermind)
(unless (free-identifier=? n n*) (nevermind)) (unless (free-identifier=? n n*) (nevermind))
#t] #t]
;; n and n* must be different, so there's no overlap ;; n and n* must be different, so there's no overlap
[(list (Struct: n #f flds _ _ _ _ _) [(list (Struct: n #f flds _ _ _)
(Struct: n* #f flds* _ _ _ _ _)) (Struct: n* #f flds* _ _ _))
#f] #f]
[(list (Struct: n #f flds _ _ _ _ _) [(list (Struct: n #f flds _ _ _)
(StructTop: (Struct: n* #f flds* _ _ _ _ _))) (StructTop: (Struct: n* #f flds* _ _ _)))
#f] #f]
[(list (and t1 (Struct: _ _ _ _ _ _ _ _)) [(list (and t1 (Struct: _ _ _ _ _ _))
(and t2 (Struct: _ _ _ _ _ _ _ _))) (and t2 (Struct: _ _ _ _ _ _)))
(or (subtype t1 t2) (subtype t2 t1))] (or (subtype t1 t2) (subtype t2 t1))]
[(list (== (-val eof)) [(list (== (-val eof))
(Function: _)) (Function: _))

22
collects/typed-racket/types/subtype.rkt
View File

@ -220,19 +220,19 @@
(define (in-hierarchy? s par) (define (in-hierarchy? s par)
(define s-name (define s-name
(match s (match s
[(Poly: _ (Struct: s-name _ _ _ _ _ _ _)) s-name] [(Poly: _ (Struct: s-name _ _ _ _ _)) s-name]
[(Struct: s-name _ _ _ _ _ _ _) s-name])) [(Struct: s-name _ _ _ _ _) s-name]))
(define p-name (define p-name
(match par (match par
[(Poly: _ (Struct: p-name _ _ _ _ _ _ _)) p-name] [(Poly: _ (Struct: p-name _ _ _ _ _)) p-name]
[(Struct: p-name _ _ _ _ _ _ _) p-name])) [(Struct: p-name _ _ _ _ _) p-name]))
(or (free-identifier=? s-name p-name) (or (free-identifier=? s-name p-name)
(match s (match s
[(Poly: _ (? Struct? s*)) (in-hierarchy? s* par)] [(Poly: _ (? Struct? s*)) (in-hierarchy? s* par)]
[(Struct: _ (and (Name: _) p) _ _ _ _ _ _) (in-hierarchy? (resolve-once p) par)] [(Struct: _ (and (Name: _) p) _ _ _ _) (in-hierarchy? (resolve-once p) par)]
[(Struct: _ (? Struct? p) _ _ _ _ _ _) (in-hierarchy? p par)] [(Struct: _ (? Struct? p) _ _ _ _) (in-hierarchy? p par)]
[(Struct: _ (Poly: _ p) _ _ _ _ _ _) (in-hierarchy? p par)] [(Struct: _ (Poly: _ p) _ _ _ _) (in-hierarchy? p par)]
[(Struct: _ #f _ _ _ _ _ _) #f] [(Struct: _ #f _ _ _ _) #f]
[_ (int-err "wtf is this? ~a" s)]))) [_ (int-err "wtf is this? ~a" s)])))
(not (or (in-hierarchy? s1 s2) (in-hierarchy? s2 s1)))) (not (or (in-hierarchy? s1 s2) (in-hierarchy? s2 s1))))
@ -405,13 +405,13 @@
A0 A0
(fail! s t))] (fail! s t))]
;; subtyping on immutable structs is covariant ;; subtyping on immutable structs is covariant
[((Struct: nm _ flds proc _ _ _ _) (Struct: nm* _ flds* proc* _ _ _ _)) (=> nevermind) [((Struct: nm _ flds proc _ _) (Struct: nm* _ flds* proc* _ _)) (=> nevermind)
(unless (free-identifier=? nm nm*) (nevermind)) (unless (free-identifier=? nm nm*) (nevermind))
(let ([A (cond [(and proc proc*) (subtype* proc proc*)] (let ([A (cond [(and proc proc*) (subtype* proc proc*)]
[proc* (fail! proc proc*)] [proc* (fail! proc proc*)]
[else A0])]) [else A0])])
(subtype/flds* A flds flds*))] (subtype/flds* A flds flds*))]
[((Struct: nm _ _ _ _ _ _ _) (StructTop: (Struct: nm* _ _ _ _ _ _ _))) (=> nevermind) [((Struct: nm _ _ _ _ _) (StructTop: (Struct: nm* _ _ _ _ _))) (=> nevermind)
(unless (free-identifier=? nm nm*) (nevermind)) (unless (free-identifier=? nm nm*) (nevermind))
A0] A0]
;; Promises are covariant ;; Promises are covariant
@ -433,7 +433,7 @@
[((MPair: _ _) (MPairTop:)) A0] [((MPair: _ _) (MPairTop:)) A0]
[((Hashtable: _ _) (HashtableTop:)) A0] [((Hashtable: _ _) (HashtableTop:)) A0]
;; subtyping on structs follows the declared hierarchy ;; subtyping on structs follows the declared hierarchy
[((Struct: nm (? Type? parent) _ _ _ _ _ _) other) [((Struct: nm (? Type? parent) _ _ _ _) other)
;(dprintf "subtype - hierarchy : ~a ~a ~a\n" nm parent other) ;(dprintf "subtype - hierarchy : ~a ~a ~a\n" nm parent other)
(subtype* A0 parent other)] (subtype* A0 parent other)]
;; subtyping on values is pointwise ;; subtyping on values is pointwise