Permalink
Browse files

Removed unused fields in Struct

  • Loading branch information...
endobson committed Sep 1, 2012
1 parent 1147ae8 commit 83921f1e04a0af6bf73d2f89f50be3e04c859ef2
@@ -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)
@@ -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
@@ -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)
@@ -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))]
@@ -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
@@ -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
@@ -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,16 +48,16 @@
(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)
(make-fld
(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) _))
@@ -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
@@ -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
@@ -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))
@@ -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: _))
@@ -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

0 comments on commit 83921f1

Please sign in to comment.