diff --git a/collects/tests/typed-scheme/succeed/simple-or.ss b/collects/tests/typed-scheme/succeed/simple-or.ss index 51148d2c..d8e638b1 100644 --- a/collects/tests/typed-scheme/succeed/simple-or.ss +++ b/collects/tests/typed-scheme/succeed/simple-or.ss @@ -1,11 +1,14 @@ #lang typed/scheme - (define: x : Any 7) (define: (f [x : (U String Number)]) : Number 0) -;(let ([tmp (number? x)]) (if tmp tmp (string? x))) +(let ([tmp (number? x)]) (if tmp tmp (string? x))) (if (let ([tmp (number? x)]) (if tmp tmp (string? x))) (f x) - 0) \ No newline at end of file + 0) + +(: strnum? (Any -> Boolean : (U String Number))) +(define (strnum? x) + (or (string? x) (number? x))) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index 87bbf895..3dc18eb5 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -176,7 +176,7 @@ (ret (subber subst-type ts) (subber subst-filter-set fs) (subber subst-object os) dt db)] [t (sub-one subst-type t)]) r)) - (let ([tr1 (debug maybe-abstract tr1)]) + (let ([tr1 (maybe-abstract tr1)]) (match* (tr1 expected) ;; these two have to be first so that errors can be allowed in cases where multiple values are expected [((tc-result1: (? (lambda (t) (type-equal? t (Un))))) (tc-results: ts2 (NoFilter:) (NoObject:))) diff --git a/collects/typed-scheme/typecheck/tc-if.ss b/collects/typed-scheme/typecheck/tc-if.ss index 938feeab..398d266f 100644 --- a/collects/typed-scheme/typecheck/tc-if.ss +++ b/collects/typed-scheme/typecheck/tc-if.ss @@ -50,10 +50,10 @@ (env-props env-els))] [(tc-results: ts fs2 os2) (with-lexical-env env-thn (tc thn (unbox flag+)))] [(tc-results: us fs3 os3) (with-lexical-env env-els (tc els (unbox flag-)))]) - ;(printf "old thn-props: ~a\n" (env-props (lexical-env))) - ;(printf "fs+: ~a~n" fs+) - ;(printf "thn-props: ~a~n" (env-props env-thn)) - ;(printf "new-thn-props: ~a~n" new-thn-props) + (printf "old els-props: ~a\n" (env-props (lexical-env))) + (printf "fs-: ~a~n" fs-) + (printf "els-props: ~a~n" (env-props env-els)) + (printf "new-els-props: ~a~n" new-els-props) ;; if we have the same number of values in both cases (cond [(= (length ts) (length us)) (let ([r (combine-results @@ -65,11 +65,11 @@ [(_ (NoFilter:)) (-FS -top -top)] [((FilterSet: f2+ f2-) (FilterSet: f3+ f3-)) - (-FS (-or (apply -and fs+ f2+ new-thn-props) (-and fs- f3+)) - (-or (apply -and fs+ f2- new-thn-props) (-and fs- f3-)))])] + (-FS (-or (apply -and fs+ f2+ new-thn-props) (apply -and fs- f3+ new-els-props)) + (-or (apply -and fs+ f2- new-thn-props) (apply -and fs- f3- new-els-props)))])] [type (Un t2 t3)] [object (if (object-equal? o2 o3) o2 (make-Empty))]) - ;(printf "result filter is: ~a\n" filter) + (printf "result filter is: ~a\n" filter) (ret type filter object))))]) (if expected (check-below r expected) r))] ;; special case if one of the branches is unreachable diff --git a/collects/typed-scheme/typecheck/tc-let-unit.ss b/collects/typed-scheme/typecheck/tc-let-unit.ss index 763841a0..aa5074ea 100644 --- a/collects/typed-scheme/typecheck/tc-let-unit.ss +++ b/collects/typed-scheme/typecheck/tc-let-unit.ss @@ -34,7 +34,9 @@ ([r (in-list results)] [names (in-list namess)]) (match r - [(tc-results: ts (FilterSet: fs+ fs-) os) + [(tc-results: ts (FilterSet: fs+ fs-) os) + (printf "f+: ~a~n" fs+) + (printf "f-: ~a~n" fs-) (values ts (apply append (for/list ([n names] diff --git a/collects/typed-scheme/types/convenience.ss b/collects/typed-scheme/types/convenience.ss index 71e2c7f9..78589b20 100644 --- a/collects/typed-scheme/types/convenience.ss +++ b/collects/typed-scheme/types/convenience.ss @@ -101,7 +101,9 @@ (subtype t1 t2))] [(_ _) #f]))) -(define (compact props) +;; props : propositions to compress +;; or? : is this or OrFilter (alternative is AndFilter) +(define (compact props or?) (define tf-map (make-hash)) (define ntf-map (make-hash)) (let loop ([props props] [others null]) @@ -110,18 +112,17 @@ (for/list ([v (in-dict-values tf-map)]) v) (for/list ([v (in-dict-values ntf-map)]) v)) (match (car props) - [(and p (TypeFilter: t1 f1 x)) + [(and p (TypeFilter: t1 f1 x) (? (lambda _ or?))) (hash-update! tf-map (list f1 (hash-id x)) (match-lambda [(TypeFilter: t2 _ _) (make-TypeFilter (Un t1 t2) f1 x)] [p (int-err "got something that isn't a typefilter ~a" p)]) p) (loop (cdr props) others)] - #; - [(and p (NotTypeFilter: t1 f1 x)) + [(and p (NotTypeFilter: t1 f1 x) (? (lambda _ (not or?)))) (hash-update! ntf-map (list f1 (hash-id x)) - (match-lambda [(NotTypeFilter: t2 _ _) (make-NotTypeFilter (restrict t1 t2) f1 x)] + (match-lambda [(NotTypeFilter: t2 _ _) (make-NotTypeFilter (Un t1 t2) f1 x)] [p (int-err "got something that isn't a nottypefilter ~a" p)]) p) (loop (cdr props) others)] @@ -144,7 +145,7 @@ (match result [(list) -bot] [(list f) f] - [_ (distribute (compact result))]) + [_ (distribute (compact result #t))]) (match (car fs) [(and t (Top:)) t] [(OrFilter: fs*) (loop (append fs* (cdr fs)) result)] @@ -153,7 +154,7 @@ (cond [(for/or ([f (in-list (append (cdr fs) result))]) (opposite? f t)) -top] - [(for/or ([f (in-list result)]) (or (filter-equal? f t) (implied-atomic? t f))) + [(for/or ([f (in-list result)]) (or (filter-equal? f t) (implied-atomic? f t))) (loop (cdr fs) result)] [else (loop (cdr fs) (cons t result))])])))) @@ -169,10 +170,16 @@ -bot (if (filter-equal? f1 f2) f1 - (make-AndFilter (list f1 f2))))] - [_ (make-AndFilter result)]) + (make-AndFilter (compact (list f1 f2) #f))))] + [_ (make-AndFilter (compact result #f))]) (match (car fs) [(and t (Bot:)) t] [(AndFilter: fs*) (loop (cdr fs) (append fs* result))] [(Top:) (loop (cdr fs) result)] - [t (loop (cdr fs) (cons t result))])))) + [t (cond [(for/or ([f (in-list (append (cdr fs) result))]) + (opposite? f t)) + -bot] + [(for/or ([f (in-list result)]) (or (filter-equal? f t) (implied-atomic? t f))) + (loop (cdr fs) result)] + [else + (loop (cdr fs) (cons t result))])]))))