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

everything but or and implies works

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2010-04-21 18:13:13 -04:00
parent 2bb2ffc513
commit 0804e64695
2 changed files with 15 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/typed-scheme/typecheck/tc-envops.ss
View File

@ -69,12 +69,12 @@
(for/fold ([Γ (replace-props env imps)]) ([f atoms])
(match f
[(Bot:) (set-box! flag #f) (env-map (lambda (x) (cons (car x) (Un))) Γ)]
[(ImpFilter: _ _) Γ]
[(or (TypeFilter: _ _ x) (NotTypeFilter: _ _ x))
(update-type/lexical (lambda (x t) (let ([new-t (update t f)])
(when (type-equal? new-t (Un))
(set-box! flag #f))
new-t))
x Γ)])))
x Γ)]
[_ Γ])))
(p/c [env+ (env? (listof Filter/c) (box/c #t). -> . env?)])

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

@ -91,19 +91,16 @@
(provide combine-props tc-results->values)
(define (combine-props new-props old-props)
(define-values (new-atoms new-formulas)
(partition (lambda (e) (or (TypeFilter? e) (NotTypeFilter? e))) new-props))
(values new-formulas new-atoms)
#;#;
(define-values (derived-imps derived-atoms)
(for/fold
([derived-imps null]
[derived-atoms null])
([o old-props])
(match o
[(ImpFilter: as cs)
(let ([as* (remove* new-atoms as filter-equal?)])
(if (null? as*)
(values derived-imps (append cs new-atoms))
(values (cons (make-ImpFilter as* cs) derived-imps) derived-atoms)))])))
(values (append new-imps derived-imps) (append new-atoms derived-atoms)))
(define (atomic-prop? p) (or (TypeFilter? p) (NotTypeFilter? p)))
(define-values (new-atoms new-formulas) (partition atomic-prop? new-props))
(let loop ([derived-props null]
[derived-atoms new-atoms]
[worklist (append old-props new-formulas)])
(if (null? worklist)
(values derived-props derived-atoms)
(let ([p (car worklist)])
(match p
[(AndFilter: ps) (loop derived-props derived-atoms (append ps (cdr worklist)))]
[(TypeFilter: _ _ _) (loop derived-props (cons p derived-atoms) (cdr worklist))]
[(NotTypeFilter: _ _ _) (loop derived-props (cons p derived-atoms) (cdr worklist))]
[_ (loop (cons p derived-props) derived-atoms (cdr worklist))])))))