checkpoint again
svn: r13735 original commit: e5e0adb499e0037c125f9662c19952bb872276ae
This commit is contained in:
Sam Tobin-Hochstadt
parent
f2ceefc6a6
commit
5f8f1bf4b0
|
|
@ -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))])
|
||||
|
|
|
|||
|
|
@ -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)))))))]))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user