From e07ce478afc1806d6805f57f96006bcb0d25668e Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Tue, 19 Jul 2011 12:48:57 -0400 Subject: [PATCH] Switched name field in struct type to identifier. Closes PR 11728. Closes PR 11998. Closes PR11859. --- collects/tests/typed-scheme/fail/pr11998.rkt | 15 +++++++++++ .../tests/typed-scheme/succeed/pr11728.rkt | 27 +++++++++++++++++++ .../tests/typed-scheme/succeed/pr11859.rkt | 9 +++++++ .../typed-scheme/unit-tests/subtype-tests.rkt | 14 +++++----- .../unit-tests/type-equal-tests.rkt | 4 +-- collects/typed-scheme/env/init-envs.rkt | 2 +- collects/typed-scheme/infer/infer-unit.rkt | 5 ++-- collects/typed-scheme/rep/type-rep.rkt | 4 +-- .../typed-scheme/typecheck/tc-structs.rkt | 5 ++-- collects/typed-scheme/types/abbrev.rkt | 10 +++---- collects/typed-scheme/types/printer.rkt | 2 +- .../typed-scheme/types/remove-intersect.rkt | 6 +++-- collects/typed-scheme/types/subtype.rkt | 9 ++++--- 13 files changed, 84 insertions(+), 28 deletions(-) create mode 100644 collects/tests/typed-scheme/fail/pr11998.rkt create mode 100644 collects/tests/typed-scheme/succeed/pr11728.rkt create mode 100644 collects/tests/typed-scheme/succeed/pr11859.rkt diff --git a/collects/tests/typed-scheme/fail/pr11998.rkt b/collects/tests/typed-scheme/fail/pr11998.rkt new file mode 100644 index 0000000000..72320dad80 --- /dev/null +++ b/collects/tests/typed-scheme/fail/pr11998.rkt @@ -0,0 +1,15 @@ +#lang racket/load +(module p typed/racket + (struct: (a) p ((v : a))) + (provide p p-v)) + +(module p2 typed/racket + (struct: (a) p ((v : a))) + (provide p)) + + +(module m typed/racket + (require (only-in 'p p-v) 'p2) + (p-v (p 0))) + +(require 'm) diff --git a/collects/tests/typed-scheme/succeed/pr11728.rkt b/collects/tests/typed-scheme/succeed/pr11728.rkt new file mode 100644 index 0000000000..190940e0df --- /dev/null +++ b/collects/tests/typed-scheme/succeed/pr11728.rkt @@ -0,0 +1,27 @@ +#lang racket/load + + +(module b typed/racket/base + (provide (all-defined-out)) + (define-struct: string-type () #:transparent)) + +(module c typed/racket/base + (provide (all-defined-out)) + (define-struct: string-type () #:transparent)) + +(module a typed/racket/base + + + (require + (prefix-in one: 'b) + (prefix-in two: 'c) + ) + + + (provide foo) + + (: foo two:string-type) + (define foo (two:string-type))) + +(require 'a) +foo diff --git a/collects/tests/typed-scheme/succeed/pr11859.rkt b/collects/tests/typed-scheme/succeed/pr11859.rkt new file mode 100644 index 0000000000..3e2c787130 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/pr11859.rkt @@ -0,0 +1,9 @@ +#lang racket/load +(module stream typed/racket + (define-type (Stream a) (Rec s (Promise (U Null (Pair a s))))) + (provide Stream)) +(module m typed/racket + (require 'stream) + (: x (Stream Integer)) + (define x (delay '()))) +(require 'm) diff --git a/collects/tests/typed-scheme/unit-tests/subtype-tests.rkt b/collects/tests/typed-scheme/unit-tests/subtype-tests.rkt index 898db32a87..254945447c 100644 --- a/collects/tests/typed-scheme/unit-tests/subtype-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/subtype-tests.rkt @@ -113,14 +113,14 @@ [(-values (list -Number)) (-values (list Univ))] [(-poly (b) ((Un (make-Base 'foo #'dummy values #'values) - (-struct 'bar #f + (-struct #'bar #f (list (make-fld -Number #'values #f) (make-fld b #'values #f)) #'values)) . -> . (-lst b))) - ((Un (make-Base 'foo #'dummy values #'values) (-struct 'bar #f (list (make-fld -Number #'values #f) (make-fld (-pair -Number (-v a)) #'values #f)) #'values)) + ((Un (make-Base 'foo #'dummy values #'values) (-struct #'bar #f (list (make-fld -Number #'values #f) (make-fld (-pair -Number (-v a)) #'values #f)) #'values)) . -> . (-lst (-pair -Number (-v a))))] - [(-poly (b) ((-struct 'bar #f (list (make-fld -Number #'values #f) (make-fld b #'values #f)) #'values) . -> . (-lst b))) - ((-struct 'bar #f (list (make-fld -Number #'values #f) (make-fld (-pair -Number (-v a)) #'values #f)) #'values) . -> . (-lst (-pair -Number (-v a))))] + [(-poly (b) ((-struct #'bar #f (list (make-fld -Number #'values #f) (make-fld b #'values #f)) #'values) . -> . (-lst b))) + ((-struct #'bar #f (list (make-fld -Number #'values #f) (make-fld (-pair -Number (-v a)) #'values #f)) #'values) . -> . (-lst (-pair -Number (-v a))))] [(-poly (a) (a . -> . (make-Listof a))) ((-v b) . -> . (make-Listof (-v b)))] [(-poly (a) (a . -> . (make-Listof a))) ((-pair -Number (-v b)) . -> . (make-Listof (-pair -Number (-v b))))] @@ -132,9 +132,9 @@ (FAIL (-> Univ) (null Univ . ->* . Univ)) [(cl->* (-Number . -> . -String) (-Boolean . -> . -String)) ((Un -Boolean -Number) . -> . -String)] - [(-struct 'a #f null #'values) (-struct 'a #f null #'values)] - [(-struct 'a #f (list (make-fld -String #'values #f)) #'values) (-struct 'a #f (list (make-fld -String #'values #f)) #'values)] - [(-struct 'a #f (list (make-fld -String #'values #f)) #'values) (-struct 'a #f (list (make-fld Univ #'values #f)) #'values)] + [(-struct #'a #f null #'values) (-struct #'a #f null #'values)] + [(-struct #'a #f (list (make-fld -String #'values #f)) #'values) (-struct #'a #f (list (make-fld -String #'values #f)) #'values)] + [(-struct #'a #f (list (make-fld -String #'values #f)) #'values) (-struct #'a #f (list (make-fld Univ #'values #f)) #'values)] )) (define-go diff --git a/collects/tests/typed-scheme/unit-tests/type-equal-tests.rkt b/collects/tests/typed-scheme/unit-tests/type-equal-tests.rkt index c57bf72771..c29bd204a3 100644 --- a/collects/tests/typed-scheme/unit-tests/type-equal-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/type-equal-tests.rkt @@ -39,12 +39,12 @@ [(-mu x (Un -Number -Symbol x)) (-mu y (Un -Number -Symbol y))] ;; found bug [FAIL (Un (-mu heap-node - (-struct 'heap-node #f + (-struct #'heap-node #f (map fld* (list (-base 'comparator) -Number (-v a) (Un heap-node (-base 'heap-empty)))) #'values)) (-base 'heap-empty)) (Un (-mu heap-node - (-struct 'heap-node #f + (-struct #'heap-node #f (map fld* (list (-base 'comparator) -Number (-pair -Number -Number) (Un heap-node (-base 'heap-empty)))) #'values)) (-base 'heap-empty))])) diff --git a/collects/typed-scheme/env/init-envs.rkt b/collects/typed-scheme/env/init-envs.rkt index b52c2365a8..ab2be0991d 100644 --- a/collects/typed-scheme/env/init-envs.rkt +++ b/collects/typed-scheme/env/init-envs.rkt @@ -27,7 +27,7 @@ [(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) - `(make-Struct ,(sub name) ,(sub parent) + `(make-Struct (quote-syntax ,name) ,(sub parent) ,(sub flds) ,(sub proc) ,(sub poly?) (quote-syntax ,pred-id) (syntax-local-certifier) (quote-syntax ,maker-id))] diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index 65650612b6..ab906f154b 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -292,7 +292,7 @@ [(_ _) (fail! s-arr t-arr)])) (define/cond-contract (cgen/flds V X Y flds-s flds-t) - ((listof symbol?) (listof symbol?) (listof symbol?) Type? Type? . -> . cset?) + ((listof symbol?) (listof symbol?) (listof symbol?) (listof fld?) (listof fld?) . -> . cset?) (cset-meet* (for/list ([s (in-list flds-s)] [t (in-list flds-t)]) (match* (s t) @@ -378,7 +378,8 @@ ;; two structs with the same name and parent ;; just check pairwise on the fields - [((Struct: nm p flds proc _ _ _ _) (Struct: nm p flds* proc* _ _ _ _)) + [((Struct: nm p flds proc _ _ _ _) (Struct: nm* p flds* proc* _ _ _ _)) (=> nevermind) + (unless (free-identifier=? nm nm*) (nevermind)) (let ([proc-c (cond [(and proc proc*) (cg proc proc*)] diff --git a/collects/typed-scheme/rep/type-rep.rkt b/collects/typed-scheme/rep/type-rep.rkt index d2d4f735c8..9e5eb16a29 100644 --- a/collects/typed-scheme/rep/type-rep.rkt +++ b/collects/typed-scheme/rep/type-rep.rkt @@ -286,7 +286,7 @@ [#:fold-rhs (*fld (type-rec-id t) acc mutable?)] [#:intern (list t (hash-id acc) mutable?)]) -;; name : symbol +;; name : identifier ;; parent : Struct ;; flds : Listof[fld] ;; proc : Function Type @@ -295,7 +295,7 @@ ;; cert : syntax certifier for pred-id ;; acc-ids : names of the accessors ;; maker-id : name of the constructor -(def-type Struct ([name symbol?] +(def-type Struct ([name identifier?] [parent (or/c #f Struct? Name?)] [flds (listof fld?)] [proc (or/c #f Function?)] diff --git a/collects/typed-scheme/typecheck/tc-structs.rkt b/collects/typed-scheme/typecheck/tc-structs.rkt index 5f62b2674e..8615f80b66 100644 --- a/collects/typed-scheme/typecheck/tc-structs.rkt +++ b/collects/typed-scheme/typecheck/tc-structs.rkt @@ -118,13 +118,12 @@ any/c) ;; create the approriate names that define-struct will bind (define-values (struct-type-id maker pred getters setters) (struct-names nm flds setters?)) - (let* ([name (syntax-e nm)] - [fld-names flds] + (let* ([fld-names flds] [this-flds (for/list ([t (in-list types)] [g (in-list getters)]) (make-fld t g setters?))] [flds (append parent-fields this-flds)] - [sty (make-Struct name 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))] diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt index ca6f63f23d..8e107d2bd3 100644 --- a/collects/typed-scheme/types/abbrev.rkt +++ b/collects/typed-scheme/types/abbrev.rkt @@ -20,7 +20,7 @@ ;; for base type predicates racket/promise racket/tcp racket/flonum) -(provide (all-defined-out) +(provide (except-out (all-defined-out) Promise) (rename-out [make-Listof -lst] [make-MListof -mlst])) @@ -107,12 +107,12 @@ ;; basic types -(define promise-sym (string->uninterned-symbol "Promise")) +(define Promise #f) +(define promise-id #'Promise) (define make-promise-ty - (let ([s promise-sym]) - (lambda (t) - (make-Struct s #f (list (make-fld t #'values #f)) #f #f #'promise? values #'values)))) + (lambda (t) + (make-Struct promise-id #f (list (make-fld t #'values #f)) #f #f #'promise? values #'values))) (define -Listof (-poly (list-elem) (make-Listof list-elem))) diff --git a/collects/typed-scheme/types/printer.rkt b/collects/typed-scheme/types/printer.rkt index 4bed2427cb..9e51da1c48 100644 --- a/collects/typed-scheme/types/printer.rkt +++ b/collects/typed-scheme/types/printer.rkt @@ -146,7 +146,7 @@ (fp "~a" (cons 'List (tuple-elems t)))] [(Base: n cnt _ _) (fp "~s" n)] [(Opaque: pred _) (fp "(Opaque ~a)" (syntax->datum pred))] - [(Struct: (== promise-sym) #f (list (fld: t _ _)) _ _ _ _ _) (fp "(Promise ~a)" t)] + [(Struct: (? (lambda (nm) (free-identifier=? promise-id nm))) #f (list (fld: t _ _)) _ _ _ _ _) (fp "(Promise ~a)" t)] [(Struct: nm par (list (fld: t _ _) ...) proc _ _ _ _) (fp "#(struct:~a ~a" nm t) (when proc diff --git a/collects/typed-scheme/types/remove-intersect.rkt b/collects/typed-scheme/types/remove-intersect.rkt index 95eaa53bea..5101253e52 100644 --- a/collects/typed-scheme/types/remove-intersect.rkt +++ b/collects/typed-scheme/types/remove-intersect.rkt @@ -60,12 +60,14 @@ (list (Struct: n _ flds _ _ _ _ _) (Value: '()))) #f] [(list (Struct: n _ flds _ _ _ _ _) - (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 _ _ _ _ _ _))) + (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 _ _ _ _ _) diff --git a/collects/typed-scheme/types/subtype.rkt b/collects/typed-scheme/types/subtype.rkt index a849ef94b8..224e9c2f9c 100644 --- a/collects/typed-scheme/types/subtype.rkt +++ b/collects/typed-scheme/types/subtype.rkt @@ -221,7 +221,7 @@ (match par [(Poly: _ (Struct: p-name _ _ _ _ _ _ _)) p-name] [(Struct: p-name _ _ _ _ _ _ _) p-name])) - (or (equal? s-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)] @@ -361,7 +361,8 @@ [(s (Union: es)) (or (and (ormap (lambda (elem) (subtype*/no-fail A0 s elem)) es) A0) (fail! s t))] ;; subtyping on immutable structs is covariant - [((Struct: nm _ flds proc _ _ _ _) (Struct: nm _ flds* proc* _ _ _ _)) + [((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])]) @@ -388,7 +389,9 @@ ;(dprintf "subtype - hierarchy : ~a ~a ~a\n" nm parent other) (subtype* A0 parent other)] ;; Promises are covariant - [((Struct: (== promise-sym) _ (list t) _ _ _ _ _) (Struct: (== promise-sym) _ (list t*) _ _ _ _ _)) (subtype* A0 t t*)] + [((Struct: (? (lambda (n) (free-identifier=? n promise-id))) _ (list t) _ _ _ _ _) + (Struct: (? (lambda (n) (free-identifier=? n promise-id))) _ (list t*) _ _ _ _ _)) + (subtype* A0 t t*)] ;; subtyping on values is pointwise [((Values: vals1) (Values: vals2)) (subtypes* A0 vals1 vals2)] ;; trivial case for Result