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

Fixup anyvalue handling in call-with-values.

Browse Source 
Closes PR 14214.
This commit is contained in:
Eric Dobson 2013-12-02 08:55:18 -08:00
parent 695f73bad7
commit 960da4579a
4 changed files with 17 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt
View File

@ -973,7 +973,11 @@
(-> (-values null)) (-> (-values null))
(->acc (list a) a null) (->acc (list a) a null)
((list a) (b b) . ->... . (make-ValuesDots (list (-result a)) b 'b))))] ((list a) (b b) . ->... . (make-ValuesDots (list (-result a)) b 'b))))]
[call-with-values (-polydots (b a) ((-> (make-ValuesDots null a 'a)) (null (a a) . ->... . b) . -> . b))] [call-with-values
(-polydots (b a)
(cl->*
((-> (make-ValuesDots null a 'a)) (null (a a) . ->... . b) . -> . b)
((-> ManyUniv) ((list) Univ . ->* . b) . -> . b)))]
;; Section 10.2 ;; Section 10.2
[raise (cl->* (Univ . -> . (Un)) [raise (cl->* (Univ . -> . (Un))

4
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-combined.rkt
View File

@ -20,5 +20,7 @@
(export tc-app^) (export tc-app^)
(link tc-app-main@ (link tc-app-main@
tc-app-hetero@ tc-app-list@ tc-app-apply@ tc-app-values@ tc-app-keywords@ tc-app-hetero@ tc-app-list@ tc-app-apply@
(() tc-app-values@)
tc-app-keywords@
tc-app-objects@ tc-app-eq@ tc-app-lambda@ tc-app-special@)) tc-app-objects@ tc-app-eq@ tc-app-lambda@ tc-app-special@))

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

@ -10,7 +10,7 @@
(for-template racket/base)) (for-template racket/base))
(import tc-expr^) (import tc-expr^ tc-app^)
(export tc-app-values^) (export tc-app-values^)
(define-tc/app-syntax-class (tc/app-values expected) (define-tc/app-syntax-class (tc/app-values expected)
@ -19,8 +19,9 @@
(pattern (call-with-values prod con) (pattern (call-with-values prod con)
(match (tc/funapp #'prod #'() (single-value #'prod) null #f) (match (tc/funapp #'prod #'() (single-value #'prod) null #f)
[(tc-results: ts fs os) [(tc-results: ts fs os)
(tc/funapp #'con #'(prod) (single-value #'con) (map ret ts fs os) expected)])) (tc/funapp #'con #'(prod) (single-value #'con) (map ret ts fs os) expected)]
[(tc-any-results:)
(tc/app-regular this-syntax expected)]))
;; special case for `values' with single argument ;; special case for `values' with single argument
;; we just ignore the values, except that it forces arg to return one value ;; we just ignore the values, except that it forces arg to return one value
(pattern (values arg) (pattern (values arg)

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

@ -1915,6 +1915,11 @@
(getter 'bad 0))] (getter 'bad 0))]
[tc-err (struct-type-make-constructor 'bad)] [tc-err (struct-type-make-constructor 'bad)]
[tc-err (struct-type-make-predicate 'bad)] [tc-err (struct-type-make-predicate 'bad)]
[tc-e
(call-with-values (lambda () (eval #'(+ 1 2))) (inst list Any))
(-lst Univ)]
) )
(test-suite (test-suite
"tc-literal tests" "tc-literal tests"