From 7253269fb62712e7e8fd94d5d0264d5bed9e8406 Mon Sep 17 00:00:00 2001
From: Alasdair
Date: Wed, 20 Feb 2019 22:31:51 +0000
Subject: Fix bug with missing satisfiablity check in subtyping

Thanks to Mark for finding this bug. Regression test is
complex_exist_sat in test/typecheck/pass/
---
 src/type_check.ml                               | 14 +++++++++++---
 test/typecheck/pass/complex_exist_sat.sail      |  7 +++++++
 test/typecheck/pass/complex_exist_sat/v1.expect |  8 ++++++++
 test/typecheck/pass/complex_exist_sat/v1.sail   |  3 +++
 test/typecheck/pass/complex_exist_sat/v2.expect |  8 ++++++++
 test/typecheck/pass/complex_exist_sat/v2.sail   |  3 +++
 6 files changed, 40 insertions(+), 3 deletions(-)
 create mode 100644 test/typecheck/pass/complex_exist_sat.sail
 create mode 100644 test/typecheck/pass/complex_exist_sat/v1.expect
 create mode 100644 test/typecheck/pass/complex_exist_sat/v1.sail
 create mode 100644 test/typecheck/pass/complex_exist_sat/v2.expect
 create mode 100644 test/typecheck/pass/complex_exist_sat/v2.sail

diff --git a/src/type_check.ml b/src/type_check.ml
index 3d0f38a6..8de4a904 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -1976,9 +1976,17 @@ let rec subtyp l env typ1 typ2 =
      let env = add_typ_vars l (List.map (mk_kopt K_int) (KidSet.elements (KidSet.inter (nexp_frees nexp2) (KidSet.of_list kids2)))) env in
      let kids2 = KidSet.elements (KidSet.diff (KidSet.of_list kids2) (nexp_frees nexp2)) in
      if not (kids2 = []) then typ_error env l ("Universally quantified constraint generated: " ^ Util.string_of_list ", " string_of_kid kids2) else ();
-     let env = Env.add_constraint (nc_eq nexp1 nexp2) env in
-     if prove __POS__ env nc2 then ()
-     else typ_raise env l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env))
+     let vars = KBindings.filter (fun _ k -> match k with K_int | K_bool -> true | _ -> false) (Env.get_typ_vars env) in
+     begin match Constraint.call_smt l vars (nc_eq nexp1 nexp2) with
+     | Constraint.Sat ->
+        let env = Env.add_constraint (nc_eq nexp1 nexp2) env in
+        if prove __POS__ env nc2 then
+          ()
+        else
+          typ_raise env l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env))
+     | _ ->
+        typ_error env l ("Constraint " ^ string_of_n_constraint (nc_eq nexp1 nexp2) ^ " is not satisfiable")
+     end
   | _, _ ->
   match typ_aux1, typ_aux2 with
   | _, Typ_internal_unknown when Env.allow_unknowns env -> ()
diff --git a/test/typecheck/pass/complex_exist_sat.sail b/test/typecheck/pass/complex_exist_sat.sail
new file mode 100644
index 00000000..65c3b6a9
--- /dev/null
+++ b/test/typecheck/pass/complex_exist_sat.sail
@@ -0,0 +1,7 @@
+val foo : int ->  {'q, 'q in {0, 1}. atom(2 * 'q)}
+
+function foo(x) = 2
+
+val bar : int ->  {'q, 'q in {0, 1}. atom(2 * 'q)}
+
+function bar(x) = 0
diff --git a/test/typecheck/pass/complex_exist_sat/v1.expect b/test/typecheck/pass/complex_exist_sat/v1.expect
new file mode 100644
index 00000000..b1937f47
--- /dev/null
+++ b/test/typecheck/pass/complex_exist_sat/v1.expect
@@ -0,0 +1,8 @@
+Type error:
+[complex_exist_sat/v1.sail]:3:18-19
+3 |function foo(x) = 3
+  |                  ^
+  | Tried performing type coercion from int(3) to {('q : Int), 'q in {0, 1}. int((2 * 'q))} on 3
+  | Coercion failed because:
+  | Constraint 3 == (2 * 'ex1#) is not satisfiable
+  | 
diff --git a/test/typecheck/pass/complex_exist_sat/v1.sail b/test/typecheck/pass/complex_exist_sat/v1.sail
new file mode 100644
index 00000000..f36f2dda
--- /dev/null
+++ b/test/typecheck/pass/complex_exist_sat/v1.sail
@@ -0,0 +1,3 @@
+val foo : int ->  {'q, 'q in {0, 1}. atom(2 * 'q)}
+
+function foo(x) = 3
\ No newline at end of file
diff --git a/test/typecheck/pass/complex_exist_sat/v2.expect b/test/typecheck/pass/complex_exist_sat/v2.expect
new file mode 100644
index 00000000..27af46d2
--- /dev/null
+++ b/test/typecheck/pass/complex_exist_sat/v2.expect
@@ -0,0 +1,8 @@
+Type error:
+[complex_exist_sat/v2.sail]:3:18-19
+3 |function foo(x) = 4
+  |                  ^
+  | Tried performing type coercion from int(4) to {('q : Int), 'q in {0, 1}. int((2 * 'q))} on 4
+  | Coercion failed because:
+  | int(4) is not a subtype of {('q : Int), 'q in {0, 1}. int((2 * 'q))}
+  | 
diff --git a/test/typecheck/pass/complex_exist_sat/v2.sail b/test/typecheck/pass/complex_exist_sat/v2.sail
new file mode 100644
index 00000000..e3e18e8c
--- /dev/null
+++ b/test/typecheck/pass/complex_exist_sat/v2.sail
@@ -0,0 +1,3 @@
+val foo : int ->  {'q, 'q in {0, 1}. atom(2 * 'q)}
+
+function foo(x) = 4
\ No newline at end of file
-- 
cgit v1.2.3