diff --git a/collects/typed-scheme/rep/object-rep.ss b/collects/typed-scheme/rep/object-rep.ss index 4a6f10a28c..afd87e320e 100644 --- a/collects/typed-scheme/rep/object-rep.ss +++ b/collects/typed-scheme/rep/object-rep.ss @@ -1,6 +1,6 @@ #lang scheme/base -(require scheme/match scheme/contract "rep-utils.ss" "free-variance.ss") +(require scheme/match scheme/contract "rep-utils.ss" "free-variance.ss" "filter-rep.ss") (dpe CarPE () [#:fold-rhs #:base]) (dpe CdrPE () [#:fold-rhs #:base]) @@ -17,6 +17,6 @@ (dlo LEmpty () [#:fold-rhs #:base]) -(dlo LPath ([p (listof PathElem?)] [idx natural-number/c]) +(dlo LPath ([p (listof PathElem?)] [idx index/c]) [#:frees (combine-frees (map free-vars* p)) (combine-frees (map free-idxs* p))] [#:fold-rhs (*LPath (map pathelem-rec-id p) idx)]) diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.ss b/collects/typed-scheme/typecheck/tc-metafunctions.ss index 090e60045a..350e7d378f 100644 --- a/collects/typed-scheme/typecheck/tc-metafunctions.ss +++ b/collects/typed-scheme/typecheck/tc-metafunctions.ss @@ -1,7 +1,7 @@ #lang scheme/base (require "../utils/utils.ss") -(require (rename-in (types subtype convenience remove-intersect union) +(require (rename-in (types subtype convenience remove-intersect union utils) [-> -->] [->* -->*] [one-of/c -one-of/c]) @@ -27,22 +27,48 @@ (make-FilterSet null (list (make-Bot)))] [else (make-FilterSet l1 l2)])) -(define/contract (abstract-filter x idx fs) - (-> identifier? index/c FilterSet? LFilterSet?) +(d/c (abstract-filters keys ids results) + (-> (listof index/c) (listof identifier?) tc-results? (or/c Values? ValuesDots?)) + (define (mk l [drest #f]) + (if drest (make-ValuesDots l (car drest) (cdr drest)) (make-Values l))) + (match results + [(tc-results: ts fs os dty dbound) + (make-ValuesDots + (for/list ([t ts] + [f fs] + [o os]) + (make-Result t (abstract-filter ids keys f) (abstract-object ids keys o))))])) + +(define/contract (abstract-object ids keys o) + (-> (listof identifier?) (listof index/c) Object? LatentObject?) + (define (lookup y) + (for/first ([x ids] [i keys] #:when (free-identifier=? x y)) i)) + (define-match-expander lookup: + (syntax-rules () + [(_ i) (app lookup (? values i))])) + (match o + [(Path: p (lookup: idx)) (make-LPath p idx)] + [_ (make-LEmpty)])) + +(define/contract (abstract-filter ids keys fs) + (-> (listof identifier?) (listof index/c) FilterSet? LFilterSet?) (match fs [(FilterSet: f+ f-) (lcombine - (apply append (for/list ([f f+]) (abo x idx f))) - (apply append (for/list ([f f-]) (abo x idx f))))])) + (apply append (for/list ([f f+]) (abo ids keys f))) + (apply append (for/list ([f f-]) (abo ids keys f))))])) -(define/contract (abo x idx f) - (-> identifier? index/c Filter/c (or/c '() (list/c LatentFilter/c))) - (define-match-expander =x - (lambda (stx) #'(? (lambda (id) (free-identifier=? id x))))) +(define/contract (abo xs idxs f) + (-> (listof identifier?) (listof index/c) Filter/c (or/c '() (list/c LatentFilter/c))) + (define (lookup y) + (for/first ([x xs] [i idxs] #:when (free-identifier=? x y)) i)) + (define-match-expander lookup: + (syntax-rules () + [(_ i) (app lookup (? values i))])) (match f [(Bot:) (list (make-LBot))] - [(TypeFilter: t p (=x)) (list (make-LTypeFilter t p idx))] - [(NotTypeFilter: t p (=x)) (list (make-LNotTypeFilter t p idx))] + [(TypeFilter: t p (lookup: idx)) (list (make-LTypeFilter t p idx))] + [(NotTypeFilter: t p (lookup: idx)) (list (make-LNotTypeFilter t p idx))] [_ null])) (define/contract (apply-filter lfs t o) diff --git a/collects/typed-scheme/types/utils.ss b/collects/typed-scheme/types/utils.ss index 43e20803db..0c4af4ee67 100644 --- a/collects/typed-scheme/types/utils.ss +++ b/collects/typed-scheme/types/utils.ss @@ -167,7 +167,7 @@ ;; this structure represents the result of typechecking an expression (d-s/c tc-result ([t Type/c] [f FilterSet?] [o Object?]) #:transparent) -(d-s/c tc-results ([ts (listof tc-result?)] [drest (or/c (cons/c symbol? Type/c) #f)])) +(d-s/c tc-results ([ts (listof tc-result?)] [drest (or/c (cons/c Type/c symbol?) #f)]) #:transparent) (define-match-expander tc-result: (syntax-parser @@ -177,9 +177,10 @@ (define-match-expander tc-results: (syntax-parser [(_ tp fp op) #'(struct tc-results ((list (struct tc-result (tp fp op)) (... ...)) #f))] + [(_ tp fp op dty dbound) #'(struct tc-results ((list (struct tc-result (tp fp op)) (... ...)) (cons dty dbound)))] [(_ tp) #'(struct tc-results ((list (struct tc-result (tp _ _)) (... ...)) #f))])) -(provide tc-result: tc-results:) +(provide tc-result: tc-results: tc-result? tc-results?) ;; convenience function for returning the result of typechecking an expression (define ret