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

Better internal error messages.

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2010-05-24 14:05:05 -07:00
parent af689b2531
commit 460bb348e1
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))] (env-props env-els))]
[(tc-results: ts fs2 os2) (with-lexical-env env-thn (tc thn (unbox flag+)))] [(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-)))]) [(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 "fs-: ~a~n" fs-)
;(printf "els-props: ~a~n" (env-props env-els))
;(printf "thn-props: ~a~n" (env-props env-thn)) ;(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) ;(printf "new-els-props: ~a~n" new-els-props)
;; if we have the same number of values in both cases ;; if we have the same number of values in both cases
(cond [(= (length ts) (length us)) (cond [(= (length ts) (length us))
@ -66,6 +68,7 @@
[(_ (NoFilter:)) [(_ (NoFilter:))
(-FS -top -top)] (-FS -top -top)]
[((FilterSet: f2+ f2-) (FilterSet: f3+ f3-)) [((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)) (-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)))])] (-or (apply -and fs+ f2- new-thn-props) (apply -and fs- f3- new-els-props)))])]
[type (Un t2 t3)] [type (Un t2 t3)]

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

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