Add filter to AnyValues.
original commit: fac2f05a6d4995a9946789bafd322899a1e8484d
This commit is contained in:
Eric Dobson
parent
fca7a3b26f
commit
e0ca6b99d9
|
|
@ -400,7 +400,19 @@
|
|||
[(a b) #:when (type-equal? a b) empty]
|
||||
;; CG-Top
|
||||
[(_ (Univ:)) empty]
|
||||
[(_ (AnyValues:)) empty]
|
||||
;; AnyValues
|
||||
[((AnyValues: s-f) (AnyValues: t-f))
|
||||
(cgen/filter V X Y s-f t-f)]
|
||||
|
||||
[((or (Values: (list (Result: _ fs _) ...))
|
||||
(ValuesDots: (list (Result: _ fs _) ...) _ _))
|
||||
(AnyValues: t-f))
|
||||
(cset-join
|
||||
(filter identity
|
||||
(for/list ([f (in-list fs)])
|
||||
(match f
|
||||
[(FilterSet: f+ f-)
|
||||
(% cset-meet (cgen/filter V X Y f+ t-f) (cgen/filter V X Y f- t-f))]))))]
|
||||
|
||||
;; check all non Type/c first so that calling subtype is safe
|
||||
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@
|
|||
;; extract filters out of the range of a function type
|
||||
(define (get-filters rng)
|
||||
(match rng
|
||||
[(AnyValues:) null]
|
||||
[(AnyValues: f) (list (-FS f f))]
|
||||
[(Values: (list (Result: _ lf _) ...)) lf]
|
||||
[(ValuesDots: (list (Result: _ lf _) ...) _ _) lf]))
|
||||
|
||||
|
|
|
|||
|
|
@ -292,7 +292,7 @@
|
|||
[#:fold-rhs (*Values (map type-rec-id rs))])
|
||||
|
||||
|
||||
(def-type AnyValues ()
|
||||
(def-type AnyValues ([f Filter/c])
|
||||
[#:fold-rhs #:base])
|
||||
|
||||
(def-type ValuesDots ([rs (listof Result?)] [dty Type/c] [dbound (or/c symbol? natural-number/c)])
|
||||
|
|
|
|||
|
|
@ -50,7 +50,8 @@
|
|||
[ta (in-sequence-forever (in-list t-a) #f)])
|
||||
(values oa ta))])
|
||||
(match rng
|
||||
[(AnyValues:) tc-any-results]
|
||||
;; TODO add filters to tc-any-results
|
||||
[(AnyValues: f) tc-any-results]
|
||||
[(Values: results)
|
||||
(define-values (t-r f-r o-r)
|
||||
(for/lists (t-r f-r o-r)
|
||||
|
|
@ -248,7 +249,7 @@
|
|||
(map (compose make-Function list make-arr)
|
||||
doms
|
||||
(map (match-lambda ; strip filters
|
||||
[(AnyValues:) ManyUniv]
|
||||
[(AnyValues: f) (-AnyValues f)]
|
||||
[(Values: (list (Result: t _ _) ...))
|
||||
(-values t)]
|
||||
[(ValuesDots: (list (Result: t _ _) ...) _ _)
|
||||
|
|
|
|||
|
|
@ -73,7 +73,7 @@
|
|||
(tc-results/c (listof identifier?) . -> . SomeValues/c)
|
||||
(define keys (for/list ([(nm k) (in-indexed arg-names)]) (list 0 k)))
|
||||
(match results
|
||||
[(tc-any-results:) (make-AnyValues)]
|
||||
[(tc-any-results:) ManyUniv]
|
||||
[(tc-results: ts fs os dty dbound)
|
||||
(make-ValuesDots
|
||||
(for/list ([t (in-list ts)] [f (in-list fs)] [o (in-list os)])
|
||||
|
|
|
|||
|
|
@ -165,7 +165,8 @@
|
|||
(define/cond-contract (values->tc-results tc formals)
|
||||
(SomeValues/c (or/c #f (listof identifier?)) . -> . tc-results/c)
|
||||
(match tc
|
||||
[(AnyValues:) tc-any-results]
|
||||
;; TODO make tc-any-results have a filter
|
||||
[(AnyValues: f) tc-any-results]
|
||||
[(ValuesDots: (list (and rs (Result: ts fs os)) ...) dty dbound)
|
||||
(if formals
|
||||
(let-values ([(ts fs os)
|
||||
|
|
|
|||
|
|
@ -40,10 +40,6 @@
|
|||
(define/decl -False (make-Value #f))
|
||||
(define/decl -True (make-Value #t))
|
||||
|
||||
;; A Type that corresponds to the any contract for the
|
||||
;; return type of functions
|
||||
(define/decl ManyUniv (make-AnyValues))
|
||||
|
||||
(define -val make-Value)
|
||||
|
||||
;; Char type and List type (needed because of how sequences are checked in subtype)
|
||||
|
|
@ -160,6 +156,11 @@
|
|||
[(Path: p i) (-not-filter t i p)]
|
||||
[_ -top]))
|
||||
|
||||
;; A Type that corresponds to the any contract for the
|
||||
;; return type of functions
|
||||
(define (-AnyValues f) (make-AnyValues f))
|
||||
(define/decl ManyUniv (make-AnyValues -top))
|
||||
|
||||
;; Function types
|
||||
(define/cond-contract (make-arr* dom rng
|
||||
#:rest [rest #f] #:drest [drest #f] #:kws [kws null]
|
||||
|
|
|
|||
|
|
@ -76,7 +76,7 @@
|
|||
;; keyword conversion.
|
||||
(define (erase-filter/Values values)
|
||||
(match values
|
||||
[(AnyValues:) values]
|
||||
[(AnyValues: _) ManyUniv]
|
||||
[(Results: ts fs os)
|
||||
(-values ts)]
|
||||
[(Results: ts fs os dty dbound)
|
||||
|
|
|
|||
|
|
@ -239,7 +239,8 @@
|
|||
(cdr drest)))
|
||||
null)
|
||||
(match rng
|
||||
[(AnyValues:) '(AnyValues)]
|
||||
[(AnyValues: (Top:)) '(AnyValues)]
|
||||
[(AnyValues: f) `(AnyValues : ,(type->sexp f))]
|
||||
[(Values: (list (Result: t (FilterSet: (Top:) (Top:)) (Empty:))))
|
||||
(list (type->sexp t))]
|
||||
[(Values: (list (Result: t
|
||||
|
|
@ -478,7 +479,8 @@
|
|||
`(List ,(t->s dty) ,@dbound*)]
|
||||
[(F: nm) nm]
|
||||
;; FIXME (Values are not types and shouldn't need to be considered here
|
||||
[(AnyValues:) 'AnyValues]
|
||||
[(AnyValues: (Top:)) 'AnyValues]
|
||||
[(AnyValues: f) `(AnyValues : ,(filter->sexp f))]
|
||||
[(Values: (list v)) v]
|
||||
[(Values: (list v ...)) (cons 'values (map t->s v))]
|
||||
[(ValuesDots: v dty dbound)
|
||||
|
|
|
|||
|
|
@ -72,7 +72,7 @@
|
|||
;; Non Types
|
||||
[Result (#:co #:co #:co)]
|
||||
[Values ((#:listof #:co))]
|
||||
[AnyValues ()]))
|
||||
[AnyValues (#:co)]))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-syntax-class type-name
|
||||
|
|
|
|||
|
|
@ -256,7 +256,6 @@
|
|||
;; these cases are above as special cases
|
||||
;; [((Union: (list)) _) A0] ;; this is extremely common, so it goes first
|
||||
;; [(_ (Univ:)) A0]
|
||||
[((or (ValuesDots: _ _ _) (Values: _) (AnyValues:)) (AnyValues:)) A0]
|
||||
;; error is top and bot
|
||||
[(_ (Error:)) A0]
|
||||
[((Error:) _) A0]
|
||||
|
|
@ -556,6 +555,15 @@
|
|||
(subtype-seq A0
|
||||
(subtypes* s-rs t-rs)
|
||||
(subtype* s-dty t-dty))]
|
||||
[((AnyValues: s-f) (AnyValues: t-f))
|
||||
(filter-subtype* A0 s-f t-f)]
|
||||
[((or (Values: (list (Result: _ fs _) ...))
|
||||
(ValuesDots: (list (Result: _ fs _) ...) _ _))
|
||||
(AnyValues: t-f))
|
||||
(for/or ([f (in-list fs)])
|
||||
(match f
|
||||
[(FilterSet: f+ f-)
|
||||
(and (filter-subtype* A0 f+ t-f) (filter-subtype* A0 f+ t-f) A0)]))]
|
||||
[((Result: t (FilterSet: ft ff) o) (Result: t* (FilterSet: ft* ff*) o))
|
||||
(subtype-seq A0
|
||||
(subtype* t t*)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user