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

Fix for-each type.

Browse Source 
Improve ... error messages.
This commit is contained in:
Sam Tobin-Hochstadt 2008-06-16 13:26:15 -04:00
parent c4e253d2d1
commit 2ad4403108
2 changed files with 12 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/typed-scheme/private/base-env.ss
View File

@ -123,7 +123,7 @@
[procedure? (make-pred-ty (make-Function (list (make-top-arr))))]
[map (-polydots (c a b) ((list ((list a) (b b) . ->... . c) (-lst a))
((-lst b) b) . ->... .(-lst c)))]
[for-each (-polydots (c a b) ((list ((list a) (b b) . ->... . -Void) (-lst a))
[for-each (-polydots (c a b) ((list ((list a) (b b) . ->... . Univ) (-lst a))
((-lst b) b) . ->... . -Void))]
[fold-left (-polydots (c a b) ((list ((list c a) (b b) . ->... . c) c (-lst a))
((-lst b) b) . ->... . c))]

16
collects/typed-scheme/private/tc-app-unit.ss
View File

@ -310,8 +310,8 @@
"no polymorphic function domain matched - domain was: ~a rest type was: ~a arguments were ~a"
(stringify dom) rest (stringify argtypes))]))]
;; polymorphic ... type
[(tc-result: (PolyDots: (and vars (list fixed-vars ... dotted-var))
(Function: (list (arr: dom rng #f (cons dty dbound) thn-eff els-eff)))))
[(tc-result: (and t (PolyDots: (and vars (list fixed-vars ... dotted-var))
(Function: (list (arr: dom rng #f (cons dty dbound) thn-eff els-eff))))))
(for-each (lambda (x) (unless (not (Poly? x))
(tc-error "Polymorphic argument ~a to polymorphic function not allowed" x)))
argtypes)
@ -325,9 +325,15 @@
[(and expected substitution) expected]
[substitution
(ret (subst-all substitution rng))]
[else (tc-error/expr #:return (ret (Un))
"no polymorphic function domain matched -~ndomain was: ~a ~ndotted rest type was: ~a ... ~a~narguments were ~a"
(stringify dom) dty dbound (stringify argtypes))]))]
[else
(match t
[(PolyDots-names: vars
(Function: (list (arr: dom rng #f (cons dty dbound) thn-eff els-eff))))
(tc-error/expr #:return (ret (Un))
(string-append
"no polymorphic function domain matched -~n"
"domain was: ~a ~ndotted rest type was: ~a ... ~a~narguments were ~a")
(stringify dom) dty dbound (stringify argtypes))])]))]
[(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests #f thn-effs els-effs) ...))))
(tc-error/expr #:return (ret (Un)) "polymorphic vararg case-lambda application not yet supported")]
[(tc-result: (Poly: vars (Function: (list (arr: doms rngs #f drests thn-effs els-effs) ...))))