fix conflicts

svn: r14601

original commit: 994f0205f49bb8960b118ca0dda8dae740b1ab1c

collects/tests/typed-scheme/fail/require-typed-wrong.ss

@@ -0,0 +1,15 @@
+#;
+(exn-pred ".*contract.*")
+#lang scheme/load
+
+(module m typed-scheme
+  (: x (Number -> Number))
+  (define (x n) (add1 n))
+  (provide x))
+
+(module n typed-scheme
+  (require (only-in 'm))
+  (require/typed 'm [x (String -> Number)])
+  (x "foo"))
+
+(require 'n)

collects/tests/typed-scheme/fail/untyped-srfi1.ss

@@ -0,0 +1,7 @@
+#;
+(exn-pred ".*untyped identifier map.*" ".*srfi.*")
+#lang typed-scheme
+
+(require srfi/1)
+
+map

collects/tests/typed-scheme/succeed/cmdline.ss

@@ -0,0 +1,38 @@
+#lang typed-scheme
+
+(require scheme/cmdline)
+
+(: version-str String)
+(define version-str "0.1")
+
+(current-command-line-arguments (vector "counter.mch"))
+
+(: verbose-mode (Parameter Boolean))
+(define verbose-mode (make-parameter #f))
+
+(: optimize-level (Parameter Integer))
+(define optimize-level (make-parameter 0))
+
+(: model-checking-mode (Parameter Any))
+(define model-checking-mode (make-parameter 'sat))
+
+(: file-to-model-check String)
+(define file-to-model-check
+ (command-line
+  #:program "eboc" ;; Should be name of executable
+  #:once-each
+  [("-v" "--verbose") "Compile with verbose messages"
+                      (verbose-mode #t)]
+  [("-m" "--mode") #{mode : String} "Mode to run the model checker on (sat, satbin)"
+                   (model-checking-mode (string-append mode))]
+  #:once-any
+  [("-o" "--optimize-1") "Compile with optimization level 1"
+                         (optimize-level 1)]
+  ["--optimize-2"        (; show help on separate lines
+                          "Compile with optimization level 2,"
+                          "which includes all of level 1")
+                         (optimize-level 2)]
+
+  #:args (#{filename : String}) ; expect one command-line argument: <filename>
+  ; return the argument as a filename to compile
+  filename))

collects/tests/typed-scheme/succeed/list-struct-sum.ss

@@ -0,0 +1,25 @@
+
+#lang typed-scheme
+(require scheme/list)
+
+(define-type-alias (ListOf X) (U Empty (Cons X)))
+(define-struct: Empty ())
+(define-struct: (X) Cons ((first : X) (rest : (ListOf X))))
+
+(: sum ((ListOf Number) -> Number))
+(define (sum alon)
+ (cond
+   [(Empty? alon) 0]
+   [else (+ (Cons-first alon)
+            (sum (Cons-rest alon)))]))
+
+
+(: sum2 ((ListOf Number) -> Number))
+(define (sum2 alon)
+ (cond
+   [(Empty? alon) 0]
+   [(Cons? alon) (+ (Cons-first alon)
+                    (sum2 (Cons-rest alon)))]))
+
+(sum (make-Cons 5 (make-Cons 3 (make-Cons 1 (make-Empty)))))
+(sum2 (make-Cons 5 (make-Cons 3 (make-Cons 1 (make-Empty)))))

collects/tests/typed-scheme/succeed/match-dots.ss

@@ -0,0 +1,8 @@
+#lang typed-scheme
+
+(require scheme/match)
+
+(: parse-sexpr : Any -> Number)
+(define (parse-sexpr sexpr)
+  (match sexpr
+    [(list #{(? symbol? a) : (Listof Symbol)} ...) 1]))

collects/tests/typed-scheme/succeed/refinement-even.ss

@@ -0,0 +1,15 @@
+#lang typed-scheme
+
+(declare-refinement even?)
+(define-type-alias Even (Refinement even?))
+
+(: x Integer)
+(define x 4)
+
+(: y Even)
+(define y (if (even? x) x (error 'bad)))
+
+(: f (Even -> String))
+(define (f e) (format "~a" e))
+
+(f y)

collects/tests/typed-scheme/xfail/apply-map-bug.ss

@@ -0,0 +1,8 @@
+
+#lang typed-scheme
+
+(: add-lists ((Listof Number) (Listof Number) * -> (Listof Number)))
+(define (add-lists lst . lsts)
+ (apply map #{+ :: (Number Number * -> Number)} lst lsts))
+
+(add-lists '(1 2 3) '(4 5 6) '(7 8 9))

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))]))