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

Make inst fail on results that are not single valued.

Browse Source
This commit is contained in:
Eric Dobson 2014-05-13 22:58:44 -07:00
parent 2533effb2f
commit 62ff915a56
2 changed files with 14 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expression.rkt
View File

@ -42,23 +42,18 @@
(define (do-inst tc-res inst) (define (do-inst tc-res inst)
(define inst-type (define inst-type
(if (row-syntax? inst) do-row-inst do-normal-inst)) (if (row-syntax? inst) do-row-inst do-normal-inst))
(define (error-case tys) (define (error-case number)
(tc-error/expr (tc-error/expr
"Cannot instantiate expression that produces ~a values" "Cannot instantiate expression that produces ~a values"
(if (null? tys) 0 "multiple"))) number))
(match tc-res (match tc-res
[(tc-results: tys fs os) [(tc-results: tys fs os)
(match tys (match tys
[(list ty) [(list ty)
(ret (list (inst-type ty inst)) fs os)] (ret (list (inst-type ty inst)) fs os)]
[_ [_ (error-case (if (null? tys) 0 "multiple"))])]
(error-case tys)])] [_ (error-case "multiple")]))
[(tc-results: tys fs os dty dbound)
(match tys
[(list ty)
(ret (list (inst-type ty inst)) fs os dty dbound)]
[_
(error-case tys)])]))
;; row-syntax? Syntax -> Boolean ;; row-syntax? Syntax -> Boolean
;; This checks if the syntax object resulted from a row instantiation ;; This checks if the syntax object resulted from a row instantiation

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

@ -2969,6 +2969,15 @@
(ret (-polydots (a ...) (ret (-polydots (a ...)
(->... (list) (a a) (-values (list (->... (list) (a a) (-values (list
(t:-> Univ (-values-dots (list) (t:-> Univ -Boolean : (-FS (-filter -Symbol (list 1 0)) -top)) 'a)))))))] (t:-> Univ (-values-dots (list) (t:-> Univ -Boolean : (-FS (-filter -Symbol (list 1 0)) -top)) 'a)))))))]
[tc-err
(inst (eval '3) Any)
#:ret (ret -Bottom)]
[tc-err
(lambda xs (inst (apply values (plambda: (b) ([x : b]) x) xs) Symbol))
#:ret (ret (-polydots (a ...) (->... (list) (a a) (-values-dots (list (t:-> -Symbol -Symbol)) a 'a))))
#:expected (ret (-polydots (a ...) (->... (list) (a a) (-values-dots (list (t:-> -Symbol -Symbol)) a 'a))))]
) )
(test-suite (test-suite
"tc-literal tests" "tc-literal tests"