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

Removed unused fields in Struct

Browse Source 
original commit: 2a8512ed72c1ac029ee4c315f1963b3ebfc5fa6d
This commit is contained in:
Eric Dobson 2012-09-01 15:49:05 -07:00 committed by Sam Tobin-Hochstadt
parent 66ccae0e72
commit f1ce0b63dd
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]
[(Name: stx) `(make-Name (quote-syntax ,stx))]
[(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)
,(sub flds) ,(sub proc) ,(sub poly?)
(quote-syntax ,pred-id) (syntax-local-certifier)
(quote-syntax ,maker-id))]
(quote-syntax ,pred-id))]
[(App: rator rands stx) `(make-App ,(sub rator) ,(sub rands) (quote-syntax ,stx))]
[(Opaque: pred cert) `(make-Opaque (quote-syntax ,pred) (syntax-local-certifier))]
[(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
;; 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))
(let ([proc-c
(cond [(and proc proc*)
@ -520,7 +520,7 @@
;; 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
;; but not currently visible
[((Struct: nm (? Type? parent) _ _ _ _ _ _) other)
[((Struct: nm (? Type? parent) _ _ _ _) other)
(cg parent other)]
;; 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)
(let ([v (parse-type #'t)])
(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)
(make-Instance (Un))]))]
[((~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])
#'(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)
[(Struct: nm par (list (fld: flds acc-ids mut?) ...) proc poly? pred?)
(cond
[(assf (λ (t) (type-equal? t ty)) structs-seen)
=>
@ -334,7 +334,7 @@
#`(let ((rec (recursive-contract struct-ctc #,(contract-kind->keyword (current-contract-kind)))))
#,fld-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: t)
#`(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?)]
[proc (or/c #f Function?)]
[poly? (or/c #f (listof symbol?))]
[pred-id identifier?]
[cert procedure?]
[maker-id identifier?])
[pred-id identifier?])
[#:intern (list (hash-id name)
(hash-id pred-id)
(hash-id maker-id)
(and parent (Rep-seq parent))
(map Rep-seq flds)
(and proc (Rep-seq proc)))]
@ -328,9 +325,7 @@
(map type-rec-id flds)
(and proc (type-rec-id proc))
poly?
pred-id
cert
maker-id)]
pred-id)]
[#:key 'struct])
;; A structure type descriptor

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

@ -85,7 +85,7 @@
vector-immutable vector)
(pattern (~and form ((~or unsafe-struct-ref unsafe-struct*-ref) struct:expr index:expr))
(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")]
[s-ty (tc/app-regular #'form expected)]))
;; vector-ref on het vectors
@ -97,7 +97,7 @@
;; unsafe struct-set!
(pattern (~and form ((~or unsafe-struct-set! unsafe-struct*-set!) s:expr index:expr val:expr))
(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")]
[s-ty (tc/app-regular #'form expected)]))
;; 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)))]
;; 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))
(make-Struct nm par
(list-update flds idx
@ -48,8 +48,8 @@
(update e (-filter u x rst))
acc-id #f)]
[_ (int-err "update on mutable struct field")]))
proc poly pred cert maker-id)]
[((Struct: nm par flds proc poly pred cert maker-id)
proc poly pred)]
[((Struct: nm par flds proc poly pred)
(NotTypeFilter: u (list rst ... (StructPE: (? (lambda (s) (subtype t s)) s) idx)) x))
(make-Struct nm par (list-update flds idx
(match-lambda [(fld: e acc-id #f)
@ -57,7 +57,7 @@
(update e (-not-filter u x rst))
acc-id #f)]
[_ (int-err "update on mutable struct field")]))
proc poly pred cert maker-id)]
proc poly pred)]
;; otherwise
[(t (TypeFilter: u (list) _))

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

@ -127,7 +127,7 @@
(and expected (tc-results->values expected))))
t argtys expected)]
;; 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)
(cons ftype0 argtys) expected)]
;; parameters are functions too

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

@ -83,7 +83,7 @@
;; Option[Struct-Ty] -> Listof[Type]
(define (get-parent-flds p)
(match p
[(Struct: _ _ flds _ _ _ _ _) flds]
[(Struct: _ _ flds _ _ _) flds]
[(Name: n) (get-parent-flds (lookup-type-name n))]
[#f null]))
@ -122,10 +122,7 @@
[g (in-list getters)])
(make-fld t g setters?))]
[flds (append parent-fields this-flds)]
[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))]
[sty (make-Struct nm parent flds proc-ty poly? pred)]
[external-fld-types/no-parent types]
[external-fld-types (map fld-t flds)])
(if type-only

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

@ -213,7 +213,7 @@
[(Name: stx) (fp "~a" (syntax-e stx))]
[(app has-name? (? values 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")]
[(ChannelTop:) (fp "Channel")]
[(ThreadCellTop:) (fp "ThreadCell")]
@ -237,7 +237,7 @@
(fp "~a" (cons 'List (tuple-elems t)))]
[(Base: n cnt _ _ _) (fp "~s" n)]
[(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)
(when proc
(fp " ~a" proc))

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

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

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

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