Add handling of dotted functions when not wrapped with a big lambda.

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

@@ -120,38 +120,91 @@
 ;(trace tc-args)
 
 (define (tc/apply f args)
-  (let* ([f-ty (tc-expr f)]
+  (define f-ty (tc-expr f))
-         [arg-tys0 (map tc-expr/t (syntax->list args))])
   ;; produces the first n-1 elements of the list, and the last element
   (define (split l)
     (let loop ([l l] [acc '()])
       (if (null? (cdr l))
           (values (reverse acc) (car l))
           (loop (cdr l) (cons (car l) acc)))))   
-    (let-values ([(arg-tys tail-ty) (split arg-tys0)])
+  (define (printable dom rst drst)
-      (define (printable dom rst)
+    (let ([doms-string (if (null? dom) "" (string-append (stringify dom) " "))])
-        (list dom rst '..))
+      (if rst
-      (match f-ty
+          (format "~a~a *" doms-string rst)
-        [(tc-result: (Function: (list (arr: doms rngs rests #f thn-effs els-effs) ..1)))
+          (format "~a~a ... ~a" doms-string (car drst) (cdr drst)))))
-         (let loop ([doms* doms] [rngs* rngs] [rests* rests])
+  (define-values (fixed-args tail) (split (syntax->list args)))
-           (cond [(null? doms*) 
+  (define (apply-error doms rests drests arg-tys tail-ty tail-bound)
     (if (and (not (null? doms)) (null? (cdr doms)))
         (tc-error/expr
          #:return (ret (Un))
-                       "bad arguments to apply - function expected ~a fixed arguments and (Listof ~a) rest argument, given ~a"
+         (string-append 
-                       (car doms) (car rests) arg-tys0)
+          "bad arguments to apply~n - function expected ~a as fixed arguments and ~a as a rest argument,~n"
+          " - given ~a as fixed arguments and ~a as a rest argument~n")
+         (if (null? (car doms))
+             "nothing"
+             (stringify (car doms)))
+         (if (car rests)
+             (format "~a *" (car rests))
+             (format "~a ... ~a" (car (car drests)) (cdr (car drests))))
+         (if (null? arg-tys)
+             "nothing"
+             (stringify arg-tys))
+         (if tail-bound
+             (format "~a ... ~a" tail-ty tail-bound)
+             tail-ty))
         (tc-error/expr
          #:return (ret (Un))
-                       "no function domain matched - domains were: ~a arguments were ~a" 
+         "no function domain matched in apply~ndomains were: ~n\t~a~narguments were: \n\t~a\n" 
-                       (map printable doms rests)
+         (stringify (map printable doms rests drests) "\n\t")
-                       arg-tys0))]
+         (stringify (append arg-tys (list (if tail-bound
-                 [(and (subtypes arg-tys (car doms*)) (car rests*) (subtype tail-ty (make-Listof (car rests*))))
+                                              (string-append tail-ty " ... " tail-bound)
+                                              tail-ty)))))))
+  (match f-ty
+    [(tc-result: (Function: (list (arr: doms rngs rests drests thn-effs els-effs) ...)))
+     (when (null? doms)
+       (tc-error/expr #:return (ret (Un))
+                      "empty case-lambda given as argument to apply"))
+     (let ([arg-tys (map tc-expr/t fixed-args)])
+       (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests])
+         (cond [(null? doms*)
+                (let-values ([(tail-ty tail-bound)
+                              (with-handlers ([exn:fail? (lambda _ (values #f #f))])
+                                (tc/dots tail))])
+                  (if tail-ty
+                      (apply-error doms rests drests arg-tys tail-ty tail-bound)
+                      (apply-error doms rests drests arg-tys (tc-expr/t tail) #f)))]
+               [(and (car rests*)
+                     (let-values ([(tail-ty tail-bound) 
+                                   (with-handlers ([exn:fail? (lambda _ (values #f #f))])
+                                     (tc/dots tail))])
+                       (and tail-ty
+                            (subtype (apply -lst* arg-tys #:tail (make-Listof tail-ty))
+                                     (apply -lst* (car doms*) #:tail (make-Listof (car rests*)))))))
                 (ret (car rngs*))]
-                 [else (loop (cdr doms*) (cdr rngs*) (cdr rests*))]))]                      
+               [(and (car rests*)
+                     (let ([tail-ty (with-handlers ([exn:fail? (lambda _ #f)])
+                                      (tc-expr/t tail))])
+                       (and tail-ty
+                            (subtype (apply -lst* arg-tys #:tail tail-ty)
+                                     (apply -lst* (car doms*) #:tail (make-Listof (car rests*)))))))
+                (ret (car rngs*))]               
+               [(and (car drests*)
+                     (let-values ([(tail-ty tail-bound) 
+                                   (with-handlers ([exn:fail? (lambda _ (values #f #f))])
+                                     (tc/dots tail))])
+                       (and tail-ty
+                            (eq? (cdr (car drests*)) tail-bound)
+                            (subtypes arg-tys (car doms*))
+                            (subtype tail-ty (car (car drests*))))))                     
+                (ret (car rngs*))]
+               [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))]
     [(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests #f thn-effs els-effs) ..1))))
+     (let*-values ([(arg-tys tail-ty) (values (map tc-expr/t fixed-args)
+                                              (tc-expr/t tail))]
+                   [(arg-tys0) (append arg-tys (list tail-ty))])
        (for-each (lambda (x) (unless (not (Poly? x))                                      
                                (tc-error "Polymorphic argument ~a to polymorphic function in apply not allowed" x)))
-                   arg-tys0)
+                 (cons tail-ty arg-tys))
        (let loop ([doms* doms] [rngs* rngs] [rests* rests])
          (cond [(null? doms*)
                 (match f-ty 
@@ -188,12 +241,12 @@
                        (unless (andmap subtype arg-tys0 new-doms*)
                          (int-err "Inconsistent substitution - arguments not subtypes: ~n~a~n~a~n" arg-tys0 new-doms*)))
                      (ret (subst-all substitution (car rngs*))))]
-                 [else (loop (cdr doms*) (cdr rngs*) (cdr rests*))]))]
+               [else (loop (cdr doms*) (cdr rngs*) (cdr rests*))])))]
     [(tc-result: (Poly: vars (Function: '())))
      (tc-error/expr #:return (ret (Un))
                     "Function has no cases")]
     [f-ty (tc-error/expr #:return (ret (Un))
-                             "Type of argument to apply is not a function type: ~n~a" f-ty)]))))
+                         "Type of argument to apply is not a function type: ~n~a" f-ty)]))
 
 
 (define (tc/funapp f-stx args-stx ftype0 argtys expected)

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

@@ -144,9 +144,12 @@
   (define (syntax-len s)
     (cond [(syntax->list s) => length]
           [else (let loop ([s s])
-                  (if (pair? (syntax-e s))
+                  (cond
-                      (+ 1 (loop (cdr (syntax-e s))))
+                    [(pair? s)
-                      1))]))
+                     (+ 1 (loop (cdr s)))]
+                    [(pair? (syntax-e s))
+                     (+ 1 (loop (cdr (syntax-e s))))]
+                    [else 1]))]))
   (if (and expected
            (= 1 (length (syntax->list formals))))
       ;; special case for not-case-lambda

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

@@ -164,9 +164,10 @@
 (define -Sexp (-mu x (*Un Sym N B -String (-val null) (-pair x x))))
 (define -Port (*Un -Input-Port -Output-Port))
 
-(define (-lst* . args) (if (null? args)
+(define (-lst* #:tail [tail (-val null)] . args)
-                           (-val null)
+  (if (null? args)
-                           (-pair (car args) (apply -lst* (cdr args)))))
+      tail
+      (-pair (car args) (apply -lst* #:tail tail (cdr args)))))
 
 
 #;(define NE (-mu x (Un N (make-Listof x))))