Merge pull request #1538 from trefis/robuster-matching

Make pattern matching compilation more robust to ill-typed columns

Changes

@@ -182,6 +182,9 @@ Working version
 - GPR#1470: Don't commute negation with float comparison
   (Leo White, review by Xavier Leroy)
 
+- GPR#1538: Make pattern matching compilation more robust to ill-typed columns
+  (Gabriel Scherer and Thomas Refis, review by Luc Maranget)
+
 OCaml 4.06.0 (3 Nov 2017):
 --------------------------
 

bytecomp/matching.ml

@@ -224,24 +224,29 @@ let ctx_matcher p =
   | Tpat_array omegas ->
       let len = List.length omegas in
       (fun q rem -> match q.pat_desc with
-      | Tpat_array args when List.length args=len ->
-          p,args @ rem
+      | Tpat_array args when List.length args = len -> p,args @ rem
       | Tpat_any -> p, omegas @ rem
       | _ -> raise NoMatch)
   | Tpat_tuple omegas ->
+      let len = List.length omegas  in
       (fun q rem -> match q.pat_desc with
-      | Tpat_tuple args -> p,args @ rem
-      | _          -> p, omegas @ rem)
-  | Tpat_record (l,_) -> (* Records are normalized *)
+      | Tpat_tuple args when List.length args = len -> p,args @ rem
+      | Tpat_any -> p, omegas @ rem
+      | _ -> raise NoMatch)
+  | Tpat_record (((_, lbl, _) :: _) as l,_) -> (* Records are normalized *)
+      let len = Array.length lbl.lbl_all in
       (fun q rem -> match q.pat_desc with
-      | Tpat_record (l',_) ->
+      | Tpat_record (((_, lbl', _) :: _) as l',_)
+        when Array.length lbl'.lbl_all = len ->
           let l' = all_record_args l' in
           p, List.fold_right (fun (_, _,p) r -> p::r) l' rem
-      | _ -> p,List.fold_right (fun (_, _,p) r -> p::r) l rem)
+      | Tpat_any -> p,List.fold_right (fun (_, _,p) r -> p::r) l rem
+      | _ -> raise NoMatch)
   | Tpat_lazy omega ->
       (fun q rem -> match q.pat_desc with
       | Tpat_lazy arg -> p, (arg::rem)
-      | _          -> p, (omega::rem))
+      | Tpat_any      -> p, (omega::rem)
+      | _             -> raise NoMatch)
  | _ -> fatal_error "Matching.ctx_matcher"
 
 
@@ -1440,8 +1445,10 @@ let get_arg_lazy p rem = match p with
 
 let matcher_lazy p rem = match p.pat_desc with
 | Tpat_or (_,_,_)     -> raise OrPat
-| Tpat_var _          -> get_arg_lazy omega rem
-| _                   -> get_arg_lazy p rem
+| Tpat_any
+| Tpat_var _          -> omega :: rem
+| Tpat_lazy arg       -> arg :: rem
+| _                   -> raise NoMatch
 
 (* Inlining the tag tests before calling the primitive that works on
    lazy blocks. This is also used in translcore.ml.
@@ -1567,8 +1574,10 @@ let get_args_tuple arity p rem = match p with
 
 let matcher_tuple arity p rem = match p.pat_desc with
 | Tpat_or (_,_,_)     -> raise OrPat
-| Tpat_var _          -> get_args_tuple arity omega rem
-| _                   ->  get_args_tuple arity p rem
+| Tpat_any
+| Tpat_var _ -> omegas arity @ rem
+| Tpat_tuple args when List.length args = arity -> args @ rem
+| _ ->  raise NoMatch
 
 let make_tuple_matching loc arity def = function
     [] -> fatal_error "Matching.make_tuple_matching"
@@ -1604,8 +1613,14 @@ let get_args_record num_fields p rem = match p with
 
 let matcher_record num_fields p rem = match p.pat_desc with
 | Tpat_or (_,_,_) -> raise OrPat
-| Tpat_var _      -> get_args_record num_fields omega rem
-| _               -> get_args_record num_fields p rem
+| Tpat_any
+| Tpat_var _      ->
+  record_matching_line num_fields [] @ rem
+| Tpat_record ([], _) when num_fields = 0 -> rem
+| Tpat_record ((_, lbl, _) :: _ as lbl_pat_list, _)
+  when Array.length lbl.lbl_all = num_fields ->
+    record_matching_line num_fields lbl_pat_list @ rem
+| _ -> raise NoMatch
 
 let make_record_matching loc all_labels def = function
     [] -> fatal_error "Matching.make_record_matching"

testsuite/tests/basic-more/ocamltests

@@ -8,6 +8,7 @@ pr1271.ml
 pr2719.ml
 pr6216.ml
 record_evaluation_order.ml
+robustmatch.ml
 sequential_and_or.ml
 structural_constants.ml
 tbuffer.ml

testsuite/tests/basic-more/robustmatch.ml

@@ -0,0 +1,17 @@
+(* TEST
+   include testing
+*)
+
+module GPR1493 = struct
+  type t1 = { x : int; y : string; }
+  type t2 = { a : int; b : string; c : string list; }
+
+  type t = ..
+  type t += C1 of t1 | C2 of t2
+
+  let f (x : t) =
+    match x with
+    | C1 { x; y } -> ()
+    | C2 { a;b;c } -> ()
+    | _ -> ()
+end

testsuite/tests/basic-more/robustmatch.reference

@@ -0,0 +1,2 @@
+
+All tests succeeded.