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

Remove redundant values checks

Browse Source 
These can all be done via check-below later in the
typechecking process
This commit is contained in:
Asumu Takikawa 2016-05-06 18:55:23 -04:00
parent 743be67d67
commit 31bf61e333
3 changed files with 18 additions and 27 deletions
typed-racket-lib/typed-racket/typecheck/tc-app
tc-app-values.rkt
typed-racket-test
fail
pr13365-variation-3.rkt
unit-tests
typecheck-tests.rkt

29
typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-values.rkt
View File

@ -5,7 +5,7 @@
"utils.rkt"
syntax/parse racket/match racket/sequence
(typecheck signatures tc-funapp)
(types utils)
(types base-abbrev utils)
(for-label racket/base))
@ -34,29 +34,24 @@
[(tc-result1: tp)
(single-value #'arg expected)]
[(tc-results: ts)
(single-value #'arg) ;Type check the argument, to find other errors
(tc-error/expr
"wrong number of values: expected ~a but got one"
(length ts))]
(single-value #'arg)] ;Type check the argument, to find other errors
;; match polydots case and error
[(tc-results: ts _ _ dty dbound)
(single-value #'arg)
(tc-error/expr
"Expected ~a ..., but got only one value" dty)]))
(single-value #'arg)]))
;; handle `values' specially
(pattern (values . args)
(match expected
[(tc-results: ets efs eos)
(match-let ([(list (tc-result1: ts fs os) ...)
(for/list ([arg (in-syntax #'args)]
[et (in-list ets)]
[ef (in-list efs)]
[eo (in-list eos)])
(single-value arg (ret et ef eo)))])
(if (= (length ts) (length ets) (syntax-length #'args))
(ret ts fs os)
(tc-error/expr "wrong number of values: expected ~a but got ~a"
(length ets) (syntax-length #'args))))]
(for/list
([arg (in-syntax #'args)]
[et (in-sequences (in-list ets) (in-cycle (in-value #f)))]
[ef (in-sequences (in-list efs) (in-cycle (in-value #f)))]
[eo (in-sequences (in-list eos) (in-cycle (in-value #f)))])
(if et
(single-value arg (ret et ef eo))
(single-value arg)))])
(ret ts fs os))]
[_ (match-let ([(list (tc-result1: ts fs os) ...)
(for/list ([arg (in-syntax #'args)])
(single-value arg))])

2
typed-racket-test/fail/pr13365-variation-3.rkt
View File

@ -1,5 +1,5 @@
#;
(exn-pred #rx"Expected a ...")
(exn-pred #rx"mismatch in.*a ...")
#lang typed/racket
(: f (All (a ...) (a ... a -> (Values a ... a))))

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

@ -3023,27 +3023,23 @@
#:expected (ret (make-HeterogeneousVector (list -Byte -Byte)) -false-propset #f)]
[tc-err (values 'x)
#:ret (ret (list -Symbol -Symbol)
(list -ff-propset -ff-propset)
(list -empty-obj -empty-obj))
#:ret (ret (list -Symbol -Symbol))
#:expected (ret (list -Symbol -Symbol) (list #f #f ) (list #f #f))]
[tc-err (values 'x 'y 'z)
#:ret (ret (list -Symbol -Symbol)
(list -ff-propset -ff-propset)
(list -empty-obj -empty-obj))
#:ret (ret (list -Symbol -Symbol))
#:expected (ret (list -Symbol -Symbol) (list #f #f ) (list #f #f))]
[tc-err (values 'y)
#:ret (ret (list -Symbol) (list -ff-propset ) (list -empty-obj) Univ 'B)
#:ret (ret (list -Symbol) (list -tt-propset) (list -empty-obj) Univ 'B)
#:expected (ret (list -Symbol) (list #f ) (list #f) Univ 'B)]
[tc-err (values (values 'x 'y))
#:ret (ret (-val 'x) -ff-propset)
#:ret (ret (-val 'x))
#:expected (ret (-val 'x) #f #f)]
[tc-err (if (random) (values 1 2) 3)
#:ret (ret (-val 3) -true-propset)
#:ret (ret (-val 3) -tt-propset)
#:expected (ret (-val 3) #f #f)]
[tc-err