suzanne.soy/typed-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Allow `apply' of non-uniform polymorphic functions to fixed-length list arguments.

Browse Source 
Please backport.

svn: r14162

original commit: 0ed8d251bff94224448a2d860d329a7427513a61
This commit is contained in:
Sam Tobin-Hochstadt 2009-03-17 21:18:50 +00:00
parent 3bcaed5d41
commit fdfa1cd04a
2 changed files with 38 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
collects/tests/typed-scheme/succeed/apply-dots-list.ss Normal file
View File

@ -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

13
collects/typed-scheme/typecheck/tc-app-unit.ss
View File

@ -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: '())))