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

Refactor struct type representation.

Browse Source 
- fields now represented by fld struct.
 - mutability on per-field basis
 - accessors are per field

This fixes lots of existing bugs, allows future #:mutable on fields.
This commit is contained in:
Sam Tobin-Hochstadt 2010-06-28 18:50:06 -04:00
parent 3c4f1f39b8
commit c01b239779
17 changed files with 225 additions and 128 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -112,11 +112,15 @@
[(-values (list -Number)) (-values (list Univ))]
[(-poly (a) ((Un (make-Base 'foo #'dummy) (-struct 'bar #f (list -Number a) null #'values)) . -> . (-lst a)))
((Un (make-Base 'foo #'dummy) (-struct 'bar #f (list -Number (-pair -Number (-v a))) null #'values))
[(-poly (b) ((Un (make-Base 'foo #'dummy)
(-struct 'bar #f
(list (make-fld -Number #'values #f) (make-fld b #'values #f))
#'values))
. -> . (-lst b)))
((Un (make-Base 'foo #'dummy) (-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) ((-struct 'bar #f (list -Number a) null #'values) . -> . (-lst a)))
((-struct 'bar #f (list -Number (-pair -Number (-v a))) null #'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))))]
@ -128,6 +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)]
))
(define-go

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

@ -24,6 +24,8 @@
#'(test-suite "Tests for type equality"
cl1 ... cl2 ...))]))
(define (fld* t) (make-fld t (datum->syntax #'here 'values) #f))
(define (type-equal-tests)
(te-tests
[-Number -Number]
@ -38,13 +40,12 @@
;; found bug
[FAIL (Un (-mu heap-node
(-struct 'heap-node #f
(list (-base 'comparator) -Number (-v a) (Un heap-node (-base 'heap-empty)))
null #'values))
(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
(list (-base 'comparator) -Number (-pair -Number -Number) (Un heap-node (-base 'heap-empty)))
null #'values))
(map fld* (list (-base 'comparator) -Number (-pair -Number -Number) (Un heap-node (-base 'heap-empty)))) #'values))
(-base 'heap-empty))]))
(define-go

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

@ -25,11 +25,11 @@
[(Union: elems) `(make-Union (sort (list ,@(map sub elems)) < #:key Type-seq))]
[(Base: n cnt) `(make-Base ',n (quote-syntax ,cnt))]
[(Name: stx) `(make-Name (quote-syntax ,stx))]
[(Struct: name parent flds proc poly? pred-id cert acc-ids maker-id)
[(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)
,(sub flds) ,(sub proc) ,(sub poly?)
(quote-syntax ,pred-id) (syntax-local-certifier)
(list ,@(for/list ([a acc-ids]) `(quote-syntax ,a)))
(quote-syntax ,maker-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))]

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

@ -13,7 +13,7 @@
"signatures.rkt"
scheme/match
mzlib/etc
mzlib/trace racket/contract
racket/trace racket/contract
unstable/sequence unstable/list unstable/debug unstable/hash
scheme/list)
@ -22,7 +22,7 @@
(define (empty-set) '())
(define current-seen (make-parameter (empty-set) #;pair?))
(define current-seen (make-parameter (empty-set)))
(define (seen-before s t) (cons (Type-seq s) (Type-seq t)))
(define (remember s t A) (cons (seen-before s t) A))
@ -259,6 +259,15 @@
(cset-meet* (list arg-mapping darg-mapping ret-mapping)))])]
[(_ _) (fail! s-arr t-arr)]))
(define (cgen/flds V X Y flds-s flds-t)
(cset-meet*
(for/list ([s (in-list flds-s)] [t (in-list flds-t)])
(match* (s t)
;; mutable - invariant
[((fld: s _ #t) (fld: t _ #t)) (cset-meet (cgen V X Y s t) (cgen V X Y t s))]
;; immutable - covariant
[((fld: s _ #f) (fld: t _ #f)) (cgen V X Y s t)]))))
;; V : a set of variables not to mention in the constraints
;; X : the set of type variables to be constrained
;; Y : the set of index variables to be constrained
@ -328,13 +337,13 @@
;; two structs with the same name and parent
;; just check pairwise on the fields
;; FIXME - wrong for mutable structs!
[((Struct: nm p flds proc _ _ _ _ _) (Struct: nm p flds* proc* _ _ _ _ _))
(let-values ([(flds flds*)
(cond [(and proc proc*)
(values (cons proc flds) (cons proc* flds*))]
[else (values flds flds*)])])
(cgen/list V X Y flds flds*))]
[((Struct: nm p flds proc _ _ _ _) (Struct: nm p flds* proc* _ _ _ _))
(let ([proc-c
(cond [(and proc proc*)
(cg proc proc*)]
[proc* (fail! S T)]
[else empty])])
(cset-meet proc-c (cgen/flds V X Y flds flds*)))]
;; two struct names, need to resolve b/c one could be a parent
[((Name: n) (Name: n*))

2
collects/typed-scheme/private/base-special-env.rkt
View File

@ -31,7 +31,7 @@
(define-hierarchy child (spec ...) grand ...)
...)
(begin
(d-s parent ([name : type] ...) ())
(d-s parent ([name : type] ...))
(define-sub-hierarchy [child parent] (type ...) (spec ...) grand ...)
...)]))

4
collects/typed-scheme/private/type-contract.rkt
View File

@ -30,7 +30,7 @@
(syntax-parse stx #:literals (define-values)
[(define-values (n) _)
(let ([typ (if maker?
((Struct-flds (lookup-type-name (Name-id typ))) #f . t:->* . typ)
((map fld-t (Struct-flds (lookup-type-name (Name-id typ)))) #f . t:->* . typ)
typ)])
(with-syntax ([cnt (type->contract
typ
@ -165,7 +165,7 @@
#;#'class?
#'(class/c (name fcn-cnt) ... (init [by-name-init by-name-cnt] ...)))]
[(Value: '()) #'null?]
[(Struct: nm par flds proc poly? pred? cert acc-ids maker-id)
[(Struct: nm par (list (fld: flds acc-ids mut?) ...) proc poly? pred? cert maker-id)
(cond
[(assf (λ (t) (type-equal? t ty)) structs-seen)
=>

8
collects/typed-scheme/rep/rep-utils.rkt
View File

@ -252,17 +252,11 @@
[stx (or/c #f syntax?)]))
[replace-syntax (Rep? syntax? . -> . Rep?)])
(define (list-update l k v)
(if (zero? k)
(cons v (cdr l))
(cons (car l) (list-update (cdr l) (sub1 k) v))))
(define (replace-field val new-val idx)
(define-values (type skipped) (struct-info val))
(define maker (struct-type-make-constructor type))
(define flds (cdr (vector->list (struct->vector val))))
(apply maker (list-update flds idx new-val)))
(apply maker (list-set flds idx new-val)))
(define (replace-syntax rep stx)
(replace-field rep stx 3))

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

@ -14,6 +14,7 @@
(and (Type? e)
(not (Scope? e))
(not (arr? e))
(not (fld? e))
(not (Values? e))
(not (ValuesDots? e))
(not (Result? e)))))
@ -224,21 +225,27 @@
[#:fold-rhs (*Function (map type-rec-id arities))])
(dt fld ([t Type/c] [acc identifier?] [mutable? boolean?])
[#:frees (λ (f) (if mutable? (make-invariant (f t)) (f t)))]
[#:fold-rhs (*fld (type-rec-id t) acc mutable?)]
[#:intern (list t (hash-id acc) mutable?)])
;; name : symbol
;; parent : Struct
;; flds : Listof[Type]
;; flds : Listof[fld]
;; proc : Function Type
;; poly? : is this a polymorphic type?
;; pred-id : identifier for the predicate of the struct
;; cert : syntax certifier for pred-id
;; acc-ids : names of the accessors
;; maker-id : name of the constructor
(dt Struct ([name symbol?]
[parent (or/c #f Struct? Name?)]
[flds (listof Type/c)]
[flds (listof fld?)]
[proc (or/c #f Function?)]
[poly? (or/c #f (listof symbol?))]
[pred-id identifier?]
[cert procedure?]
[acc-ids (listof identifier?)]
[maker-id identifier?])
[#:intern (list name parent flds proc)]
[#:frees (λ (f) (combine-frees (map f (append (if proc (list proc) null)
@ -251,7 +258,6 @@
poly?
pred-id
cert
acc-ids
maker-id)]
[#:key #f])

23
collects/typed-scheme/typecheck/tc-app.rkt
View File

@ -465,8 +465,11 @@
[(#%plain-app (~and op (~or (~literal unsafe-struct-ref) (~literal unsafe-struct*-ref))) s e:expr)
(let ([e-t (single-value #'e)])
(match (single-value #'s)
[(tc-result1: (and t (or (Struct: _ _ flds _ _ _ _ _ _)
(? needs-resolving? (app resolve-once (Struct: _ _ flds _ _ _ _ _ _))))))
[(tc-result1:
(and t (or (Struct: _ _ (list (fld: flds _ muts) ...) _ _ _ _ _)
(? needs-resolving?
(app resolve-once
(Struct: _ _ (list (fld: flds _ muts) ...) _ _ _ _ _))))))
(let ([ival (or (syntax-parse #'e [((~literal quote) i:number) (syntax-e #'i)] [_ #f])
(match e-t
[(tc-result1: (Value: (? number? i))) i]
@ -477,9 +480,11 @@
(check-below (ret (apply Un flds)) expected)
(ret (apply Un flds)))]
[(and (integer? ival) (exact? ival) (<= 0 ival (sub1 (length flds))))
(if expected
(check-below (ret (list-ref flds ival)) expected)
(ret (list-ref flds ival)))]
(let ([result (if (list-ref muts ival)
(ret (list-ref flds ival))
;; FIXME - could do something with paths here
(ret (list-ref flds ival)))])
(if expected (check-below result expected) result))]
[(not (and (integer? ival) (exact? ival)))
(tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for struct index, but got ~a" ival)]
[(< ival 0)
@ -492,8 +497,10 @@
[(#%plain-app (~and op (~or (~literal unsafe-struct-set!) (~literal unsafe-struct*-set!))) s e:expr val:expr)
(let ([e-t (single-value #'e)])
(match (single-value #'s)
[(tc-result1: (and t (or (Struct: _ _ flds _ _ _ _ _ _)
(? needs-resolving? (app resolve-once (Struct: _ _ flds _ _ _ _ _ _))))))
[(tc-result1: (and t (or (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _)
(? needs-resolving?
(app resolve-once
(Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _))))))
(let ([ival (or (syntax-parse #'e [((~literal quote) i:number) (syntax-e #'i)] [_ #f])
(match e-t
[(tc-result1: (Value: (? number? i))) i]
@ -916,7 +923,7 @@
(lambda (dom rng rest a) (infer/vararg vars null argtys-t dom rest rng (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
[((tc-result1: (Param: in out)) (list)) (ret out)]

30
collects/typed-scheme/typecheck/tc-envops.rkt
View File

@ -9,17 +9,13 @@
(rep type-rep object-rep)
(utils tc-utils)
(types resolve)
(only-in (env type-env-structs lexical-env) env? update-type/lexical env-map env-props replace-props)
(only-in (env type-env-structs lexical-env)
env? update-type/lexical env-map env-props replace-props)
scheme/contract scheme/match
mzlib/trace unstable/debug unstable/struct
(typecheck tc-metafunctions)
(for-syntax scheme/base))
(define (replace-nth l i f)
(cond [(null? l) (error 'replace-nth "list not long enough" l i f)]
[(zero? i) (cons (f (car l)) (cdr l))]
[else (cons (car l) (replace-nth (cdr l) (sub1 i) f))]))
;(trace replace-nth)
(define/contract (update t lo)
@ -42,15 +38,25 @@
(make-Syntax (update t (-not-filter u x rst)))]
;; struct ops
[((Struct: nm par flds proc poly pred cert acc-ids maker-id)
[((Struct: nm par flds proc poly pred cert maker-id)
(TypeFilter: u (list rst ... (StructPE: (? (lambda (s) (subtype t s)) s) idx)) x))
(make-Struct nm par
(replace-nth flds idx
(lambda (e) (update e (-filter u x rst))))
proc poly pred cert acc-ids maker-id)]
[((Struct: nm par flds proc poly pred cert acc-ids maker-id)
(list-update flds idx
(match-lambda [(fld: e acc-id #f)
(make-fld
(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)
(NotTypeFilter: u (list rst ... (StructPE: (? (lambda (s) (subtype t s)) s) idx)) x))
(make-Struct nm par (replace-nth flds idx (lambda (e) (update e (-not-filter u x rst)))) proc poly pred cert acc-ids maker-id)]
(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)]
;; otherwise
[(t (TypeFilter: u (list) _))

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

@ -13,6 +13,10 @@
unstable/debug
racket/function
scheme/match
(only-in racket/contract
listof any/c or/c
[->* c->*]
[-> c->])
(for-syntax scheme/base))
@ -78,35 +82,54 @@
;; 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]))
;; construct all the various types for structs, and then register the approriate names
;; identifier listof[identifier] type listof[Type] listof[Type] boolean -> Type listof[Type] listof[Type]
(define (mk/register-sty nm flds parent parent-field-types types
#:wrapper [wrapper values]
#:type-wrapper [type-wrapper values]
#:pred-wrapper [pred-wrapper values]
#:mutable [setters? #f]
#:struct-info [si #f]
#:proc-ty [proc-ty #f]
#:maker [maker* #f]
#:predicate [pred* #f]
#:constructor-return [cret #f]
#:poly? [poly? #f]
#:type-only [type-only #f])
;; identifier listof[identifier] type listof[fld] listof[Type] boolean -> Type listof[Type] listof[Type]
(d/c (mk/register-sty nm flds parent parent-fields types
#:wrapper [wrapper values]
#:type-wrapper [type-wrapper values]
#:pred-wrapper [pred-wrapper values]
#:mutable [setters? #f]
#:struct-info [si #f]
#:proc-ty [proc-ty #f]
#:maker [maker* #f]
#:predicate [pred* #f]
#:constructor-return [cret #f]
#:poly? [poly? #f]
#:type-only [type-only #f])
(c->* (identifier? (listof identifier?) (or/c Type/c #f) (listof fld?) (listof Type/c))
(#:wrapper procedure?
#:type-wrapper procedure?
#:pred-wrapper procedure?
#:mutable boolean?
#:struct-info any/c
#:proc-ty (or/c #f Type/c)
#:maker (or/c #f identifier?)
#:predicate (or/c #f identifier?)
#:constructor-return (or/c #f Type/c)
#:poly? (or/c #f (listof symbol?))
#:type-only boolean?)
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-types (append parent-field-types types)]
[sty (make-Struct name parent fld-types proc-ty poly? pred (syntax-local-certifier) getters (or maker* maker))]
[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
(syntax-local-certifier) (or maker* maker))]
[external-fld-types/no-parent types]
[external-fld-types fld-types])
[external-fld-types (map fld-t flds)])
(if type-only
(register-type-name nm (wrapper sty))
(register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters?
(register-struct-types nm sty fld-names external-fld-types
external-fld-types/no-parent setters?
#:wrapper wrapper
#:type-wrapper type-wrapper
#:pred-wrapper pred-wrapper
@ -119,15 +142,25 @@
;; generate names, and register the approriate types give field types and structure type
;; optionally wrap things
;; identifier Type Listof[identifer] Listof[Type] Listof[Type] #:wrapper (Type -> Type) #:maker identifier
(define (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters?
#:wrapper [wrapper values]
#:struct-info [si #f]
#:type-wrapper [type-wrapper values]
#:pred-wrapper [pred-wrapper values]
#:maker [maker* #f]
#:predicate [pred* #f]
#:poly? [poly? #f]
#:constructor-return [cret #f])
(d/c (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters?
#:wrapper [wrapper values]
#:struct-info [si #f]
#:type-wrapper [type-wrapper values]
#:pred-wrapper [pred-wrapper values]
#:maker [maker* #f]
#:predicate [pred* #f]
#:poly? [poly? #f]
#:constructor-return [cret #f])
(c->* (identifier? Struct? (listof identifier?) (listof Type/c) (listof Type/c) boolean?)
(#:wrapper procedure?
#:type-wrapper procedure?
#:pred-wrapper procedure?
#:struct-info any/c
#:maker (or/c #f identifier?)
#:predicate (or/c #f identifier?)
#:constructor-return (or/c #f Type/c)
#:poly? (or/c #f (listof symbol?)))
list?)
;; create the approriate names that define-struct will bind
(define-values (struct-type-id maker pred getters setters) (struct-names nm flds setters?))
;; the type name that is used in all the types
@ -212,10 +245,18 @@
;; typecheck a non-polymophic struct and register the approriate types
;; tc/struct : (U identifier (list identifier identifier)) Listof[identifier] Listof[syntax] -> void
(define (tc/struct nm/par flds tys [proc-ty #f]
#:maker [maker #f] #:constructor-return [cret #f] #:mutable [mutable #f]
#:predicate [pred #f]
#:type-only [type-only #f])
(d/c (tc/struct nm/par flds tys [proc-ty #f]
#:maker [maker #f] #:constructor-return [cret #f] #:mutable [mutable #f]
#:predicate [pred #f]
#:type-only [type-only #f])
(c->* (syntax? (listof identifier?) (listof syntax?))
((or/c #f syntax?)
#:maker any/c
#:mutable boolean?
#:constructor-return any/c
#:predicate any/c
#:type-only boolean?)
any/c)
;; get the parent info and create some types and type variables
(define-values (nm parent-name parent name name-tvar) (parse-parent nm/par))
;; parse the field types, and determine if the type is recursive
@ -239,9 +280,13 @@
;; register a struct type
;; convenience function for built-in structs
;; tc/builtin-struct : identifier identifier Listof[identifier] Listof[Type] Listof[Type] -> void
(define (tc/builtin-struct nm parent flds tys parent-tys)
(let ([parent* (if parent (make-Name parent) #f)])
(mk/register-sty nm flds parent* parent-tys tys
(d/c (tc/builtin-struct nm parent flds tys #;parent-tys)
(c-> identifier? (or/c #f identifier?) (listof identifier?)
(listof Type/c) #;(listof fld?)
any/c)
(let* ([parent-name (if parent (make-Name parent) #f)]
[parent-flds (if parent (get-parent-flds parent-name) null)])
(mk/register-sty nm flds parent-name parent-flds tys
#:mutable #t)))
;; syntax for tc/builtin-struct
@ -250,11 +295,9 @@
[(_ (nm par) ([fld : ty] ...) (par-ty ...))
#'(tc/builtin-struct #'nm #'par
(list #'fld ...)
(list ty ...)
(list par-ty ...))]
[(_ nm ([fld : ty] ...) (par-ty ...))
(list ty ...))]
[(_ nm ([fld : ty] ...))
#'(tc/builtin-struct #'nm #f
(list #'fld ...)
(list ty ...)
(list par-ty ...))]))
(list ty ...))]))

2
collects/typed-scheme/typecheck/tc-toplevel.rkt
View File

@ -72,7 +72,7 @@
[(define-values () (begin (quote-syntax (require/typed-internal nm ty #:struct-maker parent)) (#%plain-app values)))
(let* ([t (parse-type #'ty)]
[flds (Struct-flds (lookup-type-name (Name-id t)))]
[flds (map fld-t (Struct-flds (lookup-type-name (Name-id t))))]
[mk-ty (flds #f . ->* . t)])
(register-type #'nm mk-ty)
(list (make-def-binding #'nm mk-ty)))]

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

@ -86,12 +86,12 @@
;; basic types
(define promise-str (string->uninterned-symbol "Promise"))
(define promise-sym (string->uninterned-symbol "Promise"))
(define make-promise-ty
(let ([s promise-str])
(let ([s promise-sym])
(lambda (t)
(make-Struct s #f (list t) #f #f #'promise? values (list #'values) #'values))))
(make-Struct s #f (list (make-fld t #'values #f)) #f #f #'promise? values #'values))))
(define -Listof (-poly (list-elem) (make-Listof list-elem)))
@ -285,8 +285,8 @@
(define (make-arr-dots dom rng dty dbound)
(make-arr* dom rng #:drest (cons dty dbound)))
(define (-struct name parent flds accs constructor [proc #f] [poly #f] [pred #'dummy] [cert values])
(make-Struct name parent flds proc poly pred cert accs constructor))
(define (-struct name parent flds constructor [proc #f] [poly #f] [pred #'dummy] [cert values])
(make-Struct name parent flds proc poly pred cert constructor))
(d/c (-filter t i [p null])
(c:->* (Type/c name-ref/c) ((listof PathElem?)) Filter/c)

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

@ -144,9 +144,9 @@
(fp "~a" (cons 'List (tuple-elems t)))]
[(Base: n cnt) (fp "~a" n)]
[(Opaque: pred _) (fp "(Opaque ~a)" (syntax->datum pred))]
[(Struct: (== promise-str eq?) #f (list fld) _ _ _ _ _ _) (fp "(Promise ~a)" fld)]
[(Struct: nm par flds proc _ _ _ _ _)
(fp "#(struct:~a ~a" nm flds)
[(Struct: (== promise-sym) #f (list (fld: t _ _)) _ _ _ _ _) (fp "(Promise ~a)" t)]
[(Struct: nm par (list (fld: t _ _) ...) proc _ _ _ _)
(fp "#(struct:~a ~a" nm t)
(when proc
(fp " ~a" proc))
(fp ")")]
@ -223,6 +223,7 @@
(for ([t ts]) (fp " ~a" t))
(fp ")")]
[(Error:) (fp "Error")]
[(fld: t a m) (fp "(fld ~a)" t)]
[else (fp "(Unknown Type: ~a)" (struct->vector c))]
))

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

@ -50,25 +50,30 @@
[(or (list (Pair: _ _) _)
(list _ (Pair: _ _)))
#f]
[(or (list (Value: '()) (Struct: n _ flds _ _ _ _ _ _))
(list (Struct: n _ flds _ _ _ _ _ _) (Value: '())))
[(or (list (Value: '()) (Struct: n _ flds _ _ _ _ _))
(list (Struct: n _ flds _ _ _ _ _) (Value: '())))
#f]
[(list (Struct: n _ flds _ _ _ _ _ _)
(Struct: n _ flds* _ _ _ _ _ _))
(for/and ([f flds] [f* flds*]) (overlap f f*))]
[(list (Struct: n #f _ _ _ _ _ _ _)
(StructTop: (Struct: n #f _ _ _ _ _ _ _)))
[(list (Struct: n _ flds _ _ _ _ _)
(Struct: n _ flds* _ _ _ _ _))
(for/and ([f flds] [f* flds*])
(match* (f f*)
[((fld: t _ _) (fld: t* _ _)) (overlap t t*)]))]
[(list (Struct: n #f _ _ _ _ _ _)
(StructTop: (Struct: n #f _ _ _ _ _ _)))
#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 (Struct: n p flds _ _ _ _ _ _)
(Struct: n* p* flds* _ _ _ _ _ _))
(and (= (length flds) (length flds*)) (for/and ([f flds] [f* flds*]) (overlap f f*)))]
[(list (Struct: n p flds _ _ _ _ _)
(Struct: n* p* flds* _ _ _ _ _))
(and (= (length flds) (length flds*))
(for/and ([f flds] [f* flds*])
(match* (f f*)
[((fld: t _ _) (fld: t* _ _)) (overlap t t*)])))]
[(list (== (-val eof))
(Function: _))
#f]

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

@ -16,7 +16,7 @@
(define-struct (exn:subtype exn:fail) (s t))
;; inference failure - masked before it gets to the user program
;; subtyping failure - masked before it gets to the user program
(define-syntax fail!
(syntax-rules ()
[(_ s t) (raise (make-exn:subtype "subtyping failed" (current-continuation-marks) s t))]))
@ -196,6 +196,13 @@
[else (make-arr (apply map (lambda args (make-Union (sort args type<?))) (cons dom1 dom)) rng1 #f #f '())])]
[_ #f]))
(define (subtype/flds* A flds flds*)
(for/fold ([A A]) ([f (in-list flds)] [f* (in-list flds*)])
(match* (f f*)
[((fld: t _ #t) (fld: t* _ #t))
(subtype* (subtype* A t* t) t t*)]
[((fld: t _ #f) (fld: t* _ #f))
(subtype* A t t*)])))
;; the algorithm for recursive types transcribed directly from TAPL, pg 305
;; List[(cons Number Number)] type type -> List[(cons Number Number)]
@ -348,11 +355,12 @@
[(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 #f _ _ _ _ _) (Struct: nm _ flds* #f _ _ _ _ _))
(subtypes* A0 flds flds*)]
[((Struct: nm _ flds proc _ _ _ _ _) (Struct: nm _ flds* proc* _ _ _ _ _))
(subtypes* A0 (cons proc flds) (cons proc* flds*))]
[((Struct: _ _ _ _ _ _ _ _ _) (StructTop: (? (lambda (s2) (type-equal? s2 s)))))
[((Struct: nm _ flds proc _ _ _ _) (Struct: nm _ flds* proc* _ _ _ _))
(let ([A (cond [(and proc proc*) (subtype* proc proc*)]
[proc* (fail! proc proc*)]
[else A0])])
(subtype/flds* A flds flds*))]
[((Struct: _ _ _ _ _ _ _ _) (StructTop: (== s type-equal?)))
A0]
[((Box: _) (BoxTop:)) A0]
[((Channel: _) (ChannelTop:)) A0]
@ -363,11 +371,11 @@
[((MPair: _ _) (MPairTop:)) A0]
[((Hashtable: _ _) (HashtableTop:)) A0]
;; subtyping on structs follows the declared hierarchy
[((Struct: nm (? Type? parent) flds proc _ _ _ _ _) other)
[((Struct: nm (? Type? parent) flds proc _ _ _ _) other)
;(printf "subtype - hierarchy : ~a ~a ~a~n" nm parent other)
(subtype* A0 parent other)]
;; Promises are covariant
[((Struct: 'Promise _ (list t) _ _ _ _ _ _) (Struct: 'Promise _ (list t*) _ _ _ _ _ _)) (subtype* A0 t t*)]
[((Struct: (== promise-sym) _ (list t) _ _ _ _ _) (Struct: (== promise-sym) _ (list t*) _ _ _ _ _)) (subtype* A0 t t*)]
;; subtyping on values is pointwise
[((Values: vals1) (Values: vals2)) (subtypes* A0 vals1 vals2)]
;; trivial case for Result

14
collects/typed-scheme/utils/utils.rkt
View File

@ -11,7 +11,7 @@ at least theoretically.
scheme/pretty mzlib/pconvert syntax/parse)
;; to move to unstable
(provide reverse-begin)
(provide reverse-begin list-update list-set)
(provide
;; optimization
@ -26,6 +26,7 @@ at least theoretically.
rep utils typecheck infer env private types)
(define optimize? (make-parameter #f))
(define-for-syntax enable-contracts? #t)
;; fancy require syntax
(define-syntax (define-requirer stx)
@ -159,7 +160,6 @@ at least theoretically.
;; turn contracts on and off - off by default for performance.
(define-for-syntax enable-contracts? #f)
(provide (for-syntax enable-contracts?) p/c w/c cnt d-s/c d/c d/c/p)
(define-syntax-rule (d/c/p (name . args) c . body)
@ -214,3 +214,13 @@ at least theoretically.
(if enable-contracts?
(list #'[contracted (nm cnt)])
(list #'nm))]))
(define (list-update l i f)
(cond [(null? l) (error 'list-update "list not long enough" l i f)]
[(zero? i) (cons (f (car l)) (cdr l))]
[else (cons (car l) (list-update (cdr l) (sub1 i) f))]))
(define (list-set l k v)
(if (zero? k)
(cons v (cdr l))
(cons (car l) (list-set (cdr l) (sub1 k) v))))