From f1ce0b63ddcf83bf428fdca43d7a8dfb51ad0a44 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Sat, 1 Sep 2012 15:49:05 -0700 Subject: [PATCH] Removed unused fields in Struct original commit: 2a8512ed72c1ac029ee4c315f1963b3ebfc5fa6d --- collects/typed-racket/env/init-envs.rkt | 5 ++-- collects/typed-racket/infer/infer-unit.rkt | 4 ++-- collects/typed-racket/private/parse-type.rkt | 2 +- .../typed-racket/private/type-contract.rkt | 4 ++-- collects/typed-racket/rep/type-rep.rkt | 9 ++----- .../typecheck/tc-app/tc-app-hetero.rkt | 4 ++-- collects/typed-racket/typecheck/tc-envops.rkt | 8 +++---- collects/typed-racket/typecheck/tc-funapp.rkt | 2 +- .../typed-racket/typecheck/tc-structs.rkt | 7 ++---- collects/typed-racket/types/printer.rkt | 4 ++-- .../typed-racket/types/remove-intersect.rkt | 24 +++++++++---------- collects/typed-racket/types/subtype.rkt | 22 ++++++++--------- 12 files changed, 43 insertions(+), 52 deletions(-) diff --git a/collects/typed-racket/env/init-envs.rkt b/collects/typed-racket/env/init-envs.rkt index 5849288d..b7772f7a 100644 --- a/collects/typed-racket/env/init-envs.rkt +++ b/collects/typed-racket/env/init-envs.rkt @@ -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) diff --git a/collects/typed-racket/infer/infer-unit.rkt b/collects/typed-racket/infer/infer-unit.rkt index 55d8632d..ecad589e 100644 --- a/collects/typed-racket/infer/infer-unit.rkt +++ b/collects/typed-racket/infer/infer-unit.rkt @@ -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 diff --git a/collects/typed-racket/private/parse-type.rkt b/collects/typed-racket/private/parse-type.rkt index c5aa22d3..a01890a7 100644 --- a/collects/typed-racket/private/parse-type.rkt +++ b/collects/typed-racket/private/parse-type.rkt @@ -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) diff --git a/collects/typed-racket/private/type-contract.rkt b/collects/typed-racket/private/type-contract.rkt index 22a0d6cc..ba5a6baa 100644 --- a/collects/typed-racket/private/type-contract.rkt +++ b/collects/typed-racket/private/type-contract.rkt @@ -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))] diff --git a/collects/typed-racket/rep/type-rep.rkt b/collects/typed-racket/rep/type-rep.rkt index 167eed7a..153c87fd 100644 --- a/collects/typed-racket/rep/type-rep.rkt +++ b/collects/typed-racket/rep/type-rep.rkt @@ -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 diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt index 68bb04dd..ceb007dc 100644 --- a/collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt +++ b/collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt @@ -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 diff --git a/collects/typed-racket/typecheck/tc-envops.rkt b/collects/typed-racket/typecheck/tc-envops.rkt index 107848f6..8c8e4cfe 100644 --- a/collects/typed-racket/typecheck/tc-envops.rkt +++ b/collects/typed-racket/typecheck/tc-envops.rkt @@ -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) _)) diff --git a/collects/typed-racket/typecheck/tc-funapp.rkt b/collects/typed-racket/typecheck/tc-funapp.rkt index 05ad935d..005173fa 100644 --- a/collects/typed-racket/typecheck/tc-funapp.rkt +++ b/collects/typed-racket/typecheck/tc-funapp.rkt @@ -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 diff --git a/collects/typed-racket/typecheck/tc-structs.rkt b/collects/typed-racket/typecheck/tc-structs.rkt index 37650991..e2c3171c 100644 --- a/collects/typed-racket/typecheck/tc-structs.rkt +++ b/collects/typed-racket/typecheck/tc-structs.rkt @@ -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 diff --git a/collects/typed-racket/types/printer.rkt b/collects/typed-racket/types/printer.rkt index fa293e8e..ac1068db 100644 --- a/collects/typed-racket/types/printer.rkt +++ b/collects/typed-racket/types/printer.rkt @@ -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)) diff --git a/collects/typed-racket/types/remove-intersect.rkt b/collects/typed-racket/types/remove-intersect.rkt index 4065e9e3..e9246931 100644 --- a/collects/typed-racket/types/remove-intersect.rkt +++ b/collects/typed-racket/types/remove-intersect.rkt @@ -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: _)) diff --git a/collects/typed-racket/types/subtype.rkt b/collects/typed-racket/types/subtype.rkt index 38a925af..f3444ebd 100644 --- a/collects/typed-racket/types/subtype.rkt +++ b/collects/typed-racket/types/subtype.rkt @@ -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