Fix PR#7378

Changes

@@ -307,6 +307,9 @@ OCaml 4.04.0:
 - PR#7330: Missing exhaustivity check for extensible variant
   (Jacques Garrigue, report by Elarnon *)
 
+- PR#7378: GADT constructors can be re-exposed with an incompatible type
+  (Jacques Garrigue, report by Alain Frisch)
+
 * GPR#533: Thread library: fixed [Thread.wait_signal] so that it
   converts back the signal number returned by [sigwait] to an
   OS-independent number

testsuite/tests/typing-gadts/pr7378.ml

@@ -0,0 +1,23 @@
+module X = struct
+  type t =
+    | A : 'a * 'b * ('a -> unit) -> t
+end;;
+[%%expect{|
+module X : sig type t = A : 'a * 'b * ('a -> unit) -> t end
+|}]
+
+module Y = struct
+  type t = X.t =
+    | A : 'a * 'b * ('b -> unit) -> t
+end;; (* should fail *)
+[%%expect{|
+Line _, characters 2-54:
+Error: This variant or record definition does not match that of type X.t
+       The types for field A are not equal.
+|}]
+
+(* would segfault
+let () =
+  match Y.A (1, "", print_string) with
+  | X.A (x, y, f) -> f x
+*)

typing/includecore.ml

@@ -171,9 +171,9 @@ let rec compare_constructor_arguments env cstr params1 params2 arg1 arg2 =
   match arg1, arg2 with
   | Types.Cstr_tuple arg1, Types.Cstr_tuple arg2 ->
       if List.length arg1 <> List.length arg2 then [Field_arity cstr]
-      else if Misc.for_all2
-          (fun ty1 ty2 -> Ctype.equal env true (ty1::params1) (ty2::params2))
-          (arg1) (arg2)
+      else if
+        (* Ctype.equal must be called on all arguments at once, cf. PR#7378 *)
+        Ctype.equal env true (params1 @ arg1) (params2 @ arg2)
       then [] else [Field_type cstr]
   | Types.Cstr_record l1, Types.Cstr_record l2 ->
       compare_records env params1 params2 0 l1 l2
@@ -217,7 +217,7 @@ and compare_records env params1 params2 n labels1 labels2 =
       else if mut1 <> mut2 then [Field_mutable lab1] else
       if Ctype.equal env true (arg1::params1)
                               (arg2::params2)
-      then compare_records env params1 params2 (n+1) rem1 rem2
+      then compare_records env (arg1::params1) (arg2::params2) (n+1) rem1 rem2
       else [Field_type lab1]
 
 let type_declarations ?(equality = false) env name decl1 id decl2 =