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

Better internal error messages.

Browse Source 
original commit: 460bb348e10f07534bc74e7f91b8b4bc8655ac68
This commit is contained in:
Sam Tobin-Hochstadt 2010-05-24 14:05:05 -07:00
parent bbf633a95c
commit 1c955c4e56
2 changed files with 17 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/typed-scheme/typecheck/tc-if.rkt
View File

@ -50,10 +50,12 @@
(env-props env-els))]
[(tc-results: ts fs2 os2) (with-lexical-env env-thn (tc thn (unbox flag+)))]
[(tc-results: us fs3 os3) (with-lexical-env env-els (tc els (unbox flag-)))])
;(printf "old els-props: ~a\n" (env-props (lexical-env)))
;(printf "old props: ~a\n" (env-props (lexical-env)))
;(printf "fs+: ~a~n" fs+)
;(printf "fs-: ~a~n" fs-)
;(printf "els-props: ~a~n" (env-props env-els))
;(printf "thn-props: ~a~n" (env-props env-thn))
;(printf "els-props: ~a~n" (env-props env-els))
;(printf "new-thn-props: ~a~n" new-thn-props)
;(printf "new-els-props: ~a~n" new-els-props)
;; if we have the same number of values in both cases
(cond [(= (length ts) (length us))
@ -66,6 +68,7 @@
[(_ (NoFilter:))
(-FS -top -top)]
[((FilterSet: f2+ f2-) (FilterSet: f3+ f3-))
;(printf "f2- ~a f+ ~a\n" f2- fs+)
(-FS (-or (apply -and fs+ f2+ new-thn-props) (apply -and fs- f3+ new-els-props))
(-or (apply -and fs+ f2- new-thn-props) (apply -and fs- f3- new-els-props)))])]
[type (Un t2 t3)]

22
collects/typed-scheme/typecheck/tc-lambda-unit.rkt
View File

@ -41,7 +41,8 @@
(abstract-results body arg-names)
#:kws (map make-Keyword kw kw-ty req?)
#:rest (if rest (second rest) #f)
#:drest (if drest (cdr drest) #f)))]))
#:drest (if drest (cdr drest) #f)))]
[_ (int-err "not a lam-result")]))
(define (expected-str tys-len rest-ty drest arg-len rest)
(format "Expected function with ~a argument~a~a, but got function with ~a argument~a~a"
@ -74,11 +75,11 @@
(define (check-body)
(with-lexical-env/extend
arg-list arg-types
(lam-result (for/list ([al arg-list] [at arg-types] [a-ty arg-tys]) (list al at)) null
(and rest-ty (list (or rest (generate-temporary)) rest-ty))
;; make up a fake name if none exists, this is an error case anyway
(and drest (cons (or rest (generate-temporary)) drest))
(tc-exprs/check (syntax->list body) ret-ty))))
(make-lam-result (for/list ([al arg-list] [at arg-types] [a-ty arg-tys]) (list al at)) null
(and rest-ty (list (or rest (generate-temporary)) rest-ty))
;; make up a fake name if none exists, this is an error case anyway
(and drest (cons (or rest (generate-temporary)) drest))
(tc-exprs/check (syntax->list body) ret-ty))))
(when (or (not (= arg-len tys-len))
(and (or rest-ty drest) (not rest)))
(tc-error/delayed (expected-str tys-len rest-ty drest arg-len rest)))
@ -152,7 +153,7 @@
(parameterize ([dotted-env (extend-env (list #'rest)
(list (cons rest-type bound))
(dotted-env))])
(make lam-result
(make-lam-result
(map list arg-list arg-types)
null
#f
@ -163,7 +164,7 @@
(with-lexical-env/extend
(cons #'rest arg-list)
(cons (make-Listof rest-type) arg-types)
(make lam-result
(make-lam-result
(map list arg-list arg-types)
null
(list #'rest rest-type)
@ -245,7 +246,7 @@
(tc/plambda form formals bodies expected)]
[(tc-result1: (Error:)) (tc/mono-lambda/type formals bodies #f)]
[(tc-result1: (and v (Values: _))) (maybe-loop form formals bodies (values->tc-results v #f))]
[(tc-result1: t) (int-err "expected not an appropriate tc-result: ~a ~a" expected t)]))
[_ (int-err "expected not an appropriate tc-result: ~a" expected)]))
(match expected
[(tc-result1: (and t (Poly-names: ns expected*)))
(let* ([tvars (let ([p (syntax-property form 'typechecker:plambda)])
@ -299,7 +300,8 @@
(unless (check-below (tc/plambda form formals bodies #f) t)
(tc-error/expr #:return expected
"Expected a value of type ~a, but got a polymorphic function." t))
t]))
t]
[_ (int-err "not a good expected value: ~a" expected)]))
;; typecheck a sequence of case-lambda clauses, which is possibly polymorphic
;; tc/lambda/internal syntax syntax-list syntax-list option[type] -> tc-result