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

Handle apply for functions with no rest arguments.

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2011-08-17 17:16:39 -04:00
parent cfec4280d3
commit bdcc63b229
2 changed files with 15 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt
View File

@ -1327,6 +1327,8 @@
[tc-e (#%variable-reference) -Variable-Reference] [tc-e (#%variable-reference) -Variable-Reference]
[tc-e (#%variable-reference x) -Variable-Reference] [tc-e (#%variable-reference x) -Variable-Reference]
[tc-e (#%variable-reference +) -Variable-Reference] [tc-e (#%variable-reference +) -Variable-Reference]
[tc-e (apply (λ: ([x : String] [y : String]) (string-append x y)) (list "foo" "bar")) -String]
[tc-e (apply (plambda: (a) ([x : a] [y : a]) x) (list "foo" "bar")) -String]
) )
(test-suite (test-suite
"check-type tests" "check-type tests"

14
collects/typed-scheme/typecheck/tc-apply.rkt
View File

@ -75,6 +75,11 @@
(subtype tail-ty (car (car drests*))))] (subtype tail-ty (car (car drests*))))]
[_ #f])) [_ #f]))
(do-ret (car rngs*))] (do-ret (car rngs*))]
;; the function has no rest argument, but provides all the necessary fixed arguments
[(and (not (car rests*)) (not (car drests*))
(subtype (apply -lst* arg-tys #:tail tail-ty)
(apply -lst* (car doms*))))
(do-ret (car rngs*))]
;; otherwise, nothing worked, move on to the next case ;; otherwise, nothing worked, move on to the next case
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))]
;; apply of simple polymorphic function ;; apply of simple polymorphic function
@ -84,7 +89,7 @@
[(tail-ty tail-bound) (match (tc-expr/t tail) [(tail-ty tail-bound) (match (tc-expr/t tail)
[(ListDots: tail-ty tail-bound) [(ListDots: tail-ty tail-bound)
(values tail-ty tail-bound)] (values tail-ty tail-bound)]
[t (values t #f)])]) [t (values t #f)])])
(let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests])
(cond [(null? doms*) (cond [(null? doms*)
(match f-ty (match f-ty
@ -107,6 +112,13 @@
(car rests*) (car rests*)
(car rngs*))) (car rngs*)))
=> (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))]
;; the function has no rest argument, but provides all the necessary fixed arguments
[(and (not (car rests*)) (not (car drests*)) (not tail-bound)
(infer vars null
(list (apply -lst* arg-tys #:tail tail-ty))
(list (apply -lst* (car doms*)))
(car rngs*)))
=> (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))]
;; actual work, when we have a * function and ... final arg ;; actual work, when we have a * function and ... final arg
[(and (car rests*) [(and (car rests*)
tail-bound tail-bound