Typecheck `or' correctly.

svn: r17653

original commit: 33592b4f6c40faf63015fcf33e1874322007b03c

collects/tests/typed-scheme/succeed/empty-or.ss

@@ -0,0 +1,22 @@
+#lang typed/scheme
+
+(require scheme/list)
+(define-type-alias Atom (U Number #f))
+
+(: mrg ([Listof Atom] [Listof Atom] -> [Listof Number]))
+;; add corresponding numbers, drop false, stop at end of shortest list
+
+;(check-expect (mrg (list 1 false 2) (list 3 4 5 false 10)) (list 4 4 7))
+
+(define (mrg l k)
+ (cond
+   [(if (empty? l) #t (empty? k))
+    empty]
+   [(and (number? (car l)) (number? (car k)))
+    (cons (+ (car l) (car k)) (mrg (cdr l) (cdr k)))]
+   [(number? (car l))
+    (cons (car l) (mrg (rest l) (rest k)))]
+   [else
+    (error 'fail)]))
+
+;(test)

collects/typed-scheme/typecheck/tc-expr-unit.ss

@@ -326,6 +326,12 @@
              (#%plain-app _ _ args ...)))
          (tc/send #'rcvr #'meth #'(args ...) expected)]
         ;; let
+        [(let-values ([(or-part) e1]) (if op1 op2 e2))
+         (and 
+          (identifier? #'op1) (identifier? #'op2)
+          (free-identifier=? #'or-part #'op1)
+          (free-identifier=? #'or-part #'op2))
+         (tc-expr/check #'(if e1 e1 (let-values ([(or-part) e1]) e2)) expected)]
         [(let-values ([(name ...) expr] ...) . body)
          (tc/let-values #'((name ...) ...) #'(expr ...) #'body form expected)]
         [(letrec-values ([(name) expr]) name*)
@@ -388,6 +394,11 @@
            (#%plain-app _ _ args ...)))
        (tc/send #'rcvr #'meth #'(args ...))]
       ;; let
+      [(let-values ([(or-part) e1]) (if op1 op2 e2))
+       (and (identifier? #'op1) (identifier? #'op2)
+            (free-identifier=? #'or-part #'op1)
+            (free-identifier=? #'or-part #'op2))
+       (tc-expr #'(if e1 e1 (let-values ([(or-part) e1]) e2)))]
       [(let-values ([(name ...) expr] ...) . body)
        (tc/let-values #'((name ...) ...) #'(expr ...) #'body form)]
       [(letrec-values ([(name ...) expr] ...) . body)