Fix time-apply, add test

svn: r12727

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

@@ -0,0 +1,17 @@
+#lang typed-scheme
+
+
+
+ (: foo : Number Number -> Number)
+ (define (foo x y)
+   (* x y))
+
+ (: bar : Number -> Number)
+ (define (bar c)
+   (: loop : Number Number -> Number)
+   (define (loop n acc)
+     (if (< 0 n)
+         (loop (- n 1) (+ (foo c n) acc))
+         acc))
+   (loop 10000000 0))
+ (time (bar 0))

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

@@ -245,8 +245,10 @@
 
 [apply        (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))]
 [kernel:apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))]
-[time-apply (-poly (a b) (((list) a . ->* . b) (-lst a)
-                          . -> . (-values (list b N N N))))]
+[time-apply (-polydots (b a) (((list) (a a) . ->... . b)
+                              (-lst a)
+                              . -> . 
+                              (-values (list (-pair b (-val '())) N N N))))]
 
 [call/cc (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (*Un a b)))]
 [call/ec (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (*Un a b)))]

collects/typed-scheme/private/type-effect-convenience.ss

@@ -216,6 +216,14 @@
 
 (define (-Tuple l)
   (foldr -pair (-val '()) l))
+
+(define (untuple t)
+  (match t
+    [(Value: '()) null]
+    [(Pair: a b) (cond [(untuple b) => (lambda (l) (cons a l))]
+                       [else #f])]
+    [_ #f]))
+
 (define -box make-Box)
 (define -vec make-Vector)
 

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

@@ -14,6 +14,7 @@
          (prefix-in c: scheme/contract)
          (for-syntax scheme/base)
          (for-template 
+          (only-in '#%kernel [apply k:apply])
           "internal-forms.ss" scheme/base 
           (only-in scheme/private/class-internal make-object do-make-object)))
 (require (r:infer constraint-structs))
@@ -620,7 +621,7 @@
 
 (define (tc/app/internal form expected)
   (kernel-syntax-case* form #f 
-    (values apply not list list* call-with-values do-make-object make-object cons
+    (values apply k:apply not list list* call-with-values do-make-object make-object cons
             andmap ormap) ;; the special-cased functions
     ;; special case for delay
     [(#%plain-app 
@@ -680,6 +681,12 @@
        ;; if arg was a predicate application, we swap the effects
        [(tc-result: t thn-eff els-eff)
         (ret B (map var->type-eff els-eff) (map var->type-eff thn-eff))])]
+    [(#%plain-app k:apply . args)
+     (tc/app/internal #'(#%plain-app apply . args) expected)]
+    ;; special-er case for (apply values (list x y z))
+    [(#%plain-app apply values e)
+     (cond [(untuple (tc-expr/t #'e)) => (lambda (t) (ret (-values t)))]
+           [else (tc/apply #'values #'(e))])]
     ;; special case for `apply'
     [(#%plain-app apply f . args) (tc/apply #'f #'args)]
     ;; special case for keywords