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

Make heterogenous vector typechecking not double typecheck the arguments.

Browse Source
This commit is contained in:
Eric Dobson 2014-03-14 21:53:59 -07:00
parent a7d6809243
commit 74f8dc7436
3 changed files with 22 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-hetero.rkt
View File

@ -109,14 +109,18 @@
(tc-expr/check e (ret t)) (tc-expr/check e (ret t))
t)))] t)))]
[(tc-result1: (app resolve (HeterogeneousVector: ts))) [(tc-result1: (app resolve (HeterogeneousVector: ts)))
(unless (= (length ts) (syntax-length #'(args ...))) (cond
(tc-error/expr "expected vector with ~a elements, but got ~a" [(= (length ts) (syntax-length #'(args ...)))
(length ts) (ret
(make-HeterogeneousVector (stx-map tc-expr/t #'(args ...))))) (make-HeterogeneousVector
(for ([e (in-syntax #'(args ...))] (for/list ([e (in-syntax #'(args ...))]
[t (in-list ts)]) [t (in-list ts)])
(tc-expr/check e (ret t))) (tc-expr/check/t e (ret t))))
expected] -true-filter)]
[else
(tc-error/expr #:return (ret -Bottom)
"expected vector with ~a elements, but got ~a"
(length ts) (make-HeterogeneousVector (stx-map tc-expr/t #'(args ...))))])]
;; If the expected type is a union, then we examine just the parts ;; If the expected type is a union, then we examine just the parts
;; of the union that are vectors. If there's only one of those, ;; of the union that are vectors. If there's only one of those,
;; we re-run this whole algorithm with that. Otherwise, we treat ;; we re-run this whole algorithm with that. Otherwise, we treat

5
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/fail/heterogeneous-vector-bad-ann.rkt Normal file
View File

@ -0,0 +1,5 @@
#;
(exn-pred 2)
#lang typed/racket
(ann (vector (ann 1 Symbol)) (Vector Number Symbol))

5
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt
View File

@ -2593,6 +2593,11 @@
[tc-e (reverse (list 'x 'y)) [tc-e (reverse (list 'x 'y))
#:ret (ret (-Tuple (list (-val 'y) (-val 'x)))) #:ret (ret (-Tuple (list (-val 'y) (-val 'x))))
#:expected (ret (-Tuple (list (-val 'y) (-val 'x))) -no-filter -no-obj)] #:expected (ret (-Tuple (list (-val 'y) (-val 'x))) -no-filter -no-obj)]
[tc-err (vector 1 2)
#:ret (ret (make-HeterogeneousVector (list -Byte -Byte)) -false-filter -empty-obj)
#:expected (ret (make-HeterogeneousVector (list -Byte -Byte)) -false-filter -no-obj)]
) )
(test-suite (test-suite
"tc-literal tests" "tc-literal tests"