From af3088957a8f7a341b0ccee0ca85f70789f93ac4 Mon Sep 17 00:00:00 2001
From: Nicolas Chataing <nicolas.chataing@ens.fr>
Date: Tue, 22 Jun 2021 14:16:39 +0200
Subject: [PATCH] Add tests

---
 .../test_unboxed_constr.ml                    | 68 +++++++++++++++++++
 .../test_unboxed_constr_matching.ml           | 28 ++++++++
 2 files changed, 96 insertions(+)
 create mode 100644 testsuite/tests/typing-unboxed-types/test_unboxed_constr.ml
 create mode 100644 testsuite/tests/typing-unboxed-types/test_unboxed_constr_matching.ml

diff --git a/testsuite/tests/typing-unboxed-types/test_unboxed_constr.ml b/testsuite/tests/typing-unboxed-types/test_unboxed_constr.ml
new file mode 100644
index 000000000000..13ac27641949
--- /dev/null
+++ b/testsuite/tests/typing-unboxed-types/test_unboxed_constr.ml
@@ -0,0 +1,68 @@
+(* TEST
+   flags = "-dheadshape"
+   * expect
+*)
+
+(* Check the unboxing of constructors *)
+type t = A of int | B;;
+[%%expect{|
+SHAPE(t/88[1]) {head_imm = Shape_set [0]; head_blocks = Shape_set [0]}
+type t = A of int | B
+|}];;
+
+type t = A of int | B of float | C | D;;
+[%%expect{|
+SHAPE(t/91[2]) {head_imm = Shape_set [0; 1]; head_blocks = Shape_set [0; 1]}
+type t = A of int | B of float | C | D
+|}];;
+
+type t = A of int [@unboxed] | B;;
+[%%expect{|
+SHAPE(t/96[3]) CONFLICT
+type t = A of int | B
+|}];;
+
+type t = A of float [@unboxed] | B;;
+[%%expect{|
+SHAPE(t/99[4]) {head_imm = Shape_set [0]; head_blocks = Shape_set [253]}
+type t = A of float | B
+|}];;
+
+type t = A of float [@unboxed] | B of string [@unboxed] | C | D of int;;
+[%%expect{|
+SHAPE(t/102[5]) {head_imm = Shape_set [0]; head_blocks = Shape_set [0; 252; 253]}
+type t = A of float | B of string | C | D of int
+|}];;
+
+type t = K of int u u [@unboxed]
+and 'a u = 'a id
+and 'a id = Id of 'a [@unboxed];;
+[%%expect{|
+SHAPE(t/107[6]) {head_imm = Shape_any; head_blocks = Shape_set []}
+SHAPE(id/109[6]) {head_imm = Shape_any; head_blocks = Shape_any}
+type t = K of int u u
+and 'a u = 'a id
+and 'a id = Id of 'a
+|}];;
+
+type t = { a : int } [@@unboxed]
+and tt = A of t [@unboxed];;
+[%%expect{|
+SHAPE(tt/113[7]) {head_imm = Shape_any; head_blocks = Shape_set []}
+type t = { a : int; } [@@unboxed]
+and tt = A of t
+|}];;
+
+type t = A of { a : int } [@unboxed];;
+[%%expect{|
+SHAPE(t/116[8]) {head_imm = Shape_any; head_blocks = Shape_set []}
+type t = A of { a : int; }
+|}];;
+
+type ('a, 'r) u = 'r
+and 'a t = A of { body : 'r. ('a, 'r) u } [@unboxed];;
+[%%expect{|
+SHAPE(t/120[9]) {head_imm = Shape_any; head_blocks = Shape_any}
+type ('a, 'r) u = 'r
+and 'a t = A of { body : 'r. ('a, 'r) u; }
+|}];;
diff --git a/testsuite/tests/typing-unboxed-types/test_unboxed_constr_matching.ml b/testsuite/tests/typing-unboxed-types/test_unboxed_constr_matching.ml
new file mode 100644
index 000000000000..3dbbc8e8b793
--- /dev/null
+++ b/testsuite/tests/typing-unboxed-types/test_unboxed_constr_matching.ml
@@ -0,0 +1,28 @@
+(* TEST
+*)
+
+module A = struct
+  type t = A of int | B of float [@unboxed]
+
+  let f = function A _ -> 0 | B _ -> 1
+
+  let test () =
+    assert (f (A 0) = 0);
+    assert (f (B 0.) = 1)
+end
+
+let () = A.test ()
+
+module B = struct
+  type t = A of int | B of float
+  type tt = A' of t [@unboxed] | B'
+
+  let f = function A' _ -> 0 | B' -> 1
+
+  let test () =
+    assert (f (A' (A 0)) = 0);
+    assert (f (A' (B 0.)) = 0);
+    assert (f B' = 1)
+end
+
+let () = B.test ()