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

Improve error messages for polymorphic functions in apply.

Browse Source 
Fix tc-plambda when expected is #f.

svn: r9596
This commit is contained in:
Sam Tobin-Hochstadt 2008-05-02 17:20:55 +00:00
parent ccd1337e31
commit 3b0c0fcc8c
3 changed files with 47 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/typed-scheme/private/infer-ops.ss
View File

@ -326,4 +326,4 @@
;(trace infer cgen cset-meet* subst-gen) ;(trace infer cgen cset-meet* subst-gen)
;(trace cgen) ;(trace infer subst-gen)

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

@ -150,28 +150,43 @@
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*))]))] [else (loop (cdr doms*) (cdr rngs*) (cdr rests*))]))]
[(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests thn-effs els-effs) ..1)))) [(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests thn-effs els-effs) ..1))))
(for-each (lambda (x) (unless (not (Poly? x)) (for-each (lambda (x) (unless (not (Poly? x))
(tc-error "Polymorphic argument ~a to polymorphic function not allowed" x))) (tc-error "Polymorphic argument ~a to polymorphic function in apply not allowed" x)))
arg-tys0) arg-tys0)
(let loop ([doms* doms] [rngs* rngs] [rests* rests]) (let loop ([doms* doms] [rngs* rngs] [rests* rests])
(cond [(null? doms*) (cond [(null? doms*)
(if (= 1 (length doms)) (match f-ty
[(tc-result: (Poly-names: vars (Function: (list (arr: doms rngs rests thn-effs els-effs) ..1))))
(cond
[(null? doms) (int-err "how could doms be null: ~a ~a" doms f-ty)]
[(= 1 (length doms))
(if (car rests)
(tc-error/expr (tc-error/expr
#:return (ret (Un)) #:return (ret (Un))
"polymorphic function domain did not match - domain was: ~a arguments were ~a" "polymorphic function domain did not match -~ndomain was: ~a~nrest argument was: ~a~narguments were ~a~n"
(car doms) arg-tys0) (car doms) (car rests) (stringify arg-tys0))
(tc-error/expr (tc-error/expr
#:return (ret (Un)) #:return (ret (Un))
"no polymorphic function domain matched - domains were: ~a arguments were ~a" "polymorphic function domain did not match -~ndomain was: ~a~narguments were ~a~n"
doms arg-tys0))] (car doms) (stringify arg-tys0)))]
[else
(tc-error/expr
#:return (ret (Un))
"no polymorphic function domain matched - ~ndomains were: ~a~narguments were ~a~n"
(stringify
(for/list ([dom doms] [rest rests])
(if rest
(format "~a rest argument: " (stringify dom) rest)
(stringify dom)))
"\n")
(stringify arg-tys0))])])]
[(and (= (length (car doms*)) [(and (= (length (car doms*))
(length arg-tys)) (length arg-tys))
(infer vars (append (car doms*) (list (make-Listof (car rests*)))) arg-tys0 (car rngs*)) (infer vars arg-tys0 (append (car doms*) (list (make-Listof (car rests*)))) (car rngs*)))
#;(infer/list (append (car doms*) (list (make-Listof (car rests*)))) arg-tys0 vars))
=> (lambda (substitution) => (lambda (substitution)
(let* ([s (lambda (t) (subst-all substitution t))] (let* ([s (lambda (t) (subst-all substitution t))]
[new-doms* (append (map s (car doms*)) (list (make-Listof (s (car rests*)))))]) [new-doms* (append (map s (car doms*)) (list (make-Listof (s (car rests*)))))])
(unless (andmap subtype arg-tys0 new-doms*) (unless (andmap subtype arg-tys0 new-doms*)
(int-err "Inconsistent substitution - arguments not subtypes"))) (int-err "Inconsistent substitution - arguments not subtypes: ~n~a~n~a~n" arg-tys0 new-doms*)))
(ret (subst-all substitution (car rngs*))))] (ret (subst-all substitution (car rngs*))))]
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*))]))] [else (loop (cdr doms*) (cdr rngs*) (cdr rests*))]))]
[(tc-result: (Poly: vars (Function: '()))) [(tc-result: (Poly: vars (Function: '())))

9
collects/typed-scheme/private/tc-lambda-unit.ss
View File

@ -181,6 +181,15 @@
[ty (parameterize ([current-tvars (extend-env literal-tvars new-tvars (current-tvars))]) [ty (parameterize ([current-tvars (extend-env literal-tvars new-tvars (current-tvars))])
(tc/mono-lambda formals bodies expected*))]) (tc/mono-lambda formals bodies expected*))])
;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty) ;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty)
(ret expected))]
[#f
(let* ([tvars (let ([p (syntax-property form 'typechecker:plambda)])
(map syntax-e (syntax->list p)))]
[literal-tvars tvars]
[new-tvars (map make-F literal-tvars)]
[ty (parameterize ([current-tvars (extend-env literal-tvars new-tvars (current-tvars))])
(tc/mono-lambda formals bodies #f))])
;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty)
(ret (make-Poly literal-tvars ty)))] (ret (make-Poly literal-tvars ty)))]
[_ (tc-error/expr #:return expected "Expected a value of type ~a, but got a polymorphic function." expected)])) [_ (tc-error/expr #:return expected "Expected a value of type ~a, but got a polymorphic function." expected)]))