From f2a56e6819ae32241ca68b9ec02838a7cc516dd2 Mon Sep 17 00:00:00 2001 From: Tomasz Nowak Date: Tue, 8 Aug 2023 13:18:21 +0100 Subject: [PATCH 1/5] Manually applied changes from PR #11782 --- native_toplevel/opttoploop.ml | 2 +- ocaml/lambda/matching.ml | 29 +++++++++--------- ocaml/lambda/translclass.ml | 4 +-- ocaml/lambda/translcore.ml | 11 +++---- ocaml/ocamldoc/odoc_ast.ml | 18 +++++------ ocaml/toplevel/native/topeval.ml | 2 +- ocaml/typing/cmt2annot.ml | 2 +- ocaml/typing/parmatch.ml | 35 +++++++++++----------- ocaml/typing/patterns.ml | 18 +++++------ ocaml/typing/patterns.mli | 4 +-- ocaml/typing/printpat.ml | 4 +-- ocaml/typing/printtyped.ml | 4 +-- ocaml/typing/rec_check.ml | 6 ++-- ocaml/typing/tast_iterator.ml | 2 +- ocaml/typing/tast_mapper.ml | 2 +- ocaml/typing/typecore.ml | 33 ++++++++++++--------- ocaml/typing/typedtree.ml | 46 +++++++++++++++-------------- ocaml/typing/typedtree.mli | 9 ++++-- ocaml/typing/uniqueness_analysis.ml | 4 +-- ocaml/typing/untypeast.ml | 12 ++++---- 20 files changed, 130 insertions(+), 117 deletions(-) diff --git a/native_toplevel/opttoploop.ml b/native_toplevel/opttoploop.ml index adfa88f6413..4e30383bdee 100644 --- a/native_toplevel/opttoploop.ml +++ b/native_toplevel/opttoploop.ml @@ -378,7 +378,7 @@ let name_expression ~loc ~attrs sort exp = in let sg = [Sig_value(id, vd, Exported)] in let pat = - { pat_desc = Tpat_var(id, mknoloc name, Mode.Value.legacy); + { pat_desc = Tpat_var(id, mknoloc name, vd.val_uid, Mode.Value.legacy); pat_loc = loc; pat_extra = []; pat_type = exp.exp_type; diff --git a/ocaml/lambda/matching.ml b/ocaml/lambda/matching.ml index 11b3832fb6b..51d74712151 100644 --- a/ocaml/lambda/matching.ml +++ b/ocaml/lambda/matching.ml @@ -234,8 +234,8 @@ end = struct | Tpat_any | Tpat_var _ -> p - | Tpat_alias (q, id, s, mode) -> - { p with pat_desc = Tpat_alias (simpl_under_orpat q, id, s, mode) } + | Tpat_alias (q, id, s, uid, mode) -> + { p with pat_desc = Tpat_alias (simpl_under_orpat q, id, s, uid, mode) } | Tpat_or (p1, p2, o) -> let p1, p2 = (simpl_under_orpat p1, simpl_under_orpat p2) in if le_pat p1 p2 then @@ -258,8 +258,9 @@ end = struct in match p.pat_desc with | `Any -> stop p `Any - | `Var (id, s, mode) -> continue p (`Alias (Patterns.omega, id, s, mode)) - | `Alias (p, id, _, _) -> + | `Var (id, s, uid, mode) -> + continue p (`Alias (Patterns.omega, id, s, uid, mode)) + | `Alias (p, id, _, _, _) -> aux ( (General.view p, patl), bind_alias p id ~arg ~arg_sort ~action ) @@ -354,10 +355,10 @@ end = struct match p.pat_desc with | `Or (p1, p2, _) -> split_explode p1 aliases (split_explode p2 aliases rem) - | `Alias (p, id, _, _) -> split_explode p (id :: aliases) rem - | `Var (id, str, mode) -> + | `Alias (p, id, _, _, _) -> split_explode p (id :: aliases) rem + | `Var (id, str, uid, mode) -> explode - { p with pat_desc = `Alias (Patterns.omega, id, str, mode) } + { p with pat_desc = `Alias (Patterns.omega, id, str, uid, mode) } aliases rem | #view as view -> (* We are doing two things here: @@ -595,7 +596,7 @@ end = struct match p.pat_desc with | `Or (p1, p2, _) -> filter_rec ((left, p1, right) :: (left, p2, right) :: rem) - | `Alias (p, _, _, _) -> filter_rec ((left, p, right) :: rem) + | `Alias (p, _, _, _, _) -> filter_rec ((left, p, right) :: rem) | `Var _ -> filter_rec ((left, Patterns.omega, right) :: rem) | #Simple.view as view -> ( let p = { p with pat_desc = view } in @@ -645,7 +646,7 @@ let rec flatten_pat_line size p k = | Tpat_tuple args -> args :: k | Tpat_or (p1, p2, _) -> flatten_pat_line size p1 (flatten_pat_line size p2 k) - | Tpat_alias (p, _, _, _) -> + | Tpat_alias (p, _, _, _, _) -> (* Note: we are only called from flatten_matrix, which is itself only ever used in places where variables do not matter (default environments, @@ -722,7 +723,7 @@ end = struct | (p, ps) :: rem -> ( let p = General.view p in match p.pat_desc with - | `Alias (p, _, _, _) -> filter_rec ((p, ps) :: rem) + | `Alias (p, _, _, _, _) -> filter_rec ((p, ps) :: rem) | `Var _ -> filter_rec ((Patterns.omega, ps) :: rem) | `Or (p1, p2, _) -> filter_rec_or p1 p2 ps rem | #Simple.view as view -> ( @@ -1208,7 +1209,7 @@ let rec omega_like p = | Tpat_any | Tpat_var _ -> true - | Tpat_alias (p, _, _, _) -> omega_like p + | Tpat_alias (p, _, _, _, _) -> omega_like p | Tpat_or (p1, p2, _) -> omega_like p1 || omega_like p2 | _ -> false @@ -3314,8 +3315,8 @@ let rec comp_match_handlers value_kind comp_fun partial ctx first_match next_mat let rec name_pattern default = function | ((pat, _), _) :: rem -> ( match pat.pat_desc with - | Tpat_var (id, _, _) -> id - | Tpat_alias (_, id, _, _) -> id + | Tpat_var (id, _, _, _) -> id + | Tpat_alias (_, id, _, _, _) -> id | _ -> name_pattern default rem ) | _ -> Ident.create_local default @@ -3819,7 +3820,7 @@ let for_let ~scopes ~arg_sort ~return_layout loc param pat body = (* This eliminates a useless variable (and stack slot in bytecode) for "let _ = ...". See #6865. *) Lsequence (param, body) - | Tpat_var (id, _, _) -> + | Tpat_var (id, _, _, _) -> (* fast path, and keep track of simple bindings to unboxable numbers *) let k = Typeopt.layout pat.pat_env pat.pat_loc arg_sort pat.pat_type in Llet (Strict, k, id, param, body) diff --git a/ocaml/lambda/translclass.ml b/ocaml/lambda/translclass.ml index ee9db420ab8..c367ce9d3e3 100644 --- a/ocaml/lambda/translclass.ml +++ b/ocaml/lambda/translclass.ml @@ -152,8 +152,8 @@ let create_object cl obj init = let name_pattern default p = match p.pat_desc with - | Tpat_var (id, _, _) -> id - | Tpat_alias(_, id, _, _) -> id + | Tpat_var (id, _, _, _) -> id + | Tpat_alias(_, id, _, _, _) -> id | _ -> Ident.create_local default let rec build_object_init ~scopes cl_table obj params inh_init obj_init cl = diff --git a/ocaml/lambda/translcore.ml b/ocaml/lambda/translcore.ml index 715598a8132..0b7308cbb45 100644 --- a/ocaml/lambda/translcore.ml +++ b/ocaml/lambda/translcore.ml @@ -222,7 +222,7 @@ let rec trivial_pat pat = match pat.pat_desc with Tpat_var _ | Tpat_any -> true - | Tpat_alias (p, _, _, _) -> + | Tpat_alias (p, _, _, _, _) -> trivial_pat p | Tpat_construct (_, cd, [], _) -> not cd.cstr_generalized && cd.cstr_consts = 1 && cd.cstr_nonconsts = 0 @@ -283,7 +283,8 @@ let rec push_defaults loc bindings use_lhs arg_mode arg_sort cases arg_sort, cases, partial) } in - [{c_lhs = {pat with pat_desc = Tpat_var (param, mknoloc name, mode)}; + [{c_lhs = {pat with + pat_desc = Tpat_var (param, mknoloc name, desc.val_uid, mode)}; c_guard = None; c_rhs= wrap_bindings bindings exp}] | _ -> cases @@ -335,8 +336,8 @@ let assert_failed ~scopes exp = let rec iter_exn_names f pat = match pat.pat_desc with - | Tpat_var (id, _, _) -> f id - | Tpat_alias (p, id, _, _) -> + | Tpat_var (id, _, _, _) -> f id + | Tpat_alias (p, id, _, _, _) -> f id; iter_exn_names f p | _ -> () @@ -1443,7 +1444,7 @@ and transl_let ~scopes ~return_layout ?(add_regions=false) ?(in_structure=false) let idlist = List.map (fun {vb_pat=pat} -> match pat.pat_desc with - Tpat_var (id,_,_) -> id + Tpat_var (id,_,_,_) -> id | _ -> assert false) pat_expr_list in let transl_case diff --git a/ocaml/ocamldoc/odoc_ast.ml b/ocaml/ocamldoc/odoc_ast.ml index 5b246e831f8..2f47e4911ba 100644 --- a/ocaml/ocamldoc/odoc_ast.ml +++ b/ocaml/ocamldoc/odoc_ast.ml @@ -50,7 +50,7 @@ module Typedtree_search = let iter_val_pattern = function | Typedtree.Tpat_any -> None - | Typedtree.Tpat_var (name, _, _) -> Some (Name.from_ident name) + | Typedtree.Tpat_var (name, _, _, _) -> Some (Name.from_ident name) | Typedtree.Tpat_tuple _ -> None (* FIXME when we will handle tuples *) | _ -> None @@ -241,14 +241,14 @@ module Analyser = let tt_param_info_from_pattern env f_desc pat = let rec iter_pattern pat = match pat.pat_desc with - Typedtree.Tpat_var (ident, _, _) -> + Typedtree.Tpat_var (ident, _, _, _) -> let name = Name.from_ident ident in Simple_name { sn_name = name ; sn_text = f_desc name ; sn_type = Odoc_env.subst_type env pat.pat_type } - | Typedtree.Tpat_alias (pat, _, _, _) -> + | Typedtree.Tpat_alias (pat, _, _, _, _) -> iter_pattern pat | Typedtree.Tpat_tuple patlist -> @@ -307,7 +307,7 @@ module Analyser = ( ( match func_body.exp_desc with - Typedtree.Texp_let (_, {vb_pat={pat_desc = Typedtree.Tpat_var (id, _, _) }; + Typedtree.Texp_let (_, {vb_pat={pat_desc = Typedtree.Tpat_var (id, _, _, _) }; vb_expr=exp} :: _, func_body2) -> let name = Name.from_ident id in let new_param = Simple_name @@ -337,7 +337,7 @@ module Analyser = let tt_analyse_value env current_module_name comment_opt loc pat_exp rec_flag = let (pat, exp) = pat_exp in match (pat.pat_desc, exp.exp_desc) with - (Typedtree.Tpat_var (ident, _, _), Typedtree.Texp_function { cases = pat_exp_list2; _ }) -> + (Typedtree.Tpat_var (ident, _, _, _), Typedtree.Texp_function { cases = pat_exp_list2; _ }) -> (* a new function is defined *) let name_pre = Name.from_ident ident in let name = Name.parens_if_infix name_pre in @@ -362,7 +362,7 @@ module Analyser = in [ new_value ] - | (Typedtree.Tpat_var (ident, _, _), _) -> + | (Typedtree.Tpat_var (ident, _, _, _), _) -> (* a new value is defined *) let name_pre = Name.from_ident ident in let name = Name.parens_if_infix name_pre in @@ -467,7 +467,7 @@ module Analyser = ( ( match body.exp_desc with - Typedtree.Texp_let (_, {vb_pat={pat_desc = Typedtree.Tpat_var (id, _, _) }; + Typedtree.Texp_let (_, {vb_pat={pat_desc = Typedtree.Tpat_var (id, _, _, _) }; vb_expr=exp} :: _, body2) -> let name = Name.from_ident id in let new_param = Simple_name @@ -728,11 +728,11 @@ module Analyser = a default value. In this case, we look for the good parameter pattern *) let (parameter, next_tt_class_exp) = match pat.Typedtree.pat_desc with - Typedtree.Tpat_var (ident, _, _) when String.starts_with (Name.from_ident ident) ~prefix:"*opt*" -> + Typedtree.Tpat_var (ident, _, _, _) when String.starts_with (Name.from_ident ident) ~prefix:"*opt*" -> ( (* there must be a Tcl_let just after *) match tt_class_expr2.Typedtree.cl_desc with - Typedtree.Tcl_let (_, {vb_pat={pat_desc = Typedtree.Tpat_var (id,_,_) }; + Typedtree.Tcl_let (_, {vb_pat={pat_desc = Typedtree.Tpat_var (id,_,_,_) }; vb_expr=exp} :: _, _, tt_class_expr3) -> let name = Name.from_ident id in let new_param = Simple_name diff --git a/ocaml/toplevel/native/topeval.ml b/ocaml/toplevel/native/topeval.ml index 3c44ba2ef49..47b0e1bea70 100644 --- a/ocaml/toplevel/native/topeval.ml +++ b/ocaml/toplevel/native/topeval.ml @@ -134,7 +134,7 @@ let name_expression ~loc ~attrs sort exp = in let sg = [Sig_value(id, vd, Exported)] in let pat = - { pat_desc = Tpat_var(id, mknoloc name, Mode.Value.legacy); + { pat_desc = Tpat_var(id, mknoloc name, vd.val_uid, Mode.Value.legacy); pat_loc = loc; pat_extra = []; pat_type = exp.exp_type; diff --git a/ocaml/typing/cmt2annot.ml b/ocaml/typing/cmt2annot.ml index b2d203c14f6..beb8e0e34c1 100644 --- a/ocaml/typing/cmt2annot.ml +++ b/ocaml/typing/cmt2annot.ml @@ -23,7 +23,7 @@ let variables_iterator scope = let super = default_iterator in let pat sub (type k) (p : k general_pattern) = begin match p.pat_desc with - | Tpat_var (id, _, _) | Tpat_alias (_, id, _, _) -> + | Tpat_var (id, _, _, _) | Tpat_alias (_, id, _, _, _) -> Stypes.record (Stypes.An_ident (p.pat_loc, Ident.name id, Annot.Idef scope)) diff --git a/ocaml/typing/parmatch.ml b/ocaml/typing/parmatch.ml index 52d7fdabcee..0ecd1a7e584 100644 --- a/ocaml/typing/parmatch.ml +++ b/ocaml/typing/parmatch.ml @@ -37,7 +37,8 @@ let omega_list = Patterns.omega_list let extra_pat = make_pat - (Tpat_var (Ident.create_local "+", mknoloc "+", Mode.Value.max_mode)) + (Tpat_var (Ident.create_local "+", mknoloc "+", + Uid.internal_not_actually_unique, Mode.Value.max_mode)) Ctype.none Env.empty @@ -283,8 +284,8 @@ module Compat | ((Tpat_any|Tpat_var _),_) | (_,(Tpat_any|Tpat_var _)) -> true (* Structural induction *) - | Tpat_alias (p,_,_,_),_ -> compat p q - | _,Tpat_alias (q,_,_,_) -> compat p q + | Tpat_alias (p,_,_,_,_),_ -> compat p q + | _,Tpat_alias (q,_,_,_,_) -> compat p q | Tpat_or (p1,p2,_),_ -> (compat p1 q || compat p2 q) | _,Tpat_or (q1,q2,_) -> @@ -930,7 +931,7 @@ let build_other ext env = make_pat (Tpat_var (Ident.create_local "*extension*", {txt="*extension*"; loc = d.pat_loc}, - Mode.Value.max_mode)) + Uid.internal_not_actually_unique, Mode.Value.max_mode)) Ctype.none Env.empty | Construct _ -> begin match ext with @@ -1064,7 +1065,7 @@ let build_other ext env = let rec has_instance p = match p.pat_desc with | Tpat_variant (l,_,r) when is_absent l r -> false | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true - | Tpat_alias (p,_,_,_) | Tpat_variant (_,Some p,_) -> has_instance p + | Tpat_alias (p,_,_,_,_) | Tpat_variant (_,Some p,_) -> has_instance p | Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2 | Tpat_construct (_,_,ps, _) | Tpat_tuple ps | Tpat_array (_, ps) -> has_instances ps @@ -1519,7 +1520,7 @@ let is_var_column rs = (* Standard or-args for left-to-right matching *) let rec or_args p = match p.pat_desc with | Tpat_or (p1,p2,_) -> p1,p2 -| Tpat_alias (p,_,_,_) -> or_args p +| Tpat_alias (p,_,_,_,_) -> or_args p | _ -> assert false (* Just remove current column *) @@ -1699,8 +1700,8 @@ and every_both pss qs q1 q2 = let rec le_pat p q = match (p.pat_desc, q.pat_desc) with | (Tpat_var _|Tpat_any),_ -> true - | Tpat_alias(p,_,_,_), _ -> le_pat p q - | _, Tpat_alias(q,_,_,_) -> le_pat p q + | Tpat_alias(p,_,_,_,_), _ -> le_pat p q + | _, Tpat_alias(q,_,_,_,_) -> le_pat p q | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0 | Tpat_construct(_,c1,ps,_), Tpat_construct(_,c2,qs,_) -> Types.equal_tag c1.cstr_tag c2.cstr_tag && le_pats ps qs @@ -1739,8 +1740,8 @@ let get_mins le ps = *) let rec lub p q = match p.pat_desc,q.pat_desc with -| Tpat_alias (p,_,_,_),_ -> lub p q -| _,Tpat_alias (q,_,_,_) -> lub p q +| Tpat_alias (p,_,_,_,_),_ -> lub p q +| _,Tpat_alias (q,_,_,_,_) -> lub p q | (Tpat_any|Tpat_var _),_ -> q | _,(Tpat_any|Tpat_var _) -> p | Tpat_or (p1,p2,_),_ -> orlub p1 p2 q @@ -1878,14 +1879,14 @@ module Conv = struct match pat.pat_desc with Tpat_or (pa,pb,_) -> mkpat (Ppat_or (loop pa, loop pb)) - | Tpat_var (_, ({txt="*extension*"} as nm), _) -> (* PR#7330 *) + | Tpat_var (_, ({txt="*extension*"} as nm), _, _) -> (* PR#7330 *) mkpat (Ppat_var nm) | Tpat_any | Tpat_var _ -> mkpat Ppat_any | Tpat_constant c -> mkpat (Ppat_constant (Untypeast.constant c)) - | Tpat_alias (p,_,_,_) -> loop p + | Tpat_alias (p,_,_,_,_) -> loop p | Tpat_tuple lst -> mkpat (Ppat_tuple (List.map loop lst)) | Tpat_construct (cstr_lid, cstr, lst, _) -> @@ -1936,7 +1937,7 @@ end let contains_extension pat = exists_pattern (function - | {pat_desc=Tpat_var (_, {txt="*extension*"}, _)} -> true + | {pat_desc=Tpat_var (_, {txt="*extension*"}, _, _)} -> true | _ -> false) pat @@ -2047,7 +2048,7 @@ let rec collect_paths_from_pat r p = match p.pat_desc with List.fold_left (fun r (_, _, p) -> collect_paths_from_pat r p) r lps -| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_,_) -> collect_paths_from_pat r p +| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_,_,_) -> collect_paths_from_pat r p | Tpat_or (p1,p2,_) -> collect_paths_from_pat (collect_paths_from_pat r p1) p2 | Tpat_lazy p @@ -2182,7 +2183,7 @@ let inactive ~partial pat = | Tpat_tuple ps | Tpat_construct (_, _, ps, _) | Tpat_array (Immutable, ps) -> List.for_all (fun p -> loop p) ps - | Tpat_alias (p,_,_,_) | Tpat_variant (_, Some p, _) -> + | Tpat_alias (p,_,_,_,_) | Tpat_variant (_, Some p, _) -> loop p | Tpat_record (ldps,_) -> List.for_all @@ -2301,9 +2302,9 @@ type amb_row = { row : pattern list ; varsets : Ident.Set.t list; } let simplify_head_amb_pat head_bound_variables varsets ~add_column p ps k = let rec simpl head_bound_variables varsets p ps k = match (Patterns.General.view p).pat_desc with - | `Alias (p,x,_,_) -> + | `Alias (p,x,_,_,_) -> simpl (Ident.Set.add x head_bound_variables) varsets p ps k - | `Var (x, _, _) -> + | `Var (x, _, _, _) -> simpl (Ident.Set.add x head_bound_variables) varsets Patterns.omega ps k | `Or (p1,p2,_) -> simpl head_bound_variables varsets p1 ps diff --git a/ocaml/typing/patterns.ml b/ocaml/typing/patterns.ml index e761e3d5712..ba0ca2ee243 100644 --- a/ocaml/typing/patterns.ml +++ b/ocaml/typing/patterns.ml @@ -79,18 +79,18 @@ end module General = struct type view = [ | Half_simple.view - | `Var of Ident.t * string loc * Mode.Value.t - | `Alias of pattern * Ident.t * string loc * Mode.Value.t + | `Var of Ident.t * string loc * Uid.t * Mode.Value.t + | `Alias of pattern * Ident.t * string loc * Uid.t * Mode.Value.t ] type pattern = view pattern_data let view_desc = function | Tpat_any -> `Any - | Tpat_var (id, str, mode) -> - `Var (id, str, mode) - | Tpat_alias (p, id, str, mode) -> - `Alias (p, id, str, mode) + | Tpat_var (id, str, uid, mode) -> + `Var (id, str, uid, mode) + | Tpat_alias (p, id, str, uid, mode) -> + `Alias (p, id, str, uid, mode) | Tpat_constant cst -> `Constant cst | Tpat_tuple ps -> @@ -110,8 +110,8 @@ module General = struct let erase_desc = function | `Any -> Tpat_any - | `Var (id, str, mode) -> Tpat_var (id, str, mode) - | `Alias (p, id, str, mode) -> Tpat_alias (p, id, str, mode) + | `Var (id, str, uid, mode) -> Tpat_var (id, str, uid, mode) + | `Alias (p, id, str, uid, mode) -> Tpat_alias (p, id, str, uid, mode) | `Constant cst -> Tpat_constant cst | `Tuple ps -> Tpat_tuple ps | `Construct (cstr, cst_descr, args) -> @@ -129,7 +129,7 @@ module General = struct let rec strip_vars (p : pattern) : Half_simple.pattern = match p.pat_desc with - | `Alias (p, _, _, _) -> strip_vars (view p) + | `Alias (p, _, _, _, _) -> strip_vars (view p) | `Var _ -> { p with pat_desc = `Any } | #Half_simple.view as view -> { p with pat_desc = view } end diff --git a/ocaml/typing/patterns.mli b/ocaml/typing/patterns.mli index 9f6b4862f71..9fc7e38fbcf 100644 --- a/ocaml/typing/patterns.mli +++ b/ocaml/typing/patterns.mli @@ -65,8 +65,8 @@ end module General : sig type view = [ | Half_simple.view - | `Var of Ident.t * string loc * Mode.Value.t - | `Alias of pattern * Ident.t * string loc * Mode.Value.t + | `Var of Ident.t * string loc * Uid.t * Mode.Value.t + | `Alias of pattern * Ident.t * string loc * Uid.t * Mode.Value.t ] type pattern = view pattern_data diff --git a/ocaml/typing/printpat.ml b/ocaml/typing/printpat.ml index 5dcf70b5bdd..f636809983a 100644 --- a/ocaml/typing/printpat.ml +++ b/ocaml/typing/printpat.ml @@ -52,7 +52,7 @@ let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v -> | [] -> match v.pat_desc with | Tpat_any -> fprintf ppf "_" - | Tpat_var (x,_,_) -> fprintf ppf "%s" (Ident.name x) + | Tpat_var (x,_,_,_) -> fprintf ppf "%s" (Ident.name x) | Tpat_constant c -> fprintf ppf "%s" (pretty_const c) | Tpat_tuple vs -> fprintf ppf "@[(%a)@]" (pretty_vals ",") vs @@ -102,7 +102,7 @@ let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v -> fprintf ppf "@[[%c %a %c]@]" punct (pretty_vals " ;") vs punct | Tpat_lazy v -> fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v - | Tpat_alias (v, x, _, _) -> + | Tpat_alias (v, x, _, _, _) -> fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x | Tpat_value v -> fprintf ppf "%a" pretty_val (v :> pattern) diff --git a/ocaml/typing/printtyped.ml b/ocaml/typing/printtyped.ml index 293dda855c3..6c9cd7c9053 100644 --- a/ocaml/typing/printtyped.ml +++ b/ocaml/typing/printtyped.ml @@ -279,10 +279,10 @@ and pattern : type k . _ -> _ -> k general_pattern -> unit = fun i ppf x -> end; match x.pat_desc with | Tpat_any -> line i ppf "Tpat_any\n"; - | Tpat_var (s,_,m) -> + | Tpat_var (s,_,_,m) -> line i ppf "Tpat_var \"%a\"\n" fmt_ident s; value_mode i ppf m - | Tpat_alias (p, s,_,m) -> + | Tpat_alias (p, s,_,_,m) -> line i ppf "Tpat_alias \"%a\"\n" fmt_ident s; value_mode i ppf m; pattern i ppf p; diff --git a/ocaml/typing/rec_check.ml b/ocaml/typing/rec_check.ml index 5f94bd3f7a8..b649d22345b 100644 --- a/ocaml/typing/rec_check.ml +++ b/ocaml/typing/rec_check.ml @@ -225,7 +225,7 @@ let classify_expression : Typedtree.expression -> sd = let old_env = env in let add_value_binding env vb = match vb.vb_pat.pat_desc with - | Tpat_var (id, _loc, _mode) -> + | Tpat_var (id, _loc, _uid, _mode) -> let size = classify_expression old_env vb.vb_expr in Ident.add id size env | _ -> @@ -1227,8 +1227,8 @@ and pattern : type k . k general_pattern -> Env.t -> mode = fun pat env -> and is_destructuring_pattern : type k . k general_pattern -> bool = fun pat -> match pat.pat_desc with | Tpat_any -> false - | Tpat_var (_, _, _) -> false - | Tpat_alias (pat, _, _, _) -> is_destructuring_pattern pat + | Tpat_var (_, _, _, _) -> false + | Tpat_alias (pat, _, _, _, _) -> is_destructuring_pattern pat | Tpat_constant _ -> true | Tpat_tuple _ -> true | Tpat_construct _ -> true diff --git a/ocaml/typing/tast_iterator.ml b/ocaml/typing/tast_iterator.ml index 3c7cd8fcd9e..0755aa95df1 100644 --- a/ocaml/typing/tast_iterator.ml +++ b/ocaml/typing/tast_iterator.ml @@ -183,7 +183,7 @@ let pat | Tpat_variant (_, po, _) -> Option.iter (sub.pat sub) po | Tpat_record (l, _) -> List.iter (fun (_, _, i) -> sub.pat sub i) l | Tpat_array (_, l) -> List.iter (sub.pat sub) l - | Tpat_alias (p, _, _, _) -> sub.pat sub p + | Tpat_alias (p, _, _, _, _) -> sub.pat sub p | Tpat_lazy p -> sub.pat sub p | Tpat_value p -> sub.pat sub (p :> pattern) | Tpat_exception p -> sub.pat sub p diff --git a/ocaml/typing/tast_mapper.ml b/ocaml/typing/tast_mapper.ml index 2b775822802..55d2d0e4230 100644 --- a/ocaml/typing/tast_mapper.ml +++ b/ocaml/typing/tast_mapper.ml @@ -240,7 +240,7 @@ let pat | Tpat_record (l, closed) -> Tpat_record (List.map (tuple3 id id (sub.pat sub)) l, closed) | Tpat_array (am, l) -> Tpat_array (am, List.map (sub.pat sub) l) - | Tpat_alias (p, id, s, m) -> Tpat_alias (sub.pat sub p, id, s, m) + | Tpat_alias (p, id, s, uid, m) -> Tpat_alias (sub.pat sub p, id, s, uid, m) | Tpat_lazy p -> Tpat_lazy (sub.pat sub p) | Tpat_value p -> (as_computation_pattern (sub.pat sub (p :> pattern))).pat_desc diff --git a/ocaml/typing/typecore.ml b/ocaml/typing/typecore.ml index 34dffca8a47..fcabcd27458 100644 --- a/ocaml/typing/typecore.ml +++ b/ocaml/typing/typecore.ml @@ -1106,6 +1106,7 @@ let enter_variable end else Ident.create_local name.txt in + let pv_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in tps.tps_pattern_variables <- {pv_id = id; pv_mode = mode; @@ -1113,7 +1114,7 @@ let enter_variable pv_loc = loc; pv_as_var = is_as_variable; pv_attributes = attrs} :: tps.tps_pattern_variables; - id + id, pv_uid let sort_pattern_variables vs = List.sort @@ -1188,7 +1189,7 @@ and build_as_type_aux ~refine ~mode (env : Env.t ref) p = let build_as_type env p = fst (build_as_type_and_mode ~refine ~mode env p) in match p.pat_desc with - Tpat_alias(p1,_, _, _) -> build_as_type_and_mode ~refine ~mode env p1 + Tpat_alias(p1,_, _, _, _) -> build_as_type_and_mode ~refine ~mode env p1 | Tpat_tuple pl -> let tyl = List.map (build_as_type env) pl in newty (Ttuple tyl), mode @@ -1639,6 +1640,8 @@ let type_comprehension_for_range_iterator_index ~loc ~env ~param tps = for duplicates or anything else. *) ~any:Fun.id ~var:(fun ~name ~pv_mode ~pv_type ~pv_loc ~pv_as_var ~pv_attributes -> + (* CR tnowak: verify this change *) + fst ( enter_variable ~is_as_variable:pv_as_var tps @@ -1646,7 +1649,7 @@ let type_comprehension_for_range_iterator_index ~loc ~env ~param tps = name pv_mode pv_type - pv_attributes) + pv_attributes)) (* Type paths *) @@ -2495,14 +2498,14 @@ and type_pat_aux | Ppat_var name -> let ty = instance expected_ty in let alloc_mode = mode_cross_to_min !env expected_ty alloc_mode.mode in - let id = (* PR#7330 *) + let id, uid = (* PR#7330 *) if name.txt = "*extension*" then - Ident.create_local name.txt + Ident.create_local name.txt, Uid.internal_not_actually_unique else enter_variable tps loc name alloc_mode ty sp.ppat_attributes in rvp k { - pat_desc = Tpat_var (id, name, alloc_mode); + pat_desc = Tpat_var (id, name, uid, alloc_mode); pat_loc = loc; pat_extra=[]; pat_type = ty; pat_attributes = sp.ppat_attributes; @@ -2524,10 +2527,10 @@ and type_pat_aux (* We're able to pass ~is_module:true here without an error because [Ppat_unpack] is a case identified by [may_contain_modules]. See the comment on [may_contain_modules]. *) - let id = enter_variable tps loc v alloc_mode.mode - t ~is_module:true sp.ppat_attributes in + let id, uid = enter_variable tps loc v alloc_mode.mode + t ~is_module:true sp.ppat_attributes in rvp k { - pat_desc = Tpat_var (id, v, alloc_mode.mode); + pat_desc = Tpat_var (id, v, uid, alloc_mode.mode); pat_loc = sp.ppat_loc; pat_extra=[Tpat_unpack, loc, sp.ppat_attributes]; pat_type = t; @@ -2539,12 +2542,12 @@ and type_pat_aux type_pat tps Value sq expected_ty (fun q -> let ty_var, mode = solve_Ppat_alias ~refine ~mode:alloc_mode.mode env q in let mode = mode_cross_to_min !env expected_ty mode in - let id = + let id, uid = enter_variable ~is_as_variable:true tps name.loc name mode ty_var sp.ppat_attributes in rvp k { - pat_desc = Tpat_alias(q, id, name, mode); + pat_desc = Tpat_alias(q, id, name, uid, mode); pat_loc = loc; pat_extra=[]; pat_type = q.pat_type; pat_attributes = sp.ppat_attributes; @@ -4361,8 +4364,8 @@ let rec name_pattern default = function [] -> Ident.create_local default | p :: rem -> match p.pat_desc with - Tpat_var (id, _, _) -> id - | Tpat_alias(_, id, _, _) -> id + Tpat_var (id, _, _, _) -> id + | Tpat_alias(_, id, _, _, _) -> id | _ -> name_pattern default rem let name_cases default lst = @@ -6728,7 +6731,9 @@ and type_argument ?explanation ?recarg env (mode : expected_mode) sarg in let exp_env = Env.add_value ~mode id desc env in let uu = unique_use ~loc:sarg.pexp_loc ~env mode mode in - {pat_desc = Tpat_var (id, mknoloc name, mode); pat_type = ty;pat_extra=[]; + {pat_desc = Tpat_var (id, mknoloc name, desc.val_uid, mode); + pat_type = ty; + pat_extra=[]; pat_attributes = []; pat_loc = Location.none; pat_env = env}, {exp_type = ty; exp_loc = Location.none; exp_env = exp_env; diff --git a/ocaml/typing/typedtree.ml b/ocaml/typing/typedtree.ml index 0638e2ab352..81f4a897df1 100644 --- a/ocaml/typing/typedtree.ml +++ b/ocaml/typing/typedtree.ml @@ -20,6 +20,8 @@ open Jane_asttypes open Layouts open Types +module Uid = Shape.Uid + (* Value expressions for the core language *) type partial = Partial | Total @@ -61,9 +63,9 @@ and pat_extra = and 'k pattern_desc = (* value patterns *) | Tpat_any : value pattern_desc - | Tpat_var : Ident.t * string loc * Mode.Value.t -> value pattern_desc + | Tpat_var : Ident.t * string loc * Uid.t * Mode.Value.t -> value pattern_desc | Tpat_alias : - value general_pattern * Ident.t * string loc * Mode.Value.t -> value pattern_desc + value general_pattern * Ident.t * string loc * Uid.t * Mode.Value.t -> value pattern_desc | Tpat_constant : constant -> value pattern_desc | Tpat_tuple : value general_pattern list -> value pattern_desc | Tpat_construct : @@ -775,7 +777,7 @@ type pattern_action = let shallow_iter_pattern_desc : type k . pattern_action -> k pattern_desc -> unit = fun f -> function - | Tpat_alias(p, _, _, _) -> f.f p + | Tpat_alias(p, _, _, _, _) -> f.f p | Tpat_tuple patl -> List.iter f.f patl | Tpat_construct(_, _, patl, _) -> List.iter f.f patl | Tpat_variant(_, pat, _) -> Option.iter f.f pat @@ -795,8 +797,8 @@ type pattern_transformation = let shallow_map_pattern_desc : type k . pattern_transformation -> k pattern_desc -> k pattern_desc = fun f d -> match d with - | Tpat_alias (p1, id, s, m) -> - Tpat_alias (f.f p1, id, s, m) + | Tpat_alias (p1, id, s, uid, m) -> + Tpat_alias (f.f p1, id, s, uid, m) | Tpat_tuple pats -> Tpat_tuple (List.map f.f pats) | Tpat_record (lpats, closed) -> @@ -857,11 +859,11 @@ let rec iter_bound_idents : type k . _ -> k general_pattern -> _ = fun f pat -> match pat.pat_desc with - | Tpat_var (id, s, _mode) -> - f (id,s,pat.pat_type) - | Tpat_alias(p, id, s, _mode) -> + | Tpat_var (id, s, uid, _mode) -> + f (id,s,pat.pat_type, uid) + | Tpat_alias(p, id, s, uid, _mode) -> iter_bound_idents f p; - f (id,s,pat.pat_type) + f (id,s,pat.pat_type, uid) | Tpat_or(p1, _, _) -> (* Invariant : both arguments bind the same variables *) iter_bound_idents f p1 @@ -871,7 +873,7 @@ let rec iter_bound_idents d type full_bound_ident_action = - Ident.t -> string loc -> type_expr -> Mode.Value.t -> sort -> unit + Ident.t -> string loc -> type_expr -> Uid.t -> Mode.Value.t -> sort -> unit (* The intent is that the sort should be the sort of the type of the pattern. It's used to avoid computing layouts from types. `f` then gets passed @@ -885,11 +887,11 @@ let iter_pattern_full ~both_sides_of_or f sort pat = fun f sort pat -> match pat.pat_desc with (* Cases where we push the sort inwards: *) - | Tpat_var (id, s, mode) -> - f id s pat.pat_type mode sort - | Tpat_alias(p, id, s, mode) -> + | Tpat_var (id, s, uid, mode) -> + f id s pat.pat_type uid mode sort + | Tpat_alias(p, id, s, uid, mode) -> loop f sort p; - f id s pat.pat_type mode sort + f id s pat.pat_type uid mode sort | Tpat_or (p1, p2, _) -> if both_sides_of_or then (loop f sort p1; loop f sort p2) else loop f sort p1 @@ -922,7 +924,7 @@ let iter_pattern_full ~both_sides_of_or f sort pat = let rev_pat_bound_idents_full sort pat = let idents_full = ref [] in - let add id sloc typ _ sort = + let add id sloc typ _uid _ sort = idents_full := (id, sloc, typ, sort) :: !idents_full in iter_pattern_full ~both_sides_of_or:false add sort pat; @@ -952,34 +954,34 @@ let rev_let_bound_idents_full bindings = let let_bound_idents_with_modes_and_sorts bindings = let modes_and_sorts = Ident.Tbl.create 3 in - let f id sloc _ mode sort = + let f id sloc _ _uid mode sort = Ident.Tbl.add modes_and_sorts id (sloc.loc, mode, sort) in List.iter (fun vb -> iter_pattern_full ~both_sides_of_or:true f vb.vb_sort vb.vb_pat) bindings; List.rev_map - (fun (id, _, _) -> id, List.rev (Ident.Tbl.find_all modes_and_sorts id)) + (fun (id, _, _, _) -> id, List.rev (Ident.Tbl.find_all modes_and_sorts id)) (rev_let_bound_idents_full bindings) let let_bound_idents_full bindings = List.rev (rev_let_bound_idents_full bindings) let let_bound_idents pat = - List.rev_map (fun (id,_,_) -> id) (rev_let_bound_idents_full pat) + List.rev_map (fun (id,_,_,_) -> id) (rev_let_bound_idents_full pat) let alpha_var env id = List.assoc id env let rec alpha_pat : type k . _ -> k general_pattern -> k general_pattern = fun env p -> match p.pat_desc with - | Tpat_var (id, s, mode) -> (* note the ``Not_found'' case *) + | Tpat_var (id, s, uid, mode) -> (* note the ``Not_found'' case *) {p with pat_desc = - try Tpat_var (alpha_var env id, s, mode) with + try Tpat_var (alpha_var env id, s, uid, mode) with | Not_found -> Tpat_any} - | Tpat_alias (p1, id, s, mode) -> + | Tpat_alias (p1, id, s, uid, mode) -> let new_p = alpha_pat env p1 in begin try - {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s, mode)} + {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s, uid, mode)} with | Not_found -> new_p end diff --git a/ocaml/typing/typedtree.mli b/ocaml/typing/typedtree.mli index f4ad07ca7da..e7fa3197e1c 100644 --- a/ocaml/typing/typedtree.mli +++ b/ocaml/typing/typedtree.mli @@ -24,6 +24,8 @@ open Asttypes open Jane_asttypes +module Uid = Shape.Uid + (* Value expressions for the core language *) type partial = Partial | Total @@ -89,10 +91,11 @@ and 'k pattern_desc = (* value patterns *) | Tpat_any : value pattern_desc (** _ *) - | Tpat_var : Ident.t * string loc * Mode.Value.t -> value pattern_desc + | Tpat_var : Ident.t * string loc * Uid.t * Mode.Value.t -> value pattern_desc (** x *) | Tpat_alias : - value general_pattern * Ident.t * string loc * Mode.Value.t -> value pattern_desc + value general_pattern * Ident.t * string loc * Uid.t * Mode.Value.t + -> value pattern_desc (** P as a *) | Tpat_constant : constant -> value pattern_desc (** 1, 'a', "true", 1.0, 1l, 1L, 1n *) @@ -964,7 +967,7 @@ val exists_pattern: (pattern -> bool) -> pattern -> bool val let_bound_idents: value_binding list -> Ident.t list val let_bound_idents_full: - value_binding list -> (Ident.t * string loc * Types.type_expr) list + value_binding list -> (Ident.t * string loc * Types.type_expr * Uid.t) list val let_bound_idents_with_modes_and_sorts: value_binding list -> (Ident.t * (Location.t * Mode.Value.t * Layouts.sort) list) list diff --git a/ocaml/typing/uniqueness_analysis.ml b/ocaml/typing/uniqueness_analysis.ml index 8cb295bd4fa..98bb63a2c4f 100644 --- a/ocaml/typing/uniqueness_analysis.ml +++ b/ocaml/typing/uniqueness_analysis.ml @@ -966,8 +966,8 @@ and pattern_match_single pat paths : Ienv.Extension.t * UF.t = let ext1, uf1 = pattern_match_single pat1 paths in (Ienv.Extension.disjunct ext0 ext1, UF.choose uf0 uf1) | Tpat_any -> (Ienv.Extension.empty, UF.unused) - | Tpat_var (id, _, _) -> (Ienv.Extension.singleton id paths, UF.unused) - | Tpat_alias (pat', id, _, _) -> + | Tpat_var (id, _, _, _) -> (Ienv.Extension.singleton id paths, UF.unused) + | Tpat_alias (pat', id, _, _, _) -> let ext0 = Ienv.Extension.singleton id paths in let ext1, uf = pattern_match_single pat' paths in (Ienv.Extension.conjunct ext0 ext1, uf) diff --git a/ocaml/typing/untypeast.ml b/ocaml/typing/untypeast.ml index 48699c4ebb0..7f4c79235cd 100644 --- a/ocaml/typing/untypeast.ml +++ b/ocaml/typing/untypeast.ml @@ -325,7 +325,7 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat -> match pat with { pat_extra=[Tpat_unpack, loc, _attrs]; pat_desc = Tpat_any; _ } -> Ppat_unpack { txt = None; loc } - | { pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name,_); _ } -> + | { pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name,_,_); _ } -> Ppat_unpack { name with txt = Some name.txt } | { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } -> Ppat_type (map_loc sub lid) @@ -335,7 +335,7 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat -> | _ -> match pat.pat_desc with Tpat_any -> Ppat_any - | Tpat_var (id, name,_) -> + | Tpat_var (id, name,_,_) -> begin match (Ident.name id).[0] with 'A'..'Z' -> @@ -348,11 +348,11 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat -> The compiler transforms (x:t) into (_ as x : t). This avoids transforming a warning 27 into a 26. *) - | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name, _mode) + | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name, _uid, _mode) when pat_loc = pat.pat_loc -> Ppat_var name - | Tpat_alias (pat, _id, name, _mode) -> + | Tpat_alias (pat, _id, name, _uid, _mode) -> Ppat_alias (sub.pat sub pat, name) | Tpat_constant cst -> Ppat_constant (constant cst) | Tpat_tuple list -> @@ -974,7 +974,7 @@ let core_type sub ct = let class_structure sub cs = let rec remove_self = function - | { pat_desc = Tpat_alias (p, id, _s, _mode) } + | { pat_desc = Tpat_alias (p, id, _s, _uid, _mode) } when string_is_prefix "selfpat-" (Ident.name id) -> remove_self p | p -> p @@ -1004,7 +1004,7 @@ let object_field sub {of_loc; of_desc; of_attributes;} = Of.mk ~loc ~attrs desc and is_self_pat = function - | { pat_desc = Tpat_alias(_pat, id, _, _mode) } -> + | { pat_desc = Tpat_alias(_pat, id, _, _uid, _mode) } -> string_is_prefix "self-" (Ident.name id) | _ -> false From ded2ee0abe1e4e9d91840b82bc50dc4b1596d7b8 Mon Sep 17 00:00:00 2001 From: Tomasz Nowak Date: Wed, 30 Aug 2023 11:52:30 +0100 Subject: [PATCH 2/5] Pass Uid through pattern_variable --- ocaml/typing/typecore.ml | 16 +++++++++------- ocaml/typing/typecore.mli | 1 + 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/ocaml/typing/typecore.ml b/ocaml/typing/typecore.ml index fcabcd27458..2af05dc4cd6 100644 --- a/ocaml/typing/typecore.ml +++ b/ocaml/typing/typecore.ml @@ -928,6 +928,7 @@ let finalize_variants p = type pattern_variable = { pv_id: Ident.t; + pv_uid: Uid.t; pv_mode: Value.t; pv_type: type_expr; pv_loc: Location.t; @@ -1028,12 +1029,12 @@ let iter_pattern_variables_type f : pattern_variable list -> unit = let add_pattern_variables ?check ?check_as env pv = List.fold_right - (fun {pv_id; pv_mode; pv_type; pv_loc; pv_as_var; pv_attributes} env -> + (fun {pv_id; pv_uid; pv_mode; pv_type; pv_loc; pv_as_var; pv_attributes} env -> let check = if pv_as_var then check_as else check in Env.add_value ?check ~mode:pv_mode pv_id {val_type = pv_type; val_kind = Val_reg; Types.val_loc = pv_loc; val_attributes = pv_attributes; - val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + val_uid = pv_uid } env ) pv env @@ -1109,6 +1110,7 @@ let enter_variable let pv_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in tps.tps_pattern_variables <- {pv_id = id; + pv_uid; pv_mode = mode; pv_type = ty; pv_loc = loc; @@ -1624,8 +1626,9 @@ let type_for_loop_index ~loc ~env ~param = -> let check s = Warnings.Unused_for_index s in let pv_id = Ident.create_local txt in + let pv_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in let pv = - { pv_id; pv_mode; pv_type; pv_loc; pv_as_var; pv_attributes } + { pv_id; pv_uid; pv_mode; pv_type; pv_loc; pv_as_var; pv_attributes } in pv_id, add_pattern_variables ~check ~check_as:check env [pv]) @@ -3027,20 +3030,19 @@ let type_class_arg_pattern cl_num val_env met_env l spat = end; let (pv, val_env, met_env) = List.fold_right - (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} + (fun {pv_id; pv_uid; pv_type; pv_loc; pv_as_var; pv_attributes} (pv, val_env, met_env) -> let check s = if pv_as_var then Warnings.Unused_var s else Warnings.Unused_var_strict s in let id' = Ident.rename pv_id in - let val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in let val_env = Env.add_value pv_id { val_type = pv_type ; val_kind = Val_reg ; val_attributes = pv_attributes ; val_loc = pv_loc - ; val_uid + ; val_uid = pv_uid } val_env in @@ -3050,7 +3052,7 @@ let type_class_arg_pattern cl_num val_env met_env l spat = ; val_kind = Val_ivar (Immutable, cl_num) ; val_attributes = pv_attributes ; val_loc = pv_loc - ; val_uid + ; val_uid = pv_uid } met_env in diff --git a/ocaml/typing/typecore.mli b/ocaml/typing/typecore.mli index 24f81fc54f5..2ef2bf4b31a 100644 --- a/ocaml/typing/typecore.mli +++ b/ocaml/typing/typecore.mli @@ -63,6 +63,7 @@ type type_expected = private { type pattern_variable = { pv_id: Ident.t; + pv_uid: Uid.t; pv_mode: Mode.Value.t; pv_type: type_expr; pv_loc: Location.t; From 92fd9b77c637ebe1ca1a0f8802d22f0527e87ab1 Mon Sep 17 00:00:00 2001 From: Tomasz Nowak Date: Wed, 30 Aug 2023 12:06:45 +0100 Subject: [PATCH 3/5] Pass Uid a bit further to loops and add comments when we stop passing it --- ocaml/typing/typecore.ml | 30 ++++++++++++++++-------------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/ocaml/typing/typecore.ml b/ocaml/typing/typecore.ml index 2af05dc4cd6..2424116cd3e 100644 --- a/ocaml/typing/typecore.ml +++ b/ocaml/typing/typecore.ml @@ -1597,7 +1597,8 @@ let split_cases env cases = so [enter_variable] can be called, depending on the usage. *) let type_for_loop_like_index ~error ~loc ~env ~param ~any ~var = match param.ppat_desc with - | Ppat_any -> any (Ident.create_local "_for") + | Ppat_any -> + any (Ident.create_local "_for", Uid.mk ~current_unit:(Env.get_unit_name ())) | Ppat_var name -> var ~name ~pv_mode:Value.min_mode @@ -1630,7 +1631,7 @@ let type_for_loop_index ~loc ~env ~param = let pv = { pv_id; pv_uid; pv_mode; pv_type; pv_loc; pv_as_var; pv_attributes } in - pv_id, add_pattern_variables ~check ~check_as:check env [pv]) + (pv_id, pv_uid), add_pattern_variables ~check ~check_as:check env [pv]) let type_comprehension_for_range_iterator_index ~loc ~env ~param tps = type_for_loop_like_index @@ -1643,16 +1644,14 @@ let type_comprehension_for_range_iterator_index ~loc ~env ~param tps = for duplicates or anything else. *) ~any:Fun.id ~var:(fun ~name ~pv_mode ~pv_type ~pv_loc ~pv_as_var ~pv_attributes -> - (* CR tnowak: verify this change *) - fst ( - enter_variable - ~is_as_variable:pv_as_var - tps - pv_loc - name - pv_mode - pv_type - pv_attributes)) + enter_variable + ~is_as_variable:pv_as_var + tps + pv_loc + name + pv_mode + pv_type + pv_attributes) (* Type paths *) @@ -5347,7 +5346,8 @@ and type_expect_ (mk_expected ~explanation:For_loop_stop_index Predef.type_int) in let env = Env.add_share_lock For_loop env in - let for_id, new_env = + (* When we'll want to add Uid to for loops, we can take it from here. *) + let (for_id, _for_uid), new_env = type_for_loop_index ~loc ~env ~param in let new_env = Env.add_region_lock new_env in @@ -8115,7 +8115,9 @@ and type_comprehension_iterator in let start = tbound ~explanation:Comprehension_for_start start in let stop = tbound ~explanation:Comprehension_for_stop stop in - let ident = + (* When we'll want to add Uid to comprehension bindings, + we can take it from here. *) + let (ident, _uid) = type_comprehension_for_range_iterator_index tps ~loc From 04a5892e21485a94c33256a586f37a483f2c6c52 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 21 Sep 2023 12:11:08 +0100 Subject: [PATCH 4/5] Fix test --- ocaml/testsuite/tests/shapes/simple.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ocaml/testsuite/tests/shapes/simple.ml b/ocaml/testsuite/tests/shapes/simple.ml index 7940fc6f097..0cd86e26320 100644 --- a/ocaml/testsuite/tests/shapes/simple.ml +++ b/ocaml/testsuite/tests/shapes/simple.ml @@ -126,9 +126,9 @@ class c : object end class type c = object end [%%expect{| { - "#c"[type] -> <.34>; - "c"[type] -> <.34>; - "c"[class type] -> <.34>; + "#c"[type] -> <.35>; + "c"[type] -> <.35>; + "c"[class type] -> <.35>; } class type c = object end |}] From 9dc2f038144ecb85f5546c553e4cd8d4ac9297da Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 21 Sep 2023 12:59:58 +0100 Subject: [PATCH 5/5] Fix minimizer --- chamelon/compat.jst.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/chamelon/compat.jst.ml b/chamelon/compat.jst.ml index e7cd7df249f..ec23e4ce9b9 100644 --- a/chamelon/compat.jst.ml +++ b/chamelon/compat.jst.ml @@ -147,12 +147,12 @@ let view_texp (e : expression_desc) = type tpat_var_identifier = Value.t let mkTpat_var ?id:(mode = dummy_value_mode) (ident, name) = - Tpat_var (ident, name, mode) + Tpat_var (ident, name, Uid.internal_not_actually_unique, mode) type tpat_alias_identifier = Value.t let mkTpat_alias ?id:(mode = dummy_value_mode) (p, ident, name) = - Tpat_alias (p, ident, name, mode) + Tpat_alias (p, ident, name, Uid.internal_not_actually_unique, mode) type tpat_array_identifier = Asttypes.mutable_flag @@ -175,8 +175,8 @@ type 'a matched_pattern_desc = let view_tpat (type a) (p : a pattern_desc) : a matched_pattern_desc = match p with - | Tpat_var (ident, name, mode) -> Tpat_var (ident, name, mode) - | Tpat_alias (p, ident, name, mode) -> Tpat_alias (p, ident, name, mode) + | Tpat_var (ident, name, _uid, mode) -> Tpat_var (ident, name, mode) + | Tpat_alias (p, ident, name, _uid, mode) -> Tpat_alias (p, ident, name, mode) | Tpat_array (mut, l) -> Tpat_array (l, mut) | _ -> O p