From 532ec72bd9c47d514cdccf35db3ba35b2d636f90 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 19 Feb 2009 17:39:19 +0000 Subject: [PATCH] new function representation svn: r13744 original commit: 72ff13bea9b32631551ace3a24c97064c3d5b802 --- collects/typed-scheme/rep/filter-rep.ss | 16 +++--- collects/typed-scheme/rep/rep-utils.ss | 61 +++++++++++++++++++--- collects/typed-scheme/rep/type-rep.ss | 68 +++++++++++-------------- 3 files changed, 92 insertions(+), 53 deletions(-) diff --git a/collects/typed-scheme/rep/filter-rep.ss b/collects/typed-scheme/rep/filter-rep.ss index 965defde..e9f70374 100644 --- a/collects/typed-scheme/rep/filter-rep.ss +++ b/collects/typed-scheme/rep/filter-rep.ss @@ -23,17 +23,17 @@ (combine-frees (map free-idxs* (append thn els)))] [#:fold-rhs (*FilterSet (map filter-rec-id thn) (map filter-rec-id els))]) +(define index/c (or/c natural-number/c keyword?)) + (dlf LBot () [#:fold-rhs #:base]) -(dlf LTypeFilter ([t Type?] [p (listof PathElem?)]) - [#:frees (combine-frees (map free-vars* (cons t p))) - (combine-frees (map free-idxs* (cons t p)))] - [#:fold-rhs (*LTypeFilter (type-rec-id t) (map pathelem-rec-id p))]) +(dlf LTypeFilter ([t Type?] [p (listof PathElem?)] [idx index/c]) + [#:frees (lambda (frees*) (combine-frees (map (compose make-invariant frees*) (cons t p))))] + [#:fold-rhs (*LTypeFilter (type-rec-id t) (map pathelem-rec-id p) idx)]) -(dlf LNotTypeFilter ([t Type?] [p (listof PathElem?)]) - [#: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 LNotTypeFilter ([t Type?] [p (listof PathElem?)] [idx index/c]) + [#:frees (lambda (frees*) (combine-frees (map (compose make-invariant frees*) (cons t p))))] + [#:fold-rhs (*LNotTypeFilter (type-rec-id t) (map pathelem-rec-id p) idx)]) (dlf LFilterSet ([thn (listof (and/c LatentFilter? (not/c LFilterSet?)))] [els (listof (and/c LatentFilter? (not/c LFilterSet?)))]) diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index ac59875f..263f9790 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -156,6 +156,8 @@ #:transparent (pattern :type-name-base #:with name #'i + #:with tmp-rec-id (generate-temporary) + #:with case (mk-id #'i #'lower-s "-case") #:with printer (mk-id #'i "print-" #'lower-s "*") #:with ht (mk-id #'i #'lower-s "-name-ht") #:with rec-id (mk-id #'i #'lower-s "-rec-id") @@ -164,13 +166,58 @@ (datum->syntax #f (build-struct-names #'name (syntax->list #'(fld-names ...)) #f #t #'name)))) (syntax-parse stx [(_ i:type-name ...) - #'(begin - (provide i.d-id ... i.printer ... i.name ... i.pred? ... i.accs ... ... - (for-syntax i.ht ... i.rec-id ...)) - (define-syntax i.d-id (mk #'i.name #'i.ht i.key?)) ... - (define-for-syntax i.ht (make-hasheq)) ... - (define-struct/printer i.name (i.fld-names ...) (lambda (a b c) ((unbox i.printer) a b c))) ... - (define-for-syntax i.rec-id #'i.rec-id) ...)])) + (with-syntax* ([(fresh-ids ...) (generate-temporaries #'(i.name ...))] + [fresh-ids-list #'(fresh-ids ...)]) + #'(begin + (provide i.d-id ... i.printer ... i.name ... i.pred? ... i.accs ... ... + (for-syntax i.ht ... i.rec-id ...)) + (define-syntax i.d-id (mk #'i.name #'i.ht i.key?)) ... + (define-for-syntax i.ht (make-hasheq)) ... + (define-struct/printer i.name (i.fld-names ...) (lambda (a b c) ((unbox i.printer) a b c))) ... + (define-for-syntax i.rec-id #'i.rec-id) ... + (provide i.case ...) + (define-syntaxes (i.case ...) + (let () + (define (mk ht) + (lambda (stx) + (let ([ht (hash-copy ht)]) + (define (mk-matcher kw) + (datum->syntax stx (string->symbol (string-append (keyword->string kw) ":")))) + (define (add-clause cl) + (... + (syntax-case cl () + [(kw #:matcher mtch pats ... expr) + (hash-set! ht (syntax-e #'kw) (list #'mtch + (syntax/loc cl (pats ...)) + (lambda fresh-ids-list #'expr) + cl))] + [(kw pats ... expr) + (hash-set! ht (syntax-e #'kw) (list (mk-matcher (syntax-e #'kw)) + (syntax/loc cl (pats ...)) + (lambda fresh-ids-list #'expr) + cl))]))) + (define i.tmp-rec-id i.rec-id) ... + (define (gen-clause k v) + (define match-ex (car v)) + (define pats (cadr v)) + (define body-f (caddr v)) + (define src (cadddr v)) + (define pat (quasisyntax/loc src (#,match-ex . #,pats))) + (define cl (quasisyntax/loc src (#,pat #,(body-f i.tmp-rec-id ...)))) + cl) + (syntax-case stx () + [(tc fresh-ids ... ty . clauses) + (begin + (map add-clause (syntax->list #'clauses)) + (with-syntax ([old-rec-id type-rec-id]) + #`(let ([#,i.tmp-rec-id fresh-ids] ... + [#,fold-target ty]) + ;; then generate the fold + #,(quasisyntax/loc stx + (match #,fold-target + #,@(hash-map ht gen-clause))))))])))) + (apply values + (map mk (list i.ht ...)))))))])) (make-prim-type [Type #:key] Filter [LatentFilter #:d lf] Object [LatentObject #:d lo] [PathElem #:d pe]) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index 32c0d7f6..61405616 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -109,19 +109,28 @@ (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 DomType?] [required? boolean?]) - [#:frees (free-vars* ty) - (free-idxs* ty)] +(dt Keyword ([kw keyword?] [ty Type?] [required? boolean?]) + [#:frees (λ (f) (f ty))] [#:fold-rhs (*Keyword kw (type-rec-id ty) required?)]) +(dt Result ([t Type?] [f LFilterSet?] [o LatentObject?]) + [#:frees (λ (f) (combine-frees (map f (list t f o))))] + [#:fold-rhs (*Result (type-rec-id t) (latentfilter-rec-id f) (latentobject-rec-id f))]) + +;; types : Listof[Type] +(dt Values ([rs (listof Result?)]) + #:no-provide + [#:frees (λ (f) (combine-frees (map f rs)))] + [#:fold-rhs (*Values (map type-rec-id types))]) + +(dt ValuesDots ([types (listof Result?)] [dty Type?] [dbound (or/c symbol? natural-number/c)]) + [#:frees (λ (f) (combine-frees (map f (cons dty types))))] + [#:fold-rhs (*ValuesDots (map type-rec-id types) (type-rec-id dty) dbound)]) + + ;; dom : Listof[Type] ;; rng : Type ;; rest : Option[Type] @@ -131,12 +140,11 @@ ;; thn-eff : Effect ;; els-eff : Effect ;; arr is NOT a Type -(dt arr ([dom (listof DomType?)] - [rng Type?] +(dt arr ([dom (listof Type?)] + [rng (or/c Values? ValuesDots?)] [rest (or/c #f Type?)] [drest (or/c #f (cons/c Type? (or/c natural-number/c symbol?)))] - [kws (listof Keyword?)] - [filters (listof LatentFilter?)]) + [kws (listof Keyword?)]) [#:frees (lambda (free*) (combine-frees (append (map (compose flip-variances free*) @@ -146,18 +154,14 @@ (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))))] + [(cons t (? number? bnd)) (list (flip-variances (free* t)))] + [#f null]) + (list (free* rng)))))] [#:fold-rhs (*arr (map type-rec-id dom) (type-rec-id rng) (and rest (type-rec-id rest)) (and drest (cons (type-rec-id (car drest)) (cdr drest))) - (for/list ([kw kws]) - (make Keyword (Keyword-kw kw) (type-rec-id (Keyword-ty kw)) (Keyword-require? kw))) - (map effect-rec-id thn-eff) - (map effect-rec-id els-eff))]) + (map type-rec-id kws))]) ;; top-arr is the supertype of all function types (dt top-arr () [#:fold-rhs #:base]) @@ -230,20 +234,6 @@ (dt Univ () [#:frees #f] [#:fold-rhs #:base]) -;; types : Listof[Type] -(dt Values ([types (listof Type?)]) - #:no-provide - [#:frees (combine-frees (map free-vars* types)) - (combine-frees (map free-idxs* types))] - [#:fold-rhs (*Values (map type-rec-id types))] - [#:key 'values]) - -(dt ValuesDots ([types (listof Type?)] [dty Type?] [dbound (or/c symbol? natural-number/c)]) - [#:frees (combine-frees (map free-vars* (cons dty types))) - (combine-frees (map free-idxs* (cons dty types)))] - [#:fold-rhs (*ValuesDots (map type-rec-id types) (type-rec-id dty) dbound)] - [#:key 'values]) - ;; in : Type ;; out : Type (dt Param ([in Type?] [out Type?]) [#:key 'parameter]) @@ -297,7 +287,7 @@ (provide set-union-maker! get-union-maker) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - +#| ;; remove-dups: List[Type] -> List[Type] ;; removes duplicate types from a SORTED list (define (remove-dups types) @@ -305,11 +295,11 @@ [(null? (cdr types)) types] [(type-equal? (car types) (cadr types)) (remove-dups (cdr types))] [else (cons (car types) (remove-dups (cdr types)))])) - +|# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; type/effect fold - +#| (define-syntaxes (type-case filter-case latentfilter-case object-case latentobject-case pathelem-case) (let () (define (mk ht) @@ -361,9 +351,10 @@ (list type-name-ht filter-name-ht latentfilter-name-ht object-name-ht latentobject-name-ht pathelem-name-ht))))) (provide type-case filter-case latentfilter-case object-case latentobject-case pathelem-case) - +|# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +#| (define (add-scopes n t) (if (zero? n) t @@ -649,3 +640,4 @@ ;(trace unfold) +|# \ No newline at end of file