From fdfa1cd04a3aa1c842adacfd725378d7176da037 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 17 Mar 2009 21:18:50 +0000 Subject: [PATCH] Allow `apply' of non-uniform polymorphic functions to fixed-length list arguments. Please backport. svn: r14162 original commit: 0ed8d251bff94224448a2d860d329a7427513a61 --- .../typed-scheme/succeed/apply-dots-list.ss | 25 +++++++++++++++++++ .../typed-scheme/typecheck/tc-app-unit.ss | 13 ++++++++++ 2 files changed, 38 insertions(+) create mode 100644 collects/tests/typed-scheme/succeed/apply-dots-list.ss diff --git a/collects/tests/typed-scheme/succeed/apply-dots-list.ss b/collects/tests/typed-scheme/succeed/apply-dots-list.ss new file mode 100644 index 00000000..d068a14e --- /dev/null +++ b/collects/tests/typed-scheme/succeed/apply-dots-list.ss @@ -0,0 +1,25 @@ + +;; Change the lang to scheme for untyped version +#lang typed-scheme + +(define tests (list (list (λ() 1) 1 "test 1") + (list (λ() 2) 2 "test 2"))) + +; Comment out the type signature when running untyped +(: check-all (All (A ...) ((List (-> A) A String) ... A -> Void))) +(define (check-all . tests) + (let aux ([tests tests] + [num-passed 0]) + (if (null? tests) + (printf "~a tests passed.~n" num-passed) + (let ((test (car tests))) + (let ((actual ((car test))) + (expected (cadr test)) + (msg (caddr test))) + (if (equal? actual expected) + (aux (cdr tests) (+ num-passed 1)) + (printf "Test failed: ~a. Expected ~a, got ~a.~n" + msg expected actual))))))) + +(apply check-all tests) ; Works in untyped, but not in typed +(check-all (car tests) (cadr tests)) ; Works in typed or untyped \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-app-unit.ss b/collects/typed-scheme/typecheck/tc-app-unit.ss index dbe864f1..61b4f54b 100644 --- a/collects/typed-scheme/typecheck/tc-app-unit.ss +++ b/collects/typed-scheme/typecheck/tc-app-unit.ss @@ -342,6 +342,19 @@ drest-bound (subst-all (alist-delete drest-bound substitution eq?) (car rngs*)))))] + ;; ... function, (List A B C etc) arg + [(and (car drests*) + (not tail-bound) + (eq? (cdr (car drests*)) dotted-var) + (= (length (car doms*)) + (length arg-tys)) + (untuple tail-ty) + (infer/dots fixed-vars dotted-var (append arg-tys (untuple tail-ty)) (car doms*) + (car (car drests*)) (car rngs*) (fv (car rngs*)))) + => (lambda (substitution) + (define drest-bound (cdr (car drests*))) + (do-apply-log substitution 'dots 'dots) + (ret (subst-all substitution (car rngs*))))] ;; if nothing matches, around the loop again [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] [(tc-result: (PolyDots: vars (Function: '())))