From 0804e64695ab0d04a8db1d1f95e1fc8f14b32217 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Wed, 21 Apr 2010 18:13:13 -0400
Subject: [PATCH] everything but or and implies works

---
 collects/typed-scheme/typecheck/tc-envops.ss  |  4 +--
 .../typecheck/tc-metafunctions.ss             | 29 +++++++++----------
 2 files changed, 15 insertions(+), 18 deletions(-)

diff --git a/collects/typed-scheme/typecheck/tc-envops.ss b/collects/typed-scheme/typecheck/tc-envops.ss
index bd97da2e4a..8a8a353db6 100644
--- a/collects/typed-scheme/typecheck/tc-envops.ss
+++ b/collects/typed-scheme/typecheck/tc-envops.ss
@@ -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?)])
\ No newline at end of file
diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.ss b/collects/typed-scheme/typecheck/tc-metafunctions.ss
index 38c971a17e..e18bf9c99d 100644
--- a/collects/typed-scheme/typecheck/tc-metafunctions.ss
+++ b/collects/typed-scheme/typecheck/tc-metafunctions.ss
@@ -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))])))))