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

Fix bug in inference when tvars in env.

Browse Source 
svn: r11968
This commit is contained in:
Sam Tobin-Hochstadt 2008-10-07 21:55:25 +00:00
parent a584304aa2
commit dbf4462228
1 changed files with 8 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -376,21 +376,22 @@
[(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...))) [(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...)))
(PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...)))) (PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...))))
(let ([fcn-string (if name (let ([fcn-string (if name
(format "function ~a (over ~~a)" (syntax->datum name)) (format "function ~a" (syntax->datum name))
"function over ~a")]) "function")])
(if (and (andmap null? msg-doms) (if (and (andmap null? msg-doms)
(null? argtypes)) (null? argtypes))
(tc-error/expr #:return (ret (Un)) (tc-error/expr #:return (ret (Un))
(string-append (string-append
"Could not infer types for applying polymorphic " "Could not infer types for applying polymorphic "
fcn-string fcn-string
"\n") "\n"))
(stringify msg-vars))
(tc-error/expr #:return (ret (Un)) (tc-error/expr #:return (ret (Un))
(string-append (string-append
"Polymorphic " fcn-string " could not be applied to arguments:~n" "Polymorphic " fcn-string " could not be applied to arguments:~n"
(domain-mismatches t msg-doms msg-rests msg-drests argtypes #f #f)) (domain-mismatches t msg-doms msg-rests msg-drests argtypes #f #f)
(stringify msg-vars))))])) (if (not (for/and ([t (apply append (map fv/list msg-doms))]) (memq t msg-vars)))
(string-append "Type Variables: " (stringify msg-vars) "\n")
"")))))]))
(define (tc/funapp f-stx args-stx ftype0 argtys expected) (define (tc/funapp f-stx args-stx ftype0 argtys expected)
@ -454,7 +455,7 @@
(Function: (list (arr: doms rngs (and rests #f) (and drests #f) '() thn-effs els-effs) ...)))))) (Function: (list (arr: doms rngs (and rests #f) (and drests #f) '() thn-effs els-effs) ...))))))
(handle-clauses (doms rngs) f-stx (handle-clauses (doms rngs) f-stx
(lambda (dom _) (= (length dom) (length argtypes))) (lambda (dom _) (= (length dom) (length argtypes)))
(lambda (dom rng) (infer (fv/list (cons rng dom)) argtypes dom rng (fv rng) expected)) (lambda (dom rng) (infer vars argtypes dom rng (fv rng) expected))
t argtypes expected)] t argtypes expected)]
;; polymorphic varargs ;; polymorphic varargs
[(tc-result: (and t [(tc-result: (and t