diff options
Diffstat (limited to 'tools')
-rw-r--r-- | tools/cmt2annot.ml | 10 | ||||
-rw-r--r-- | tools/depend.ml | 16 | ||||
-rw-r--r-- | tools/ocamlprof.ml | 39 | ||||
-rw-r--r-- | tools/tast_iter.ml | 24 | ||||
-rw-r--r-- | tools/tast_iter.mli | 2 | ||||
-rw-r--r-- | tools/untypeast.ml | 27 |
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 |