Explicit representation of guards, get rid of Pexp_when.

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

33 files changed, 425 insertions, 311 deletions

diff --git a/boot/ocamlc b/boot/ocamlc
index 5d4eb47622..5f723ffd58 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamldep b/boot/ocamldep
index c6a5ec58f3..21508f18e2 100755
--- a/boot/ocamldep
+++ b/boot/ocamldep
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index 4746d96e38..a27fd1037c 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -109,6 +109,12 @@ let create_object cl obj init =
                            [obj; Lvar obj'; Lvar cl]))))
   end
 
+let name_pattern default p =
+  match p.pat_desc with
+  | Tpat_var (id, _) -> id
+  | Tpat_alias(p, id, _) -> id
+  | _ -> Ident.create default
+
 let rec build_object_init cl_table obj params inh_init obj_init cl =
   match cl.cl_desc with
     Tcl_ident ( path, _, _) ->
@@ -156,7 +162,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
       in
       (inh_init,
        let build params rem =
-         let param = name_pattern "param" [pat, ()] in
+         let param = name_pattern "param" pat in
          Lfunction (Curried, param::params,
                     Matching.for_function
                       pat.pat_loc None (Lvar param) [pat, rem] partial)
@@ -396,7 +402,7 @@ let rec transl_class_rebind obj_init cl vf =
   | Tcl_fun (_, pat, _, cl, partial) ->
       let path, obj_init = transl_class_rebind obj_init cl vf in
       let build params rem =
-        let param = name_pattern "param" [pat, ()] in
+        let param = name_pattern "param" pat in
         Lfunction (Curried, param::params,
                    Matching.for_function
                      pat.pat_loc None (Lvar param) [pat, rem] partial)
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index d621221f54..73a6f14082 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -493,7 +493,7 @@ let extract_float = function
 
 let rec name_pattern default = function
     [] -> Ident.create default
-  | (p, e) :: rem ->
+  | {c_lhs=p; _} :: rem ->
       match p.pat_desc with
         Tpat_var (id, _) -> id
       | Tpat_alias(p, id, _) -> id
@@ -501,25 +501,27 @@ let rec name_pattern default = function
 
 (* Push the default values under the functional abstractions *)
 
-let rec push_defaults loc bindings pat_expr_list partial =
-  match pat_expr_list with
-    [pat, ({exp_desc = Texp_function(l, pl,partial)} as exp)] ->
+let rec push_defaults loc bindings cases partial =
+  match cases with
+    [{c_lhs=pat; c_guard=None;
+      c_rhs={exp_desc = Texp_function(l, pl,partial)} as exp}] ->
       let pl = push_defaults exp.exp_loc bindings pl partial in
-      [pat, {exp with exp_desc = Texp_function(l, pl, partial)}]
-  | [pat, {exp_attributes=["#default",_];
-           exp_desc = Texp_let
-             (Nonrecursive, cases, ({exp_desc = Texp_function _} as e2))}] ->
-      push_defaults loc (cases :: bindings) [pat, e2] partial
-  | [pat, exp] ->
+      [{c_lhs=pat; c_guard=None; c_rhs={exp with exp_desc = Texp_function(l, pl, partial)}}]
+  | [{c_lhs=pat; c_guard=None;
+      c_rhs={exp_attributes=["#default",_];
+             exp_desc = Texp_let
+               (Nonrecursive, binds, ({exp_desc = Texp_function _} as e2))}}] ->
+      push_defaults loc (binds :: bindings) [{c_lhs=pat;c_guard=None;c_rhs=e2}] partial
+  | [case] ->
       let exp =
         List.fold_left
-          (fun exp cases ->
-            {exp with exp_desc = Texp_let(Nonrecursive, cases, exp)})
-          exp bindings
+          (fun exp binds ->
+            {exp with exp_desc = Texp_let(Nonrecursive, binds, exp)})
+          case.c_rhs bindings
       in
-      [pat, exp]
-  | (pat, exp) :: _ when bindings <> [] ->
-      let param = name_pattern "param" pat_expr_list in
+      [{case with c_rhs=exp}]
+  | {c_lhs=pat; c_rhs=exp; c_guard=_} :: _ when bindings <> [] ->
+      let param = name_pattern "param" cases in
       let name = Ident.name param in
       let exp =
         { exp with exp_loc = loc; exp_desc =
@@ -529,12 +531,12 @@ let rec push_defaults loc bindings pat_expr_list partial =
                           {val_type = pat.pat_type; val_kind = Val_reg;
                            Types.val_loc = Location.none;
                           })},
-             pat_expr_list, partial) }
+             cases, partial) }
       in
       push_defaults loc bindings
-        [{pat with pat_desc = Tpat_var (param, mknoloc name)}, exp] Total
+        [{c_lhs={pat with pat_desc = Tpat_var (param, mknoloc name)}; c_guard=None; c_rhs=exp}] Total
   | _ ->
-      pat_expr_list
+      cases
 
 (* Insertion of debugging events *)
 
@@ -771,10 +773,6 @@ and transl_exp0 e =
   | Texp_for(param, _, low, high, dir, body) ->
       Lfor(param, transl_exp low, transl_exp high, dir,
            event_before body (transl_exp body))
-  | Texp_when(cond, body) ->
-      event_before cond
-        (Lifthenelse(transl_exp cond, event_before body (transl_exp body),
-                     staticfail))
   | Texp_send(_, _, Some exp) -> transl_exp exp
   | Texp_send(expr, met, None) ->
       let obj = transl_exp expr in
@@ -876,13 +874,22 @@ and transl_exp0 e =
 and transl_list expr_list =
   List.map transl_exp expr_list
 
-and transl_cases pat_expr_list =
-  List.map
-    (fun (pat, expr) -> (pat, event_before expr (transl_exp expr)))
-    pat_expr_list
+and transl_guard guard rhs =
+  let expr = event_before rhs (transl_exp rhs) in
+  match guard with
+  | None -> expr
+  | Some cond ->
+      event_before cond (Lifthenelse(transl_exp cond, expr, staticfail))
+
+and transl_case {c_lhs; c_guard; c_rhs} =
+  c_lhs, transl_guard c_guard c_rhs
+
+and transl_cases cases =
+  List.map transl_case cases
 
 and transl_tupled_cases patl_expr_list =
-  List.map (fun (patl, expr) -> (patl, transl_exp expr)) patl_expr_list
+  List.map (fun (patl, guard, expr) -> (patl, transl_guard guard expr))
+    patl_expr_list
 
 and transl_apply lam sargs loc =
   let lapply funct args =
@@ -934,37 +941,39 @@ and transl_apply lam sargs loc =
   in
   build_apply lam [] (List.map (fun (l, x,o) -> may_map transl_exp x, o) sargs)
 
-and transl_function loc untuplify_fn repr partial pat_expr_list =
-  match pat_expr_list with
-    [pat, ({exp_desc = Texp_function(_, pl,partial')} as exp)]
+and transl_function loc untuplify_fn repr partial cases =
+  match cases with
+    [{c_lhs=pat; c_guard=None;
+      c_rhs={exp_desc = Texp_function(_, pl,partial')} as exp}]
     when Parmatch.fluid pat ->
-      let param = name_pattern "param" pat_expr_list in
+      let param = name_pattern "param" cases in
       let ((_, params), body) =
         transl_function exp.exp_loc false repr partial' pl in
       ((Curried, param :: params),
        Matching.for_function loc None (Lvar param) [pat, body] partial)
-  | ({pat_desc = Tpat_tuple pl}, _) :: _ when untuplify_fn ->
+  | {c_lhs={pat_desc = Tpat_tuple pl}} :: _ when untuplify_fn ->
       begin try
         let size = List.length pl in
         let pats_expr_list =
           List.map
-            (fun (pat, expr) -> (Matching.flatten_pattern size pat, expr))
-            pat_expr_list in
+            (fun {c_lhs; c_guard; c_rhs} ->
+              (Matching.flatten_pattern size c_lhs, c_guard, c_rhs))
+            cases in
         let params = List.map (fun p -> Ident.create "param") pl in
         ((Tupled, params),
          Matching.for_tupled_function loc params
            (transl_tupled_cases pats_expr_list) partial)
       with Matching.Cannot_flatten ->
-        let param = name_pattern "param" pat_expr_list in
+        let param = name_pattern "param" cases in
         ((Curried, [param]),
          Matching.for_function loc repr (Lvar param)
-           (transl_cases pat_expr_list) partial)
+           (transl_cases cases) partial)
       end
   | _ ->
-      let param = name_pattern "param" pat_expr_list in
+      let param = name_pattern "param" cases in
       ((Curried, [param]),
        Matching.for_function loc repr (Lvar param)
-         (transl_cases pat_expr_list) partial)
+         (transl_cases cases) partial)
 
 and transl_let rec_flag pat_expr_list body =
   match rec_flag with
diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli
index 401b8f806f..2129b47758 100644
--- a/bytecomp/translcore.mli
+++ b/bytecomp/translcore.mli
@@ -17,8 +17,6 @@ open Asttypes
 open Typedtree
 open Lambda
 
-val name_pattern: string -> (pattern * 'a) list -> Ident.t
-
 val transl_exp: expression -> lambda
 val transl_apply: lambda -> (label * expression option * optional) list
                   -> Location.t -> lambda
diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
index d32b97d9f8..fe3aa51c80 100644
--- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
+++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
@@ -778,15 +778,15 @@ value varify_constructors var_names =
     | <:expr@loc< fun [ $PaLab _ lab po$ when $w$ -> $e$ ] >> ->
         mkexp loc
           (Pexp_function lab None
-            [(patt_of_lab loc lab po, when_expr e w)])
+            [when_expr (patt_of_lab loc lab po) e w])
     | <:expr@loc< fun [ $PaOlbi _ lab p e1$ when $w$ -> $e2$ ] >> ->
         let lab = paolab lab p in
         mkexp loc
-          (Pexp_function ("?" ^ lab) (Some (expr e1)) [(patt p, when_expr e2 w)])
+          (Pexp_function ("?" ^ lab) (Some (expr e1)) [when_expr (patt p) e2 w])
     | <:expr@loc< fun [ $PaOlb _ lab p$ when $w$ -> $e$ ] >> ->
         let lab = paolab lab p in
         mkexp loc
-          (Pexp_function ("?" ^ lab) None [(patt_of_lab loc lab p, when_expr e w)])
+          (Pexp_function ("?" ^ lab) None [when_expr (patt_of_lab loc lab p) e w])
     | ExFun loc a -> mkexp loc (Pexp_function "" None (match_case a []))
     | ExIfe loc e1 e2 e3 ->
         mkexp loc (Pexp_ifthenelse (expr e1) (expr e2) (Some (expr e3)))
@@ -931,13 +931,15 @@ value varify_constructors var_names =
     match x with
     [ <:match_case< $x$ | $y$ >> -> match_case x (match_case y acc)
     | <:match_case< $pat:p$ when $w$ -> $e$ >> ->
-        [(patt p, when_expr e w) :: acc]
+        [when_expr (patt p) e w :: acc]
     | <:match_case<>> -> acc
     | _ -> assert False ]
-  and when_expr e w =
-    match w with
-    [ <:expr<>> -> expr e
-    | w -> mkexp (loc_of_expr w) (Pexp_when (expr w) (expr e)) ]
+  and when_expr p e w =
+    let g = match w with
+    [ <:expr<>> -> None
+    | g -> Some (expr g) ]
+    in
+    {pc_lhs = p; pc_guard = g; pc_rhs = expr e}
   and mklabexp x acc =
     match x with
     [ <:rec_binding< $x$; $y$ >> ->
diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml
index 0a61d8cf6c..df6c080fdd 100644
--- a/camlp4/boot/Camlp4.ml
+++ b/camlp4/boot/Camlp4.ml
@@ -15035,21 +15035,21 @@ module Struct =
                   ->
                   mkexp loc
                     (Pexp_function (lab, None,
-                       [ ((patt_of_lab loc lab po), (when_expr e w)) ]))
+                       [ when_expr (patt_of_lab loc lab po) e w ]))
               | Ast.ExFun (loc,
                   (Ast.McArr (_, (PaOlbi (_, lab, p, e1)), w, e2))) ->
                   let lab = paolab lab p
                   in
                     mkexp loc
                       (Pexp_function (("?" ^ lab), (Some (expr e1)),
-                         [ ((patt p), (when_expr e2 w)) ]))
+                         [ when_expr (patt p) e2 w ]))
               | Ast.ExFun (loc, (Ast.McArr (_, (PaOlb (_, lab, p)), w, e)))
                   ->
                   let lab = paolab lab p
                   in
                     mkexp loc
                       (Pexp_function (("?" ^ lab), None,
-                         [ ((patt_of_lab loc lab p), (when_expr e w)) ]))
+                         [ when_expr (patt_of_lab loc lab p) e w ]))
               | ExFun (loc, a) ->
                   mkexp loc (Pexp_function ("", None, (match_case a [])))
               | ExIfe (loc, e1, e2, e3) ->
@@ -15240,13 +15240,16 @@ module Struct =
             and match_case x acc =
               match x with
               | Ast.McOr (_, x, y) -> match_case x (match_case y acc)
-              | Ast.McArr (_, p, w, e) -> ((patt p), (when_expr e w)) :: acc
+              | Ast.McArr (_, p, w, e) -> when_expr (patt p) e w :: acc
               | Ast.McNil _ -> acc
               | _ -> assert false
-            and when_expr e w =
-              match w with
-              | Ast.ExNil _ -> expr e
-              | w -> mkexp (loc_of_expr w) (Pexp_when ((expr w), (expr e)))
+            and when_expr p e w =
+              let g =
+                match w with
+                | Ast.ExNil _ -> None
+                | w -> Some (expr w)
+              in
+              {pc_lhs = p; pc_guard = g; pc_rhs = expr e}
             and mklabexp x acc =
               match x with
               | Ast.RbSem (_, x, y) -> mklabexp x (mklabexp y acc)
diff --git a/experimental/frisch/extension_points.txt b/experimental/frisch/extension_points.txt
index 294c400040..595536859e 100644
--- a/experimental/frisch/extension_points.txt
+++ b/experimental/frisch/extension_points.txt
@@ -404,6 +404,23 @@ As in the Typedtree.
 +  | Cfk_concrete of override_flag * expression
 +
 
+--- Explicit representation of "when" guards
+
+Replaced the "(pattern * expression) list" argument of Pexp_function, Pexp_match, Pexp_try 
+with "case list", with case defined as:
+
+  {
+   pc_lhs: pattern;
+   pc_guard: expression option;
+   pc_rhs: expression;
+  }
+
+and get rid of Pexp_when. Idem in the Typedtree.
+
+Rationale:
+
+  - Make it explicit when the guard can appear.
+
 
 === More TODOs
 
diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml
index 45d913c23a..fb41929206 100644
--- a/ocamldoc/odoc_ast.ml
+++ b/ocamldoc/odoc_ast.ml
@@ -297,13 +297,13 @@ module Analyser =
           (* This case means we have a 'function' without pattern, that's impossible *)
           raise (Failure "tt_analyse_function_parameters: 'function' without pattern")
 
-      | (pattern_param, exp) :: second_ele :: q ->
+      | {c_lhs=pattern_param} :: second_ele :: q ->
           (* implicit pattern matching -> anonymous parameter and no more parameter *)
           (* A VOIR : le label ? *)
           let parameter = Odoc_parameter.Tuple ([], Odoc_env.subst_type env pattern_param.pat_type) in
           [ parameter ]
 
-      | (pattern_param, func_body) :: [] ->
+      | {c_lhs=pattern_param; c_rhs=func_body} :: [] ->
           let parameter =
             tt_param_info_from_pattern
               env
@@ -451,7 +451,7 @@ module Analyser =
                  [] ->
                    (* cas impossible, on l'a filtre avant *)
                    assert false
-               | (pattern_param, exp) :: second_ele :: q ->
+               | {c_lhs=pattern_param} :: second_ele :: q ->
                    (* implicit pattern matching -> anonymous parameter *)
                    (* Note : We can't match this pattern if it is the first call to the function. *)
                    let new_param = Simple_name
@@ -460,7 +460,7 @@ module Analyser =
                    in
                    [ new_param ]
 
-               | (pattern_param, body) :: [] ->
+               | {c_lhs=pattern_param; c_rhs=body} :: [] ->
                    (* if this is the first call to the function, this is the first parameter and we skip it *)
                    if not first then
                      (
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index b1b5bb97f3..1d03f3bfec 100644
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -729,6 +729,14 @@ and search_pos_class_expr ~pos cl =
       ~env:!start_env ~loc:cl.cl_loc
   end
 
+and search_case ~pos {c_lhs; c_guard; c_rhs} =
+  search_pos_pat c_lhs ~pos ~env:c_rhs.exp_env;
+  begin match c_guard with
+  | None -> ()
+  | Some g -> search_pos_expr g ~pos
+  end;
+  search_pos_expr c_rhs ~pos
+
 and search_pos_expr ~pos exp =
   if in_loc exp.exp_loc ~pos then begin
   begin match exp.exp_desc with
@@ -746,28 +754,16 @@ and search_pos_expr ~pos exp =
       end;
       search_pos_expr exp ~pos
   | Texp_function (_, l, _) ->
-      List.iter l ~f:
-      begin fun (pat, exp) ->
-        search_pos_pat pat ~pos ~env:exp.exp_env;
-        search_pos_expr exp ~pos
-      end
+      List.iter l ~f:(search_case ~pos)
   | Texp_apply (exp, l) ->
       List.iter l ~f:(fun (_, x,_) -> Misc.may (search_pos_expr ~pos) x);
       search_pos_expr exp ~pos
   | Texp_match (exp, l, _) ->
       search_pos_expr exp ~pos;
-      List.iter l ~f:
-      begin fun (pat, exp) ->
-        search_pos_pat pat ~pos ~env:exp.exp_env;
-        search_pos_expr exp ~pos
-      end
+      List.iter l ~f:(search_case ~pos)
   | Texp_try (exp, l) ->
       search_pos_expr exp ~pos;
-      List.iter l ~f:
-      begin fun (pat, exp) ->
-        search_pos_pat pat ~pos ~env:exp.exp_env;
-        search_pos_expr exp ~pos
-      end
+      List.iter l ~f:(search_case ~pos)
   | Texp_tuple l -> List.iter l ~f:(search_pos_expr ~pos)
   | Texp_construct (_, _, l,_) -> List.iter l ~f:(search_pos_expr ~pos)
   | Texp_variant (_, None) -> ()
@@ -790,8 +786,6 @@ and search_pos_expr ~pos exp =
       search_pos_expr a ~pos; search_pos_expr b ~pos
   | Texp_for (_, _, a, b, _, c) ->
       List.iter [a;b;c] ~f:(search_pos_expr ~pos)
-  | Texp_when (a, b) ->
-      search_pos_expr a ~pos; search_pos_expr b ~pos
   | Texp_send (exp, _, _) -> search_pos_expr exp ~pos
   | Texp_new (path, _, _) ->
       add_found_str (`Exp(`New path, exp.exp_type))
diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml
index 3b03d728c0..c79b501327 100644
--- a/parsing/ast_helper.ml
+++ b/parsing/ast_helper.ml
@@ -95,7 +95,6 @@ module Exp = struct
   let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b))
   let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e))
   let constraint_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_constraint (a, b, c))
-  let when_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_when (a, b))
   let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b))
   let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a)
   let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b))
@@ -110,6 +109,13 @@ module Exp = struct
   let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a)
   let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_open (a, b))
   let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a)
+
+  let case lhs ?guard rhs =
+    {
+     pc_lhs = lhs;
+     pc_guard = guard;
+     pc_rhs = rhs;
+    }
 end
 
 module Mty = struct
@@ -376,8 +382,8 @@ module Convenience = struct
   let float x = Exp.constant (Const_float (string_of_float x))
   let record ?over l =
     Exp.record (List.map (fun (s, e) -> (lid s, e)) l) over
-  let func l = Exp.function_ "" None l
-  let lam ?(label = "") ?default pat exp = Exp.function_ label default [pat, exp]
+  let func l = Exp.function_ "" None (List.map (fun (p, e) -> Exp.case p e) l)
+  let lam ?(label = "") ?default pat exp = Exp.function_ label default [{pc_lhs=pat; pc_guard=None; pc_rhs=exp}]
   let app f l = Exp.apply f (List.map (fun a -> "", a) l)
   let evar s = Exp.ident (lid s)
   let let_in ?(recursive = false) b body =
diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli
index abc0ac5b17..b479eb97da 100644
--- a/parsing/ast_helper.mli
+++ b/parsing/ast_helper.mli
@@ -75,10 +75,10 @@ module Exp:
     val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression
     val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression
     val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> (pattern * expression) list -> expression -> expression
-    val function_: ?loc:loc -> ?attrs:attrs -> label -> expression option -> (pattern * expression) list -> expression
+    val function_: ?loc:loc -> ?attrs:attrs -> label -> expression option -> case list -> expression
     val apply: ?loc:loc -> ?attrs:attrs -> expression -> (label * expression) list -> expression
-    val match_: ?loc:loc -> ?attrs:attrs -> expression -> (pattern * expression) list -> expression
-    val try_: ?loc:loc -> ?attrs:attrs -> expression -> (pattern * expression) list -> expression
+    val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression
+    val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression
     val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression
     val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option -> bool -> expression
     val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option -> expression
@@ -91,7 +91,6 @@ module Exp:
     val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression
     val for_: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression -> direction_flag -> expression -> expression
     val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type option -> core_type option -> expression
-    val when_: ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression
     val send: ?loc:loc -> ?attrs:attrs -> expression -> string -> expression
     val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression
     val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression
@@ -106,6 +105,8 @@ module Exp:
     val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression
     val open_: ?loc:loc -> ?attrs:attrs -> lid -> expression -> expression
     val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression
+
+    val case: pattern -> ?guard:expression -> expression -> case
   end
 module Mty:
   sig
diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
index 9c2f02afce..6edc435a3c 100644
--- a/parsing/ast_mapper.ml
+++ b/parsing/ast_mapper.ml
@@ -189,6 +189,13 @@ module E = struct
   let apply_nolabs ?loc ?attrs f el = Exp.apply ?loc ?attrs f (List.map (fun e -> ("", e)) el)
   let strconst ?loc ?attrs x = Exp.constant ?loc ?attrs (Const_string (x, None))
 
+  let map_case sub {pc_lhs; pc_guard; pc_rhs} =
+    {
+     pc_lhs = sub # pat pc_lhs;
+     pc_guard = map_opt (sub # expr) pc_guard;
+     pc_rhs = sub # expr pc_rhs;
+    }
+
   let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} =
     let open Exp in
     let loc = sub # location loc in
@@ -197,10 +204,10 @@ module E = struct
     | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x)
     | Pexp_constant x -> constant ~loc ~attrs x
     | Pexp_let (r, pel, e) -> let_ ~loc ~attrs r (List.map (map_tuple (sub # pat) (sub # expr)) pel) (sub # expr e)
-    | Pexp_function (lab, def, pel) -> function_ ~loc ~attrs lab (map_opt (sub # expr) def) (List.map (map_tuple (sub # pat) (sub # expr)) pel)
+    | Pexp_function (lab, def, pel) -> function_ ~loc ~attrs lab (map_opt (sub # expr) def) (List.map (map_case sub) pel)
     | Pexp_apply (e, l) -> apply ~loc ~attrs (sub # expr e) (List.map (map_snd (sub # expr)) l)
-    | Pexp_match (e, l) -> match_ ~loc ~attrs (sub # expr e) (List.map (map_tuple (sub # pat) (sub # expr)) l)
-    | Pexp_try (e, l) -> try_ ~loc ~attrs (sub # expr e) (List.map (map_tuple (sub # pat) (sub # expr)) l)
+    | Pexp_match (e, l) -> match_ ~loc ~attrs (sub # expr e) (List.map (map_case sub) l)
+    | Pexp_try (e, l) -> try_ ~loc ~attrs (sub # expr e) (List.map (map_case sub) l)
     | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub # expr) el)
     | Pexp_construct (lid, arg, b) -> construct ~loc ~attrs (map_loc sub lid) (map_opt (sub # expr) arg) b
     | Pexp_variant (lab, eo) -> variant ~loc ~attrs lab (map_opt (sub # expr) eo)
@@ -213,7 +220,6 @@ module E = struct
     | Pexp_while (e1, e2) -> while_ ~loc ~attrs (sub # expr e1) (sub # expr e2)
     | Pexp_for (id, e1, e2, d, e3) -> for_ ~loc ~attrs (map_loc sub id) (sub # expr e1) (sub # expr e2) d (sub # expr e3)
     | Pexp_constraint (e, t1, t2) -> constraint_ ~loc ~attrs (sub # expr e) (map_opt (sub # typ) t1) (map_opt (sub # typ) t2)
-    | Pexp_when (e1, e2) -> when_ ~loc ~attrs (sub # expr e1) (sub # expr e2)
     | Pexp_send (e, s) -> send ~loc ~attrs (sub # expr e) s
     | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid)
     | Pexp_setinstvar (s, e) -> setinstvar ~loc ~attrs (map_loc sub s) (sub # expr e)
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 20405f6c97..25e3045465 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -1034,7 +1034,8 @@ expr:
   | FUNCTION ext_attributes opt_bar match_cases
       { mkexp_attrs (Pexp_function("", None, List.rev $4)) $2 }
   | FUN ext_attributes labeled_simple_pattern fun_def
-      { let (l,o,p) = $3 in mkexp_attrs (Pexp_function(l, o, [p, $4])) $2 }
+      { let (l,o,p) = $3 in
+        mkexp_attrs (Pexp_function(l, o, [Exp.case p $4])) $2 }
   | FUN ext_attributes LPAREN TYPE LIDENT RPAREN fun_def
       { mkexp_attrs (Pexp_newtype($5, $7)) $2 }
   | MATCH ext_attributes seq_expr WITH opt_bar match_cases
@@ -1261,25 +1262,32 @@ strict_binding:
     EQUAL seq_expr
       { $2 }
   | labeled_simple_pattern fun_binding
-      { let (l, o, p) = $1 in ghexp(Pexp_function(l, o, [p, $2])) }
+      { let (l, o, p) = $1 in ghexp(Pexp_function(l, o, [Exp.case p $2])) }
   | LPAREN TYPE LIDENT RPAREN fun_binding
       { mkexp(Pexp_newtype($3, $5)) }
 ;
 match_cases:
-    pattern match_action                        { [$1, $2] }
-  | match_cases BAR pattern match_action        { ($3, $4) :: $1 }
+    match_case { [$1] }
+  | match_cases BAR match_case { $3 :: $1 }
+;
+match_case:
+    pattern MINUSGREATER seq_expr
+      { Exp.case $1 $3 }
+  | pattern WHEN seq_expr MINUSGREATER seq_expr
+      { Exp.case $1 ~guard:$3 $5 }
 ;
 fun_def:
-    match_action                                { $1 }
+    MINUSGREATER seq_expr                       { $2 }
+/* Cf #5939: we used to accept (fun p when e0 -> e) */
   | labeled_simple_pattern fun_def
-      { let (l,o,p) = $1 in ghexp(Pexp_function(l, o, [p, $2])) }
+      {
+       let (l,o,p) = $1 in
+       let case = Exp.case p $2 in
+       ghexp(Pexp_function(l, o, [case]))
+      }
   | LPAREN TYPE LIDENT RPAREN fun_def
       { mkexp(Pexp_newtype($3, $5)) }
 ;
-match_action:
-    MINUSGREATER seq_expr                       { $2 }
-  | WHEN seq_expr MINUSGREATER seq_expr         { ghexp(Pexp_when($2, $4)) }
-;
 expr_comma_list:
     expr_comma_list COMMA expr                  { $3 :: $1 }
   | expr COMMA expr                             { [$3; $1] }
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index d723de66ae..dfecb3343c 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -194,8 +194,7 @@ and expression_desc =
         (* let P1 = E1 and ... and Pn = EN in E       (flag = Nonrecursive)
            let rec P1 = E1 and ... and Pn = EN in E   (flag = Recursive)
          *)
-  | Pexp_function of label * expression option *
-        (pattern * guarded_expression) list
+  | Pexp_function of label * expression option * case list
         (* function P1 -> E1 | ... | Pn -> En    (lab = "", None)
            fun P1 -> E1                          (lab = "", None)
            fun ~l:P1 -> E1                       (lab = "l", None)
@@ -203,18 +202,19 @@ and expression_desc =
            fun ?l:(P1 = E0) -> E1                (lab = "?l", Some E0)
 
            Notes:
-           - n >= 1
-           - There is no concrete syntax if n >= 2 and lab <> ""
-           - If E0 is provided, lab must start with '?'
+           - n >= 1.
+           - There is no concrete syntax if n >= 2 and lab <> "".
+           - If E0 is provided, lab must start with '?'.
+           - Guards are only possible if lab = "".
          *)
   | Pexp_apply of expression * (label * expression) list
         (* E0 ~l1:E1 ... ~ln:En
            li can be empty (non labeled argument) or start with '?'
            (optional argument).
          *)
-  | Pexp_match of expression * (pattern * guarded_expression) list
+  | Pexp_match of expression * case list
         (* match E0 with P1 -> E1 | ... | Pn -> En *)
-  | Pexp_try of expression * (pattern * guarded_expression) list
+  | Pexp_try of expression * case list
         (* try E0 with P1 -> E1 | ... | Pn -> En *)
   | Pexp_tuple of expression list
         (* (E1, ..., En)   (n >= 2) *)
@@ -258,10 +258,6 @@ and expression_desc =
            Invariant: one of the two types must be provided
            (otherwise this is currently accepted as equivalent to just E).
          *)
-  | Pexp_when of expression * expression
-        (* ... when E1 -> E2
-           This node can occur only in contexts marked as guarded_expression.
-         *)
   | Pexp_send of expression * string
         (*  E # m *)
   | Pexp_new of Longident.t loc
@@ -298,9 +294,12 @@ and expression_desc =
   | Pexp_extension of extension
         (* [%id E] *)
 
-and guarded_expression = expression
-   (* This type abbreviation is used to mark contexts where Pexp_when
-      can be used. *)
+and case =   (* (P -> E) or (P when E0 -> E) *)
+  {
+   pc_lhs: pattern;
+   pc_guard: expression option;
+   pc_rhs: expression;
+  }
 
 (* Value descriptions *)
 
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
index df6cb54285..2b286130d8 100644
--- a/parsing/pprintast.ml
+++ b/parsing/pprintast.ml
@@ -531,6 +531,9 @@ class printer  ()= object(self:'self)
     | Pexp_let _ | Pexp_letmodule _ when semi ->
         self#paren true self#reset#expression f x
     | Pexp_function _(* (p, eo, l) *) ->
+        assert false
+          (* TODO *)
+(*
         let rec aux acc = function
           | {pexp_desc = Pexp_function (l,eo, [(p',e')]);_}
               -> aux ((l,eo,p')::acc) e'
@@ -550,6 +553,8 @@ class printer  ()= object(self:'self)
                  (fun f (l,eo,p) ->
                    self#label_exp f (l,eo,p))) ls
               self#expression e end
+*)
+
     | Pexp_match (e, l) ->
         pp f "@[<hv0>@[<hv0>@[<2>match %a@]@ with@]%a@]" self#reset#expression e self#case_list l 
 
@@ -612,7 +617,6 @@ class printer  ()= object(self:'self)
         let lst = sequence_helper [] x in
         pp f "@[<hv>%a@]"
           (self#list self#under_semi#expression ~sep:";@;") lst
-    | Pexp_when (_e1, _e2) ->  assert false (*FIXME handled already in pattern *)
     | Pexp_new (li) ->
         pp f "@[<hov2>new@ %a@]" self#longident_loc li;
     | Pexp_setinstvar (s, e) ->
@@ -977,23 +981,20 @@ class printer  ()= object(self:'self)
     let rec pp_print_pexp_function f x =
       if x.pexp_attributes <> [] then pp f "=@;%a" self#expression x
       else match x.pexp_desc with 
-      | Pexp_function (label,eo,[(p,e)]) ->
+(*      | Pexp_function (label,eo,[(p,e)]) -> (* TODO *)
           if label="" then 
             match e.pexp_desc with
             | Pexp_when _  -> pp f "=@;%a" self#expression x
             | _ -> 
                 pp f "%a@ %a" self#simple_pattern p pp_print_pexp_function e
           else
-            pp f "%a@ %a" self#label_exp (label,eo,p) pp_print_pexp_function e
+            pp f "%a@ %a" self#label_exp (label,eo,p) pp_print_pexp_function e *)
       | Pexp_newtype (str,e) ->
           pp f "(type@ %s)@ %a" str pp_print_pexp_function e
       | _ -> pp f "=@;%a" self#expression x in 
     if x.pexp_attributes <> [] then
       pp f "%a@;=@;%a" self#pattern p self#expression x 
     else match (x.pexp_desc,p.ppat_desc) with
-    | (Pexp_when (e1,e2),_) ->
-        pp f "=@[<2>fun@ %a@ when@ %a@ ->@ %a@]"
-          self#simple_pattern p self#expression e1 self#expression e2
     | ( _ , Ppat_constraint( p ,ty)) -> (* special case for the first*)
         (match ty.ptyp_desc with
         | Ptyp_poly _ -> 
@@ -1192,14 +1193,10 @@ class printer  ()= object(self:'self)
              self#core_type ct1 self#core_type ct2 ))  x.ptype_cstrs  ;
       (* TODO: attributes *)
   end
-  method case_list f (l:(pattern * expression) list) :unit=
-    let aux f (p,e) =
-      let (e,w) =
-        (match e with
-        | {pexp_desc = Pexp_when (e1, e2);_} -> (e2, Some (e1))
-        | _ -> (e, None)) in
+  method case_list f l : unit =
+    let aux f {pc_lhs; pc_guard; pc_rhs} =
       pp f "@;| @[<2>%a%a@;->@;%a@]"
-        self#pattern p (self#option self#expression ~first:"@;when@;") w self#under_pipe#expression e in
+        self#pattern pc_lhs (self#option self#expression ~first:"@;when@;") pc_guard self#under_pipe#expression pc_rhs in
     self#list aux f l ~sep:""
   method label_x_expression_param f (l,e) =
     match l with
diff --git a/parsing/pprintast.mli b/parsing/pprintast.mli
index fa7343390d..1d70abf460 100644
--- a/parsing/pprintast.mli
+++ b/parsing/pprintast.mli
@@ -23,8 +23,7 @@ class printer :
           Asttypes.rec_flag * (Parsetree.pattern * Parsetree.expression) list ->
             unit
     method case_list :
-      Format.formatter ->
-      (Parsetree.pattern * Parsetree.expression) list -> unit
+      Format.formatter -> Parsetree.case list -> unit
     method class_expr : Format.formatter -> Parsetree.class_expr -> unit
     method class_field : Format.formatter -> Parsetree.class_field -> unit
     method class_params_def :
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 2991cd937e..07b58ad102 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -245,7 +245,7 @@ and expression i ppf x =
   | Pexp_function (p, eo, l) ->
       line i ppf "Pexp_function \"%s\"\n" p;
       option i expression ppf eo;
-      list i pattern_x_expression_case ppf l;
+      list i case ppf l;
   | Pexp_apply (e, l) ->
       line i ppf "Pexp_apply\n";
       expression i ppf e;
@@ -253,11 +253,11 @@ and expression i ppf x =
   | Pexp_match (e, l) ->
       line i ppf "Pexp_match\n";
       expression i ppf e;
-      list i pattern_x_expression_case ppf l;
+      list i case ppf l;
   | Pexp_try (e, l) ->
       line i ppf "Pexp_try\n";
       expression i ppf e;
-      list i pattern_x_expression_case ppf l;
+      list i case ppf l;
   | Pexp_tuple (l) ->
       line i ppf "Pexp_tuple\n";
       list i expression ppf l;
@@ -307,10 +307,6 @@ and expression i ppf x =
       expression i ppf e;
       option i core_type ppf cto1;
       option i core_type ppf cto2;
-  | Pexp_when (e1, e2) ->
-      line i ppf "Pexp_when\n";
-      expression i ppf e1;
-      expression i ppf e2;
   | Pexp_send (e, s) ->
       line i ppf "Pexp_send \"%s\"\n" s;
       expression i ppf e;
@@ -771,10 +767,14 @@ and longident_x_pattern i ppf (li, p) =
   line i ppf "%a\n" fmt_longident_loc li;
   pattern (i+1) ppf p;
 
-and pattern_x_expression_case i ppf (p, e) =
+and case i ppf {pc_lhs; pc_guard; pc_rhs} =
   line i ppf "<case>\n";
-  pattern (i+1) ppf  p;
-  expression (i+1) ppf e;
+  pattern (i+1) ppf pc_lhs;
+  begin match pc_guard with
+  | None -> ()
+  | Some g -> line (i+1) ppf "<when>\n"; expression (i + 2) ppf g
+  end;
+  expression (i+1) ppf pc_rhs;
 
 and pattern_x_expression_def i ppf (p, e) =
   line i ppf "<def>\n";
diff --git a/tools/cmt2annot.ml b/tools/cmt2annot.ml
index ddf8f45a22..7f2ea9bab7 100644
--- a/tools/cmt2annot.ml
+++ b/tools/cmt2annot.ml
@@ -32,7 +32,15 @@ let bind_bindings scope bindings =
   List.iter (fun (p, _) -> o # pattern p) bindings
 
 let bind_cases l =
-  List.iter (fun (p, e) -> (bind_variables e.exp_loc) # pattern p) l
+  List.iter
+    (fun {c_lhs; c_guard; c_rhs} ->
+      let loc =
+        let open Location in
+        match c_guard with
+        | None -> c_rhs.exp_loc
+        | Some g -> {c_rhs.exp_loc with loc_start=g.exp_loc.loc_start}
+      in
+      (bind_variables loc) # pattern c_lhs) l
 
 let iterator rebuild_env =
   object(this)
diff --git a/tools/depend.ml b/tools/depend.ml
index 91cb778e41..e99c481c9f 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -136,11 +136,11 @@ let rec add_expr bv exp =
   | Pexp_let(rf, pel, e) ->
       let bv = add_bindings rf bv pel in add_expr bv e
   | Pexp_function (_, opte, pel) ->
-      add_opt add_expr bv opte; add_pat_expr_list bv pel
+      add_opt add_expr bv opte; add_cases bv pel
   | Pexp_apply(e, el) ->
       add_expr bv e; List.iter (fun (_,e) -> add_expr bv e) el
-  | Pexp_match(e, pel) -> add_expr bv e; add_pat_expr_list bv pel
-  | Pexp_try(e, pel) -> add_expr bv e; add_pat_expr_list bv pel
+  | Pexp_match(e, pel) -> add_expr bv e; add_cases bv pel
+  | Pexp_try(e, pel) -> add_expr bv e; add_cases bv pel
   | Pexp_tuple el -> List.iter (add_expr bv) el
   | Pexp_construct(c, opte, _) -> add bv c; add_opt add_expr bv opte
   | Pexp_variant(_, opte) -> add_opt add_expr bv opte
@@ -160,7 +160,6 @@ let rec add_expr bv exp =
       add_expr bv e1;
       add_opt add_type bv oty2;
       add_opt add_type bv oty3
-  | Pexp_when(e1, e2) -> add_expr bv e1; add_expr bv e2
   | Pexp_send(e, m) -> add_expr bv e
   | Pexp_new li -> add bv li
   | Pexp_setinstvar(v, e) -> add_expr bv e
@@ -178,8 +177,13 @@ let rec add_expr bv exp =
   | Pexp_open (m, e) -> addmodule bv m; add_expr bv e
   | Pexp_extension _ -> ()
 
-and add_pat_expr_list bv pel =
-  List.iter (fun (p, e) -> let bv = add_pattern bv p in add_expr bv e) pel
+and add_cases bv cases =
+  List.iter (add_case bv) cases
+
+and add_case bv {pc_lhs; pc_guard; pc_rhs} =
+  let bv = add_pattern bv pc_lhs in
+  add_opt add_expr bv pc_guard;
+  add_expr bv pc_rhs
 
 and add_bindings recf bv pel =
   let bv' = List.fold_left (fun bv (p, _) -> add_pattern bv p) bv pel in
diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
index 397494b523..38edde9c21 100644
--- a/tools/ocamlprof.ml
+++ b/tools/ocamlprof.ml
@@ -150,8 +150,16 @@ let final_rewrite add_function =
 let rec rewrite_patexp_list iflag l =
   rewrite_exp_list iflag (List.map snd l)
 
-and rewrite_patlexp_list iflag l =
-  rewrite_exp_list iflag (List.map snd l)
+and rewrite_cases iflag l =
+  List.iter
+    (fun pc ->
+      begin match pc.pc_guard with
+      | None -> ()
+      | Some g -> rewrite_exp iflag g
+      end;
+      rewrite_exp iflag pc.pc_rhs
+    )
+    l
 
 and rewrite_labelexp_list iflag l =
   rewrite_exp_list iflag (List.map snd l)
@@ -176,21 +184,21 @@ and rw_exp iflag sexp =
     if !instr_fun then
       rewrite_function iflag caselist
     else
-      rewrite_patlexp_list iflag caselist
+      rewrite_cases iflag caselist
 
   | Pexp_match(sarg, caselist) ->
     rewrite_exp iflag sarg;
     if !instr_match && not sexp.pexp_loc.loc_ghost then
       rewrite_funmatching caselist
     else
-      rewrite_patlexp_list iflag caselist
+      rewrite_cases iflag caselist
 
   | Pexp_try(sbody, caselist) ->
     rewrite_exp iflag sbody;
     if !instr_try && not sexp.pexp_loc.loc_ghost then
       rewrite_trymatching caselist
     else
-      rewrite_patexp_list iflag caselist
+      rewrite_cases iflag caselist
 
   | Pexp_apply(sfunct, sargs) ->
     rewrite_exp iflag sfunct;
@@ -251,10 +259,6 @@ and rw_exp iflag sexp =
   | Pexp_constraint(sarg, _, _) ->
     rewrite_exp iflag sarg
 
-  | Pexp_when(scond, sbody) ->
-    rewrite_exp iflag scond;
-    rewrite_exp iflag sbody
-
   | Pexp_send (sobj, _) ->
     rewrite_exp iflag sobj
 
@@ -295,23 +299,24 @@ and rewrite_ifbody iflag ghost sifbody =
 and rewrite_annotate_exp_list l =
   List.iter
     (function
-     | {pexp_desc = Pexp_when(scond, sbody)}
-        -> insert_profile rw_exp scond;
-           insert_profile rw_exp sbody;
-     | {pexp_desc = Pexp_constraint(sbody, _, _)} (* let f x : t = e *)
+     | {pc_guard=Some scond; pc_rhs=sbody} ->
+         insert_profile rw_exp scond;
+         insert_profile rw_exp sbody;
+     | {pc_rhs={pexp_desc = Pexp_constraint(sbody, _, _)}} (* let f x : t = e *)
         -> insert_profile rw_exp sbody
-     | sexp -> insert_profile rw_exp sexp)
+     | {pc_rhs=sexp} -> insert_profile rw_exp sexp)
     l
 
 and rewrite_function iflag = function
-  | [spat, ({pexp_desc = Pexp_function _} as sexp)] -> rewrite_exp iflag sexp
+  | [{pc_lhs=spat; pc_guard=None;
+      pc_rhs={pexp_desc = Pexp_function _} as sexp}] -> rewrite_exp iflag sexp
   | l -> rewrite_funmatching l
 
 and rewrite_funmatching l =
-  rewrite_annotate_exp_list (List.map snd l)
+  rewrite_annotate_exp_list l
 
 and rewrite_trymatching l =
-  rewrite_annotate_exp_list (List.map snd l)
+  rewrite_annotate_exp_list l
 
 (* Rewrite a class definition *)
 
diff --git a/tools/tast_iter.ml b/tools/tast_iter.ml
index d268530fd6..f1559698b8 100644
--- a/tools/tast_iter.ml
+++ b/tools/tast_iter.ml
@@ -10,7 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-open Asttypes
 open Typedtree
 
 let opt f = function None -> () | Some x -> f x
@@ -93,16 +92,16 @@ let expression sub exp =
       sub # bindings (rec_flag, list);
       sub # expression exp
   | Texp_function (_, cases, _) ->
-      sub # bindings (Nonrecursive, cases)
+      sub # cases cases
   | Texp_apply (exp, list) ->
       sub # expression exp;
       List.iter (fun (_, expo, _) -> opt (sub # expression) expo) list
-  | Texp_match (exp, list, _) ->
+  | Texp_match (exp, cases, _) ->
       sub # expression exp;
-      sub # bindings (Nonrecursive, list)
-  | Texp_try (exp, list) ->
+      sub # cases cases
+  | Texp_try (exp, cases) ->
       sub # expression exp;
-      sub # bindings (Nonrecursive, list)
+      sub # cases cases
   | Texp_tuple list ->
       List.iter (sub # expression) list
   | Texp_construct (_, _, args, _) ->
@@ -133,9 +132,6 @@ let expression sub exp =
       sub # expression exp1;
       sub # expression exp2;
       sub # expression exp3
-  | Texp_when (exp1, exp2) ->
-      sub # expression exp1;
-      sub # expression exp2
   | Texp_send (exp, _meth, expo) ->
       sub # expression exp;
       opt (sub # expression) expo
@@ -331,6 +327,14 @@ let class_field sub cf =
 let bindings sub (_rec_flag, list) =
   List.iter (sub # binding) list
 
+let cases sub l =
+  List.iter (sub # case) l
+
+let case sub {c_lhs; c_guard; c_rhs} =
+  sub # pattern c_lhs;
+  opt (sub # expression) c_guard;
+  sub # expression c_rhs
+
 let binding sub (pat, exp) =
   sub # pattern pat;
   sub # expression exp
@@ -338,6 +342,8 @@ let binding sub (pat, exp) =
 class iter = object(this)
   method binding = binding this
   method bindings = bindings this
+  method case = case this
+  method cases = cases this
   method class_description = class_description this
   method class_expr = class_expr this
   method class_field = class_field this
diff --git a/tools/tast_iter.mli b/tools/tast_iter.mli
index 6fd9ea0656..0a6214f7f5 100644
--- a/tools/tast_iter.mli
+++ b/tools/tast_iter.mli
@@ -16,6 +16,8 @@ open Typedtree
 class iter: object
   method binding: (pattern * expression) -> unit
   method bindings: (rec_flag * (pattern * expression) list) -> unit
+  method case: case -> unit
+  method cases: case list -> unit
   method class_description: class_description -> unit
   method class_expr: class_expr -> unit
   method class_field: class_field -> unit
diff --git a/tools/untypeast.ml b/tools/untypeast.ml
index ad14f76f14..1353e3dadf 100644
--- a/tools/untypeast.ml
+++ b/tools/untypeast.ml
@@ -210,6 +210,15 @@ and untype_extra (extra, loc, attrs) sexp =
   in
   Exp.mk ~loc ~attrs desc
 
+and untype_cases l = List.map untype_case l
+
+and untype_case {c_lhs; c_guard; c_rhs} =
+  {
+   pc_lhs = untype_pattern c_lhs;
+   pc_guard = option untype_expression c_guard;
+   pc_rhs = untype_expression c_rhs;
+  }
+
 and untype_expression exp =
   let desc =
     match exp.exp_desc with
@@ -221,9 +230,7 @@ and untype_expression exp =
               untype_pattern pat, untype_expression exp) list,
           untype_expression exp)
     | Texp_function (label, cases, _) ->
-        Pexp_function (label, None,
-          List.map (fun (pat, exp) ->
-              (untype_pattern pat, untype_expression exp)) cases)
+        Pexp_function (label, None, untype_cases cases)
     | Texp_apply (exp, list) ->
         Pexp_apply (untype_expression exp,
           List.fold_right (fun (label, expo, _) list ->
@@ -231,14 +238,10 @@ and untype_expression exp =
                 None -> list
               | Some exp -> (label, untype_expression exp) :: list
           ) list [])
-    | Texp_match (exp, list, _) ->
-        Pexp_match (untype_expression exp,
-          List.map (fun (pat, exp) ->
-              untype_pattern pat, untype_expression exp) list)
-    | Texp_try (exp, list) ->
-        Pexp_try (untype_expression exp,
-          List.map (fun (pat, exp) ->
-              untype_pattern pat, untype_expression exp) list)
+    | Texp_match (exp, cases, _) ->
+        Pexp_match (untype_expression exp, untype_cases cases)
+    | Texp_try (exp, cases) ->
+        Pexp_try (untype_expression exp, untype_cases cases)
     | Texp_tuple list ->
         Pexp_tuple (List.map untype_expression list)
     | Texp_construct (lid, _, args, explicit_arity) ->
@@ -276,8 +279,6 @@ and untype_expression exp =
         Pexp_for (name,
           untype_expression exp1, untype_expression exp2,
           dir, untype_expression exp3)
-    | Texp_when (exp1, exp2) ->
-        Pexp_when (untype_expression exp1, untype_expression exp2)
     | Texp_send (exp, meth, _) ->
         Pexp_send (untype_expression exp, match meth with
             Tmeth_name name -> name
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index 4339f099ec..c744392dc0 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -1641,19 +1641,10 @@ let pressure_variants tdefs patl =
   about guarded patterns
 *)
 
-let has_guard act =   match act.exp_desc with
-| Texp_when(_, _) -> true
-| _ -> false
-
-
 let rec initial_matrix = function
     [] -> []
-  | (pat, act) :: rem ->
-      if has_guard act
-      then
-        initial_matrix rem
-      else
-        [pat] :: initial_matrix rem
+  | {c_guard=Some _} :: rem -> initial_matrix rem
+  | {c_guard=None; c_lhs=p} :: rem -> [p] :: initial_matrix rem
 
 (******************************************)
 (* Look for a row that matches some value *)
@@ -1675,8 +1666,8 @@ let rec initial_all no_guard = function
         raise NoGuard
       else
         []
-  | (pat, act) :: rem ->
-      ([pat], pat.pat_loc) :: initial_all (no_guard && not (has_guard act)) rem
+  | {c_lhs=pat; c_guard; _} :: rem ->
+      ([pat], pat.pat_loc) :: initial_all (no_guard && c_guard = None) rem
 
 
 let rec do_filter_var = function
@@ -1957,7 +1948,7 @@ let rec collect_paths_from_pat r p = match p.pat_desc with
 let do_check_fragile_param exhaust loc casel pss =
   let exts =
     List.fold_left
-      (fun r (p,_) -> collect_paths_from_pat r p)
+      (fun r c -> collect_paths_from_pat r c.c_lhs)
       [] casel in
   match exts with
   | [] -> ()
@@ -1985,7 +1976,7 @@ let check_unused tdefs casel =
   if Warnings.is_active Warnings.Unused_match then
     let rec do_rec pref = function
       | [] -> ()
-      | (q,act)::rem ->
+      | {c_lhs=q; c_guard} :: rem ->
           let qs = [q] in
             begin try
               let pss =
@@ -2005,7 +1996,7 @@ let check_unused tdefs casel =
             with Empty | Not_an_adt | Not_found | NoGuard -> assert false
             end ;
 
-          if has_guard act then
+          if c_guard <> None then
             do_rec pref rem
           else
             do_rec ([q]::pref) rem in
diff --git a/typing/parmatch.mli b/typing/parmatch.mli
index b48d45b6c9..1215c165d4 100644
--- a/typing/parmatch.mli
+++ b/typing/parmatch.mli
@@ -53,13 +53,13 @@ val complete_constrs :
     pattern -> constructor_tag list -> constructor_description  list
 
 val pressure_variants: Env.t -> pattern list -> unit
-val check_partial: Location.t -> (pattern * expression) list -> partial
+val check_partial: Location.t -> case list -> partial
 val check_partial_gadt:
     ((string, constructor_description) Hashtbl.t ->
      (string, label_description) Hashtbl.t ->
      Parsetree.pattern -> pattern option) ->
-    Location.t -> (pattern * expression) list -> partial
-val check_unused: Env.t -> (pattern * expression) list -> unit
+    Location.t -> case list -> partial
+val check_unused: Env.t -> case list -> unit
 
 (* Irrefutability tests *)
 val irrefutable : pattern -> bool
diff --git a/typing/printtyped.ml b/typing/printtyped.ml
index 94d4b92846..54ea2e941b 100644
--- a/typing/printtyped.ml
+++ b/typing/printtyped.ml
@@ -281,7 +281,7 @@ and expression i ppf x =
   | Texp_function (p, l, _partial) ->
       line i ppf "Pexp_function \"%s\"\n" p;
 (*      option i expression ppf eo; *)
-      list i pattern_x_expression_case ppf l;
+      list i case ppf l;
   | Texp_apply (e, l) ->
       line i ppf "Pexp_apply\n";
       expression i ppf e;
@@ -289,11 +289,11 @@ and expression i ppf x =
   | Texp_match (e, l, partial) ->
       line i ppf "Pexp_match\n";
       expression i ppf e;
-      list i pattern_x_expression_case ppf l;
+      list i case ppf l;
   | Texp_try (e, l) ->
       line i ppf "Pexp_try\n";
       expression i ppf e;
-      list i pattern_x_expression_case ppf l;
+      list i case ppf l;
   | Texp_tuple (l) ->
       line i ppf "Pexp_tuple\n";
       list i expression ppf l;
@@ -338,10 +338,6 @@ and expression i ppf x =
       expression i ppf e1;
       expression i ppf e2;
       expression i ppf e3;
-  | Texp_when (e1, e2) ->
-      line i ppf "Pexp_when\n";
-      expression i ppf e1;
-      expression i ppf e2;
   | Texp_send (e, Tmeth_name s, eo) ->
       line i ppf "Pexp_send \"%s\"\n" s;
       expression i ppf e;
@@ -770,10 +766,14 @@ and longident_x_pattern i ppf (li, _, p) =
   line i ppf "%a\n" fmt_longident li;
   pattern (i+1) ppf p;
 
-and pattern_x_expression_case i ppf (p, e) =
+and case i ppf {c_lhs; c_guard; c_rhs} =
   line i ppf "<case>\n";
-  pattern (i+1) ppf  p;
-  expression (i+1) ppf e;
+  pattern (i+1) ppf c_lhs;
+  begin match c_guard with
+  | None -> ()
+  | Some g -> line (i+1) ppf "<when>\n"; expression (i + 2) ppf g
+  end;
+  expression (i+1) ppf c_rhs;
 
 and pattern_x_expression_def i ppf (p, e) =
   line i ppf "<def>\n";
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index bd88868d51..a1d17c2808 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -344,8 +344,9 @@ let make_method loc cl_num expr =
   let mkid s = mkloc s loc in
   Exp.function_ ~loc:expr.pexp_loc "" None
     [
-     Pat.alias ~loc (Pat.var ~loc (mkid "self-*")) (mkid ("self-" ^ cl_num)),
-     expr
+     Exp.case
+       (Pat.alias ~loc (Pat.var ~loc (mkid "self-*")) (mkid ("self-" ^ cl_num)))
+       expr
     ]
 
 
@@ -855,17 +856,19 @@ and class_expr cl_num val_env met_env scl =
       let loc = default.pexp_loc in
       let open Ast_helper in
       let scases = [
-        Pat.construct ~loc
-          (mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
-          (Some (Pat.var ~loc (mknoloc "*sth*")))
-          false,
-        Exp.ident ~loc (mknoloc (Longident.Lident "*sth*"));
-
-        Pat.construct ~loc
-          (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
-          None
-          false,
-        default;
+        Exp.case
+          (Pat.construct ~loc
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
+             (Some (Pat.var ~loc (mknoloc "*sth*")))
+             false)
+          (Exp.ident ~loc (mknoloc (Longident.Lident "*sth*")));
+
+        Exp.case
+          (Pat.construct ~loc
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
+             None
+             false)
+          default;
        ]
       in
       let smatch =
@@ -912,12 +915,14 @@ and class_expr cl_num val_env met_env scl =
       in
       let partial =
         Parmatch.check_partial pat.pat_loc
-          [pat, (* Dummy expression *)
-           {exp_desc = Texp_constant (Asttypes.Const_int 1);
-            exp_loc = Location.none; exp_extra = [];
-            exp_type = Ctype.none;
-            exp_attributes = [];
-            exp_env = Env.empty }]
+          [{c_lhs=pat;
+            c_guard=None;
+            c_rhs = (* Dummy expression *)
+            {exp_desc = Texp_constant (Asttypes.Const_int 1);
+             exp_loc = Location.none; exp_extra = [];
+             exp_type = Ctype.none;
+             exp_attributes = [];
+             exp_env = Env.empty }}]
       in
       Ctype.raise_nongen_level ();
       let cl = class_expr cl_num val_env' met_env scl' in
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 3b74000bf0..10db12ddde 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -109,6 +109,9 @@ let rp node =
 
 let snd3 (_,x,_) = x
 
+let case lhs rhs =
+  {c_lhs = lhs; c_guard = None; c_rhs = rhs}
+
 (* Upper approximation of free identifiers on the parse tree *)
 
 let iter_expression f e =
@@ -122,11 +125,11 @@ let iter_expression f e =
     | Pexp_new _
     | Pexp_constant _ -> ()
     | Pexp_function (_, eo, pel) ->
-        may expr eo; List.iter (fun (_, e) -> expr e) pel
+        may expr eo; List.iter case pel
     | Pexp_apply (e, lel) -> expr e; List.iter (fun (_, e) -> expr e) lel
-    | Pexp_let (_, pel, e)
+    | Pexp_let (_, pel, e) ->  expr e; List.iter (fun (_, e) -> expr e) pel
     | Pexp_match (e, pel)
-    | Pexp_try (e, pel) -> expr e; List.iter (fun (_, e) -> expr e) pel
+    | Pexp_try (e, pel) -> expr e; List.iter case pel
     | Pexp_array el
     | Pexp_tuple el -> List.iter expr el
     | Pexp_construct (_, eo, _)
@@ -142,7 +145,6 @@ let iter_expression f e =
     | Pexp_send (e, _)
     | Pexp_constraint (e, _, _)
     | Pexp_field (e, _) -> expr e
-    | Pexp_when (e1, e2)
     | Pexp_while (e1, e2)
     | Pexp_sequence (e1, e2)
     | Pexp_setfield (e1, _, e2) -> expr e1; expr e2
@@ -153,6 +155,10 @@ let iter_expression f e =
     | Pexp_object { pcstr_fields = fs } -> List.iter class_field fs
     | Pexp_pack me -> module_expr me
 
+  and case {pc_lhs = _; pc_guard; pc_rhs} =
+    may expr pc_guard;
+    expr pc_rhs
+
   and module_expr me =
     match me.pmod_desc with
     | Pmod_extension _
@@ -208,14 +214,19 @@ let iter_expression f e =
   expr e
 
 
-let all_idents el =
+let all_idents_cases el =
   let idents = Hashtbl.create 8 in
   let f = function
     | {pexp_desc=Pexp_ident { txt = Longident.Lident id; _ }; _} ->
         Hashtbl.replace idents id ()
     | _ -> ()
   in
-  List.iter (iter_expression f) el;
+  List.iter
+    (fun cp ->
+      may (iter_expression f) cp.pc_guard;
+      iter_expression f cp.pc_rhs
+    )
+    el;
   Hashtbl.fold (fun x () rest -> x :: rest) idents []
 
 
@@ -1272,7 +1283,7 @@ let rec final_subexpression sexp =
   | Pexp_sequence (_, e)
   | Pexp_try (e, _)
   | Pexp_ifthenelse (_, e, _)
-  | Pexp_match (_, (_, e) :: _)
+  | Pexp_match (_, {pc_rhs=e} :: _)
     -> final_subexpression e
   | _ -> sexp
 
@@ -1586,11 +1597,11 @@ let rec approx_type env sty =
 let rec type_approx env sexp =
   match sexp.pexp_desc with
     Pexp_let (_, _, e) -> type_approx env e
-  | Pexp_function (p,_,(_,e)::_) when is_optional p ->
+  | Pexp_function (p,_,{pc_rhs=e}::_) when is_optional p ->
        newty (Tarrow(p, type_option (newvar ()), type_approx env e, Cok))
-  | Pexp_function (p,_,(_,e)::_) ->
+  | Pexp_function (p,_,{pc_rhs=e}::_) ->
        newty (Tarrow(p, newvar (), type_approx env e, Cok))
-  | Pexp_match (_, (_,e)::_) -> type_approx env e
+  | Pexp_match (_, {pc_rhs=e}::_) -> type_approx env e
   | Pexp_try (e, _) -> type_approx env e
   | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l))
   | Pexp_ifthenelse (_,e,_) -> type_approx env e
@@ -1775,8 +1786,8 @@ let check_absent_variant env =
 
 let duplicate_ident_types loc caselist env =
   let caselist =
-    List.filter (fun (pat, _) -> contains_gadt env pat) caselist in
-  let idents = all_idents (List.map snd caselist) in
+    List.filter (fun {pc_lhs} -> contains_gadt env pc_lhs) caselist in
+  let idents = all_idents_cases caselist in
   List.fold_left
     (fun env s ->
       try
@@ -1882,7 +1893,7 @@ and type_expect_ ?in_function env sexp ty_expected =
         exp_env = env }
   | Pexp_let(Nonrecursive, [spat, sval], sbody) when contains_gadt env spat ->
       type_expect ?in_function env
-        {sexp with pexp_desc = Pexp_match (sval, [spat, sbody])}
+        {sexp with pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody])}
         ty_expected
   | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
       let scp =
@@ -1901,21 +1912,24 @@ and type_expect_ ?in_function env sexp ty_expected =
         exp_type = body.exp_type;
         exp_attributes = sexp.pexp_attributes;
         exp_env = env }
-  | Pexp_function (l, Some default, [spat, sbody]) ->
+  | Pexp_function (l, Some default, [{pc_lhs;pc_guard;pc_rhs}]) ->
+      assert(pc_guard = None); (* fun ~l:p when e0 -> e is no longer allowed *)
       let open Ast_helper in
       let default_loc = default.pexp_loc in
       let scases = [
-        Pat.construct ~loc:default_loc
-          (mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
-          (Some (Pat.var ~loc:default_loc (mknoloc "*sth*")))
-          false,
-        Exp.ident ~loc:default_loc (mknoloc (Longident.Lident "*sth*"));
-
-        Pat.construct ~loc:default_loc
-          (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
-          None
-          false,
-        default;
+        Exp.case
+          (Pat.construct ~loc:default_loc
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
+             (Some (Pat.var ~loc:default_loc (mknoloc "*sth*")))
+             false)
+          (Exp.ident ~loc:default_loc (mknoloc (Longident.Lident "*sth*")));
+
+        Exp.case
+          (Pat.construct ~loc:default_loc
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
+             None
+             false)
+          default;
        ]
       in
       let smatch =
@@ -1926,8 +1940,9 @@ and type_expect_ ?in_function env sexp ty_expected =
         Exp.function_ ~loc
           l None
           [
-           Pat.var ~loc (mknoloc "*opt*"),
-           Exp.let_ ~loc Nonrecursive ~attrs:["#default",Exp.constant (Const_int 0)] [spat, smatch] sbody;
+           Exp.case
+             (Pat.var ~loc (mknoloc "*opt*"))
+             (Exp.let_ ~loc Nonrecursive ~attrs:["#default",Exp.constant (Const_int 0)] [pc_lhs, smatch] pc_rhs)
           ]
       in
       type_expect ?in_function env sfun ty_expected
@@ -1971,7 +1986,7 @@ and type_expect_ ?in_function env sexp ty_expected =
         ls = [] && not tvar
       in
       if is_optional l && not_function ty_res then
-        Location.prerr_warning (fst (List.hd cases)).pat_loc
+        Location.prerr_warning (List.hd cases).c_lhs.pat_loc
           Warnings.Unerasable_optional_argument;
       re {
         exp_desc = Texp_function(l,cases, partial);
@@ -2371,15 +2386,6 @@ and type_expect_ ?in_function env sexp ty_expected =
         exp_env = env;
         exp_extra = (Texp_constraint (cty, cty'), loc, sexp.pexp_attributes) :: arg.exp_extra;
       }
-  | Pexp_when(scond, sbody) ->
-      let cond = type_expect env scond Predef.type_bool in
-      let body = type_expect env sbody ty_expected in
-      re {
-        exp_desc = Texp_when(cond, body);
-        exp_loc = loc; exp_extra = [];
-        exp_type = body.exp_type;
-        exp_attributes = sexp.pexp_attributes;
-        exp_env = env }
   | Pexp_send (e, met) ->
       if !Clflags.principal then begin_def ();
       let obj = type_exp env e in
@@ -2861,11 +2867,15 @@ and type_argument env sarg ty_expected' ty_expected =
       in
       let eta_pat, eta_var = var_pair "eta" ty_arg in
       let func texp =
+        let e =
+          {texp with exp_type = ty_res; exp_desc =
+           Texp_apply
+             (texp,
+              List.rev args @ ["", Some eta_var, Required])}
+        in
         { texp with exp_type = ty_fun; exp_desc =
-          Texp_function("", [eta_pat, {texp with exp_type = ty_res; exp_desc =
-                    Texp_apply (texp,
-                                List.rev args @ ["", Some eta_var, Required])}],
-                        Total) } in
+          Texp_function("", [case eta_pat e], Total) }
+      in
       if warn then Location.prerr_warning texp.exp_loc
           (Warnings.Without_principality "eliminated optional argument");
       if is_nonexpansive texp then func texp else
@@ -3148,9 +3158,9 @@ and type_statement env sexp =
 
 (* Typing of match cases *)
 
-and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
+and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist : Typedtree.case list * _ =
   (* ty_arg is _fully_ generalized *)
-  let patterns = List.map fst caselist in
+  let patterns = List.map (fun {pc_lhs=p} -> p) caselist in
   let erase_either =
     List.exists contains_polymorphic_variant patterns
     && contains_variant_either ty_arg
@@ -3183,8 +3193,13 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
     Printtyp.raw_type_expr ty_arg; *)
   let pat_env_list =
     List.map
-      (fun (spat, sexp) ->
-        let loc = sexp.pexp_loc in
+      (fun {pc_lhs; pc_guard; pc_rhs} ->
+        let loc =
+          let open Location in
+          match pc_guard with
+          | None -> pc_rhs.pexp_loc
+          | Some g -> {pc_rhs.pexp_loc with loc_start=g.pexp_loc.loc_start}
+        in
         if !Clflags.principal then begin_def (); (* propagation of pattern *)
         let scope = Some (Annot.Idef loc) in
         let (pat, ext_env, force, unpacks) =
@@ -3192,7 +3207,7 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
             if !Clflags.principal || erase_either
             then Some false else None in
           let ty_arg = instance ?partial env ty_arg in
-          type_pattern ~lev env spat scope ty_arg
+          type_pattern ~lev env pc_lhs scope ty_arg
         in
         pattern_force := force @ !pattern_force;
         let pat =
@@ -3224,8 +3239,8 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
   let in_function = if List.length caselist = 1 then in_function else None in
   let cases =
     List.map2
-      (fun (pat, (ext_env, unpacks)) (spat, sexp) ->
-        let sexp = wrap_unpacks sexp unpacks in
+      (fun (pat, (ext_env, unpacks)) {pc_lhs; pc_guard; pc_rhs} ->
+        let sexp = wrap_unpacks pc_rhs unpacks in
         let ty_res' =
           if !Clflags.principal then begin
             begin_def ();
@@ -3233,17 +3248,30 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
             end_def ();
             generalize_structure ty; ty
           end
-          else if contains_gadt env spat then correct_levels ty_res
+          else if contains_gadt env pc_lhs then correct_levels ty_res
           else ty_res in
 (*        Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level())
           Printtyp.raw_type_expr ty_res'; *)
+        let guard =
+          match pc_guard with
+          | None -> None
+          | Some scond ->
+              Some
+                (type_expect ext_env (wrap_unpacks scond unpacks)
+                   Predef.type_bool)
+        in
         let exp = type_expect ?in_function ext_env sexp ty_res' in
-        (pat, {exp with exp_type = instance env ty_res'}))
+        {
+         c_lhs = pat;
+         c_guard = guard;
+         c_rhs = {exp with exp_type = instance env ty_res'}
+        }
+      )
       pat_env_list caselist
   in
   if !Clflags.principal || has_gadts then begin
     let ty_res' = instance env ty_res in
-    List.iter (fun (_,exp) -> unify_exp env exp ty_res') cases
+    List.iter (fun c -> unify_exp env c.c_rhs ty_res') cases
   end;
   let partial =
     if partial_flag then
@@ -3425,7 +3453,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
     Location.prerr_warning (fst (List.hd spat_sexp_list)).ppat_loc
       Warnings.Unused_rec_flag;
   List.iter2
-    (fun pat exp -> ignore(Parmatch.check_partial pat.pat_loc [pat, exp]))
+    (fun pat exp -> ignore(Parmatch.check_partial pat.pat_loc [case pat exp]))
     pat_list exp_list;
   end_def();
   List.iter2
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index 2c431b2403..c412f0e595 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -73,10 +73,10 @@ and expression_desc =
     Texp_ident of Path.t * Longident.t loc * Types.value_description
   | Texp_constant of constant
   | Texp_let of rec_flag * (pattern * expression) list * expression
-  | Texp_function of label * (pattern * expression) list * partial
+  | Texp_function of label * case list * partial
   | Texp_apply of expression * (label * expression option * optional) list
-  | Texp_match of expression * (pattern * expression) list * partial
-  | Texp_try of expression * (pattern * expression) list
+  | Texp_match of expression * case list * partial
+  | Texp_try of expression * case list
   | Texp_tuple of expression list
   | Texp_construct of
       Longident.t loc * constructor_description * expression list *
@@ -95,7 +95,6 @@ and expression_desc =
   | Texp_for of
       Ident.t * string loc * expression * expression * direction_flag *
         expression
-  | Texp_when of expression * expression
   | Texp_send of expression * meth * expression option
   | Texp_new of Path.t * Longident.t loc * Types.class_declaration
   | Texp_instvar of Path.t * Path.t * string loc
@@ -112,6 +111,13 @@ and meth =
     Tmeth_name of string
   | Tmeth_val of Ident.t
 
+and case =
+    {
+     c_lhs: pattern;
+     c_guard: expression option;
+     c_rhs: expression;
+    }
+
 (* Value expressions for the class language *)
 
 and class_expr =
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index 6c4cac87e8..8a6e99ced2 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -72,10 +72,10 @@ and expression_desc =
     Texp_ident of Path.t * Longident.t loc * Types.value_description
   | Texp_constant of constant
   | Texp_let of rec_flag * (pattern * expression) list * expression
-  | Texp_function of label * (pattern * expression) list * partial
+  | Texp_function of label * case list * partial
   | Texp_apply of expression * (label * expression option * optional) list
-  | Texp_match of expression * (pattern * expression) list * partial
-  | Texp_try of expression * (pattern * expression) list
+  | Texp_match of expression * case list * partial
+  | Texp_try of expression * case list
   | Texp_tuple of expression list
   | Texp_construct of
       Longident.t loc * constructor_description * expression list *
@@ -94,7 +94,6 @@ and expression_desc =
   | Texp_for of
       Ident.t * string loc * expression * expression * direction_flag *
         expression
-  | Texp_when of expression * expression
   | Texp_send of expression * meth * expression option
   | Texp_new of Path.t * Longident.t loc * Types.class_declaration
   | Texp_instvar of Path.t * Path.t * string loc
@@ -111,6 +110,13 @@ and meth =
     Tmeth_name of string
   | Tmeth_val of Ident.t
 
+and case =
+    {
+     c_lhs: pattern;
+     c_guard: expression option;
+     c_rhs: expression;
+    }
+
 (* Value expressions for the class language *)
 
 and class_expr =
diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml
index a051fee6b2..196659e0be 100644
--- a/typing/typedtreeIter.ml
+++ b/typing/typedtreeIter.ml
@@ -96,8 +96,6 @@ module MakeIterator(Iter : IteratorArgument) : sig
       | Some x -> f x
 
 
-    open Asttypes
-
     let rec iter_structure str =
       Iter.enter_structure str;
       List.iter iter_structure_item str.str_items;
@@ -115,6 +113,14 @@ module MakeIterator(Iter : IteratorArgument) : sig
       List.iter iter_binding list;
       Iter.leave_bindings rec_flag
 
+    and iter_case {c_lhs; c_guard; c_rhs} =
+      iter_pattern c_lhs;
+      may_iter iter_expression c_guard;
+      iter_expression c_rhs
+
+    and iter_cases cases =
+      List.iter iter_case cases
+
     and iter_structure_item item =
       Iter.enter_structure_item item;
       begin
@@ -235,7 +241,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
             iter_bindings rec_flag list;
             iter_expression exp
         | Texp_function (label, cases, _) ->
-            iter_bindings Nonrecursive cases
+            iter_cases cases
         | Texp_apply (exp, list) ->
             iter_expression exp;
             List.iter (fun (label, expo, _) ->
@@ -245,10 +251,10 @@ module MakeIterator(Iter : IteratorArgument) : sig
             ) list
         | Texp_match (exp, list, _) ->
             iter_expression exp;
-            iter_bindings Nonrecursive list
+            iter_cases list
         | Texp_try (exp, list) ->
             iter_expression exp;
-            iter_bindings Nonrecursive list
+            iter_cases list
         | Texp_tuple list ->
             List.iter iter_expression list
         | Texp_construct (_, _, args, _) ->
@@ -288,9 +294,6 @@ module MakeIterator(Iter : IteratorArgument) : sig
             iter_expression exp1;
             iter_expression exp2;
             iter_expression exp3
-        | Texp_when (exp1, exp2) ->
-            iter_expression exp1;
-            iter_expression exp2
         | Texp_send (exp, meth, expo) ->
             iter_expression exp;
           begin
diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml
index c9169c9f8a..55aa357de4 100644
--- a/typing/typedtreeMap.ml
+++ b/typing/typedtreeMap.ml
@@ -75,7 +75,6 @@ module MakeMap(Map : MapArgument) = struct
 
 
   open Misc
-  open Asttypes
 
   let rec map_structure str =
     let str = Map.enter_structure str in
@@ -87,6 +86,16 @@ module MakeMap(Map : MapArgument) = struct
   and map_bindings rec_flag list =
     List.map map_binding list
 
+  and map_case {c_lhs; c_guard; c_rhs} =
+    {
+     c_lhs = map_pattern c_lhs;
+     c_guard = may_map map_expression c_guard;
+     c_rhs = map_expression c_rhs;
+    }
+
+  and map_cases list =
+    List.map map_case list
+
   and map_structure_item item =
     let item = Map.enter_structure_item item in
     let str_desc =
@@ -226,7 +235,7 @@ module MakeMap(Map : MapArgument) = struct
                     map_bindings rec_flag list,
                     map_expression exp)
         | Texp_function (label, cases, partial) ->
-          Texp_function (label, map_bindings Nonrecursive cases, partial)
+          Texp_function (label, map_cases cases, partial)
         | Texp_apply (exp, list) ->
           Texp_apply (map_expression exp,
                       List.map (fun (label, expo, optional) ->
@@ -240,13 +249,13 @@ module MakeMap(Map : MapArgument) = struct
         | Texp_match (exp, list, partial) ->
           Texp_match (
             map_expression exp,
-            map_bindings Nonrecursive list,
+            map_cases list,
             partial
           )
         | Texp_try (exp, list) ->
           Texp_try (
             map_expression exp,
-            map_bindings Nonrecursive list
+            map_cases list
           )
         | Texp_tuple list ->
           Texp_tuple (List.map map_expression list)
@@ -305,11 +314,6 @@ module MakeMap(Map : MapArgument) = struct
             dir,
             map_expression exp3
           )
-        | Texp_when (exp1, exp2) ->
-          Texp_when (
-            map_expression exp1,
-            map_expression exp2
-          )
         | Texp_send (exp, meth, expo) ->
           Texp_send (map_expression exp, meth, may_map map_expression expo)
         | Texp_new (path, lid, cl_decl) -> exp.exp_desc