Add functions List.compare_lengths and List.compare_length_with (#…

…760)

Changes

@@ -8,6 +8,12 @@ Next version (tbd):
 - PR#7315, GPR#736: refine some error locations
   (Gabriel Scherer and Alain Frisch, report by Matej Košík)
 
+### Standard library:
+
+- GPR#760: Add a functions List.compare_lengths and
+  List.compare_length_with to avoid full list length computations
+  (Fabrice Le Fessant)
+
 ### Tools:
 
 - PR#7333: ocamldoc, use the first sentence of text file as

stdlib/list.ml

@@ -430,3 +430,19 @@ let sort_uniq cmp l =
   in
   let len = length l in
   if len < 2 then l else sort len l
+
+let rec compare_lengths l1 l2 =
+  match l1, l2 with
+  | [], [] -> 0
+  | [], _ -> -1
+  | _, [] -> 1
+  | _ :: l1, _ :: l2 -> compare_lengths l1 l2
+;;
+
+let rec compare_length_with l n =
+  match l, n with
+  | [], 0 -> 0
+  | [], _ -> if n > 0 then -1 else 1
+  | _, 0 -> 1
+  | _ :: l, n -> compare_length_with l (n-1)
+;;

stdlib/list.mli

@@ -29,6 +29,20 @@
 val length : 'a list -> int
 (** Return the length (number of elements) of the given list. *)
 
+val compare_lengths : 'a list -> 'b list -> int
+(** Compare the lengths of two lists. [compare_lengths l1 l2] is
+   equivalent to [compare (length l1) (length l2)], except that
+   the computation stops after itering on the shortest list.
+   @since 4.05.0
+ *)
+
+val compare_length_with : 'a list -> int -> int
+(** Compare the length of a list to an integer. [compare_length_with l n] is
+   equivalent to [compare (length l) n], except that
+   the computation stops after at most [n] iterations on the list.
+   @since 4.05.0
+*)
+
 val cons : 'a -> 'a list -> 'a list
 (** [cons x xs] is [x :: xs]
     @since 4.03.0

testsuite/tests/translprim/comparison_table.ml.reference

@@ -232,7 +232,7 @@
                 (apply f (field 0 param) (field 1 param)))
             map =
               (function f l
-                (apply (field 12 (global List!)) (apply uncurry f)
+                (apply (field 14 (global List!)) (apply uncurry f)
                   l)))
            (makeblock 0
              (makeblock 0 (apply map gen_cmp vec)
@@ -280,7 +280,7 @@
                     (apply f (field 0 param) (field 1 param)))
                 map =
                   (function f l
-                    (apply (field 12 (global List!))
+                    (apply (field 14 (global List!))
                       (apply uncurry f) l)))
                (makeblock 0
                  (makeblock 0 (apply map eta_gen_cmp vec)