fix conflicts

svn: r14601

collects/typed-scheme/env/lexical-env.ss

@@ -23,7 +23,7 @@
 
 ;; find the type of identifier i, looking first in the lexical env, then in the top-level env
 ;; identifer -> Type
-(define (lookup-type/lexical i [env (lexical-env)])
+(define (lookup-type/lexical i [env (lexical-env)] #:fail [fail #f])
   (lookup env i 
           (lambda (i) (lookup-type 
                        i (lambda () 
@@ -31,7 +31,7 @@
                                   =>
                                   (lambda (a)
                                     (-lst (substitute Univ (cdr a) (car a))))]
-                                 [else (lookup-fail i)]))))))
+                                 [else ((or fail lookup-fail) i)]))))))
 
 ;; refine the type of i in the lexical env
 ;; (identifier type -> type) identifier -> environment
@@ -41,7 +41,7 @@
   (define (update f k env)
     (parameterize
         ([current-orig-stx k])
-      (let* ([v (lookup-type/lexical k)]
+      (let* ([v (lookup-type/lexical k env #:fail (lambda _ Univ))]
              [new-v (f k v)]
              [new-env (extend env k new-v)])
         new-env)))

collects/typed-scheme/private/base-env.ss

@@ -9,7 +9,7 @@
  (only-in '#%kernel [apply kernel:apply])
  scheme/promise
  (only-in string-constants/private/only-once maybe-print-message)
- (only-in scheme/match/runtime match:error)
+ (only-in scheme/match/runtime match:error matchable? match-equality-test)
  (for-syntax (only-in (types abbrev) [-Number N] [-Boolean B] [-Symbol Sym])))
 
 [raise (Univ . -> . (Un))]
@@ -146,6 +146,8 @@
        [(Sym B -Namespace (-> Univ)) Univ])]
 
 [match:error (Univ . -> . (Un))]
+[match-equality-test (-Param (Univ Univ . -> . Univ) (Univ Univ . -> . Univ))]
+[matchable? (make-pred-ty (Un -String -Bytes))]
 [display (cl-> [(Univ) -Void] [(Univ -Port) -Void])]
 [write   (cl-> [(Univ) -Void] [(Univ -Port) -Void])]
 [print   (cl-> [(Univ) -Void] [(Univ -Port) -Void])]
@@ -568,6 +570,9 @@
         (cl->*
          ((-lst a) . -> . (-lst a))
          ((-lst a) (a a . -> . Univ) . -> . (-lst a))))]
+[append-map
+ (-polydots (c a b) ((list ((list a) (b b) . ->... . (-lst c)) (-lst a))
+                     ((-lst b) b) . ->... .(-lst c)))]
 
 ;; scheme/tcp
 [tcp-listener? (make-pred-ty -TCP-Listener)]

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

@@ -21,7 +21,7 @@
           (only-in scheme/private/class-internal make-object do-make-object)))
 (require (r:infer constraint-structs))
 
-(import tc-expr^ tc-lambda^ tc-dots^)
+(import tc-expr^ tc-lambda^ tc-dots^ tc-let^)
 (export tc-app^)
 
 ;; comparators that inform the type system
@@ -779,6 +779,13 @@
          (match-let* ([ft (tc-expr #'f)]
                       [(tc-result: t) (tc/funapp #'f #'(arg) ft (list (ret ty)) #f)])
            (ret (Un (-val #f) t)))))]
+    ;; infer for ((lambda
+    [(#%plain-app (#%plain-lambda (x ...) . body) args ...)
+     (= (length (syntax->list #'(x ...)))
+        (length (syntax->list #'(args ...))))
+     (tc/let-values/check #'((x) ...) #'(args ...) #'body 
+                          #'(let-values ([(x) args] ...) . body)
+                          expected)]
     ;; default case
     [(#%plain-app f args ...) 
      (tc/funapp #'f #'(args ...) (tc-expr #'f) (map tc-expr (syntax->list #'(args ...))) expected)]))
@@ -804,7 +811,11 @@
        (ret expected))]
     ;; special case when argument needs inference
     [_
-     (let ([ts (map (compose generalize tc-expr/t) (syntax->list actuals))])
+     (let ([ts (for/list ([ac (syntax->list actuals)]
+                          [f (syntax->list args)])
+                 (or 
+                  (type-annotation f #:infer #t)
+                  (generalize (tc-expr/t ac))))])
        (tc/rec-lambda/check form args body lp ts expected)
        (ret expected))]))
 

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

@@ -41,7 +41,8 @@
         (syntax-rules ()
           [(check-rest f v)
            (with-update-type/lexical f v (loop (cdr effs)))]
-          [(check-rest f t v) (check-rest (type-op f t) v)]))
+          [(check-rest f t v) 
+           (check-rest (type-op f t) v)]))
       (if (null? effs)
           ;; base case
           (let* ([reachable? (not (unbox flag))])
@@ -79,7 +80,8 @@
             ;; just replace the type of v with (-val #f)
             [(Var-False-Effect: v) (check-rest (lambda (_ old) (-val #f)) v)]
             ;; v cannot have type (-val #f)
-            [(Var-True-Effect: v) (check-rest *remove (-val #f) v)])))))
+            [(Var-True-Effect: v) 
+             (check-rest *remove (-val #f) v)])))))
 
 ;; the main function
 (define (tc/if-twoarm tst thn els)