Fix followup to MPR#7661, Extension constructor patterns with argumentpr7661-again

are pruned to omega in default matrices. Not doing so may lead to pattern
of different types being compared, due to extension constructor confusion.

1 files changed, 18 insertions, 6 deletions

diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index 2c530dff3e..251d12885d 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -636,9 +636,19 @@ let rec what_is_cases cases = match cases with
 | _ -> assert false
 
 
-
+(********************************************)
 (* A few operations on default environments *)
-let as_matrix cases = get_mins le_pats (List.map (fun (ps,_) -> ps) cases)
+(********************************************)
+
+(* Due to extension constructor confusion, keeping those with argument in matrices
+   may violate type correctness of patterns on arguments. *)
+
+let forget_extension_with_arg ps = match ps with
+| {pat_desc=Tpat_construct (_,{cstr_tag=Cstr_extension _},_::_)}::ps -> omega::ps
+| _ -> ps
+
+let as_matrix cases =
+  get_mins le_pats (List.map (fun (ps,_) -> forget_extension_with_arg ps) cases)
 
 let cons_default matrix raise_num default =
   match matrix with
@@ -1576,11 +1586,13 @@ let divide_tuple arity p ctx pm =
 
 (* Matching against a record pattern *)
 
-
 let record_matching_line num_fields lbl_pat_list =
-  let patv = Array.make num_fields omega in
-  List.iter (fun (_, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list;
-  Array.to_list patv
+  try
+    let patv = Array.make num_fields omega in
+    List.iter (fun (_, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list;
+    Array.to_list patv
+  with Invalid_argument _ -> assert false
+  (* By typing, subject pattern and matched patterns have the same type, and hence the same labels. *)
 
 let get_args_record num_fields p rem = match p with
 | {pat_desc=Tpat_any} ->