PR#7403: fix a bug in Set.map (new in 4.04.0)

(cherry-pick from the 4.04 branch)

Changes

@@ -92,6 +92,14 @@ Next version (4.05.0):
   to a string array of new arguments
   (Bernhard Schommer)
 
+Next minor version (4.04.1):
+----------------------------
+
+### Standard library:
+
+- PR#7403, GPR#894: fix a bug in Set.map as introduced in 4.04.0
+  (Gabriel Scherer, report by Thomas Leonard)
+
 OCaml 4.04.0 (4 Nov 2016):
 --------------------------
 

stdlib/set.ml

@@ -398,6 +398,15 @@ module Make(Ord: OrderedType) =
           if c = 0 then Some v
           else find_opt x (if c < 0 then l else r)
 
+    let try_join l v r =
+      (* [join l v r] can only be called when (elements of l < v <
+         elements of r); use [try_join l v r] when this property may
+         not hold, but you hope it does hold in the common case *)
+      if (l = Empty || Ord.compare (max_elt l) v < 0)
+      && (r = Empty || Ord.compare v (min_elt r) < 0)
+      then join l v r
+      else union l (add v r)
+
     let rec map f = function
       | Empty -> Empty
       | Node (l, v, r, _) as t ->
@@ -406,12 +415,7 @@ module Make(Ord: OrderedType) =
          let v' = f v in
          let r' = map f r in
          if l == l' && v == v' && r == r' then t
-         else begin
-             if (l' = Empty || Ord.compare (max_elt l') v < 0)
-                && (r' = Empty || Ord.compare v (min_elt r') < 0)
-             then join l' v' r'
-             else union l' (add v' r')
-         end
+         else try_join l' v' r'
 
     let of_sorted_list l =
       let rec sub n l =

testsuite/tests/lib-set/testset.ml

@@ -167,3 +167,21 @@ let () =
   for i = 1 to 10 do s1 := S.add i !s1 done;
   let s2 = S.filter (fun e -> e >= 0) !s1 in
   assert (s2 == !s1)
+
+let valid_structure s =
+  (* this test should return 'true' for all set,
+     but it can detect sets that are ill-structured,
+     for example incorrectly ordered, as the S.mem
+     function will make assumptions about the set ordering.
+
+     (This trick was used to exhibit the bug in PR#7403)
+  *)
+  List.for_all (fun n -> S.mem n s) (S.elements s)
+
+let () =
+  (* PR#7403: map buggily orders elements according to the input
+     set order, not the output set order. Mapping functions that
+     change the value ordering thus break the set structure. *)
+  let test = S.of_list [1; 3; 5] in
+  let f = function 3 -> 8 | n -> n in
+  assert (valid_structure (S.map f test))