diff --git a/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml b/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml index fe475a096..c2d535ac6 100644 --- a/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml +++ b/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml @@ -166,12 +166,27 @@ let not_ambiguous__constructor = function ;; -type tt = Z of int | Y of int * int | X of tt * tt +type amoi = Z of int | Y of int * int | X of amoi * amoi ;; -let ambiguous a = match a with +let ambiguous__amoi a = match a with | X (Z x,Y (y,0)) | X (Z y,Y (x,_)) when x+y > 0 -> 0 | X _|Y _|Z _ -> 1 ;; + +module type S = sig val b : bool end +;; + +let ambiguous__module_variable x b = match x with + | (module M:S),_,(1,_) + | _,(module M:S),(_,1) when M.b && b -> 1 + | _ -> 2 +;; + +let not_ambiguous__module_variable x b = match x with + | (module M:S),_,(1,_) + | _,(module M:S),(_,1) when b -> 1 + | _ -> 2 +;; diff --git a/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml.reference b/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml.reference index 496087ab7..4543e0462 100644 --- a/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml.reference +++ b/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml.reference @@ -93,10 +93,19 @@ val ambiguous__second_orpat : # val not_ambiguous__lazy : ('a list * 'b list) * bool lazy_t -> unit = # type t = A of int * int option * int option | B # val not_ambiguous__constructor : t -> unit = -# type tt = Z of int | Y of int * int | X of tt * tt -# Characters 34-67: +# type amoi = Z of int | Y of int * int | X of amoi * amoi +# Characters 40-73: ..X (Z x,Y (y,0)) | X (Z y,Y (x,_)) Warning 57: Ambiguous guarded pattern, variables x,y may match different or-pattern arguments -val ambiguous : tt -> int = +val ambiguous__amoi : amoi -> int = +# module type S = sig val b : bool end +# Characters 56-101: + ....(module M:S),_,(1,_) + | _,(module M:S),(_,1)................... +Warning 57: Ambiguous guarded pattern, variable M may match different or-pattern arguments +val ambiguous__module_variable : + (module S) * (module S) * (int * int) -> bool -> int = +# val not_ambiguous__module_variable : + (module S) * (module S) * (int * int) -> bool -> int = # diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 800ff9ced..f66bbaa70 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -2165,20 +2165,56 @@ let rec do_stable rs = match rs with let stable p = do_stable [{unseen=[p]; seen=[];}] -(* all identifier paths that appear in an expression. +(* All identifier paths that appear in an expression that occurs + as a clause right hand side or guard. - This could be in a more general place, but for the ambiguous guards - seem to be the only user. At the same time, it cannot go in - typedtree.mli, as it depends on TypedtreeIter. + The function is rather complex due to the compilation of + unpack patterns by introducing code in rhs expressions + and **guards**. + + For pattern (module M:S) -> e the code is + let module M_mod = unpack M .. in e + + Hence M is "free" in e iff M_mod is free in e. + + Not doing so will yield excessive warning in + (module (M:S) } ...) when true -> .... + as M is always present in + let module M_mod = unpack M .. in true *) -let all_exp_idents exp = + +let all_rhs_idents exp = let ids = ref IdSet.empty in let module Iterator = TypedtreeIter.MakeIterator(struct include TypedtreeIter.DefaultIteratorArgument let enter_expression exp = match exp.exp_desc with - | Texp_ident (Path.Pident id, _lid, _descr) -> - ids := IdSet.add id !ids + | Texp_ident (path, _lid, _descr) -> + List.iter + (fun id -> ids := IdSet.add id !ids) + (Path.heads path) | _ -> () + +(* Very hackish, detect unpack pattern compilation + and perfom "indirect check for them" *) + let is_unpack exp = + List.exists + (fun (attr, _) -> attr.txt = "#modulepat") exp.exp_attributes + + let leave_expression exp = + if is_unpack exp then begin match exp.exp_desc with + | Texp_letmodule + (id_mod,_, + {mod_desc= + Tmod_unpack ({exp_desc=Texp_ident (Path.Pident id_exp,_,_)},_)}, + _) -> + assert (IdSet.mem id_exp !ids) ; + if not (IdSet.mem id_mod !ids) then begin + ids := IdSet.remove id_exp !ids + end + | _ -> assert false + end + + end) in Iterator.iter_expression exp; !ids @@ -2193,7 +2229,7 @@ let check_ambiguous_bindings = | { c_guard=None ; _} -> () | { c_lhs=p; c_guard=Some g; _} -> let all = - IdSet.inter (pattern_vars p) (all_exp_idents g) in + IdSet.inter (pattern_vars p) (all_rhs_idents g) in if not (IdSet.is_empty all) then begin let st = stable p in let ambiguous = IdSet.diff all st in