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

6 files changed, 72 insertions, 46 deletions

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