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

Switched name field in struct type to identifier. Closes PR 11728.

Browse Source 
Closes PR 11998. Closes PR11859.
This commit is contained in:
Eric Dobson 2011-07-19 12:48:57 -04:00 committed by Sam Tobin-Hochstadt
parent 81b1178a17
commit e07ce478af
13 changed files with 84 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/tests/typed-scheme/fail/pr11998.rkt Normal file
View File

@ -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)

27
collects/tests/typed-scheme/succeed/pr11728.rkt Normal file
View File

@ -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

9
collects/tests/typed-scheme/succeed/pr11859.rkt Normal file
View File

@ -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)

14
collects/tests/typed-scheme/unit-tests/subtype-tests.rkt
View File

@ -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

4
collects/tests/typed-scheme/unit-tests/type-equal-tests.rkt
View File

@ -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))]))

2
collects/typed-scheme/env/init-envs.rkt vendored
View File

@ -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))]

5
collects/typed-scheme/infer/infer-unit.rkt
View File

@ -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*)]

4
collects/typed-scheme/rep/type-rep.rkt
View File

@ -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?)]

5
collects/typed-scheme/typecheck/tc-structs.rkt
View File

@ -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))]

10
collects/typed-scheme/types/abbrev.rkt
View File

@ -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)))

2
collects/typed-scheme/types/printer.rkt
View File

@ -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

6
collects/typed-scheme/types/remove-intersect.rkt
View File

@ -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 _ _ _ _ _)

9
collects/typed-scheme/types/subtype.rkt
View File

@ -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