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))] [(-values (list -Number)) (-values (list Univ))]
[(-poly (a) ((Un (make-Base 'foo #'dummy) (-struct 'bar #f (list -Number a) null #'values)) . -> . (-lst a))) [(-poly (b) ((Un (make-Base 'foo #'dummy)
((Un (make-Base 'foo #'dummy) (-struct 'bar #f (list -Number (-pair -Number (-v a))) null #'values)) (-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))))] . -> . (-lst (-pair -Number (-v a))))]
[(-poly (a) ((-struct 'bar #f (list -Number a) null #'values) . -> . (-lst a))) [(-poly (b) ((-struct 'bar #f (list (make-fld -Number #'values #f) (make-fld b #'values #f)) #'values) . -> . (-lst b)))
((-struct 'bar #f (list -Number (-pair -Number (-v a))) null #'values) . -> . (-lst (-pair -Number (-v a))))] ((-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))) ((-v b) . -> . (make-Listof (-v b)))]
[(-poly (a) (a . -> . (make-Listof a))) ((-pair -Number (-v b)) . -> . (make-Listof (-pair -Number (-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)) (FAIL (-> Univ) (null Univ . ->* . Univ))
[(cl->* (-Number . -> . -String) (-Boolean . -> . -String)) ((Un -Boolean -Number) . -> . -String)] [(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 (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" #'(test-suite "Tests for type equality"
cl1 ... cl2 ...))])) cl1 ... cl2 ...))]))
(define (fld* t) (make-fld t (datum->syntax #'here 'values) #f))
(define (type-equal-tests) (define (type-equal-tests)
(te-tests (te-tests
[-Number -Number] [-Number -Number]
@ -38,13 +40,12 @@
;; found bug ;; found bug
[FAIL (Un (-mu heap-node [FAIL (Un (-mu heap-node
(-struct 'heap-node #f (-struct 'heap-node #f
(list (-base 'comparator) -Number (-v a) (Un heap-node (-base 'heap-empty))) (map fld* (list (-base 'comparator) -Number (-v a) (Un heap-node (-base 'heap-empty))))
null #'values)) #'values))
(-base 'heap-empty)) (-base 'heap-empty))
(Un (-mu heap-node (Un (-mu heap-node
(-struct 'heap-node #f (-struct 'heap-node #f
(list (-base 'comparator) -Number (-pair -Number -Number) (Un heap-node (-base 'heap-empty))) (map fld* (list (-base 'comparator) -Number (-pair -Number -Number) (Un heap-node (-base 'heap-empty)))) #'values))
null #'values))
(-base 'heap-empty))])) (-base 'heap-empty))]))
(define-go (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))] [(Union: elems) `(make-Union (sort (list ,@(map sub elems)) < #:key Type-seq))]
[(Base: n cnt) `(make-Base ',n (quote-syntax ,cnt))] [(Base: n cnt) `(make-Base ',n (quote-syntax ,cnt))]
[(Name: stx) `(make-Name (quote-syntax ,stx))] [(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) `(make-Struct ,(sub name) ,(sub parent)
,(sub flds) ,(sub proc) ,(sub poly?) ,(sub flds) ,(sub proc) ,(sub poly?)
(quote-syntax ,pred-id) (syntax-local-certifier) (quote-syntax ,pred-id) (syntax-local-certifier)
(list ,@(for/list ([a acc-ids]) `(quote-syntax ,a)))
(quote-syntax ,maker-id))] (quote-syntax ,maker-id))]
[(App: rator rands stx) `(make-App ,(sub rator) ,(sub rands) (quote-syntax ,stx))] [(App: rator rands stx) `(make-App ,(sub rator) ,(sub rands) (quote-syntax ,stx))]
[(Opaque: pred cert) `(make-Opaque (quote-syntax ,pred) (syntax-local-certifier))] [(Opaque: pred cert) `(make-Opaque (quote-syntax ,pred) (syntax-local-certifier))]

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

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

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

@ -31,7 +31,7 @@
(define-hierarchy child (spec ...) grand ...) (define-hierarchy child (spec ...) grand ...)
...) ...)
(begin (begin
(d-s parent ([name : type] ...) ()) (d-s parent ([name : type] ...))
(define-sub-hierarchy [child parent] (type ...) (spec ...) grand ...) (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) (syntax-parse stx #:literals (define-values)
[(define-values (n) _) [(define-values (n) _)
(let ([typ (if maker? (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)]) typ)])
(with-syntax ([cnt (type->contract (with-syntax ([cnt (type->contract
typ typ
@ -165,7 +165,7 @@
#;#'class? #;#'class?
#'(class/c (name fcn-cnt) ... (init [by-name-init by-name-cnt] ...)))] #'(class/c (name fcn-cnt) ... (init [by-name-init by-name-cnt] ...)))]
[(Value: '()) #'null?] [(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 (cond
[(assf (λ (t) (type-equal? t ty)) structs-seen) [(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?)])) [stx (or/c #f syntax?)]))
[replace-syntax (Rep? syntax? . -> . Rep?)]) [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 (replace-field val new-val idx)
(define-values (type skipped) (struct-info val)) (define-values (type skipped) (struct-info val))
(define maker (struct-type-make-constructor type)) (define maker (struct-type-make-constructor type))
(define flds (cdr (vector->list (struct->vector val)))) (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) (define (replace-syntax rep stx)
(replace-field rep stx 3)) (replace-field rep stx 3))

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

@ -14,6 +14,7 @@
(and (Type? e) (and (Type? e)
(not (Scope? e)) (not (Scope? e))
(not (arr? e)) (not (arr? e))
(not (fld? e))
(not (Values? e)) (not (Values? e))
(not (ValuesDots? e)) (not (ValuesDots? e))
(not (Result? e))))) (not (Result? e)))))
@ -224,21 +225,27 @@
[#:fold-rhs (*Function (map type-rec-id arities))]) [#: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 ;; name : symbol
;; parent : Struct ;; parent : Struct
;; flds : Listof[Type] ;; flds : Listof[fld]
;; proc : Function Type ;; proc : Function Type
;; poly? : is this a polymorphic type? ;; poly? : is this a polymorphic type?
;; pred-id : identifier for the predicate of the struct ;; pred-id : identifier for the predicate of the struct
;; cert : syntax certifier for pred-id ;; cert : syntax certifier for pred-id
;; acc-ids : names of the accessors
;; maker-id : name of the constructor
(dt Struct ([name symbol?] (dt Struct ([name symbol?]
[parent (or/c #f Struct? Name?)] [parent (or/c #f Struct? Name?)]
[flds (listof Type/c)] [flds (listof fld?)]
[proc (or/c #f Function?)] [proc (or/c #f Function?)]
[poly? (or/c #f (listof symbol?))] [poly? (or/c #f (listof symbol?))]
[pred-id identifier?] [pred-id identifier?]
[cert procedure?] [cert procedure?]
[acc-ids (listof identifier?)]
[maker-id identifier?]) [maker-id identifier?])
[#:intern (list name parent flds proc)] [#:intern (list name parent flds proc)]
[#:frees (λ (f) (combine-frees (map f (append (if proc (list proc) null) [#:frees (λ (f) (combine-frees (map f (append (if proc (list proc) null)
@ -251,7 +258,6 @@
poly? poly?
pred-id pred-id
cert cert
acc-ids
maker-id)] maker-id)]
[#:key #f]) [#: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) [(#%plain-app (~and op (~or (~literal unsafe-struct-ref) (~literal unsafe-struct*-ref))) s e:expr)
(let ([e-t (single-value #'e)]) (let ([e-t (single-value #'e)])
(match (single-value #'s) (match (single-value #'s)
[(tc-result1: (and t (or (Struct: _ _ flds _ _ _ _ _ _) [(tc-result1:
(? needs-resolving? (app resolve-once (Struct: _ _ flds _ _ _ _ _ _)))))) (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]) (let ([ival (or (syntax-parse #'e [((~literal quote) i:number) (syntax-e #'i)] [_ #f])
(match e-t (match e-t
[(tc-result1: (Value: (? number? i))) i] [(tc-result1: (Value: (? number? i))) i]
@ -477,9 +480,11 @@
(check-below (ret (apply Un flds)) expected) (check-below (ret (apply Un flds)) expected)
(ret (apply Un flds)))] (ret (apply Un flds)))]
[(and (integer? ival) (exact? ival) (<= 0 ival (sub1 (length flds)))) [(and (integer? ival) (exact? ival) (<= 0 ival (sub1 (length flds))))
(if expected (let ([result (if (list-ref muts ival)
(check-below (ret (list-ref flds ival)) expected) (ret (list-ref flds 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))) [(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)] (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for struct index, but got ~a" ival)]
[(< ival 0) [(< ival 0)
@ -492,8 +497,10 @@
[(#%plain-app (~and op (~or (~literal unsafe-struct-set!) (~literal unsafe-struct*-set!))) s e:expr val:expr) [(#%plain-app (~and op (~or (~literal unsafe-struct-set!) (~literal unsafe-struct*-set!))) s e:expr val:expr)
(let ([e-t (single-value #'e)]) (let ([e-t (single-value #'e)])
(match (single-value #'s) (match (single-value #'s)
[(tc-result1: (and t (or (Struct: _ _ flds _ _ _ _ _ _) [(tc-result1: (and t (or (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _)
(? needs-resolving? (app resolve-once (Struct: _ _ flds _ _ _ _ _ _)))))) (? needs-resolving?
(app resolve-once
(Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _))))))
(let ([ival (or (syntax-parse #'e [((~literal quote) i:number) (syntax-e #'i)] [_ #f]) (let ([ival (or (syntax-parse #'e [((~literal quote) i:number) (syntax-e #'i)] [_ #f])
(match e-t (match e-t
[(tc-result1: (Value: (? number? i))) i] [(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)))) (lambda (dom rng rest a) (infer/vararg vars null argtys-t dom rest rng (and expected (tc-results->values expected))))
t argtys expected)] t argtys expected)]
;; procedural structs ;; 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)] (tc/funapp f-stx #`(#,(syntax/loc f-stx dummy) . #,args-stx) (ret proc-ty) (cons ftype0 argtys) expected)]
;; parameters are functions too ;; parameters are functions too
[((tc-result1: (Param: in out)) (list)) (ret out)] [((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) (rep type-rep object-rep)
(utils tc-utils) (utils tc-utils)
(types resolve) (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 scheme/contract scheme/match
mzlib/trace unstable/debug unstable/struct mzlib/trace unstable/debug unstable/struct
(typecheck tc-metafunctions) (typecheck tc-metafunctions)
(for-syntax scheme/base)) (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) ;(trace replace-nth)
(define/contract (update t lo) (define/contract (update t lo)
@ -42,15 +38,25 @@
(make-Syntax (update t (-not-filter u x rst)))] (make-Syntax (update t (-not-filter u x rst)))]
;; struct ops ;; 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)) (TypeFilter: u (list rst ... (StructPE: (? (lambda (s) (subtype t s)) s) idx)) x))
(make-Struct nm par (make-Struct nm par
(replace-nth flds idx (list-update flds idx
(lambda (e) (update e (-filter u x rst)))) (match-lambda [(fld: e acc-id #f)
proc poly pred cert acc-ids maker-id)] (make-fld
[((Struct: nm par flds proc poly pred cert acc-ids maker-id) (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)) (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 ;; otherwise
[(t (TypeFilter: u (list) _)) [(t (TypeFilter: u (list) _))

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

@ -13,6 +13,10 @@
unstable/debug unstable/debug
racket/function racket/function
scheme/match scheme/match
(only-in racket/contract
listof any/c or/c
[->* c->*]
[-> c->])
(for-syntax scheme/base)) (for-syntax scheme/base))
@ -78,14 +82,14 @@
;; Option[Struct-Ty] -> Listof[Type] ;; Option[Struct-Ty] -> Listof[Type]
(define (get-parent-flds p) (define (get-parent-flds p)
(match p (match p
[(Struct: _ _ flds _ _ _ _ _ _) flds] [(Struct: _ _ flds _ _ _ _ _) flds]
[(Name: n) (get-parent-flds (lookup-type-name n))] [(Name: n) (get-parent-flds (lookup-type-name n))]
[#f null])) [#f null]))
;; construct all the various types for structs, and then register the approriate names ;; 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] ;; identifier listof[identifier] type listof[fld] listof[Type] boolean -> Type listof[Type] listof[Type]
(define (mk/register-sty nm flds parent parent-field-types types (d/c (mk/register-sty nm flds parent parent-fields types
#:wrapper [wrapper values] #:wrapper [wrapper values]
#:type-wrapper [type-wrapper values] #:type-wrapper [type-wrapper values]
#:pred-wrapper [pred-wrapper values] #:pred-wrapper [pred-wrapper values]
@ -97,16 +101,35 @@
#:constructor-return [cret #f] #:constructor-return [cret #f]
#:poly? [poly? #f] #:poly? [poly? #f]
#:type-only [type-only #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 ;; create the approriate names that define-struct will bind
(define-values (struct-type-id maker pred getters setters) (struct-names nm flds setters?)) (define-values (struct-type-id maker pred getters setters) (struct-names nm flds setters?))
(let* ([name (syntax-e nm)] (let* ([name (syntax-e nm)]
[fld-types (append parent-field-types types)] [fld-names flds]
[sty (make-Struct name parent fld-types proc-ty poly? pred (syntax-local-certifier) getters (or maker* maker))] [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/no-parent types]
[external-fld-types fld-types]) [external-fld-types (map fld-t flds)])
(if type-only (if type-only
(register-type-name nm (wrapper sty)) (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 #:wrapper wrapper
#:type-wrapper type-wrapper #:type-wrapper type-wrapper
#:pred-wrapper pred-wrapper #:pred-wrapper pred-wrapper
@ -119,7 +142,7 @@
;; generate names, and register the approriate types give field types and structure type ;; generate names, and register the approriate types give field types and structure type
;; optionally wrap things ;; optionally wrap things
;; identifier Type Listof[identifer] Listof[Type] Listof[Type] #:wrapper (Type -> Type) #:maker identifier ;; 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? (d/c (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters?
#:wrapper [wrapper values] #:wrapper [wrapper values]
#:struct-info [si #f] #:struct-info [si #f]
#:type-wrapper [type-wrapper values] #:type-wrapper [type-wrapper values]
@ -128,6 +151,16 @@
#:predicate [pred* #f] #:predicate [pred* #f]
#:poly? [poly? #f] #:poly? [poly? #f]
#:constructor-return [cret #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 ;; create the approriate names that define-struct will bind
(define-values (struct-type-id maker pred getters setters) (struct-names nm flds setters?)) (define-values (struct-type-id maker pred getters setters) (struct-names nm flds setters?))
;; the type name that is used in all the types ;; the type name that is used in all the types
@ -212,10 +245,18 @@
;; typecheck a non-polymophic struct and register the approriate types ;; typecheck a non-polymophic struct and register the approriate types
;; tc/struct : (U identifier (list identifier identifier)) Listof[identifier] Listof[syntax] -> void ;; tc/struct : (U identifier (list identifier identifier)) Listof[identifier] Listof[syntax] -> void
(define (tc/struct nm/par flds tys [proc-ty #f] (d/c (tc/struct nm/par flds tys [proc-ty #f]
#:maker [maker #f] #:constructor-return [cret #f] #:mutable [mutable #f] #:maker [maker #f] #:constructor-return [cret #f] #:mutable [mutable #f]
#:predicate [pred #f] #:predicate [pred #f]
#:type-only [type-only #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 ;; get the parent info and create some types and type variables
(define-values (nm parent-name parent name name-tvar) (parse-parent nm/par)) (define-values (nm parent-name parent name name-tvar) (parse-parent nm/par))
;; parse the field types, and determine if the type is recursive ;; parse the field types, and determine if the type is recursive
@ -239,9 +280,13 @@
;; register a struct type ;; register a struct type
;; convenience function for built-in structs ;; convenience function for built-in structs
;; tc/builtin-struct : identifier identifier Listof[identifier] Listof[Type] Listof[Type] -> void ;; tc/builtin-struct : identifier identifier Listof[identifier] Listof[Type] Listof[Type] -> void
(define (tc/builtin-struct nm parent flds tys parent-tys) (d/c (tc/builtin-struct nm parent flds tys #;parent-tys)
(let ([parent* (if parent (make-Name parent) #f)]) (c-> identifier? (or/c #f identifier?) (listof identifier?)
(mk/register-sty nm flds parent* parent-tys tys (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))) #:mutable #t)))
;; syntax for tc/builtin-struct ;; syntax for tc/builtin-struct
@ -250,11 +295,9 @@
[(_ (nm par) ([fld : ty] ...) (par-ty ...)) [(_ (nm par) ([fld : ty] ...) (par-ty ...))
#'(tc/builtin-struct #'nm #'par #'(tc/builtin-struct #'nm #'par
(list #'fld ...) (list #'fld ...)
(list ty ...) (list ty ...))]
(list par-ty ...))] [(_ nm ([fld : ty] ...))
[(_ nm ([fld : ty] ...) (par-ty ...))
#'(tc/builtin-struct #'nm #f #'(tc/builtin-struct #'nm #f
(list #'fld ...) (list #'fld ...)
(list ty ...) (list ty ...))]))
(list par-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))) [(define-values () (begin (quote-syntax (require/typed-internal nm ty #:struct-maker parent)) (#%plain-app values)))
(let* ([t (parse-type #'ty)] (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)]) [mk-ty (flds #f . ->* . t)])
(register-type #'nm mk-ty) (register-type #'nm mk-ty)
(list (make-def-binding #'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 ;; basic types
(define promise-str (string->uninterned-symbol "Promise")) (define promise-sym (string->uninterned-symbol "Promise"))
(define make-promise-ty (define make-promise-ty
(let ([s promise-str]) (let ([s promise-sym])
(lambda (t) (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))) (define -Listof (-poly (list-elem) (make-Listof list-elem)))
@ -285,8 +285,8 @@
(define (make-arr-dots dom rng dty dbound) (define (make-arr-dots dom rng dty dbound)
(make-arr* dom rng #:drest (cons 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]) (define (-struct name parent flds constructor [proc #f] [poly #f] [pred #'dummy] [cert values])
(make-Struct name parent flds proc poly pred cert accs constructor)) (make-Struct name parent flds proc poly pred cert constructor))
(d/c (-filter t i [p null]) (d/c (-filter t i [p null])
(c:->* (Type/c name-ref/c) ((listof PathElem?)) Filter/c) (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)))] (fp "~a" (cons 'List (tuple-elems t)))]
[(Base: n cnt) (fp "~a" n)] [(Base: n cnt) (fp "~a" n)]
[(Opaque: pred _) (fp "(Opaque ~a)" (syntax->datum pred))] [(Opaque: pred _) (fp "(Opaque ~a)" (syntax->datum pred))]
[(Struct: (== promise-str eq?) #f (list fld) _ _ _ _ _ _) (fp "(Promise ~a)" fld)] [(Struct: (== promise-sym) #f (list (fld: t _ _)) _ _ _ _ _) (fp "(Promise ~a)" t)]
[(Struct: nm par flds proc _ _ _ _ _) [(Struct: nm par (list (fld: t _ _) ...) proc _ _ _ _)
(fp "#(struct:~a ~a" nm flds) (fp "#(struct:~a ~a" nm t)
(when proc (when proc
(fp " ~a" proc)) (fp " ~a" proc))
(fp ")")] (fp ")")]
@ -223,6 +223,7 @@
(for ([t ts]) (fp " ~a" t)) (for ([t ts]) (fp " ~a" t))
(fp ")")] (fp ")")]
[(Error:) (fp "Error")] [(Error:) (fp "Error")]
[(fld: t a m) (fp "(fld ~a)" t)]
[else (fp "(Unknown Type: ~a)" (struct->vector c))] [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: _ _) _) [(or (list (Pair: _ _) _)
(list _ (Pair: _ _))) (list _ (Pair: _ _)))
#f] #f]
[(or (list (Value: '()) (Struct: n _ flds _ _ _ _ _ _)) [(or (list (Value: '()) (Struct: n _ flds _ _ _ _ _))
(list (Struct: n _ flds _ _ _ _ _ _) (Value: '()))) (list (Struct: n _ flds _ _ _ _ _) (Value: '())))
#f] #f]
[(list (Struct: n _ flds _ _ _ _ _ _) [(list (Struct: n _ flds _ _ _ _ _)
(Struct: n _ flds* _ _ _ _ _ _)) (Struct: n _ flds* _ _ _ _ _))
(for/and ([f flds] [f* flds*]) (overlap f f*))] (for/and ([f flds] [f* flds*])
[(list (Struct: n #f _ _ _ _ _ _ _) (match* (f f*)
(StructTop: (Struct: n #f _ _ _ _ _ _ _))) [((fld: t _ _) (fld: t* _ _)) (overlap t t*)]))]
[(list (Struct: n #f _ _ _ _ _ _)
(StructTop: (Struct: n #f _ _ _ _ _ _)))
#t] #t]
;; n and n* must be different, so there's no overlap ;; n and n* must be different, so there's no overlap
[(list (Struct: n #f flds _ _ _ _ _ _) [(list (Struct: n #f flds _ _ _ _ _)
(Struct: n* #f flds* _ _ _ _ _ _)) (Struct: n* #f flds* _ _ _ _ _))
#f] #f]
[(list (Struct: n #f flds _ _ _ _ _ _) [(list (Struct: n #f flds _ _ _ _ _)
(StructTop: (Struct: n* #f flds* _ _ _ _ _ _))) (StructTop: (Struct: n* #f flds* _ _ _ _ _)))
#f] #f]
[(list (Struct: n p flds _ _ _ _ _ _) [(list (Struct: n p flds _ _ _ _ _)
(Struct: n* p* flds* _ _ _ _ _ _)) (Struct: n* p* flds* _ _ _ _ _))
(and (= (length flds) (length flds*)) (for/and ([f flds] [f* flds*]) (overlap f f*)))] (and (= (length flds) (length flds*))
(for/and ([f flds] [f* flds*])
(match* (f f*)
[((fld: t _ _) (fld: t* _ _)) (overlap t t*)])))]
[(list (== (-val eof)) [(list (== (-val eof))
(Function: _)) (Function: _))
#f] #f]

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

@ -16,7 +16,7 @@
(define-struct (exn:subtype exn:fail) (s t)) (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! (define-syntax fail!
(syntax-rules () (syntax-rules ()
[(_ s t) (raise (make-exn:subtype "subtyping failed" (current-continuation-marks) s t))])) [(_ 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 '())])] [else (make-arr (apply map (lambda args (make-Union (sort args type<?))) (cons dom1 dom)) rng1 #f #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 ;; the algorithm for recursive types transcribed directly from TAPL, pg 305
;; List[(cons Number Number)] type type -> List[(cons Number Number)] ;; 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) [(s (Union: es)) (or (and (ormap (lambda (elem) (subtype*/no-fail A0 s elem)) es) A0)
(fail! s t))] (fail! s t))]
;; subtyping on immutable structs is covariant ;; subtyping on immutable structs is covariant
[((Struct: nm _ flds #f _ _ _ _ _) (Struct: nm _ flds* #f _ _ _ _ _)) [((Struct: nm _ flds proc _ _ _ _) (Struct: nm _ flds* proc* _ _ _ _))
(subtypes* A0 flds flds*)] (let ([A (cond [(and proc proc*) (subtype* proc proc*)]
[((Struct: nm _ flds proc _ _ _ _ _) (Struct: nm _ flds* proc* _ _ _ _ _)) [proc* (fail! proc proc*)]
(subtypes* A0 (cons proc flds) (cons proc* flds*))] [else A0])])
[((Struct: _ _ _ _ _ _ _ _ _) (StructTop: (? (lambda (s2) (type-equal? s2 s))))) (subtype/flds* A flds flds*))]
[((Struct: _ _ _ _ _ _ _ _) (StructTop: (== s type-equal?)))
A0] A0]
[((Box: _) (BoxTop:)) A0] [((Box: _) (BoxTop:)) A0]
[((Channel: _) (ChannelTop:)) A0] [((Channel: _) (ChannelTop:)) A0]
@ -363,11 +371,11 @@
[((MPair: _ _) (MPairTop:)) A0] [((MPair: _ _) (MPairTop:)) A0]
[((Hashtable: _ _) (HashtableTop:)) A0] [((Hashtable: _ _) (HashtableTop:)) A0]
;; subtyping on structs follows the declared hierarchy ;; 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) ;(printf "subtype - hierarchy : ~a ~a ~a~n" nm parent other)
(subtype* A0 parent other)] (subtype* A0 parent other)]
;; Promises are covariant ;; 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 ;; subtyping on values is pointwise
[((Values: vals1) (Values: vals2)) (subtypes* A0 vals1 vals2)] [((Values: vals1) (Values: vals2)) (subtypes* A0 vals1 vals2)]
;; trivial case for Result ;; 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) scheme/pretty mzlib/pconvert syntax/parse)
;; to move to unstable ;; to move to unstable
(provide reverse-begin) (provide reverse-begin list-update list-set)
(provide (provide
;; optimization ;; optimization
@ -26,6 +26,7 @@ at least theoretically.
rep utils typecheck infer env private types) rep utils typecheck infer env private types)
(define optimize? (make-parameter #f)) (define optimize? (make-parameter #f))
(define-for-syntax enable-contracts? #t)
;; fancy require syntax ;; fancy require syntax
(define-syntax (define-requirer stx) (define-syntax (define-requirer stx)
@ -159,7 +160,6 @@ at least theoretically.
;; turn contracts on and off - off by default for performance. ;; 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) (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) (define-syntax-rule (d/c/p (name . args) c . body)
@ -214,3 +214,13 @@ at least theoretically.
(if enable-contracts? (if enable-contracts?
(list #'[contracted (nm cnt)]) (list #'[contracted (nm cnt)])
(list #'nm))])) (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))))