From 7f6da53efa781a0e507eeef196dffa92daf0ad6f Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 24 Jun 2010 13:39:31 -0400 Subject: [PATCH] Use the correct field numbers in substructs. Maintain table of struct accessors/mutators. original commit: 3c8952d63d2cd28a3b5a588c0367b53dc963308b --- .../typed-scheme/succeed/test-child-field.rkt | 10 +++++ collects/typed-scheme/rep/type-rep.rkt | 3 +- .../typed-scheme/typecheck/tc-structs.rkt | 43 +++++++++++-------- collects/typed-scheme/types/type-table.rkt | 20 ++++++++- 4 files changed, 53 insertions(+), 23 deletions(-) create mode 100644 collects/tests/typed-scheme/succeed/test-child-field.rkt diff --git a/collects/tests/typed-scheme/succeed/test-child-field.rkt b/collects/tests/typed-scheme/succeed/test-child-field.rkt new file mode 100644 index 00000000..40f36fe6 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/test-child-field.rkt @@ -0,0 +1,10 @@ +#lang typed/racket + +(define-struct: x ([a : Any])) +(define-struct: (A) (y x) ([b : A])) + +(: f : (y Any) -> String) +(define (f v) + (if (string? (y-b v)) + (y-b v) + "foo")) \ No newline at end of file diff --git a/collects/typed-scheme/rep/type-rep.rkt b/collects/typed-scheme/rep/type-rep.rkt index bc3ff7ec..d0c122f1 100644 --- a/collects/typed-scheme/rep/type-rep.rkt +++ b/collects/typed-scheme/rep/type-rep.rkt @@ -18,8 +18,7 @@ (not (ValuesDots? e)) (not (Result? e))))) -(define Type/c - (flat-named-contract 'Type Type/c?)) +(define Type/c (flat-named-contract 'Type Type/c?)) ;; Name = Symbol diff --git a/collects/typed-scheme/typecheck/tc-structs.rkt b/collects/typed-scheme/typecheck/tc-structs.rkt index 66ddbb10..1942898d 100644 --- a/collects/typed-scheme/typecheck/tc-structs.rkt +++ b/collects/typed-scheme/typecheck/tc-structs.rkt @@ -3,7 +3,7 @@ (require "../utils/utils.rkt" (except-in (rep type-rep free-variance) Dotted) (private parse-type) - (types convenience utils union resolve abbrev substitute) + (types convenience utils union resolve abbrev substitute type-table) (env global-env type-env-structs type-name-env tvar-env) (utils tc-utils) "def-binding.rkt" @@ -142,26 +142,31 @@ (or (eq? variance Constant) (eq? variance Covariant)))) #t))) + (define parent-count (- (length external-fld-types) (length external-fld-types/no-parent))) ;; the list of names w/ types (define bindings - (append - (list - (cons struct-type-id - (make-StructType sty)) - (cons (or maker* maker) - (wrapper (->* external-fld-types (if cret cret name)))) - (cons (or pred* pred) - (make-pred-ty (if (not covariant?) - (make-StructTop sty) - (pred-wrapper name))))) - (for/list ([g (in-list getters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals)]) - (let ([func (if setters? - (->* (list name) t) - (->acc (list name) t (list (make-StructPE name i))))]) - (cons g (wrapper func)))) - (if setters? - (map (lambda (g t) (cons g (wrapper (->* (list name t) -Void)))) setters external-fld-types/no-parent) - null))) + (list* + (cons struct-type-id + (make-StructType sty)) + (cons (or maker* maker) + (wrapper (->* external-fld-types (if cret cret name)))) + (cons (or pred* pred) + (make-pred-ty (if (not covariant?) + (make-StructTop sty) + (pred-wrapper name)))) + (append + (for/list ([g (in-list getters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals parent-count)]) + (let* ([path (make-StructPE name i)] + [func (if setters? + (->* (list name) t) + (->acc (list name) t (list path)))]) + (add-struct-fn! g path #f) + (cons g (wrapper func)))) + (if setters? + (for/list ([g (in-list setters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals parent-count)]) + (add-struct-fn! g (make-StructPE name i) #t) + (cons g (wrapper (->* (list name t) -Void)))) + null)))) (register-type-name nm (wrapper sty)) (cons (make-def-struct-stx-binding nm si) diff --git a/collects/typed-scheme/types/type-table.rkt b/collects/typed-scheme/types/type-table.rkt index 498768da..78cc289c 100644 --- a/collects/typed-scheme/types/type-table.rkt +++ b/collects/typed-scheme/types/type-table.rkt @@ -1,6 +1,7 @@ #lang scheme/base -(require unstable/debug "../utils/utils.rkt" (rep type-rep) (only-in (types abbrev utils) tc-results?) (utils tc-utils) scheme/contract) +(require unstable/debug scheme/contract "../utils/utils.rkt" syntax/id-table racket/dict racket/match + (rep type-rep object-rep) (only-in (types abbrev utils) tc-results?) (utils tc-utils)) (define table (make-hasheq)) @@ -12,6 +13,21 @@ (define (type-of e) (hash-ref table e (lambda () (int-err (format "no type for ~a" (syntax->datum e)))))) +(define struct-fn-table (make-free-id-table)) + +(define (add-struct-fn! id pe mut?) (dict-set! struct-fn-table id (list pe mut?))) + +(define-values (struct-accessor? struct-mutator?) + (let () + (define ((mk mut?) id) + (cond [(dict-ref struct-fn-table id #f) + => (match-lambda [(list pe #f) pe] [_ #f])] + [else #f])) + (values (mk #f) (mk #t)))) + (p/c [add-typeof-expr (syntax? tc-results? . -> . any/c)] [type-of (syntax? . -> . tc-results?)] - [reset-type-table (-> any/c)]) \ No newline at end of file + [reset-type-table (-> any/c)] + [add-struct-fn! (identifier? StructPE? boolean? . -> . any/c)] + [struct-accessor? (identifier? . -> . (or/c #f StructPE?))] + [struct-mutator? (identifier? . -> . (or/c #f StructPE?))]) \ No newline at end of file