From 5f8f1bf4b065ffc9df3398d06c35bda327840aa6 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 19 Feb 2009 01:39:11 +0000 Subject: [PATCH] checkpoint again svn: r13735 original commit: e5e0adb499e0037c125f9662c19952bb872276ae --- collects/typed-scheme/rep/filter-rep.ss | 14 ++++- collects/typed-scheme/rep/interning.ss | 10 ++-- collects/typed-scheme/rep/rep-utils.ss | 28 ++++++---- collects/typed-scheme/rep/type-rep.ss | 69 +++++++++++-------------- 4 files changed, 65 insertions(+), 56 deletions(-) diff --git a/collects/typed-scheme/rep/filter-rep.ss b/collects/typed-scheme/rep/filter-rep.ss index d468d109..965defde 100644 --- a/collects/typed-scheme/rep/filter-rep.ss +++ b/collects/typed-scheme/rep/filter-rep.ss @@ -1,7 +1,6 @@ #lang scheme/base -(require mzlib/plt-match) -(require mzlib/etc) +(require scheme/match scheme/contract) (require "rep-utils.ss" "free-variance.ss") (df Bot () [#:fold-rhs #:base]) @@ -18,6 +17,11 @@ (combine-frees (map free-idxs* (cons t p)))] [#:fold-rhs (*NotTypeFilter (type-rec-id t) (map pathelem-rec-id p) v)]) +(df FilterSet ([thn (listof (and/c Filter? (not/c FilterSet?)))] + [els (listof (and/c Filter? (not/c FilterSet?)))]) + [#:frees (combine-frees (map free-vars* (append thn els))) + (combine-frees (map free-idxs* (append thn els)))] + [#:fold-rhs (*FilterSet (map filter-rec-id thn) (map filter-rec-id els))]) (dlf LBot () [#:fold-rhs #:base]) @@ -30,3 +34,9 @@ [#:frees (combine-frees (map free-vars* (cons t p))) (combine-frees (map free-idxs* (cons t p)))] [#:fold-rhs (*LNotTypeFilter (type-rec-id t) (map pathelem-rec-id p))]) + +(dlf LFilterSet ([thn (listof (and/c LatentFilter? (not/c LFilterSet?)))] + [els (listof (and/c LatentFilter? (not/c LFilterSet?)))]) + [#:frees (combine-frees (map free-vars* (append thn els))) + (combine-frees (map free-idxs* (append thn els)))] + [#:fold-rhs (*LFilterSet (map latentfilter-rec-id thn) (map latentfilter-rec-id els))]) diff --git a/collects/typed-scheme/rep/interning.ss b/collects/typed-scheme/rep/interning.ss index 4a85792c..151b9769 100644 --- a/collects/typed-scheme/rep/interning.ss +++ b/collects/typed-scheme/rep/interning.ss @@ -4,13 +4,11 @@ (provide defintern hash-id) - (define-syntax (defintern stx) (syntax-parse stx - [(_ name+args make-name:id key:expr . rest) - #:with (_:id _:id ...) #'name+args - #'(defintern name+args (lambda () (make-hash #;'weak)) make-name key . rest)] - [(_ (*name:id arg:id ...) make-ht make-name key-expr ([#:extra-arg e:expr]) ...*) + [(_ name+args make-name key (~or [#:extra-arg e:expr] #:opt) ...) + #'(defintern name+args (lambda () (make-hash #;'weak)) make-name key #:extra-arg e)] + [(_ (*name:id arg:id ...) make-ht make-name key-expr (~or [#:extra-arg e:expr] #:opt) ...) #'(define *name (let ([table (make-ht)]) (lambda (arg ...) @@ -18,7 +16,7 @@ (let ([key key-expr]) (hash-ref table key (lambda () - (let ([new (make-name (count!) e ... arg ...)]) + (let ([new (make-name (count!) e arg ...)]) (hash-set! table key new) new)))))))])) diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index ee2b6326..ac59875f 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -8,6 +8,7 @@ "interning.ss" mzlib/etc scheme/contract + (for-meta 1 stxclass/util) (for-syntax stxclass scheme/base @@ -40,11 +41,18 @@ [(e ...) #`(combine-frees (list (#,f e) ...))])) (define-syntax-class frees-pat #:transparent - #:attributes (f1 f2) - (pattern (f1:expr f2:expr)) + #:attributes (f1 f2 def) + (pattern (f1:expr f2:expr) + #:with def #'(begin)) (pattern (#f) #:with f1 #'empty-hash-table - #:with f2 #'empty-hash-table)) + #:with f2 #'empty-hash-table + #:with def #'(begin)) + (pattern (e:expr) + #:with id (generate-temporary) + #:with def #'(define id e) + #:with f1 #'(id free-vars*) + #:with f2 #'(id free-idxs*))) (define-syntax-class fold-pat #:transparent #:attributes (e) @@ -54,12 +62,12 @@ #:with e #'#'ex)) (lambda (stx) (syntax-parse stx - [(dform nm:id flds:idlist ([[#:key key-expr:expr]] #:opt - [[#:intern intern?:expr]] #:opt - [[#:frees . frees:frees-pat]] #:opt - [[#:fold-rhs fold-rhs:fold-pat]] #:opt - [[#:contract cnt:expr]] #:opt - [no-provide?:no-provide-kw] #:opt) ...*) + [(dform nm:id flds:idlist (~or [[#:key key-expr:expr]] #:opt + [[#:intern intern?:expr]] #:opt + [[#:frees . frees:frees-pat]] #:opt + [[#:fold-rhs fold-rhs:fold-pat]] #:opt + [[#:contract cnt:expr]] #:opt + [no-provide?:no-provide-kw] #:opt) ...) (with-syntax* ([ex (mk-id #'nm #'nm ":")] [kw-stx (string->keyword (symbol->string #'nm.datum))] @@ -90,6 +98,7 @@ [() (mk #'#f)] [(f) (mk #'f)] [_ (mk #'(list . flds.fs))]))] + [frees-def (if #'frees #'frees.def #'(begin))] [frees (with-syntax ([(f1 f2) (if #'frees #'(frees.f1 frees.f2) @@ -99,6 +108,7 @@ (w/c nm ([*maker *maker-cnt]) (define (*maker . flds.fs) (define v (**maker . flds.fs)) + frees-def (unless-in-table var-table v (define fvs f1) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index e34ba3f1..32c0d7f6 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -2,7 +2,7 @@ (require "../utils/utils.ss") (require (utils tc-utils) - "rep-utils.ss" "effect-rep.ss" "free-variance.ss" + "rep-utils.ss" "object-rep.ss" "filter-rep.ss" "free-variance.ss" mzlib/trace scheme/match scheme/contract stxclass/util @@ -109,14 +109,18 @@ (dt Opaque ([pred identifier?] [cert procedure?]) [#:intern (hash-id pred)] [#:frees #f] [#:fold-rhs #:base] [#:key pred]) +;; represents an argument and its associated filters +(dt DomType ([t Type?] [filters LFilterSet?]) + [#:fold-rhs (*DomTy (type-rec-id t) + (latentfilter-rec-id filters))]) + ;; kw : keyword? ;; ty : Type ;; required? : Boolean -(dt Keyword ([kw keyword?] [ty Type?] [required? boolean?]) +(dt Keyword ([kw keyword?] [ty DomType?] [required? boolean?]) [#:frees (free-vars* ty) (free-idxs* ty)] - [#:fold-rhs (*Keyword kw (type-rec-id ty) required?)] - [#:key 'keyword]) + [#:fold-rhs (*Keyword kw (type-rec-id ty) required?)]) ;; dom : Listof[Type] ;; rng : Type @@ -127,36 +131,25 @@ ;; thn-eff : Effect ;; els-eff : Effect ;; arr is NOT a Type -(dt arr ([dom (listof Type?)] +(dt arr ([dom (listof DomType?)] [rng Type?] [rest (or/c #f Type?)] [drest (or/c #f (cons/c Type? (or/c natural-number/c symbol?)))] [kws (listof Keyword?)] - [thn-eff (listof Effect?)] - [els-eff (listof Effect?)]) - [#:key 'procedure] - [#:frees (combine-frees (append (map flip-variances (map free-vars* (append (if rest (list rest) null) - (map Keyword-ty kws) - dom))) - (match drest - [(cons t (? symbol? bnd)) - (list (fix-bound (flip-variances (free-vars* t)) bnd))] - [(cons t bnd) (list (flip-variances (free-vars* t)))] - [_ null]) - (list (free-vars* rng)) - (map make-invariant - (map free-vars* (append thn-eff els-eff))))) - (combine-frees (append (map flip-variances (map free-idxs* (append (if rest (list rest) null) - (map Keyword-ty kws) - dom))) - (match drest - [(cons t (? number? bnd)) - (list (fix-bound (flip-variances (free-idxs* t)) bnd))] - [(cons t bnd) (list (flip-variances (free-idxs* t)))] - [_ null]) - (list (free-idxs* rng)) - (map make-invariant - (map free-idxs* (append thn-eff els-eff)))))] + [filters (listof LatentFilter?)]) + [#:frees (lambda (free*) + (combine-frees + (append (map (compose flip-variances free*) + (append (if rest (list rest) null) + (map Keyword-ty kws) + dom)) + (match drest + [(cons t (? symbol? bnd)) + (list (fix-bound (flip-variances (free* t)) bnd))] + [(cons t bnd) (list (flip-variances (free* t)))] + [_ null]) + (list (free* rng)) + (map (compose make-invariant free*) filters))))] [#:fold-rhs (*arr (map type-rec-id dom) (type-rec-id rng) (and rest (type-rec-id rest)) @@ -167,13 +160,13 @@ (map effect-rec-id els-eff))]) ;; top-arr is the supertype of all function types -(dt top-arr () - [#:frees #f] [#:fold-rhs #:base]) +(dt top-arr () [#:fold-rhs #:base]) (define arr/c (or/c top-arr? arr?)) ;; arities : Listof[arr] (dt Function ([arities (listof arr/c)]) + [#:key 'procedure] [#:frees (combine-frees (map free-vars* arities)) (combine-frees (map free-idxs* arities))] [#:fold-rhs (*Function (map type-rec-id arities))]) @@ -317,7 +310,7 @@ ;; type/effect fold -(define-syntaxes (type-case effect-case) +(define-syntaxes (type-case filter-case latentfilter-case object-case latentobject-case pathelem-case) (let () (define (mk ht) (lambda (stx) @@ -363,17 +356,15 @@ #,(quasisyntax/loc stx (match #,fold-target #,@(hash-map ht gen-clause))))))])))) - (values (mk type-name-ht) (mk effect-name-ht)))) + (apply values + (map mk + (list type-name-ht filter-name-ht latentfilter-name-ht object-name-ht latentobject-name-ht pathelem-name-ht))))) -(provide type-case effect-case) +(provide type-case filter-case latentfilter-case object-case latentobject-case pathelem-case) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; sub-eff : (Type -> Type) Eff -> Eff -(define (sub-eff sb eff) - (effect-case sb eff)) - (define (add-scopes n t) (if (zero? n) t (add-scopes (sub1 n) (*Scope t))))