new function representation
svn: r13744 original commit: 72ff13bea9b32631551ace3a24c97064c3d5b802
This commit is contained in:
Sam Tobin-Hochstadt
parent
5f8f1bf4b0
commit
532ec72bd9
|
|
@ -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?)))])
|
||||
|
|
|
|||
|
|
@ -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])
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|#
|
||||
Loading…
Reference in New Issue
Block a user