Handle rest args and case-lambda in app.

Fix parsing.

svn: r14722

collects/typed-scheme/private/parse-type.ss

@@ -570,7 +570,7 @@
     [(values t ...)
      #:when (eq? 'values (syntax-e #'values))
      (ret (map parse-type (syntax->list #'(t ...))))]
-    [t (parse-type #'t)]))
+    [t (ret (parse-type #'t))]))
 
 (define parse-tc-results/id (parse/id parse-tc-results))
 

collects/typed-scheme/test2.ss

@@ -1,13 +1,24 @@
 #lang typed-scheme
 
 (: f (Number String -> Number))
-(define (f x z) (f x z))
+(define (f x z) #;(f x z) 7)
 (lambda: ([x : Any] [y : Any]) (values (number? y) (number? x)))
 (lambda: ([x : Any] [y : Any]) (values (number? x) (number? y)))
 (lambda: ([x : Any] [y : Any]) (values (and (number? x) (boolean? y)) (number? y)))
 (lambda: ([x : Any]) (values (number? x) (number? x)))
 (: g (Any -> Boolean : Number))
 (define g (lambda: ([x : Any]) (number? x)))
+(: q ((Number -> Number) -> Number))
+(define q (lambda: ([x : (Number -> Number)]) (x 1)))
+;(q (lambda (z) (f z "foo")))
+
+(: p (Number * -> Number))
+(define (p . x) 7)
+
+(lambda x (number? x))
+(+)
+(+ 1 2 3)
+(+ 1 2 3.5)
 
 ;(f 12 "hi")
 

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

@@ -0,0 +1,41 @@
+#lang scheme/base
+
+(require "../utils/utils.ss"
+         (utils tc-utils))
+
+(provide (all-defined-out))
+
+(define (stringify-domain dom rst drst [rng #f])
+  (let ([doms-string (if (null? dom) "" (string-append (stringify dom) " "))]
+        [rng-string (if rng (format " -> ~a" rng) "")])
+    (cond [drst
+           (format "~a~a ... ~a~a" doms-string (car drst) (cdr drst) rng-string)]
+          [rst
+           (format "~a~a *~a" doms-string rst rng-string)]
+          [else (string-append (stringify dom) rng-string)])))
+
+(define (domain-mismatches ty doms rests drests rngs arg-tys tail-ty tail-bound #:expected [expected #f])
+  (define arguments-str
+    (stringify-domain arg-tys (if (not tail-bound) tail-ty #f) (if tail-bound (cons tail-ty tail-bound) #f)))    
+  (cond
+    [(null? doms)
+     (int-err "How could doms be null: ~a ~a" ty)]
+    [(= 1 (length doms))
+     (format "Domain: ~a~nArguments: ~a~n~a"
+             (stringify-domain (car doms) (car rests) (car drests))
+             arguments-str
+             (if expected
+                 (format "Result type: ~a~nExpected result: ~a~n"
+                         (car rngs) expected)
+                 ""))]
+    [else
+     (format "~a: ~a~nArguments: ~a~n~a"
+             (if expected "Types" "Domains")
+             (stringify (if expected 
+                            (map stringify-domain doms rests drests rngs)
+                            (map stringify-domain doms rests drests))
+                        "~n\t")
+             arguments-str
+             (if expected
+                 (format "Expected result: ~a~n" expected)
+                 ""))]))

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

@@ -2,9 +2,10 @@
 
 (require (rename-in "../utils/utils.ss" [infer r:infer])
          "signatures.ss" "tc-metafunctions.ss"
+         "tc-app-helper.ss"
          stxclass scheme/match mzlib/trace
          (for-syntax stxclass)
-         (types utils abbrev)
+         (types utils abbrev union subtype)
          (utils tc-utils)
          (rep type-rep filter-rep object-rep)
          (for-template 
@@ -88,23 +89,47 @@
 (define (in-indexes dom)
   (in-range (length dom)))
 
-;; syntax? syntax? tc-results? (listof tc-results?) (or/c #f tc-results) -> tc-results?
 (define (tc/funapp f-stx args-stx ftype0 argtys expected)
   (match* (ftype0 argtys)
-    [((tc-result1: (Function: (list (arr: dom (Values: (list (Result: t-r lf-r lo-r) ...)) #f #f '()))))
+    ;; we special-case this (no case-lambda) for improved error messages
+    [((tc-result1: (and t (Function: (list (and a (arr: dom (Values: (list (Result: t-r lf-r lo-r) ...)) rest #f kws))))))
+      argtys)
+     (tc/funapp1 f-stx args-stx a argtys expected)]
+    [((tc-result1: (and t (Function: (and arrs (list (arr: doms rngs rests #f kws) ...)))))
+      (and argtys (list (tc-result1: argtys-t) ...)))
+     (let loop ([doms* doms] [rngs rngs] [rests* rests] [a arrs])
+       (cond [(null? doms*) 
+              (tc-error/expr 
+               #:return (or expected (ret (Un)))
+               (string-append "No function domains matched in function application:\n"
+                              (domain-mismatches t doms rests #f rngs argtys #f #f)))]
+             [(subtypes/varargs argtys-t (car doms*) (car rests*))
+              (tc/funapp1 f-stx args-stx (car a) argtys expected #:check #f)]
+             [else (loop (cdr doms*) (cdr rngs) (cdr rests*) (cdr a))]))]))
+
+
+;; syntax? syntax? arr? (listof tc-results?) (or/c #f tc-results) [boolean?] -> tc-results?
+(define (tc/funapp1 f-stx args-stx ftype0 argtys expected #:check [check? #t])
+  (match* (ftype0 argtys)
+    [((arr: dom (Values: (list (Result: t-r lf-r lo-r) ...)) rest #f '())
       (list (tc-result1: t-a phi-a o-a) ...))
-     (unless (= (length dom) (length t-a))
+     (when check?
+       (cond [(and (not rest) (not (= (length dom) (length t-a))))
               (tc-error/expr #:return (ret t-r)
-                      "Wrong number of arguments"))
+                             "Wrong number of arguments, expected ~a and got ~a" (length dom) (length t-a))]
-     (for ([dom-t (in-list dom)] [arg-t (in-list t-a)])
+             [(and rest (< (length t-a) (length dom)))
-       (check-below arg-t dom-t))
+              (tc-error/expr #:return (ret t-r)
+                             "Wrong number of arguments, expected at least ~a and got ~a" (length dom) (length t-a))])
+       (for ([dom-t (in-list-forever dom rest)] [a (syntax->list args-stx)] [arg-t (in-list t-a)])
+         (parameterize ([current-orig-stx a]) (check-below arg-t dom-t))))
      (let* (;; Listof[Listof[LFilterSet]]
             [lfs-f (for/list ([lf lf-r])
                      (for/list ([i (in-indexes dom)])
                        (split-lfilters lf i)))]
             ;; Listof[FilterSet]
             [f-r (for/list ([lfs lfs-f])
-                   (merge-filter-sets (for/list ([lf lfs] [t t-a] [o o-a])
+                   (merge-filter-sets 
+                    (for/list ([lf lfs] [t t-a] [o o-a])
                       (apply-filter lf t o))))]
             ;; Listof[Object]
             [o-r (for/list ([lo lo-r])                     
@@ -116,4 +141,4 @@
                      [_ (make-Empty)]))])
        (ret t-r f-r o-r))]
     [(_ _)
-     (int-err "funapp with keyword/rest args NYI")]))
+     (int-err "funapp with keyword args NYI")]))

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

@@ -5,7 +5,7 @@
          "tc-metafunctions.ss"
          mzlib/trace
          scheme/list
-         stxclass/util
+         stxclass/util syntax/stx
          (rename-in scheme/contract [-> -->] [->* -->*] [one-of/c -one-of/c])
          (except-in (rep type-rep) make-arr)
          (rename-in (types convenience utils union)
@@ -160,10 +160,11 @@
                    #f
                    (tc-exprs (syntax->list body)))))]))]))
 
-
+(define (formals->list l)
-;; FIXED TO HERE
+  (let loop ([l (syntax-e l)])
-
+    (cond [(stx-pair? l) (cons (stx-car l) (loop (stx-cdr l)))]
-;(trace tc-args)
+          [(pair? l) (cons (car l) (loop (cdr l)))]
+          [else null])))
 
 ;; tc/mono-lambda : syntax-list syntax-list (or/c #f tc-results) -> (listof lam-result)
 ;; typecheck a sequence of case-lambda clauses
@@ -200,7 +201,7 @@
          [(tc-result1: (Function: (list (arr: argss rets rests drests '()) ...)))
           (for/list ([args argss] [ret rets] [rest rests] [drest drests])
             (tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies))
-                                    args (values->tc-results ret (syntax->list (car (syntax->list formals)))) rest drest))]
+                                    args (values->tc-results ret (formals->list (car (syntax->list formals)))) rest drest))]
          [_ (go (syntax->list formals) (syntax->list bodies) null null null)]))]
     ;; otherwise
     [else (go (syntax->list formals) (syntax->list bodies) null null null)]))