Use the correct field numbers in substructs.

Maintain table of struct accessors/mutators.
This commit is contained in:
Sam Tobin-Hochstadt 2010-06-24 13:39:31 -04:00
parent 3078807757
commit 3c8952d63d
4 changed files with 53 additions and 23 deletions

View File

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

View File

@ -18,8 +18,7 @@
(not (ValuesDots? e)) (not (ValuesDots? e))
(not (Result? e))))) (not (Result? e)))))
(define Type/c (define Type/c (flat-named-contract 'Type Type/c?))
(flat-named-contract 'Type Type/c?))
;; Name = Symbol ;; Name = Symbol

View File

@ -3,7 +3,7 @@
(require "../utils/utils.rkt" (require "../utils/utils.rkt"
(except-in (rep type-rep free-variance) Dotted) (except-in (rep type-rep free-variance) Dotted)
(private parse-type) (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) (env global-env type-env-structs type-name-env tvar-env)
(utils tc-utils) (utils tc-utils)
"def-binding.rkt" "def-binding.rkt"
@ -142,10 +142,10 @@
(or (eq? variance Constant) (or (eq? variance Constant)
(eq? variance Covariant)))) (eq? variance Covariant))))
#t))) #t)))
(define parent-count (- (length external-fld-types) (length external-fld-types/no-parent)))
;; the list of names w/ types ;; the list of names w/ types
(define bindings (define bindings
(append (list*
(list
(cons struct-type-id (cons struct-type-id
(make-StructType sty)) (make-StructType sty))
(cons (or maker* maker) (cons (or maker* maker)
@ -153,15 +153,20 @@
(cons (or pred* pred) (cons (or pred* pred)
(make-pred-ty (if (not covariant?) (make-pred-ty (if (not covariant?)
(make-StructTop sty) (make-StructTop sty)
(pred-wrapper name))))) (pred-wrapper name))))
(for/list ([g (in-list getters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals)]) (append
(let ([func (if setters? (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) (->* (list name) t)
(->acc (list name) t (list (make-StructPE name i))))]) (->acc (list name) t (list path)))])
(add-struct-fn! g path #f)
(cons g (wrapper func)))) (cons g (wrapper func))))
(if setters? (if setters?
(map (lambda (g t) (cons g (wrapper (->* (list name t) -Void)))) setters external-fld-types/no-parent) (for/list ([g (in-list setters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals parent-count)])
null))) (add-struct-fn! g (make-StructPE name i) #t)
(cons g (wrapper (->* (list name t) -Void))))
null))))
(register-type-name nm (wrapper sty)) (register-type-name nm (wrapper sty))
(cons (cons
(make-def-struct-stx-binding nm si) (make-def-struct-stx-binding nm si)

View File

@ -1,6 +1,7 @@
#lang scheme/base #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)) (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 (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)] (p/c [add-typeof-expr (syntax? tc-results? . -> . any/c)]
[type-of (syntax? . -> . tc-results?)] [type-of (syntax? . -> . tc-results?)]
[reset-type-table (-> any/c)]) [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?))])