Fix modes from or-patterns (#50)

Author: lpw25

lambda/matching.ml

@@ -1482,8 +1482,8 @@ and precompile_or ~arg_id (cls : Simple.clause list) ors args def k =
               (* bound variables of the or-pattern and used in the orpm
                  actions *)
               Typedtree.pat_bound_idents_full orp
-              |> List.filter (fun (id, _, _, _) -> Ident.Set.mem id pm_fv)
-              |> List.map (fun (id, _, ty, _) ->
+              |> List.filter (fun (id, _) -> Ident.Set.mem id pm_fv)
+              |> List.map (fun (id, ty) ->
                      (id, Typeopt.value_kind orp.pat_env ty))
             in
             let or_num = next_raise_count () in
@@ -3569,10 +3569,10 @@ let for_let ~scopes loc param pat body =
       let catch_ids = pat_bound_idents_full pat in
       let ids_with_kinds =
         List.map
-          (fun (id, _, typ, _) -> (id, Typeopt.value_kind pat.pat_env typ))
+          (fun (id, typ) -> (id, Typeopt.value_kind pat.pat_env typ))
           catch_ids
       in
-      let ids = List.map (fun (id, _, _, _) -> id) catch_ids in
+      let ids = List.map (fun (id, _) -> id) catch_ids in
       let bind =
         map_return (assign_pat ~scopes opt nraise ids loc pat) param in
       if !opt then

lambda/translcore.ml

@@ -1214,9 +1214,9 @@ and transl_match ~scopes e arg pat_expr_list partial =
         (* Simplif doesn't like it if binders are not uniq, so we make sure to
            use different names in the value and the exception branches. *)
         let ids_full = Typedtree.pat_bound_idents_full pv in
-        let ids = List.map (fun (id, _, _, _) -> id) ids_full in
+        let ids = List.map (fun (id, _) -> id) ids_full in
         let ids_kinds =
-          List.map (fun (id, _, ty, _) -> id, Typeopt.value_kind pv.pat_env ty)
+          List.map (fun (id, ty) -> id, Typeopt.value_kind pv.pat_env ty)
             ids_full
         in
         let vids = List.map Ident.rename ids in

testsuite/tests/typing-local/local.ml

@@ -1718,3 +1718,38 @@ let promote (local_ x) = +x
 [%%expect{|
 val promote : local_ int -> int = <fun>
 |}]
+
+(* Or-patterns *)
+let foo (local_ x) y =
+  match y, x with
+  | Some z, None | None, Some z -> z
+  | None, None | Some _, Some _ -> assert false
+[%%expect{|
+val foo : local_ 'a option -> 'a option -> local_ 'a = <fun>
+|}]
+
+let foo (local_ x) y =
+  match x, y with
+  | Some z, None | None, Some z -> z
+  | None, None | Some _, Some _ -> assert false
+[%%expect{|
+val foo : local_ 'a option -> 'a option -> local_ 'a = <fun>
+|}]
+
+let (Some z, _, _) | (None, Some z, _)
+    | (None, None, z) = (Some (ref 0), (local_ (Some (ref 0))), (ref 0))
+[%%expect{|
+Line 1, characters 33-34:
+1 | let (Some z, _, _) | (None, Some z, _)
+                                     ^
+Error: This value escapes its region
+|}]
+
+let (Some z, _, _) | (None, Some z, _)
+    | (None, None, z) = ((local_ Some (ref 0)), (Some (ref 0)), (ref 0))
+[%%expect{|
+Line 1, characters 10-11:
+1 | let (Some z, _, _) | (None, Some z, _)
+              ^
+Error: This value escapes its region
+|}]

typing/typeclass.ml

@@ -1204,8 +1204,10 @@ and class_expr_aux cl_num val_env met_env scl =
         Typecore.type_let In_class_def val_env rec_flag sdefs in
       let (vals, met_env) =
         List.fold_right
-          (fun (id, id_loc, _typ, mode) (vals, met_env) ->
-             Typecore.escape ~loc:id_loc.loc ~env:val_env mode;
+          (fun (id, modes) (vals, met_env) ->
+             List.iter
+               (fun (loc, mode) -> Typecore.escape ~loc ~env:val_env mode)
+               modes;
              let path = Pident id in
              (* do not mark the value as used *)
              let vd = Env.find_value path val_env in
@@ -1235,7 +1237,7 @@ and class_expr_aux cl_num val_env met_env scl =
              ((id', expr)
               :: vals,
               Env.add_value id' desc met_env))
-          (let_bound_idents_full defs)
+          (let_bound_idents_with_modes defs)
           ([], met_env)
       in
       let cl = class_expr cl_num val_env met_env scl' in

typing/typecore.ml

@@ -595,10 +595,12 @@ let enter_orpat_variables loc env  p1_vs p2_vs =
   let rec unify_vars p1_vs p2_vs =
     let vars vs = List.map (fun {pv_id; _} -> pv_id) vs in
     match p1_vs, p2_vs with
-      | {pv_id = x1; pv_type = t1; _}::rem1, {pv_id = x2; pv_type = t2; _}::rem2
+      | ({pv_id = x1; pv_type = t1; pv_mode = m1; _} as pv1)::rem1,
+        {pv_id = x2; pv_type = t2; pv_mode = m2; _}::rem2
         when Ident.equal x1 x2 ->
           if x1==x2 then
-            unify_vars rem1 rem2
+            let vars, alist = unify_vars rem1 rem2 in
+            pv1 :: vars, alist
           else begin
             begin try
               unify_var env (newvar ()) t1;
@@ -607,9 +609,12 @@ let enter_orpat_variables loc env  p1_vs p2_vs =
             | Unify trace ->
                 raise(Error(loc, env, Or_pattern_type_clash(x1, trace)))
             end;
-          (x2,x1)::unify_vars rem1 rem2
+            let m = Value_mode.join [m1; m2] in
+            let var = { pv1 with pv_mode = m } in
+            let vars, alist = unify_vars rem1 rem2 in
+            var :: vars, (x2, x1) :: alist
           end
-      | [],[] -> []
+      | [],[] -> [], []
       | {pv_id; _}::_, [] | [],{pv_id; _}::_ ->
           raise (Error (loc, env, Orpat_vars (pv_id, [])))
       | {pv_id = x; _}::_, {pv_id = y; _}::_ ->
@@ -2027,10 +2032,11 @@ and type_pat_aux
         | Error _, Ok p ->
             rp k p
         | Ok p1, Ok p2 ->
-            let alpha_env =
-              enter_orpat_variables loc !env p1_variables p2_variables in
+            let vars, alpha_env =
+              enter_orpat_variables loc !env p1_variables p2_variables
+            in
             let p2 = alpha_pat alpha_env p2 in
-            pattern_variables := p1_variables;
+            pattern_variables := vars;
             module_variables := p1_module_variables;
             let make_pat desc =
               { pat_desc = desc;

typing/typedtree.ml

@@ -761,11 +761,11 @@ let rec iter_bound_idents
   : type k . _ -> k general_pattern -> _
   = fun f pat ->
   match pat.pat_desc with
-  | Tpat_var (id,s) ->
-     f (id,s,pat.pat_type,pat.pat_mode)
-  | Tpat_alias(p, id, s) ->
+  | Tpat_var (id, _) ->
+     f (id, pat.pat_type)
+  | Tpat_alias(p, id, _) ->
       iter_bound_idents f p;
-      f (id,s,pat.pat_type,pat.pat_mode)
+      f (id, pat.pat_type)
   | Tpat_or(p1, _, _) ->
       (* Invariant : both arguments bind the same variables *)
       iter_bound_idents f p1
@@ -781,7 +781,7 @@ let rev_pat_bound_idents_full pat =
   !idents_full
 
 let rev_only_idents idents_full =
-  List.rev_map (fun (id,_,_,_) -> id) idents_full
+  List.rev_map (fun (id,_) -> id) idents_full
 
 let pat_bound_idents_full pat =
   List.rev (rev_pat_bound_idents_full pat)
@@ -794,6 +794,23 @@ let rev_let_bound_idents_full bindings =
   List.iter (fun vb -> iter_bound_idents add vb.vb_pat) bindings;
   !idents_full
 
+let let_bound_idents_with_modes bindings =
+  let modes = Ident.Tbl.create 3 in
+  let rec loop : type k . k general_pattern -> _ =
+    fun pat ->
+      match pat.pat_desc with
+      | Tpat_var (id, { loc }) ->
+          Ident.Tbl.add modes id (loc, pat.pat_mode)
+      | Tpat_alias(p, id, { loc }) ->
+          loop p;
+          Ident.Tbl.add modes id (loc, pat.pat_mode)
+      | d -> shallow_iter_pattern_desc { f = loop } d
+  in
+  List.iter (fun vb -> loop vb.vb_pat) bindings;
+  List.rev_map
+    (fun (id, _) -> id, List.rev (Ident.Tbl.find_all modes id))
+    (rev_let_bound_idents_full bindings)
+
 let let_bound_idents_full bindings =
   List.rev (rev_let_bound_idents_full bindings)
 let let_bound_idents pat =

typing/typedtree.mli

@@ -803,8 +803,10 @@ val exists_pattern: (pattern -> bool) -> pattern -> bool
 
 val let_bound_idents: value_binding list -> Ident.t list
 val let_bound_idents_full:
-    value_binding list
-    -> (Ident.t * string loc * Types.type_expr * Types.Value_mode.t) list
+    value_binding list -> (Ident.t * Types.type_expr) list
+val let_bound_idents_with_modes:
+  value_binding list
+  -> (Ident.t * (Location.t * Types.Value_mode.t) list) list
 
 (** Alpha conversion of patterns *)
 val alpha_pat:
@@ -815,8 +817,7 @@ val mkloc: 'a -> Location.t -> 'a Asttypes.loc
 
 val pat_bound_idents: 'k general_pattern -> Ident.t list
 val pat_bound_idents_full:
-  'k general_pattern
-  -> (Ident.t * string loc * Types.type_expr * Types.Value_mode.t) list
+  'k general_pattern -> (Ident.t * Types.type_expr) list
 
 (** Splits an or pattern into its value (left) and exception (right) parts. *)
 val split_pattern:

typing/typemod.ml

@@ -2170,11 +2170,14 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr =
         (* Note: Env.find_value does not trigger the value_used event. Values
            will be marked as being used during the signature inclusion test. *)
         Tstr_value(rec_flag, defs),
-        List.map (fun (id, { Asttypes.loc; _ }, _typ, mode)->
-          Typecore.escape ~loc ~env:newenv mode;
-          Signature_names.check_value names loc id;
+        List.map (fun (id, modes) ->
+          List.iter
+            (fun (loc, mode) -> Typecore.escape ~loc ~env:newenv mode)
+            modes;
+          let (first_loc, _) = List.hd modes in
+          Signature_names.check_value names first_loc id;
           Sig_value(id, Env.find_value (Pident id) newenv, Exported)
-        ) (let_bound_idents_full defs),
+        ) (let_bound_idents_with_modes defs),
         newenv
     | Pstr_primitive sdesc ->
         let (desc, newenv) = Typedecl.transl_value_decl env loc sdesc in