From 17942318ba1742881750ab80a0e08ec11ba85fb9 Mon Sep 17 00:00:00 2001
From: Eric Dobson <eric.n.dobson@gmail.com>
Date: Sun, 18 May 2014 23:00:19 -0700
Subject: [PATCH] Add bottom as a special case in multiple value context.

original commit: 11e19caa026d2edae8ed0640b426c516eec8a943
---
 .../typed-racket/infer/infer-unit.rkt           | 17 +++++++++++++++--
 .../typed-racket/types/subtype.rkt              |  4 +++-
 .../typed-racket/unit-tests/infer-tests.rkt     |  3 +++
 .../typed-racket/unit-tests/subtype-tests.rkt   |  1 +
 4 files changed, 22 insertions(+), 3 deletions(-)

diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/infer-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/infer-unit.rkt
index e28f69c7..7ccdd633 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/infer-unit.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/infer-unit.rkt
@@ -405,9 +405,22 @@
                         (cgen/filter-set V X Y f-s f-t)
                         (cgen/object V X Y o-s o-t))]
 
-          ;; Values just delegate to cgen/seq
+          ;; Values just delegate to cgen/seq, except special handling for -Bottom.
+          ;; A single -Bottom in a Values means that there is no value returned and so any other
+          ;; Values or ValuesDots should be above it.
           [((ValuesSeq: s-seq) (ValuesSeq: t-seq))
-           (cgen/seq V X Y s-seq t-seq)]
+           ;; Check for a substition that S is below (ret -Bottom).
+           (define bottom-case
+             (match S
+               [(Values: (list (Result: s f-s o-s)))
+                (cgen V X Y s -Bottom)]
+               [else #f]))
+           (define regular-case
+             (cgen/seq V X Y s-seq t-seq))
+           ;; If we want the OR of the csets that the two cases return.
+           (cset-join
+             (filter values
+               (list bottom-case regular-case)))]
 
           ;; they're subtypes. easy.
           [(a b) 
diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/subtype.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/subtype.rkt
index 23b3ece1..253c34ee 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/subtype.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/subtype.rkt
@@ -549,7 +549,9 @@
          ;; subtyping on structs follows the declared hierarchy
          [((Struct: nm (? Type/c? parent) _ _ _ _) other)
           (subtype* A0 parent other)]
-         ;; subtyping on values is pointwise
+         ;; subtyping on values is pointwise, except special case for Bottom
+         [((Values: (list (Result: (== -Bottom) _ _))) _)
+          A0]
          [((Values: vals1) (Values: vals2)) (subtypes* A0 vals1 vals2)]
          [((ValuesDots: s-rs s-dty dbound) (ValuesDots: t-rs t-dty dbound))
           (subtype-seq A0
diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/infer-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/infer-tests.rkt
index f91bff3d..090aacd8 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/infer-tests.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/infer-tests.rkt
@@ -225,6 +225,9 @@
     [infer-t (-lst* -String) (make-ListDots -Symbol 'b) #:indices '(b) #:fail]
     [infer-t (->* (list -Symbol) -Symbol -Void) (->* (list) (-v a) -Void) #:vars '(a) #:fail]
 
+    [infer-t (-> (-values (list -Bottom))) (-> (-values (list (-v b) (-v b)))) #:vars '(a)]
+    [infer-t (-> (-values (list (-v a)))) (-> (-values (list (-v b) (-v b)))) #:vars '(a)]
+
     ;; Currently Broken
     ;(infer-t (make-ListDots -Symbol 'b) (-pair -Symbol (-lst -Symbol)) #:indices '(b))
     [i2-t (-v a) N ('a N)]
diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/subtype-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/subtype-tests.rkt
index 5200cc3a..aaceec05 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/subtype-tests.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/subtype-tests.rkt
@@ -262,6 +262,7 @@
    [(make-ListDots (-> -Symbol (make-F 'a)) 'a) (-lst (-> -Symbol Univ))]
 
    [FAIL (make-ValuesDots (list) -Symbol 'a) (make-ValuesDots (list (-result -String)) -String 'a)]
+   [(-values (list -Bottom)) (-values (list -String -Symbol))]
 
    ;; keyword function types
    [(->key #:x -Symbol #f Univ) (->key Univ)]