do not allow conjunctive types in patterns (PR#109)

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@3155 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

typing/ctype.ml

@@ -1078,6 +1078,14 @@ let deep_occur t0 ty =
   with Occur ->
     unmark_type ty; true
 
+(*
+   This flag indicates whether unification should allow conjunctive
+   types in variants or not. They are allowed when typing expressions,
+   but not when typing patterns. This avoids some silly bug, and strange
+   error messages.
+*)
+let allow_conjunctive = ref true
+
 (*
    1. When unifying two non-abbreviated types, one type is made a link
       to the other. When unifying an abbreviated type with a
@@ -1330,10 +1338,18 @@ and unify_row env row1 row2 =
             if e1 == e2 then () else
             let tl = tl1 @ tl2 in
             let tl =
-              List.fold_right
-                (fun t tl ->
-                  let t = repr t in if List.memq t tl then tl else t::tl)
-                tl [] in
+              if !allow_conjunctive then
+                List.fold_right
+                  (fun t tl ->
+                    let t = repr t in if List.memq t tl then tl else t::tl)
+                  tl []
+              else match tl with
+              | [] -> []
+              | t1 :: tl ->
+                  if c1 || c2 then raise (Unify []);
+                  List.iter (unify env t1) tl;
+                  [t1]
+            in
             let f = Reither(c1 or c2, tl, ref None) in
             e1 := Some f; e2 := Some f
         | Reither(false, tl, e1), Rpresent(Some t2) ->
@@ -1355,10 +1371,24 @@ and unify_row env row1 row2 =
     rm1.desc <- md1; rm2.desc <- md2; raise exn
   end
 
-let unify env ty1 ty2 =
+let unify_strict env ty1 ty2 =
+  let old = !allow_conjunctive in
   try
-    unify env ty1 ty2
+    allow_conjunctive := false;
+    unify env ty1 ty2;
+    allow_conjunctive := old
   with Unify trace ->
+    allow_conjunctive := old;
+    raise (Unify (expand_trace env trace))
+
+let unify env ty1 ty2 =
+  let old = !allow_conjunctive in
+  try
+    allow_conjunctive := true;
+    unify env ty1 ty2;
+    allow_conjunctive := old
+  with Unify trace ->
+    allow_conjunctive := old;
     raise (Unify (expand_trace env trace))
 
 let _ = unify' := unify

typing/ctype.mli

@@ -120,6 +120,8 @@ val enforce_constraints: Env.t -> type_expr -> unit
 
 val unify: Env.t -> type_expr -> type_expr -> unit
         (* Unify the two types given. Raise [Unify] if not possible. *)
+val unify_strict: Env.t -> type_expr -> type_expr -> unit
+        (* Same as [unify], but do not allow conjunctive types in variants. *)
 val filter_arrow: Env.t -> type_expr -> label -> type_expr * type_expr
         (* A special case of unification (with l:'a -> 'b). *)
 val filter_method: Env.t -> string -> private_flag -> type_expr -> type_expr

typing/typecore.ml

@@ -93,9 +93,10 @@ let extract_option_type env ty =
 
 (* Typing of patterns *)
 
+(* Creating new conjunctive types is not allowed when typing patterns *)
 let unify_pat env pat expected_ty =
   try
-    unify env pat.pat_type expected_ty
+    unify_strict env pat.pat_type expected_ty
   with Unify trace ->
     raise(Error(pat.pat_loc, Pattern_type_clash(trace)))
 
@@ -261,7 +262,7 @@ let rec type_pat env sp =
             raise(Error(sp.ppat_loc, Unbound_label lid)) in
         let (ty_arg, ty_res) = instance_label label in
         begin try
-          unify env ty_res ty
+          unify_strict env ty_res ty
         with Unify trace ->
           raise(Error(sp.ppat_loc, Label_mismatch(lid, trace)))
         end;