18 files changed, 152 insertions, 0 deletions

diff --git a/testsuite/tests/letrec/Makefile b/testsuite/tests/letrec/Makefile
new file mode 100644
index 0000000000..bcc2fdb011
--- /dev/null
+++ b/testsuite/tests/letrec/Makefile
@@ -0,0 +1,4 @@
+BASEDIR=../..
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/letrec/backreferences.ml b/testsuite/tests/letrec/backreferences.ml
new file mode 100644
index 0000000000..4a893225b1
--- /dev/null
+++ b/testsuite/tests/letrec/backreferences.ml
@@ -0,0 +1,18 @@
+(* testing backreferences; some compilation scheme may handle
+   differently recursive references to a mutually-recursive RHS
+   depending on whether it is before or after in the bindings list *)
+type t = { x : t; y : t; z : t }
+
+let test =
+  let rec x = { x; y; z }
+      and y = { x; y; z }
+      and z = { x; y; z }
+  in
+  List.iter (fun (f, t_ref) ->
+    List.iter (fun t -> assert (f t == t_ref)) [x; y; z]
+  )
+    [
+      (fun t -> t.x), x;
+      (fun t -> t.y), y;
+      (fun t -> t.z), z;
+    ]
diff --git a/testsuite/tests/letrec/class_1.ml b/testsuite/tests/letrec/class_1.ml
new file mode 100644
index 0000000000..a7d0338802
--- /dev/null
+++ b/testsuite/tests/letrec/class_1.ml
@@ -0,0 +1,5 @@
+(* class expression are compiled to recursive bindings *)
+class test =
+object
+  method x = 1
+end
diff --git a/testsuite/tests/letrec/class_2.ml b/testsuite/tests/letrec/class_2.ml
new file mode 100644
index 0000000000..71c7880d67
--- /dev/null
+++ b/testsuite/tests/letrec/class_2.ml
@@ -0,0 +1,8 @@
+(* class expressions may also contain local recursive bindings *)
+class test =
+  let rec f = print_endline "f"; fun x -> g x
+      and g = print_endline "g"; fun x -> f x in
+object
+  method f : 'a 'b. 'a -> 'b = f
+  method g : 'a 'b. 'a -> 'b = g
+end
diff --git a/testsuite/tests/letrec/class_2.reference b/testsuite/tests/letrec/class_2.reference
new file mode 100644
index 0000000000..ab713757f4
--- /dev/null
+++ b/testsuite/tests/letrec/class_2.reference
@@ -0,0 +1,2 @@
+f
+g
diff --git a/testsuite/tests/letrec/evaluation_order_1.ml b/testsuite/tests/letrec/evaluation_order_1.ml
new file mode 100644
index 0000000000..5b88844d7e
--- /dev/null
+++ b/testsuite/tests/letrec/evaluation_order_1.ml
@@ -0,0 +1,20 @@
+(* test evaluation order
+
+   'y' is translated into a constant, and is therefore considered
+   non-recursive. With the current letrec compilation method,
+   it should be evaluated before x and z.
+*)
+type tree = Tree of tree list
+
+let test =
+  let rec x = (print_endline "x"; Tree [y; z])
+  and y = (print_endline "y"; Tree [])
+  and z = (print_endline "z"; Tree [x])
+  in
+  match (x, y, z) with
+    | (Tree [y1; z1], Tree[], Tree[x1]) ->
+      assert (y1 == y);
+      assert (z1 == z);
+      assert (x1 == x)
+    | _ ->
+      assert false
diff --git a/testsuite/tests/letrec/evaluation_order_1.reference b/testsuite/tests/letrec/evaluation_order_1.reference
new file mode 100644
index 0000000000..f471662b7d
--- /dev/null
+++ b/testsuite/tests/letrec/evaluation_order_1.reference
@@ -0,0 +1,3 @@
+y
+x
+z
diff --git a/testsuite/tests/letrec/evaluation_order_2.ml b/testsuite/tests/letrec/evaluation_order_2.ml
new file mode 100644
index 0000000000..736f82ad32
--- /dev/null
+++ b/testsuite/tests/letrec/evaluation_order_2.ml
@@ -0,0 +1,18 @@
+(* A variant of evaluation_order_1.ml where the side-effects
+   are inside the blocks. Note that this changes the evaluation
+   order, as y is considered recursive.
+*)
+type tree = Tree of tree list
+
+let test =
+  let rec x = (Tree [(print_endline "x"; y); z])
+  and y = Tree (print_endline "y"; [])
+  and z = Tree (print_endline "z"; [x])
+  in
+  match (x, y, z) with
+    | (Tree [y1; z1], Tree[], Tree[x1]) ->
+      assert (y1 == y);
+      assert (z1 == z);
+      assert (x1 == x)
+    | _ ->
+      assert false
diff --git a/testsuite/tests/letrec/evaluation_order_2.reference b/testsuite/tests/letrec/evaluation_order_2.reference
new file mode 100644
index 0000000000..04ec35a6dc
--- /dev/null
+++ b/testsuite/tests/letrec/evaluation_order_2.reference
@@ -0,0 +1,3 @@
+x
+y
+z
diff --git a/testsuite/tests/letrec/evaluation_order_3.ml b/testsuite/tests/letrec/evaluation_order_3.ml
new file mode 100644
index 0000000000..8f76a8f858
--- /dev/null
+++ b/testsuite/tests/letrec/evaluation_order_3.ml
@@ -0,0 +1,11 @@
+type t = { x : t; y : t }
+
+let p = print_endline
+
+let test =
+  let rec x = p "x"; { x = (p "x_x"; x); y = (p "x_y"; y) }
+      and y = p "y"; { x = (p "y_x"; x); y = (p "y_y"; y) }
+   in
+   assert (x.x == x); assert (x.y == y);
+   assert (y.x == x); assert (y.y == y);
+   ()
diff --git a/testsuite/tests/letrec/evaluation_order_3.reference b/testsuite/tests/letrec/evaluation_order_3.reference
new file mode 100644
index 0000000000..5b8c549eca
--- /dev/null
+++ b/testsuite/tests/letrec/evaluation_order_3.reference
@@ -0,0 +1,6 @@
+x
+x_y
+x_x
+y
+y_y
+y_x
diff --git a/testsuite/tests/letrec/float_block_1.ml b/testsuite/tests/letrec/float_block_1.ml
new file mode 100644
index 0000000000..cdfa9d2f85
--- /dev/null
+++ b/testsuite/tests/letrec/float_block_1.ml
@@ -0,0 +1,10 @@
+(* a bug in cmmgen.ml provokes a change in compilation order between
+   ocamlc and ocamlopt in certain letrec-bindings involving float
+   arrays *)
+let test =
+  let rec x = print_endline "x"; [| 1; 2; 3 |]
+      and y = print_endline "y"; [| 1.; 2.; 3. |]
+  in
+  assert (x = [| 1; 2; 3 |]);
+  assert (y = [| 1.; 2.; 3. |]);
+  ()
diff --git a/testsuite/tests/letrec/float_block_1.reference b/testsuite/tests/letrec/float_block_1.reference
new file mode 100644
index 0000000000..b77b4eb1d9
--- /dev/null
+++ b/testsuite/tests/letrec/float_block_1.reference
@@ -0,0 +1,2 @@
+x
+y
diff --git a/testsuite/tests/letrec/float_block_2.ml b/testsuite/tests/letrec/float_block_2.ml
new file mode 100644
index 0000000000..968cba4eb1
--- /dev/null
+++ b/testsuite/tests/letrec/float_block_2.ml
@@ -0,0 +1,7 @@
+(* a bug in cmmgen.ml provokes a segfault in certain natively compiled
+   letrec-bindings involving float arrays *)
+let test =
+  let rec x = [| y; y |] and y = 1. in
+  assert (x = [| 1.; 1. |]);
+  assert (y = 1.);
+  ()
diff --git a/testsuite/tests/letrec/lists.ml b/testsuite/tests/letrec/lists.ml
new file mode 100644
index 0000000000..5686e49357
--- /dev/null
+++ b/testsuite/tests/letrec/lists.ml
@@ -0,0 +1,8 @@
+(* a test with lists, because cyclic lists are fun *)
+let test =
+  let rec li = 0::1::2::3::4::5::6::7::8::9::li in
+  match li with
+    | 0::1::2::3::4::5::6::7::8::9::
+        0::1::2::3::4::5::6::7::8::9::li' ->
+      assert (li == li')
+    | _ -> assert false
diff --git a/testsuite/tests/letrec/mixing_value_closures_1.ml b/testsuite/tests/letrec/mixing_value_closures_1.ml
new file mode 100644
index 0000000000..e79f79ecbe
--- /dev/null
+++ b/testsuite/tests/letrec/mixing_value_closures_1.ml
@@ -0,0 +1,8 @@
+(* mixing values and closures may exercise interesting code paths *)
+type t = A of (int -> int)
+let test =
+  let rec x = A f
+  and f = function
+    | 0 -> 2
+    | n -> match x with A g -> g 0
+  in assert (f 1 = 2)
diff --git a/testsuite/tests/letrec/mixing_value_closures_2.ml b/testsuite/tests/letrec/mixing_value_closures_2.ml
new file mode 100644
index 0000000000..eb5fcb7420
--- /dev/null
+++ b/testsuite/tests/letrec/mixing_value_closures_2.ml
@@ -0,0 +1,8 @@
+(* a polymorphic variant of test3.ml; found a real bug once *)
+let test =
+  let rec x = `A f
+  and f = function
+    | 0 -> 2
+    | n -> match x with `A g -> g 0
+  in
+  assert (f 1 = 2)
diff --git a/testsuite/tests/letrec/mutual_functions.ml b/testsuite/tests/letrec/mutual_functions.ml
new file mode 100644
index 0000000000..a5b6c51ffe
--- /dev/null
+++ b/testsuite/tests/letrec/mutual_functions.ml
@@ -0,0 +1,11 @@
+(* a simple test with mutually recursive functions *)
+let test =
+  let rec even = function
+    | 0 -> true
+    | n -> odd (n - 1)
+  and odd = function
+    | 0 -> false
+    | n -> even (n - 1)
+  in
+  List.iter (fun i -> assert (even i <> odd i && even i = (i mod 2 = 0)))
+    [0;1;2;3;4;5;6]