suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

re-enable abstract-filter

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2010-04-19 19:42:08 -04:00
parent f57ef37a66
commit c3304b20f0
1 changed files with 18 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
collects/typed-scheme/typecheck/tc-metafunctions.ss
View File

@ -43,50 +43,40 @@
(for/list ([t ts] [f fs] [o os]) (for/list ([t ts] [f fs] [o os])
(make-Result t f o)))])) (make-Result t f o)))]))
#;
(define/contract (abstract-object ids keys o) (d/c (abstract-object ids keys o)
(-> (listof identifier?) (listof index/c) Object? LatentObject?) (-> (listof identifier?) (listof name-ref/c) Object? Object?)
(define (lookup y) (define (lookup y)
(for/first ([x ids] [i keys] #:when (free-identifier=? x y)) i)) (for/first ([x ids] [i keys] #:when (free-identifier=? x y)) i))
(define-match-expander lookup: (define-match-expander lookup:
(syntax-rules () (syntax-rules ()
[(_ i) (app lookup (? values i))])) [(_ i) (app lookup (? values i))]))
(match o (match o
[(Path: p (lookup: idx)) (make-LPath p idx)] [(Path: p (lookup: idx)) (make-Path p idx)]
[_ (make-LEmpty)])) [_ (make-Empty)]))
#;
(d/c (abstract-filter ids keys fs) (d/c (abstract-filter ids keys fs)
(-> (listof identifier?) (listof index/c) FilterSet/c LatentFilterSet/c) (-> (listof identifier?) (listof name-ref/c) FilterSet/c FilterSet/c)
(match fs (match fs
[(FilterSet: f+ f-) [(FilterSet: f+ f-)
(combine (combine (abo ids keys f+) (abo ids keys f-))]
(apply append (for/list ([f f+]) (abo ids keys f)))
(apply append (for/list ([f f-]) (abo ids keys f))))]
[(NoFilter:) (combine -top -top)])) [(NoFilter:) (combine -top -top)]))
#; (d/c (abo xs idxs f [inc 0])
(d/c (abo xs idxs f) ((listof identifier?) (listof name-ref/c) Filter/c . -> . Filter/c)
((listof identifier?) (listof index/c) Filter/c . -> . (or/c null? (list/c LatentFilter/c)))
(define (lookup y) (define (lookup y)
(for/first ([x xs] [i idxs] #:when (free-identifier=? x y)) i)) (for/first ([x xs] [i idxs] #:when (free-identifier=? x y)) (+ inc i)))
(define-match-expander lookup: (define-match-expander lookup:
(syntax-rules () (syntax-rules ()
[(_ i) (app lookup (? values i))])) [(_ i) (app lookup (? values i))]))
(match f (define (rec f) (abo xs idxs f inc))
[(Bot:) (list (make-LBot))] (define (sb-t t) t)
[(TypeFilter: t p (lookup: idx)) (list (make-LTypeFilter t p idx))] (filter-case (#:Type sb-t #:Filter rec) f
[(NotTypeFilter: t p (lookup: idx)) (list (make-LNotTypeFilter t p idx))] [#:TypeFilter t p (lookup: idx)
[(ImpFilter: as cs) (make-TypeFilter t p idx)]
(let ([a* (apply append (for/list ([f as]) (abo xs idxs f)))] [#:NotTypeFilter t p (lookup: idx)
[c* (apply append (for/list ([f cs]) (abo xs idxs f)))]) (make-NotTypeFilter t p idx)]))
(cond [(< (length a*) (length as)) ;; if we removed some things, we can't be sure
null]
[(null? c*) ;; this clause is now useless
null]
[else
(list (make-LImpFilter a* c*))]))]
[_ null]))
(define (merge-filter-sets fs) (define (merge-filter-sets fs)
(match fs (match fs