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

23
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,6 +593,7 @@
(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 ...)
(let loop ([expected expected])
(match expected (match expected
[(tc-result1: (Vector: t)) [(tc-result1: (Vector: t))
(for ([e (in-list (syntax->list #'(args ...)))]) (for ([e (in-list (syntax->list #'(args ...)))])
@ -607,13 +608,23 @@
[t (in-list ts)]) [t (in-list ts)])
(tc-expr/check e (ret t))) (tc-expr/check e (ret t)))
expected] expected]
[(or #f (tc-result1: _)) [(tc-result1: (? needs-resolving? e) f o)
(loop (ret (resolve-once e) f o))]
[(tc-result1: (and T (Union: (app (λ (ts)
(for/list ([t ts]
#:when (let ([k (Type-key t)])
(eq? 'vector k)))
t))
ts))))
(if (null? ts)
(let ([arg-tys (map single-value (syntax->list #'(args ...)))]) (let ([arg-tys (map single-value (syntax->list #'(args ...)))])
(tc/funapp #'op #'(args ...) (single-value #'op) arg-tys expected)) (tc/funapp #'op #'(args ...) (single-value #'op) arg-tys expected))
#;#; (check-below (for/first ([t ts]) (loop (ret t)))
(tc-error/expr "expected ~a, but got ~a" t (make-HeterogenousVector (map tc-expr/t (syntax->list #'(args ...))))) expected))]
expected] [(or #f (tc-result1: _))
[_ (int-err "bad expected: ~a" expected)])] (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))