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

Better handling of expected types for `vector'

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2010-07-01 17:32:16 -04:00
parent 71bb63c128
commit ed88b9dd1a
1 changed files with 33 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
collects/typed-scheme/typecheck/tc-app.rkt
View File

@ -18,7 +18,7 @@
(utils tc-utils) (utils tc-utils)
(only-in srfi/1 alist-delete) (only-in srfi/1 alist-delete)
(except-in (env type-env-structs tvar-env index-env) extend) (except-in (env type-env-structs tvar-env index-env) extend)
(rep type-rep filter-rep object-rep) (rep type-rep filter-rep object-rep rep-utils)
(r:infer infer) (r:infer infer)
'#%paramz '#%paramz
(for-template (for-template
@ -593,27 +593,38 @@
(let ([arg-tys (list v-ty e-t (single-value #'val))]) (let ([arg-tys (list v-ty e-t (single-value #'val))])
(tc/funapp #'op #'(v e val) (single-value #'op) arg-tys expected))]))] (tc/funapp #'op #'(v e val) (single-value #'op) arg-tys expected))]))]
[(#%plain-app (~and op (~literal vector)) args:expr ...) [(#%plain-app (~and op (~literal vector)) args:expr ...)
(match expected (let loop ([expected expected])
[(tc-result1: (Vector: t)) (match expected
(for ([e (in-list (syntax->list #'(args ...)))]) [(tc-result1: (Vector: t))
(tc-expr/check e (ret t))) (for ([e (in-list (syntax->list #'(args ...)))])
expected] (tc-expr/check e (ret t)))
[(tc-result1: (HeterogenousVector: ts)) expected]
(unless (= (length ts) (length (syntax->list #'(args ...)))) [(tc-result1: (HeterogenousVector: ts))
(tc-error/expr "expected vector with ~a elements, but got ~a" (unless (= (length ts) (length (syntax->list #'(args ...))))
(length ts) (tc-error/expr "expected vector with ~a elements, but got ~a"
(make-HeterogenousVector (map tc-expr/t (syntax->list #'(args ...)))))) (length ts)
(for ([e (in-list (syntax->list #'(args ...)))] (make-HeterogenousVector (map tc-expr/t (syntax->list #'(args ...))))))
[t (in-list ts)]) (for ([e (in-list (syntax->list #'(args ...)))]
(tc-expr/check e (ret t))) [t (in-list ts)])
expected] (tc-expr/check e (ret t)))
[(or #f (tc-result1: _)) expected]
(let ([arg-tys (map single-value (syntax->list #'(args ...)))]) [(tc-result1: (? needs-resolving? e) f o)
(tc/funapp #'op #'(args ...) (single-value #'op) arg-tys expected)) (loop (ret (resolve-once e) f o))]
#;#; [(tc-result1: (and T (Union: (app (λ (ts)
(tc-error/expr "expected ~a, but got ~a" t (make-HeterogenousVector (map tc-expr/t (syntax->list #'(args ...))))) (for/list ([t ts]
expected] #:when (let ([k (Type-key t)])
[_ (int-err "bad expected: ~a" expected)])] (eq? 'vector k)))
t))
ts))))
(if (null? ts)
(let ([arg-tys (map single-value (syntax->list #'(args ...)))])
(tc/funapp #'op #'(args ...) (single-value #'op) arg-tys expected))
(check-below (for/first ([t ts]) (loop (ret t)))
expected))]
[(or #f (tc-result1: _))
(let ([arg-tys (map single-value (syntax->list #'(args ...)))])
(tc/funapp #'op #'(args ...) (single-value #'op) arg-tys expected))]
[_ (int-err "bad expected: ~a" expected)]))]
;; special case for `-' used like `sub1' ;; special case for `-' used like `sub1'
[(#%plain-app (~and op (~literal -)) v (~and arg2 ((~literal quote) 1))) [(#%plain-app (~and op (~literal -)) v (~and arg2 ((~literal quote) 1)))
(add-typeof-expr #'arg2 (ret -PositiveFixnum)) (add-typeof-expr #'arg2 (ret -PositiveFixnum))