ident: split Local into Local and Scoped
Also rename [create] into [create_scoped] and [create_var] into [create_local].master
parent
686961f032
commit
b134588f28
|
@ -35,8 +35,8 @@ let rec with_afl_logging b =
|
|||
docs/technical_details.txt in afl-fuzz source for for a full
|
||||
description of what's going on. *)
|
||||
let cur_location = Random.int afl_map_size in
|
||||
let cur_pos = Ident.create_var "pos" in
|
||||
let afl_area = Ident.create_var "shared_mem" in
|
||||
let cur_pos = Ident.create_local "pos" in
|
||||
let afl_area = Ident.create_local "shared_mem" in
|
||||
let op oper args = Cop (oper, args, Debuginfo.none) in
|
||||
Clet(afl_area, op (Cload (Word_int, Asttypes.Mutable)) [afl_area_ptr],
|
||||
Clet(cur_pos, op Cxor [op (Cload (Word_int, Asttypes.Mutable))
|
||||
|
|
|
@ -861,7 +861,7 @@ let rec close fenv cenv = function
|
|||
in
|
||||
make_const (transl cst)
|
||||
| Lfunction _ as funct ->
|
||||
close_one_function fenv cenv (Ident.create_var "fun") funct
|
||||
close_one_function fenv cenv (Ident.create_local "fun") funct
|
||||
|
||||
(* We convert [f a] to [let a' = a in let f' = f in fun b c -> f' a' b c]
|
||||
when fun_arity > nargs *)
|
||||
|
@ -884,10 +884,10 @@ let rec close fenv cenv = function
|
|||
| ((ufunct, (Value_closure(fundesc, _) as fapprox)), uargs)
|
||||
when nargs < fundesc.fun_arity ->
|
||||
let first_args = List.map (fun arg ->
|
||||
(Ident.create_var "arg", arg) ) uargs in
|
||||
(Ident.create_local "arg", arg) ) uargs in
|
||||
let final_args =
|
||||
Array.to_list (Array.init (fundesc.fun_arity - nargs)
|
||||
(fun _ -> Ident.create_var "arg")) in
|
||||
(fun _ -> Ident.create_local "arg")) in
|
||||
let rec iter args body =
|
||||
match args with
|
||||
[] -> body
|
||||
|
@ -899,7 +899,7 @@ let rec close fenv cenv = function
|
|||
(List.map (fun (arg1, _arg2) -> Lvar arg1) first_args)
|
||||
@ (List.map (fun arg -> Lvar arg ) final_args)
|
||||
in
|
||||
let funct_var = Ident.create_var "funct" in
|
||||
let funct_var = Ident.create_local "funct" in
|
||||
let fenv = Ident.Map.add funct_var fapprox fenv in
|
||||
let (new_fun, approx) = close fenv cenv
|
||||
(Lfunction{
|
||||
|
@ -923,7 +923,7 @@ let rec close fenv cenv = function
|
|||
|
||||
| ((ufunct, Value_closure(fundesc, _approx_res)), uargs)
|
||||
when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity ->
|
||||
let args = List.map (fun arg -> Ident.create_var "arg", arg) uargs in
|
||||
let args = List.map (fun arg -> Ident.create_local "arg",arg) uargs in
|
||||
let (first_args, rem_args) = split_list fundesc.fun_arity args in
|
||||
let first_args = List.map (fun (id, _) -> Uvar id) first_args in
|
||||
let rem_args = List.map (fun (id, _) -> Uvar id) rem_args in
|
||||
|
@ -972,7 +972,7 @@ let rec close fenv cenv = function
|
|||
then begin
|
||||
(* Simple case: only function definitions *)
|
||||
let (clos, infos) = close_functions fenv cenv defs in
|
||||
let clos_ident = Ident.create_var "clos" in
|
||||
let clos_ident = Ident.create_local "clos" in
|
||||
let fenv_body =
|
||||
List.fold_right
|
||||
(fun (id, _pos, approx) fenv -> Ident.Map.add id approx fenv)
|
||||
|
@ -1203,7 +1203,7 @@ and close_functions fenv cenv fun_defs =
|
|||
let useless_env = ref initially_closed in
|
||||
(* Translate each function definition *)
|
||||
let clos_fundef (id, params, body, fundesc, dbg) env_pos =
|
||||
let env_param = Ident.create_var "env" in
|
||||
let env_param = Ident.create_local "env" in
|
||||
let cenv_fv =
|
||||
build_closure_env env_param (fv_pos - env_pos) fv in
|
||||
let cenv_body =
|
||||
|
|
|
@ -64,7 +64,7 @@ let bind name arg fn =
|
|||
Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _
|
||||
| Cconst_pointer _ | Cconst_natpointer _
|
||||
| Cblockheader _ -> fn arg
|
||||
| _ -> let id = Ident.create_var name in Clet(id, arg, fn (Cvar id))
|
||||
| _ -> let id = Ident.create_local name in Clet(id, arg, fn (Cvar id))
|
||||
|
||||
let bind_load name arg fn =
|
||||
match arg with
|
||||
|
@ -76,7 +76,7 @@ let bind_nonvar name arg fn =
|
|||
Cconst_int _ | Cconst_natint _ | Cconst_symbol _
|
||||
| Cconst_pointer _ | Cconst_natpointer _
|
||||
| Cblockheader _ -> fn arg
|
||||
| _ -> let id = Ident.create_var name in Clet(id, arg, fn (Cvar id))
|
||||
| _ -> let id = Ident.create_local name in Clet(id, arg, fn (Cvar id))
|
||||
|
||||
let caml_black = Nativeint.shift_left (Nativeint.of_int 3) 8
|
||||
(* cf. runtime/caml/gc.h *)
|
||||
|
@ -728,7 +728,7 @@ let float_array_set arr ofs newval dbg =
|
|||
|
||||
let string_length exp dbg =
|
||||
bind "str" exp (fun str ->
|
||||
let tmp_var = Ident.create_var "tmp" in
|
||||
let tmp_var = Ident.create_local "tmp" in
|
||||
Clet(tmp_var,
|
||||
Cop(Csubi,
|
||||
[Cop(Clsl,
|
||||
|
@ -770,7 +770,7 @@ let make_alloc_generic set_fn dbg tag wordsize args =
|
|||
if wordsize <= Config.max_young_wosize then
|
||||
Cop(Calloc, Cblockheader(block_header tag wordsize, dbg) :: args, dbg)
|
||||
else begin
|
||||
let id = Ident.create_var "alloc" in
|
||||
let id = Ident.create_local "alloc" in
|
||||
let rec fill_fields idx = function
|
||||
[] -> Cvar id
|
||||
| e1::el -> Csequence(set_fn (Cvar id) (Cconst_int idx) e1 dbg,
|
||||
|
@ -2664,7 +2664,7 @@ and transl_let env str kind id exp body =
|
|||
there may be constant closures inside that need lifting out. *)
|
||||
Clet(id, transl env exp, transl env body)
|
||||
| Boxed (boxed_number, _false) ->
|
||||
let unboxed_id = Ident.create_var (Ident.name id) in
|
||||
let unboxed_id = Ident.create_local (Ident.name id) in
|
||||
Clet(unboxed_id, transl_unbox_number dbg env boxed_number exp,
|
||||
transl (add_unboxed_id id unboxed_id boxed_number env) body)
|
||||
|
||||
|
@ -3127,8 +3127,8 @@ CAMLprim value caml_cache_public_method (value meths, value tag, value *cache)
|
|||
|
||||
let cache_public_method meths tag cache dbg =
|
||||
let raise_num = next_raise_count () in
|
||||
let li = Ident.create_var "li" and hi = Ident.create_var "hi"
|
||||
and mi = Ident.create_var "mi" and tagged = Ident.create_var "tagged" in
|
||||
let li = Ident.create_local "li" and hi = Ident.create_local "hi"
|
||||
and mi = Ident.create_local "mi" and tagged = Ident.create_local "tagged" in
|
||||
Clet (
|
||||
li, Cconst_int 3,
|
||||
Clet (
|
||||
|
@ -3179,16 +3179,16 @@ let cache_public_method meths tag cache dbg =
|
|||
|
||||
let apply_function_body arity =
|
||||
let dbg = Debuginfo.none in
|
||||
let arg = Array.make arity (Ident.create_var "arg") in
|
||||
for i = 1 to arity - 1 do arg.(i) <- Ident.create_var "arg" done;
|
||||
let clos = Ident.create_var "clos" in
|
||||
let arg = Array.make arity (Ident.create_local "arg") in
|
||||
for i = 1 to arity - 1 do arg.(i) <- Ident.create_local "arg" done;
|
||||
let clos = Ident.create_local "clos" in
|
||||
let env = empty_env in
|
||||
let rec app_fun clos n =
|
||||
if n = arity-1 then
|
||||
Cop(Capply typ_val,
|
||||
[get_field env (Cvar clos) 0 dbg; Cvar arg.(n); Cvar clos], dbg)
|
||||
else begin
|
||||
let newclos = Ident.create_var "clos" in
|
||||
let newclos = Ident.create_local "clos" in
|
||||
Clet(newclos,
|
||||
Cop(Capply typ_val,
|
||||
[get_field env (Cvar clos) 0 dbg; Cvar arg.(n); Cvar clos], dbg),
|
||||
|
@ -3208,14 +3208,15 @@ let apply_function_body arity =
|
|||
let send_function arity =
|
||||
let dbg = Debuginfo.none in
|
||||
let (args, clos', body) = apply_function_body (1+arity) in
|
||||
let cache = Ident.create_var "cache"
|
||||
let cache = Ident.create_local "cache"
|
||||
and obj = List.hd args
|
||||
and tag = Ident.create_var "tag" in
|
||||
and tag = Ident.create_local "tag" in
|
||||
let env = empty_env in
|
||||
let clos =
|
||||
let cache = Cvar cache and obj = Cvar obj and tag = Cvar tag in
|
||||
let meths = Ident.create_var "meths" and cached = Ident.create_var "cached" in
|
||||
let real = Ident.create_var "real" in
|
||||
let meths = Ident.create_local "meths"
|
||||
and cached = Ident.create_local "cached" in
|
||||
let real = Ident.create_local "real" in
|
||||
let mask = get_field env (Cvar meths) 1 dbg in
|
||||
let cached_pos = Cvar cached in
|
||||
let tag_pos = Cop(Cadda, [Cop (Cadda, [cached_pos; Cvar meths], dbg);
|
||||
|
@ -3267,8 +3268,8 @@ let apply_function arity =
|
|||
|
||||
let tuplify_function arity =
|
||||
let dbg = Debuginfo.none in
|
||||
let arg = Ident.create_var "arg" in
|
||||
let clos = Ident.create_var "clos" in
|
||||
let arg = Ident.create_local "arg" in
|
||||
let clos = Ident.create_local "clos" in
|
||||
let env = empty_env in
|
||||
let rec access_components i =
|
||||
if i >= arity
|
||||
|
@ -3317,8 +3318,8 @@ let tuplify_function arity =
|
|||
let max_arity_optimized = 15
|
||||
let final_curry_function arity =
|
||||
let dbg = Debuginfo.none in
|
||||
let last_arg = Ident.create_var "arg" in
|
||||
let last_clos = Ident.create_var "clos" in
|
||||
let last_arg = Ident.create_local "arg" in
|
||||
let last_clos = Ident.create_local "clos" in
|
||||
let env = empty_env in
|
||||
let rec curry_fun args clos n =
|
||||
if n = 0 then
|
||||
|
@ -3329,13 +3330,13 @@ let final_curry_function arity =
|
|||
else
|
||||
if n = arity - 1 || arity > max_arity_optimized then
|
||||
begin
|
||||
let newclos = Ident.create_var "clos" in
|
||||
let newclos = Ident.create_local "clos" in
|
||||
Clet(newclos,
|
||||
get_field env (Cvar clos) 3 dbg,
|
||||
curry_fun (get_field env (Cvar clos) 2 dbg :: args) newclos (n-1))
|
||||
end else
|
||||
begin
|
||||
let newclos = Ident.create_var "clos" in
|
||||
let newclos = Ident.create_local "clos" in
|
||||
Clet(newclos,
|
||||
get_field env (Cvar clos) 4 dbg,
|
||||
curry_fun (get_field env (Cvar clos) 3 dbg :: args)
|
||||
|
@ -3357,7 +3358,7 @@ let rec intermediate_curry_functions arity num =
|
|||
else begin
|
||||
let name1 = "caml_curry" ^ string_of_int arity in
|
||||
let name2 = if num = 0 then name1 else name1 ^ "_" ^ string_of_int num in
|
||||
let arg = Ident.create_var "arg" and clos = Ident.create_var "clos" in
|
||||
let arg = Ident.create_local "arg" and clos = Ident.create_local "clos" in
|
||||
Cfunction
|
||||
{fun_name = name2;
|
||||
fun_args = [arg, typ_val; clos, typ_val];
|
||||
|
@ -3382,7 +3383,7 @@ let rec intermediate_curry_functions arity num =
|
|||
(if arity <= max_arity_optimized && arity - num > 2 then
|
||||
let rec iter i =
|
||||
if i <= arity then
|
||||
let arg = Ident.create_var (Printf.sprintf "arg%d" i) in
|
||||
let arg = Ident.create_local (Printf.sprintf "arg%d" i) in
|
||||
(arg, typ_val) :: iter (i+1)
|
||||
else []
|
||||
in
|
||||
|
@ -3393,7 +3394,7 @@ let rec intermediate_curry_functions arity num =
|
|||
(get_field env (Cvar clos) 2 dbg) :: args @ [Cvar clos],
|
||||
dbg)
|
||||
else
|
||||
let newclos = Ident.create_var "clos" in
|
||||
let newclos = Ident.create_local "clos" in
|
||||
Clet(newclos,
|
||||
get_field env (Cvar clos) 4 dbg,
|
||||
iter (i-1) (get_field env (Cvar clos) 3 dbg :: args) newclos)
|
||||
|
|
|
@ -144,14 +144,14 @@ end = struct
|
|||
let ident_for_var_exn t id = Variable.Map.find id t.var
|
||||
|
||||
let add_fresh_ident t var =
|
||||
let id = Ident.create_var (Variable.name var) in
|
||||
let id = Ident.create_local (Variable.name var) in
|
||||
id, { t with var = Variable.Map.add var id t.var }
|
||||
|
||||
let ident_for_mutable_var_exn t mut_var =
|
||||
Mutable_variable.Map.find mut_var t.mutable_var
|
||||
|
||||
let add_fresh_mutable_ident t mut_var =
|
||||
let id = Ident.create_var (Mutable_variable.name mut_var) in
|
||||
let id = Ident.create_local (Mutable_variable.name mut_var) in
|
||||
let mutable_var = Mutable_variable.Map.add mut_var id t.mutable_var in
|
||||
id, { t with mutable_var; }
|
||||
|
||||
|
@ -466,7 +466,7 @@ and to_clambda_set_of_closures t env
|
|||
(({ function_decls; free_vars } : Flambda.set_of_closures)
|
||||
as set_of_closures) : Clambda.ulambda =
|
||||
let all_functions = Variable.Map.bindings function_decls.funs in
|
||||
let env_var = Ident.create_var "env" in
|
||||
let env_var = Ident.create_local "env" in
|
||||
let to_clambda_function
|
||||
(closure_id, (function_decl : Flambda.function_declaration))
|
||||
: Clambda.ufunction =
|
||||
|
|
|
@ -928,7 +928,7 @@ method private emit_parts (env:environment) ~effects_after exp =
|
|||
Some (Ctuple [], env)
|
||||
else begin
|
||||
(* The normal case *)
|
||||
let id = Ident.create_var "bind" in
|
||||
let id = Ident.create_local "bind" in
|
||||
if all_regs_anonymous r then
|
||||
(* r is an anonymous, unshared register; use it directly *)
|
||||
Some (Cvar id, env_add id r env)
|
||||
|
@ -1201,7 +1201,7 @@ method emit_fundecl f =
|
|||
if not Config.spacetime then None, env
|
||||
else begin
|
||||
let reg = self#regs_for typ_int in
|
||||
let node_hole = Ident.create_var "spacetime_node_hole" in
|
||||
let node_hole = Ident.create_local "spacetime_node_hole" in
|
||||
Some (node_hole, reg), env_add node_hole reg env
|
||||
end
|
||||
in
|
||||
|
|
|
@ -18,8 +18,8 @@ let index_within_node = ref node_num_header_words
|
|||
when not using Spacetime profiling. (This could cause stamps to differ
|
||||
between bytecode and native .cmis when no .mli is present, e.g.
|
||||
arch.ml.) *)
|
||||
let spacetime_node = ref (lazy (Cmm.Cvar (Ident.create_var "dummy")))
|
||||
let spacetime_node_ident = ref (lazy (Ident.create_var "dummy"))
|
||||
let spacetime_node = ref (lazy (Cmm.Cvar (Ident.create_local "dummy")))
|
||||
let spacetime_node_ident = ref (lazy (Ident.create_local "dummy"))
|
||||
let current_function_label = ref ""
|
||||
let direct_tail_call_point_indexes = ref []
|
||||
|
||||
|
@ -55,15 +55,15 @@ let reset ~spacetime_node_ident:ident ~function_label =
|
|||
reverse_shape := []
|
||||
|
||||
let code_for_function_prologue ~function_name ~node_hole =
|
||||
let node = Ident.create_var "node" in
|
||||
let new_node = Ident.create_var "new_node" in
|
||||
let must_allocate_node = Ident.create_var "must_allocate_node" in
|
||||
let is_new_node = Ident.create_var "is_new_node" in
|
||||
let node = Ident.create_local "node" in
|
||||
let new_node = Ident.create_local "new_node" in
|
||||
let must_allocate_node = Ident.create_local "must_allocate_node" in
|
||||
let is_new_node = Ident.create_local "is_new_node" in
|
||||
let no_tail_calls = List.length !direct_tail_call_point_indexes < 1 in
|
||||
let dbg = Debuginfo.none in
|
||||
let open Cmm in
|
||||
let initialize_direct_tail_call_points_and_return_node =
|
||||
let new_node_encoded = Ident.create_var "new_node_encoded" in
|
||||
let new_node_encoded = Ident.create_local "new_node_encoded" in
|
||||
(* The callee node pointers within direct tail call points must initially
|
||||
point back at the start of the current node and be marked as per
|
||||
[Encode_tail_caller_node] in the runtime. *)
|
||||
|
@ -88,7 +88,7 @@ let code_for_function_prologue ~function_name ~node_hole =
|
|||
Cop (Cor, [Cvar new_node; Cconst_int 1], dbg),
|
||||
body)
|
||||
in
|
||||
let pc = Ident.create_var "pc" in
|
||||
let pc = Ident.create_local "pc" in
|
||||
Clet (node, Cop (Cload (Word_int, Asttypes.Mutable), [Cvar node_hole], dbg),
|
||||
Clet (must_allocate_node,
|
||||
Cop (Cand, [Cvar node; Cconst_int 1], dbg),
|
||||
|
@ -115,10 +115,10 @@ let code_for_function_prologue ~function_name ~node_hole =
|
|||
|
||||
let code_for_blockheader ~value's_header ~node ~dbg =
|
||||
let num_words = Nativeint.shift_right_logical value's_header 10 in
|
||||
let existing_profinfo = Ident.create_var "existing_profinfo" in
|
||||
let existing_count = Ident.create_var "existing_count" in
|
||||
let profinfo = Ident.create_var "profinfo" in
|
||||
let address_of_profinfo = Ident.create_var "address_of_profinfo" in
|
||||
let existing_profinfo = Ident.create_local "existing_profinfo" in
|
||||
let existing_count = Ident.create_local "existing_count" in
|
||||
let profinfo = Ident.create_local "profinfo" in
|
||||
let address_of_profinfo = Ident.create_local "address_of_profinfo" in
|
||||
let label = Cmm.new_label () in
|
||||
let index_within_node =
|
||||
next_index_within_node ~part_of_shape:Mach.Allocation_point ~label
|
||||
|
@ -216,7 +216,7 @@ let code_for_call ~node ~callee ~is_tail ~label =
|
|||
index_within_node::!direct_tail_call_point_indexes
|
||||
| Direct _ | Indirect _ -> ()
|
||||
end;
|
||||
let place_within_node = Ident.create_var "place_within_node" in
|
||||
let place_within_node = Ident.create_local "place_within_node" in
|
||||
let dbg = Debuginfo.none in
|
||||
let open Cmm in
|
||||
Clet (place_within_node,
|
||||
|
@ -227,8 +227,8 @@ let code_for_call ~node ~callee ~is_tail ~label =
|
|||
match callee with
|
||||
| Direct _callee ->
|
||||
if Config.enable_call_counts then begin
|
||||
let count_addr = Ident.create_var "call_count_addr" in
|
||||
let count = Ident.create_var "call_count" in
|
||||
let count_addr = Ident.create_local "call_count_addr" in
|
||||
let count = Ident.create_local "call_count" in
|
||||
Clet (count_addr,
|
||||
Cop (Caddi, [Cvar place_within_node; Cconst_int Arch.size_addr], dbg),
|
||||
Clet (count,
|
||||
|
@ -276,7 +276,7 @@ class virtual instruction_selection = object (self)
|
|||
~label_after =
|
||||
(* [callee] is a pseudoregister, so we have to bind it in the environment
|
||||
and reference the variable to which it is bound. *)
|
||||
let callee_ident = Ident.create_var "callee" in
|
||||
let callee_ident = Ident.create_local "callee" in
|
||||
let env = Selectgen.env_add callee_ident [| callee |] env in
|
||||
let instrumentation =
|
||||
code_for_call
|
||||
|
@ -424,7 +424,7 @@ class virtual instruction_selection = object (self)
|
|||
method! emit_fundecl f =
|
||||
if Config.spacetime then begin
|
||||
disable_instrumentation <- false;
|
||||
let node = Ident.create_var "spacetime_node" in
|
||||
let node = Ident.create_local "spacetime_node" in
|
||||
reset ~spacetime_node_ident:node ~function_label:f.Cmm.fun_name
|
||||
end;
|
||||
super#emit_fundecl f
|
||||
|
|
|
@ -67,8 +67,8 @@ module Make(I:I) = struct
|
|||
|
||||
(* Utilities *)
|
||||
|
||||
let gen_cell_id () = Ident.create_var "cell"
|
||||
let gen_size_id () = Ident.create_var "size"
|
||||
let gen_cell_id () = Ident.create_local "cell"
|
||||
let gen_size_id () = Ident.create_local "size"
|
||||
|
||||
let mk_let_cell id str ind body =
|
||||
let dbg = Debuginfo.none in
|
||||
|
|
|
@ -438,7 +438,7 @@ let name_lambda strict arg fn =
|
|||
match arg with
|
||||
Lvar id -> fn id
|
||||
| _ ->
|
||||
let id = Ident.create_var "let" in
|
||||
let id = Ident.create_local "let" in
|
||||
Llet(strict, Pgenval, id, arg, fn id)
|
||||
|
||||
let name_lambda_list args fn =
|
||||
|
@ -447,7 +447,7 @@ let name_lambda_list args fn =
|
|||
| (Lvar _ as arg) :: rem ->
|
||||
name_list (arg :: names) rem
|
||||
| arg :: rem ->
|
||||
let id = Ident.create_var "let" in
|
||||
let id = Ident.create_local "let" in
|
||||
Llet(Strict, Pgenval, id, arg, name_list (Lvar id :: names) rem) in
|
||||
name_list [] args
|
||||
|
||||
|
|
|
@ -694,7 +694,7 @@ let mk_alpha_env arg aliases ids =
|
|||
| Some v -> v
|
||||
| _ -> raise Cannot_flatten
|
||||
else
|
||||
Ident.create_var (Ident.name id))
|
||||
Ident.create_local (Ident.name id))
|
||||
ids
|
||||
|
||||
let rec explode_or_pat arg patl mk_action rem vars aliases = function
|
||||
|
@ -1510,9 +1510,9 @@ let code_force_lazy =
|
|||
*)
|
||||
|
||||
let inline_lazy_force_cond arg loc =
|
||||
let idarg = Ident.create_var "lzarg" in
|
||||
let idarg = Ident.create_local "lzarg" in
|
||||
let varg = Lvar idarg in
|
||||
let tag = Ident.create_var "tag" in
|
||||
let tag = Ident.create_local "tag" in
|
||||
let force_fun = Lazy.force code_force_lazy_block in
|
||||
Llet(Strict, Pgenval, idarg, arg,
|
||||
Llet(Alias, Pgenval, tag, Lprim(Pccall prim_obj_tag, [varg], loc),
|
||||
|
@ -1537,7 +1537,7 @@ let inline_lazy_force_cond arg loc =
|
|||
varg))))
|
||||
|
||||
let inline_lazy_force_switch arg loc =
|
||||
let idarg = Ident.create_var "lzarg" in
|
||||
let idarg = Ident.create_local "lzarg" in
|
||||
let varg = Lvar idarg in
|
||||
let force_fun = Lazy.force code_force_lazy_block in
|
||||
Llet(Strict, Pgenval, idarg, arg,
|
||||
|
@ -1756,7 +1756,7 @@ let prim_string_compare =
|
|||
let bind_sw arg k = match arg with
|
||||
| Lvar _ -> k arg
|
||||
| _ ->
|
||||
let id = Ident.create_var "switch" in
|
||||
let id = Ident.create_local "switch" in
|
||||
Llet (Strict,Pgenval,id,arg,k (Lvar id))
|
||||
|
||||
|
||||
|
@ -1949,7 +1949,7 @@ module SArg = struct
|
|||
let newvar,newarg = match arg with
|
||||
| Lvar v -> v,arg
|
||||
| _ ->
|
||||
let newvar = Ident.create_var "switcher" in
|
||||
let newvar = Ident.create_local "switcher" in
|
||||
newvar,Lvar newvar in
|
||||
bind Alias newvar arg (body newarg)
|
||||
let make_const i = Lconst (Const_base (Const_int i))
|
||||
|
@ -2353,7 +2353,7 @@ let combine_constructor loc arg ex_pat cstr partial ctx def
|
|||
match nonconsts with
|
||||
[] -> default
|
||||
| _ ->
|
||||
let tag = Ident.create_var "tag" in
|
||||
let tag = Ident.create_local "tag" in
|
||||
let tests =
|
||||
List.fold_right
|
||||
(fun (path, act) rem ->
|
||||
|
@ -2439,7 +2439,7 @@ let call_switcher_variant_constant loc fail arg int_lambda_list =
|
|||
|
||||
|
||||
let call_switcher_variant_constr loc fail arg int_lambda_list =
|
||||
let v = Ident.create_var "variant" in
|
||||
let v = Ident.create_local "variant" in
|
||||
Llet(Alias, Pgenval, v, Lprim(Pfield 0, [arg], loc),
|
||||
call_switcher loc
|
||||
fail (Lvar v) min_int max_int int_lambda_list)
|
||||
|
@ -2501,7 +2501,7 @@ let combine_array loc arg kind partial ctx def
|
|||
(len_lambda_list, total1, _pats) =
|
||||
let fail, local_jumps = mk_failaction_neg partial ctx def in
|
||||
let lambda1 =
|
||||
let newvar = Ident.create_var "len" in
|
||||
let newvar = Ident.create_local "len" in
|
||||
let switch =
|
||||
call_switcher loc
|
||||
fail (Lvar newvar)
|
||||
|
@ -2704,7 +2704,7 @@ let rec name_pattern default = function
|
|||
| Tpat_alias(_, id, _) -> id
|
||||
| _ -> name_pattern default rem
|
||||
end
|
||||
| _ -> Ident.create_var default
|
||||
| _ -> Ident.create_local default
|
||||
|
||||
let arg_to_var arg cls = match arg with
|
||||
| Lvar v -> v,arg
|
||||
|
@ -3198,7 +3198,7 @@ let do_for_multiple_match loc paraml pat_act_list partial =
|
|||
let next, nexts = split_precompile None pm1 in
|
||||
|
||||
let size = List.length paraml
|
||||
and idl = List.map (fun _ -> Ident.create_var "*match*") paraml in
|
||||
and idl = List.map (fun _ -> Ident.create_local "*match*") paraml in
|
||||
let args = List.map (fun id -> Lvar id, Alias) idl in
|
||||
|
||||
let flat_next = flatten_precompiled size args next
|
||||
|
@ -3235,7 +3235,7 @@ let do_for_multiple_match loc paraml pat_act_list partial =
|
|||
|
||||
let param_to_var param = match param with
|
||||
| Lvar v -> v,None
|
||||
| _ -> Ident.create_var "*match*",Some param
|
||||
| _ -> Ident.create_local "*match*",Some param
|
||||
|
||||
let bind_opt (v,eo) k = match eo with
|
||||
| None -> k
|
||||
|
|
|
@ -663,7 +663,7 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~body ~attr ~loc =
|
|||
let fv = Lambda.free_variables body in
|
||||
List.iter (fun (id, _) -> if Ident.Set.mem id fv then raise Exit) map;
|
||||
|
||||
let inner_id = Ident.create_var (Ident.name fun_id ^ "_inner") in
|
||||
let inner_id = Ident.create_local (Ident.name fun_id ^ "_inner") in
|
||||
let map_param p = try List.assoc p map with Not_found -> p in
|
||||
let args = List.map (fun p -> Lvar (map_param p)) params in
|
||||
let wrapper_body =
|
||||
|
|
|
@ -96,7 +96,7 @@ let bind_super tbl (vals, meths) cl_init =
|
|||
meths cl_init)
|
||||
|
||||
let create_object cl obj init =
|
||||
let obj' = Ident.create_var "self" in
|
||||
let obj' = Ident.create_local "self" in
|
||||
let (inh_init, obj_init, has_init) = init obj' in
|
||||
if obj_init = lambda_unit then
|
||||
(inh_init,
|
||||
|
@ -117,7 +117,7 @@ let name_pattern default p =
|
|||
match p.pat_desc with
|
||||
| Tpat_var (id, _) -> id
|
||||
| Tpat_alias(_, id, _) -> id
|
||||
| _ -> Ident.create_var default
|
||||
| _ -> Ident.create_local default
|
||||
|
||||
let normalize_cl_path cl path =
|
||||
Env.normalize_path (Some cl.cl_loc) cl.cl_env path
|
||||
|
@ -125,7 +125,7 @@ let normalize_cl_path cl path =
|
|||
let rec build_object_init cl_table obj params inh_init obj_init cl =
|
||||
match cl.cl_desc with
|
||||
Tcl_ident ( path, _, _) ->
|
||||
let obj_init = Ident.create_var "obj_init" in
|
||||
let obj_init = Ident.create_local "obj_init" in
|
||||
let envs, inh_init = inh_init in
|
||||
let env =
|
||||
match envs with None -> []
|
||||
|
@ -202,8 +202,8 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids =
|
|||
Tcl_let (_rec_flag, _defs, vals, cl) ->
|
||||
build_object_init_0 cl_table (vals@params) cl copy_env subst_env top ids
|
||||
| _ ->
|
||||
let self = Ident.create_var "self" in
|
||||
let env = Ident.create_var "env" in
|
||||
let self = Ident.create_local "self" in
|
||||
let env = Ident.create_local "env" in
|
||||
let obj = if ids = [] then lambda_unit else Lvar self in
|
||||
let envs = if top then None else Some env in
|
||||
let ((_,inh_init), obj_init) =
|
||||
|
@ -223,7 +223,7 @@ let bind_methods tbl meths vals cl_init =
|
|||
let len = List.length methl and nvals = List.length vals in
|
||||
if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else
|
||||
if len = 0 && nvals < 2 then transl_vals tbl true Strict vals cl_init else
|
||||
let ids = Ident.create_var "ids" in
|
||||
let ids = Ident.create_local "ids" in
|
||||
let i = ref (len + nvals) in
|
||||
let getter, names =
|
||||
if nvals = 0 then "get_method_labels", [] else
|
||||
|
@ -303,7 +303,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
|
|||
let met_code =
|
||||
if !Clflags.native_code && List.length met_code = 1 then
|
||||
(* Force correct naming of method for profiles *)
|
||||
let met = Ident.create_var ("method_" ^ name.txt) in
|
||||
let met = Ident.create_local ("method_" ^ name.txt) in
|
||||
[Llet(Strict, Pgenval, met, List.hd met_code, Lvar met)]
|
||||
else met_code
|
||||
in
|
||||
|
@ -351,7 +351,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
|
|||
Tcl_ident (path, _, _), (obj_init, path')::inh_init ->
|
||||
assert (Path.same (normalize_cl_path cl path) path');
|
||||
let lpath = transl_normal_path path' in
|
||||
let inh = Ident.create_var "inh"
|
||||
let inh = Ident.create_local "inh"
|
||||
and ofs = List.length vals + 1
|
||||
and valids, methids = super in
|
||||
let cl_init =
|
||||
|
@ -464,8 +464,8 @@ let rec transl_class_rebind_0 self obj_init cl vf =
|
|||
|
||||
let transl_class_rebind cl vf =
|
||||
try
|
||||
let obj_init = Ident.create_var "obj_init"
|
||||
and self = Ident.create_var "self" in
|
||||
let obj_init = Ident.create_local "obj_init"
|
||||
and self = Ident.create_local "self" in
|
||||
let obj_init0 =
|
||||
lapply {ap_should_be_tailcall=false;
|
||||
ap_loc=Location.none;
|
||||
|
@ -478,11 +478,11 @@ let transl_class_rebind cl vf =
|
|||
let id = (obj_init' = lfunction [self] obj_init0) in
|
||||
if id then transl_normal_path path else
|
||||
|
||||
let cla = Ident.create_var "class"
|
||||
and new_init = Ident.create_var "new_init"
|
||||
and env_init = Ident.create_var "env_init"
|
||||
and table = Ident.create_var "table"
|
||||
and envs = Ident.create_var "envs" in
|
||||
let cla = Ident.create_local "class"
|
||||
and new_init = Ident.create_local "new_init"
|
||||
and env_init = Ident.create_local "env_init"
|
||||
and table = Ident.create_local "table"
|
||||
and envs = Ident.create_local "envs" in
|
||||
Llet(
|
||||
Strict, Pgenval, new_init, lfunction [obj_init] obj_init',
|
||||
Llet(
|
||||
|
@ -660,12 +660,12 @@ let transl_class ids cl_id pub_meths cl vflag =
|
|||
if rebind <> lambda_unit then rebind else
|
||||
|
||||
(* Prepare for heavy environment handling *)
|
||||
let tables = Ident.create_var (Ident.name cl_id ^ "_tables") in
|
||||
let tables = Ident.create_local (Ident.name cl_id ^ "_tables") in
|
||||
let (top_env, req) = oo_add_class tables in
|
||||
let top = not req in
|
||||
let cl_env, llets = build_class_lets cl in
|
||||
let new_ids = if top then [] else Env.diff top_env cl_env in
|
||||
let env2 = Ident.create_var "env" in
|
||||
let env2 = Ident.create_local "env" in
|
||||
let meth_ids = get_class_meths cl in
|
||||
let subst env lam i0 new_ids' =
|
||||
let fv = free_variables lam in
|
||||
|
@ -693,7 +693,7 @@ let transl_class ids cl_id pub_meths cl vflag =
|
|||
let no_env_update _ _ env = env in
|
||||
let msubst arr = function
|
||||
Lfunction {kind = Curried; params = self :: args; body} ->
|
||||
let env = Ident.create_var "env" in
|
||||
let env = Ident.create_local "env" in
|
||||
let body' =
|
||||
if new_ids = [] then body else
|
||||
Lambda.subst no_env_update (subst env body 0 new_ids_meths) body in
|
||||
|
@ -714,7 +714,7 @@ let transl_class ids cl_id pub_meths cl vflag =
|
|||
| _ -> assert false
|
||||
in
|
||||
let new_ids_init = ref [] in
|
||||
let env1 = Ident.create_var "env" and env1' = Ident.create_var "env'" in
|
||||
let env1 = Ident.create_local "env" and env1' = Ident.create_local "env'" in
|
||||
let copy_env self =
|
||||
if top then lambda_unit else
|
||||
Lifused(env2, Lprim(Psetfield_computed (Pointer, Assignment),
|
||||
|
@ -731,7 +731,7 @@ let transl_class ids cl_id pub_meths cl vflag =
|
|||
in
|
||||
|
||||
(* Now we start compiling the class *)
|
||||
let cla = Ident.create_var "class" in
|
||||
let cla = Ident.create_local "class" in
|
||||
let (inh_init, obj_init) =
|
||||
build_object_init_0 cla [] cl copy_env subst_env top ids in
|
||||
let inh_init' = List.rev inh_init in
|
||||
|
@ -739,10 +739,10 @@ let transl_class ids cl_id pub_meths cl vflag =
|
|||
build_class_init cla true ([],[]) inh_init' obj_init msubst top cl
|
||||
in
|
||||
assert (inh_init' = []);
|
||||
let table = Ident.create_var "table"
|
||||
and class_init = Ident.create_var (Ident.name cl_id ^ "_init")
|
||||
and env_init = Ident.create_var "env_init"
|
||||
and obj_init = Ident.create_var "obj_init" in
|
||||
let table = Ident.create_local "table"
|
||||
and class_init = Ident.create_local (Ident.name cl_id ^ "_init")
|
||||
and env_init = Ident.create_local "env_init"
|
||||
and obj_init = Ident.create_local "obj_init" in
|
||||
let pub_meths =
|
||||
List.sort
|
||||
(fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s'))
|
||||
|
@ -800,8 +800,8 @@ let transl_class ids cl_id pub_meths cl vflag =
|
|||
if top then llets (lbody_virt lambda_unit) else
|
||||
|
||||
(* Now for the hard stuff: prepare for table caching *)
|
||||
let envs = Ident.create_var "envs"
|
||||
and cached = Ident.create_var "cached" in
|
||||
let envs = Ident.create_local "envs"
|
||||
and cached = Ident.create_local "cached" in
|
||||
let lenvs =
|
||||
if !new_ids_meths = [] && !new_ids_init = [] && inh_init = []
|
||||
then lambda_unit
|
||||
|
|
|
@ -436,7 +436,7 @@ and transl_exp0 e =
|
|||
| Texp_setinstvar(path_self, path, _, expr) ->
|
||||
transl_setinstvar e.exp_loc (transl_normal_path path_self) path expr
|
||||
| Texp_override(path_self, modifs) ->
|
||||
let cpy = Ident.create_var "copy" in
|
||||
let cpy = Ident.create_local "copy" in
|
||||
Llet(Strict, Pgenval, cpy,
|
||||
Lapply{ap_should_be_tailcall=false;
|
||||
ap_loc=Location.none;
|
||||
|
@ -502,7 +502,8 @@ and transl_exp0 e =
|
|||
transl_exp e
|
||||
| `Other ->
|
||||
(* other cases compile to a lazy block holding a function *)
|
||||
let fn = Lfunction {kind = Curried; params= [Ident.create_var "param"];
|
||||
let fn = Lfunction {kind = Curried;
|
||||
params= [Ident.create_local "param"];
|
||||
attr = default_function_attribute;
|
||||
loc = e.exp_loc;
|
||||
body = transl_exp e} in
|
||||
|
@ -510,7 +511,7 @@ and transl_exp0 e =
|
|||
end
|
||||
| Texp_object (cs, meths) ->
|
||||
let cty = cs.cstr_type in
|
||||
let cl = Ident.create_var "class" in
|
||||
let cl = Ident.create_local "class" in
|
||||
!transl_object cl meths
|
||||
{ cl_desc = Tcl_structure cs;
|
||||
cl_loc = e.exp_loc;
|
||||
|
@ -590,7 +591,7 @@ and transl_apply ?(should_be_tailcall=false) ?(inlined = Default_inline)
|
|||
match lam with
|
||||
Lvar _ | Lconst _ -> lam
|
||||
| _ ->
|
||||
let id = Ident.create_var name in
|
||||
let id = Ident.create_local name in
|
||||
defs := (id, lam) :: !defs;
|
||||
Lvar id
|
||||
in
|
||||
|
@ -601,7 +602,7 @@ and transl_apply ?(should_be_tailcall=false) ?(inlined = Default_inline)
|
|||
if args = [] then lam else lapply lam (List.rev_map fst args) in
|
||||
let handle = protect "func" lam
|
||||
and l = List.map (fun (arg, opt) -> may_map (protect "arg") arg, opt) l
|
||||
and id_arg = Ident.create_var "param" in
|
||||
and id_arg = Ident.create_local "param" in
|
||||
let body =
|
||||
match build_apply handle ((Lvar id_arg, optional)::args') l with
|
||||
Lfunction{kind = Curried; params = ids; body = lam; attr; loc} ->
|
||||
|
@ -646,7 +647,7 @@ and transl_function loc untuplify_fn repr partial param cases =
|
|||
(fun {c_lhs; c_guard; c_rhs} ->
|
||||
(Matching.flatten_pattern size c_lhs, c_guard, c_rhs))
|
||||
cases in
|
||||
let params = List.map (fun _ -> Ident.create_var "param") pl in
|
||||
let params = List.map (fun _ -> Ident.create_local "param") pl in
|
||||
((Tupled, params),
|
||||
Matching.for_tupled_function loc params
|
||||
(transl_tupled_cases pats_expr_list) partial)
|
||||
|
@ -718,7 +719,7 @@ and transl_record loc env fields repres opt_init_expr =
|
|||
then begin
|
||||
(* Allocate new record with given fields (and remaining fields
|
||||
taken from init_expr if any *)
|
||||
let init_id = Ident.create_var "init" in
|
||||
let init_id = Ident.create_local "init" in
|
||||
let lv =
|
||||
Array.mapi
|
||||
(fun i (_, definition) ->
|
||||
|
@ -781,7 +782,7 @@ and transl_record loc env fields repres opt_init_expr =
|
|||
end else begin
|
||||
(* Take a shallow copy of the init record, then mutate the fields
|
||||
of the copy *)
|
||||
let copy_id = Ident.create_var "newrecord" in
|
||||
let copy_id = Ident.create_local "newrecord" in
|
||||
let update_field cont (lbl, definition) =
|
||||
match definition with
|
||||
| Kept _type -> cont
|
||||
|
|
|
@ -74,7 +74,7 @@ let rec apply_coercion loc strict restr arg =
|
|||
in
|
||||
wrap_id_pos_list loc id_pos_list get_field lam)
|
||||
| Tcoerce_functor(cc_arg, cc_res) ->
|
||||
let param = Ident.create_var "funarg" in
|
||||
let param = Ident.create_local "funarg" in
|
||||
let carg = apply_coercion loc Alias cc_arg (Lvar param) in
|
||||
apply_coercion_result loc strict arg [param] [carg] cc_res
|
||||
| Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } ->
|
||||
|
@ -89,7 +89,7 @@ and apply_coercion_field loc get_field (pos, cc) =
|
|||
and apply_coercion_result loc strict funct params args cc_res =
|
||||
match cc_res with
|
||||
| Tcoerce_functor(cc_arg, cc_res) ->
|
||||
let param = Ident.create_var "funarg" in
|
||||
let param = Ident.create_local "funarg" in
|
||||
let arg = apply_coercion loc Alias cc_arg (Lvar param) in
|
||||
apply_coercion_result loc strict funct
|
||||
(param :: params) (arg :: args) cc_res
|
||||
|
@ -117,7 +117,7 @@ and wrap_id_pos_list loc id_pos_list get_field lam =
|
|||
let (lam,s) =
|
||||
List.fold_left (fun (lam, s) (id',pos,c) ->
|
||||
if Ident.Set.mem id' fv then
|
||||
let id'' = Ident.create_var (Ident.name id') in
|
||||
let id'' = Ident.create_local (Ident.name id') in
|
||||
(Llet(Alias, Pgenval, id'',
|
||||
apply_coercion loc Alias c (get_field pos),lam),
|
||||
Ident.Map.add id' id'' s)
|
||||
|
@ -622,7 +622,7 @@ and transl_structure loc fields cc rootpath final_env = function
|
|||
| Tstr_include incl ->
|
||||
let ids = bound_value_identifiers incl.incl_type in
|
||||
let modl = incl.incl_mod in
|
||||
let mid = Ident.create_var "include" in
|
||||
let mid = Ident.create_local "include" in
|
||||
let rec rebind_idents pos newfields = function
|
||||
[] ->
|
||||
transl_structure loc newfields cc rootpath final_env rem
|
||||
|
@ -1008,7 +1008,7 @@ let transl_store_structure glob map prims str =
|
|||
| Tstr_include incl ->
|
||||
let ids = bound_value_identifiers incl.incl_type in
|
||||
let modl = incl.incl_mod in
|
||||
let mid = Ident.create_var "include" in
|
||||
let mid = Ident.create_local "include" in
|
||||
let loc = incl.incl_loc in
|
||||
let rec store_idents pos = function
|
||||
[] -> transl_store rootpath (add_idents true ids subst) rem
|
||||
|
@ -1236,7 +1236,7 @@ let transl_toplevel_item item =
|
|||
| Tstr_include incl ->
|
||||
let ids = bound_value_identifiers incl.incl_type in
|
||||
let modl = incl.incl_mod in
|
||||
let mid = Ident.create_var "include" in
|
||||
let mid = Ident.create_local "include" in
|
||||
let rec set_idents pos = function
|
||||
[] ->
|
||||
lambda_unit
|
||||
|
@ -1330,7 +1330,7 @@ let transl_store_package component_names target_name coercion =
|
|||
List.map get_component component_names,
|
||||
Location.none)
|
||||
in
|
||||
let blk = Ident.create_var "block" in
|
||||
let blk = Ident.create_local "block" in
|
||||
(List.length pos_cc_list,
|
||||
Llet (Strict, Pgenval, blk,
|
||||
apply_coercion Location.none Strict coercion components,
|
||||
|
|
|
@ -37,7 +37,7 @@ let share c =
|
|||
begin try
|
||||
Lvar (Hashtbl.find consts c)
|
||||
with Not_found ->
|
||||
let id = Ident.create_var "shared" in
|
||||
let id = Ident.create_local "shared" in
|
||||
Hashtbl.add consts c id;
|
||||
Lvar id
|
||||
end
|
||||
|
@ -112,7 +112,7 @@ let transl_label_init_general f =
|
|||
|
||||
let transl_label_init_flambda f =
|
||||
assert(Config.flambda);
|
||||
let method_cache_id = Ident.create_var "method_cache" in
|
||||
let method_cache_id = Ident.create_local "method_cache" in
|
||||
method_cache := Lvar method_cache_id;
|
||||
(* Calling f (usually Translmod.transl_struct) requires the
|
||||
method_cache variable to be initialised to be able to generate
|
||||
|
|
|
@ -668,7 +668,7 @@ let lambda_of_prim prim_name prim loc args arg_exps =
|
|||
in
|
||||
Lprim(Praise kind, [arg], loc)
|
||||
| Raise_with_backtrace, [exn; bt] ->
|
||||
let vexn = Ident.create_var "exn" in
|
||||
let vexn = Ident.create_local "exn" in
|
||||
let raise_arg =
|
||||
match arg_exps with
|
||||
| None -> Lvar vexn
|
||||
|
@ -725,7 +725,7 @@ let transl_primitive loc p env ty path =
|
|||
| Some prim -> prim
|
||||
in
|
||||
let rec make_params n =
|
||||
if n <= 0 then [] else Ident.create_var "prim" :: make_params (n-1)
|
||||
if n <= 0 then [] else Ident.create_local "prim" :: make_params (n-1)
|
||||
in
|
||||
let params = make_params p.prim_arity in
|
||||
let args = List.map (fun id -> Lvar id) params in
|
||||
|
|
|
@ -39,7 +39,8 @@ exception Error of error
|
|||
let abstract_type =
|
||||
Btype.newgenty (
|
||||
Tconstr
|
||||
(Pident (Ident.create ~scope:Btype.lowest_level "<abstr>"), [], ref Mnil)
|
||||
(Pident (
|
||||
Ident.create_scoped ~scope:Btype.lowest_level "<abstr>"), [], ref Mnil)
|
||||
)
|
||||
|
||||
let rec path event = function
|
||||
|
|
|
@ -98,7 +98,7 @@ module Function_decls = struct
|
|||
~attr ~loc =
|
||||
let let_rec_ident =
|
||||
match let_rec_ident with
|
||||
| None -> Ident.create_var "unnamed_function"
|
||||
| None -> Ident.create_local "unnamed_function"
|
||||
| Some let_rec_ident -> let_rec_ident
|
||||
in
|
||||
{ let_rec_ident;
|
||||
|
|
|
@ -231,7 +231,7 @@ let to_path n =
|
|||
List.fold_left
|
||||
(fun acc_opt -> fun s ->
|
||||
match acc_opt with
|
||||
None -> Some (Path.Pident (Ident.create_var s))
|
||||
None -> Some (Path.Pident (Ident.create_local s))
|
||||
| Some acc -> Some (Path.Pdot (acc, s, 0)))
|
||||
None
|
||||
(Str.split (Str.regexp "\\.") n)
|
||||
|
|
|
@ -29,7 +29,7 @@ let ident_name s =
|
|||
| n -> String.sub s 0 n
|
||||
|
||||
let bind_ident s =
|
||||
let id = Ident.create_var (ident_name s) in
|
||||
let id = Ident.create_local (ident_name s) in
|
||||
Hashtbl.add tbl_ident s id;
|
||||
id
|
||||
|
||||
|
|
|
@ -133,22 +133,22 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
|
|||
O.t -> Outcometree.out_value) gen_printer)
|
||||
|
||||
let printers = ref ([
|
||||
( Pident(Ident.create_var "print_int"),
|
||||
( Pident(Ident.create_local "print_int"),
|
||||
Simple (Predef.type_int,
|
||||
(fun x -> Oval_int (O.obj x : int))) );
|
||||
( Pident(Ident.create_var "print_float"),
|
||||
( Pident(Ident.create_local "print_float"),
|
||||
Simple (Predef.type_float,
|
||||
(fun x -> Oval_float (O.obj x : float))) );
|
||||
( Pident(Ident.create_var "print_char"),
|
||||
( Pident(Ident.create_local "print_char"),
|
||||
Simple (Predef.type_char,
|
||||
(fun x -> Oval_char (O.obj x : char))) );
|
||||
( Pident(Ident.create_var "print_int32"),
|
||||
( Pident(Ident.create_local "print_int32"),
|
||||
Simple (Predef.type_int32,
|
||||
(fun x -> Oval_int32 (O.obj x : int32))) );
|
||||
( Pident(Ident.create_var "print_nativeint"),
|
||||
( Pident(Ident.create_local "print_nativeint"),
|
||||
Simple (Predef.type_nativeint,
|
||||
(fun x -> Oval_nativeint (O.obj x : nativeint))) );
|
||||
( Pident(Ident.create_var "print_int64"),
|
||||
( Pident(Ident.create_local "print_int64"),
|
||||
Simple (Predef.type_int64,
|
||||
(fun x -> Oval_int64 (O.obj x : int64)) ))
|
||||
] : (Path.t * printer) list)
|
||||
|
@ -223,7 +223,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
|
|||
|
||||
let abstract_type =
|
||||
let scope = Ctype.get_current_level () in
|
||||
let id = Ident.create ~scope "abstract" in
|
||||
let id = Ident.create_scoped ~scope "abstract" in
|
||||
let ty = Ctype.newty (Tconstr (Pident id, [], ref Mnil)) in
|
||||
Ctype.init_def (scope + 1);
|
||||
ty
|
||||
|
|
|
@ -1132,7 +1132,8 @@ let instance_constructor ?in_pattern cstr =
|
|||
let name = existential_name cstr existential in
|
||||
let path =
|
||||
Path.Pident
|
||||
(Ident.create ~scope:expansion_scope (get_new_abstract_name name))
|
||||
(Ident.create_scoped ~scope:expansion_scope
|
||||
(get_new_abstract_name name))
|
||||
in
|
||||
let new_env = Env.add_local_type path decl !env in
|
||||
env := new_env;
|
||||
|
@ -1937,7 +1938,8 @@ let reify env t =
|
|||
let name = match name with Some s -> "$'"^s | _ -> "$" in
|
||||
let path =
|
||||
Path.Pident
|
||||
(Ident.create ~scope:fresh_constr_scope (get_new_abstract_name name))
|
||||
(Ident.create_scoped ~scope:fresh_constr_scope
|
||||
(get_new_abstract_name name))
|
||||
in
|
||||
let decl = new_declaration (Some fresh_constr_scope) None in
|
||||
let new_env = Env.add_local_type path decl !env in
|
||||
|
@ -2296,7 +2298,7 @@ let complete_type_list ?(allow_absent=false) env nl1 lv2 mty2 nl2 tl2 =
|
|||
|
||||
It'd be nice if we avoided creating such temporary dummy modules and broken
|
||||
environments though. *)
|
||||
let id2 = Ident.create_var "Pkg" in
|
||||
let id2 = Ident.create_local "Pkg" in
|
||||
let env' = Env.add_module id2 mty2 env in
|
||||
let rec complete nl1 ntl2 =
|
||||
match nl1, ntl2 with
|
||||
|
@ -2976,7 +2978,7 @@ let filter_self_method env lab priv meths ty =
|
|||
try
|
||||
Meths.find lab !meths
|
||||
with Not_found ->
|
||||
let pair = (Ident.create_var lab, ty') in
|
||||
let pair = (Ident.create_local lab, ty') in
|
||||
meths := Meths.add lab pair !meths;
|
||||
pair
|
||||
|
||||
|
|
|
@ -1959,7 +1959,7 @@ let add_local_type path info env =
|
|||
(* Insertion of bindings by name *)
|
||||
|
||||
let enter scope store_fun name data env =
|
||||
let id = Ident.create ~scope name in (id, store_fun id data env)
|
||||
let id = Ident.create_scoped ~scope name in (id, store_fun id data env)
|
||||
|
||||
let enter_value ?check = enter 0 (store_value ?check)
|
||||
and enter_type ~scope = enter scope (store_type ~check:true)
|
||||
|
@ -1973,7 +1973,7 @@ and enter_class ~scope = enter scope store_class
|
|||
and enter_cltype ~scope = enter scope store_cltype
|
||||
|
||||
let enter_module ~scope ?arg s mty env =
|
||||
let id = Ident.create ~scope s in
|
||||
let id = Ident.create_scoped ~scope s in
|
||||
(id, enter_module_declaration ?arg id (md mty) env)
|
||||
|
||||
(* Insertion of all components of a signature *)
|
||||
|
|
|
@ -16,7 +16,8 @@
|
|||
open Format
|
||||
|
||||
type t =
|
||||
| Local of { name: string; stamp: int; scope: int }
|
||||
| Local of { name: string; stamp: int }
|
||||
| Scoped of { name: string; stamp: int; scope: int }
|
||||
| Global of string
|
||||
| Predef_exn of string
|
||||
|
||||
|
@ -24,16 +25,16 @@ type t =
|
|||
|
||||
let currentstamp = ref 0
|
||||
|
||||
let create ~scope s =
|
||||
let create_scoped ~scope s =
|
||||
incr currentstamp;
|
||||
Local { name = s; stamp = !currentstamp; scope }
|
||||
Scoped { name = s; stamp = !currentstamp; scope }
|
||||
|
||||
let create_var s =
|
||||
let create_local s =
|
||||
incr currentstamp;
|
||||
Local { name = s; stamp = !currentstamp; scope = 0 }
|
||||
Local { name = s; stamp = !currentstamp }
|
||||
|
||||
let create_hidden s =
|
||||
Local { name = s; stamp = -1; scope = 0 }
|
||||
Local { name = s; stamp = -1 }
|
||||
|
||||
let create_predef_exn s =
|
||||
Predef_exn s
|
||||
|
@ -43,23 +44,29 @@ let create_persistent s =
|
|||
|
||||
let name = function
|
||||
| Local { name; _ }
|
||||
| Scoped { name; _ }
|
||||
| Global name
|
||||
| Predef_exn name -> name
|
||||
|
||||
let rename = function
|
||||
| Local { name; stamp = _; scope } ->
|
||||
| Local { name; stamp = _ } ->
|
||||
incr currentstamp;
|
||||
Local { name; stamp = !currentstamp; scope }
|
||||
Local { name; stamp = !currentstamp }
|
||||
| Scoped { name; stamp = _; scope } ->
|
||||
incr currentstamp;
|
||||
Scoped { name; stamp = !currentstamp; scope }
|
||||
| id ->
|
||||
Misc.fatal_errorf "Ident.rename %s" (name id)
|
||||
|
||||
let unique_name = function
|
||||
| Local { name; stamp } -> name ^ "_" ^ string_of_int stamp
|
||||
| Local { name; stamp }
|
||||
| Scoped { name; stamp } -> name ^ "_" ^ string_of_int stamp
|
||||
| Global name
|
||||
| Predef_exn name -> name
|
||||
|
||||
let unique_toplevel_name = function
|
||||
| Local { name; stamp } -> name ^ "/" ^ string_of_int stamp
|
||||
| Local { name; stamp }
|
||||
| Scoped { name; stamp } -> name ^ "/" ^ string_of_int stamp
|
||||
| Global name
|
||||
| Predef_exn name -> name
|
||||
|
||||
|
@ -70,6 +77,7 @@ let persistent = function
|
|||
let equal i1 i2 =
|
||||
match i1, i2 with
|
||||
| Local { name = name1; _ }, Local { name = name2; _ }
|
||||
| Scoped { name = name1; _ }, Scoped { name = name2; _ }
|
||||
| Global name1, Global name2
|
||||
| Predef_exn name1, Predef_exn name2 ->
|
||||
name1 = name2
|
||||
|
@ -85,11 +93,12 @@ let same i1 i2 = i1 = i2
|
|||
let compare i1 i2 = Stdlib.compare i1 i2
|
||||
|
||||
let stamp = function
|
||||
| Local { stamp; _ } -> stamp
|
||||
| Local { stamp; _ }
|
||||
| Scoped { stamp; _ } -> stamp
|
||||
| _ -> 0
|
||||
|
||||
let scope = function
|
||||
| Local { scope; _ } -> scope
|
||||
| Scoped { scope; _ } -> scope
|
||||
| _ -> 0
|
||||
|
||||
let current_stamp () = !currentstamp
|
||||
|
@ -103,7 +112,8 @@ let reinit () =
|
|||
else currentstamp := !reinit_level
|
||||
|
||||
let global = function
|
||||
| Local _ -> false
|
||||
| Local _
|
||||
| Scoped _ -> false
|
||||
| Global _
|
||||
| Predef_exn _ -> true
|
||||
|
||||
|
@ -118,6 +128,9 @@ let print ppf = function
|
|||
| Local { name; stamp = n } ->
|
||||
fprintf ppf "%s%s" name
|
||||
(if !Clflags.unique_ids then Printf.sprintf "/%i" n else "")
|
||||
| Scoped { name; stamp = n; scope } ->
|
||||
fprintf ppf "%s%s" name
|
||||
(if !Clflags.unique_ids then Printf.sprintf "/%i[%i]" n scope else "")
|
||||
|
||||
type 'a tbl =
|
||||
Empty
|
||||
|
@ -254,10 +267,11 @@ let key_name = ""
|
|||
let make_key_generator () =
|
||||
let c = ref 1 in
|
||||
function
|
||||
| Local _ ->
|
||||
| Local _
|
||||
| Scoped _ ->
|
||||
let stamp = !c in
|
||||
decr c ;
|
||||
Local { name = key_name; stamp = stamp; scope = 0 }
|
||||
Local { name = key_name; stamp = stamp }
|
||||
| global_id ->
|
||||
Misc.fatal_errorf "Ident.make_key_generator () %s" (name global_id)
|
||||
|
||||
|
@ -269,6 +283,12 @@ let compare x y =
|
|||
else compare x.name y.name
|
||||
| Local _, _ -> 1
|
||||
| _, Local _ -> (-1)
|
||||
| Scoped x, Scoped y ->
|
||||
let c = x.stamp - y.stamp in
|
||||
if c <> 0 then c
|
||||
else compare x.name y.name
|
||||
| Scoped _, _ -> 1
|
||||
| _, Scoped _ -> (-1)
|
||||
| Global x, Global y -> compare x y
|
||||
| Global _, _ -> 1
|
||||
| _, Global _ -> (-1)
|
||||
|
|
|
@ -25,8 +25,8 @@ include Identifiable.S with type t := t
|
|||
*)
|
||||
|
||||
|
||||
val create: scope:int -> string -> t
|
||||
val create_var: string -> t
|
||||
val create_scoped: scope:int -> string -> t
|
||||
val create_local: string -> t
|
||||
val create_persistent: string -> t
|
||||
val create_predef_exn: string -> t
|
||||
val rename: t -> t
|
||||
|
|
|
@ -34,7 +34,7 @@ let omega = make_pat Tpat_any Ctype.none Env.empty
|
|||
|
||||
let extra_pat =
|
||||
make_pat
|
||||
(Tpat_var (Ident.create_var "+", mknoloc "+"))
|
||||
(Tpat_var (Ident.create_local "+", mknoloc "+"))
|
||||
Ctype.none Env.empty
|
||||
|
||||
let rec omegas i =
|
||||
|
@ -974,7 +974,7 @@ let some_private_tag = "<some private tag>"
|
|||
let build_other ext env = match env with
|
||||
| ({pat_desc = Tpat_construct (lid, {cstr_tag=Cstr_extension _},_)},_) :: _ ->
|
||||
(* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *)
|
||||
make_pat (Tpat_var (Ident.create_var "*extension*",
|
||||
make_pat (Tpat_var (Ident.create_local "*extension*",
|
||||
{lid with txt="*extension*"})) Ctype.none Env.empty
|
||||
| ({pat_desc = Tpat_construct _} as p,_) :: _ ->
|
||||
begin match ext with
|
||||
|
|
|
@ -26,7 +26,7 @@ let wrap create s =
|
|||
builtin_idents := (s, id) :: !builtin_idents;
|
||||
id
|
||||
|
||||
let ident_create = wrap (Ident.create ~scope:lowest_level)
|
||||
let ident_create = wrap (Ident.create_scoped ~scope:lowest_level)
|
||||
let ident_create_predef_exn = wrap Ident.create_predef_exn
|
||||
|
||||
let ident_int = ident_create "int"
|
||||
|
|
|
@ -101,7 +101,7 @@ let dummy_method = Btype.dummy_method
|
|||
(its constructor is not available).
|
||||
*)
|
||||
let unbound_class =
|
||||
Path.Pident (Ident.create ~scope:Btype.lowest_level "*undef*")
|
||||
Path.Pident (Ident.create_scoped ~scope:Btype.lowest_level "*undef*")
|
||||
|
||||
|
||||
(************************************)
|
||||
|
@ -608,7 +608,7 @@ and class_field_aux self_loc cl_num self_type meths vars
|
|||
in
|
||||
(* Inherited concrete methods *)
|
||||
let inh_meths =
|
||||
Concr.fold (fun lab rem -> (lab, Ident.create_var lab)::rem)
|
||||
Concr.fold (fun lab rem -> (lab, Ident.create_local lab)::rem)
|
||||
cl_sig.csig_concr []
|
||||
in
|
||||
(* Super *)
|
||||
|
@ -1183,7 +1183,7 @@ and class_expr_aux cl_num val_env met_env scl =
|
|||
Types.val_loc = vd.Types.val_loc;
|
||||
}
|
||||
in
|
||||
let id' = Ident.create_var (Ident.name id) in
|
||||
let id' = Ident.create_local (Ident.name id) in
|
||||
((id', expr)
|
||||
:: vals,
|
||||
Env.add_value id' desc met_env))
|
||||
|
@ -1725,10 +1725,10 @@ let type_classes define_class approx kind env cls =
|
|||
List.map
|
||||
(function cl ->
|
||||
(cl,
|
||||
Ident.create ~scope cl.pci_name.txt,
|
||||
Ident.create ~scope cl.pci_name.txt,
|
||||
Ident.create ~scope cl.pci_name.txt,
|
||||
Ident.create ~scope ("#" ^ cl.pci_name.txt)))
|
||||
Ident.create_scoped ~scope cl.pci_name.txt,
|
||||
Ident.create_scoped ~scope cl.pci_name.txt,
|
||||
Ident.create_scoped ~scope cl.pci_name.txt,
|
||||
Ident.create_scoped ~scope ("#" ^ cl.pci_name.txt)))
|
||||
cls
|
||||
in
|
||||
Ctype.init_def (scope + 1);
|
||||
|
|
|
@ -491,7 +491,7 @@ let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty
|
|||
if List.exists (fun {pv_id; _} -> Ident.name pv_id = name.txt)
|
||||
!pattern_variables
|
||||
then raise(Error(loc, Env.empty, Multiply_bound_variable name.txt));
|
||||
let id = Ident.create_var name.txt in
|
||||
let id = Ident.create_local name.txt in
|
||||
pattern_variables :=
|
||||
{pv_id = id;
|
||||
pv_type = ty;
|
||||
|
@ -1123,7 +1123,7 @@ and type_pat_aux ~exception_allowed ~constrs ~labels ~no_existentials ~mode
|
|||
let ty = instance expected_ty in
|
||||
let id = (* PR#7330 *)
|
||||
if name.txt = "*extension*" then
|
||||
Ident.create_var name.txt
|
||||
Ident.create_local name.txt
|
||||
else
|
||||
enter_variable loc name ty sp.ppat_attributes
|
||||
in
|
||||
|
@ -1624,7 +1624,7 @@ let type_class_arg_pattern cl_num val_env met_env l spat =
|
|||
let check s =
|
||||
if pv_as_var then Warnings.Unused_var s
|
||||
else Warnings.Unused_var_strict s in
|
||||
let id' = Ident.create_var (Ident.name pv_id) in
|
||||
let id' = Ident.create_local (Ident.name pv_id) in
|
||||
((id', pv_id, pv_type)::pv,
|
||||
Env.add_value id' {val_type = pv_type;
|
||||
val_kind = Val_ivar (Immutable, cl_num);
|
||||
|
@ -2112,7 +2112,7 @@ let proper_exp_loc exp =
|
|||
(* To find reasonable names for let-bound and lambda-bound idents *)
|
||||
|
||||
let rec name_pattern default = function
|
||||
[] -> Ident.create_var default
|
||||
[] -> Ident.create_local default
|
||||
| p :: rem ->
|
||||
match p.pat_desc with
|
||||
Tpat_var (id, _) -> id
|
||||
|
@ -2694,7 +2694,7 @@ and type_expect_
|
|||
(mk_expected ~explanation:For_loop_stop_index Predef.type_int) in
|
||||
let id, new_env =
|
||||
match param.ppat_desc with
|
||||
| Ppat_any -> Ident.create_var "_for", env
|
||||
| Ppat_any -> Ident.create_local "_for", env
|
||||
| Ppat_var {txt} ->
|
||||
Env.enter_value txt {val_type = instance Predef.type_int;
|
||||
val_attributes = [];
|
||||
|
@ -3663,7 +3663,7 @@ and type_argument ?recarg env sarg ty_expected' ty_expected =
|
|||
if args = [] then texp else
|
||||
(* eta-expand to avoid side effects *)
|
||||
let var_pair name ty =
|
||||
let id = Ident.create_var name in
|
||||
let id = Ident.create_local name in
|
||||
{pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[];
|
||||
pat_attributes = [];
|
||||
pat_loc = Location.none; pat_env = env},
|
||||
|
|
|
@ -235,7 +235,7 @@ let transl_labels env closed lbls =
|
|||
(fun () ->
|
||||
let arg = Ast_helper.Typ.force_poly arg in
|
||||
let cty = transl_simple_type env closed arg in
|
||||
{ld_id = Ident.create_var name.txt;
|
||||
{ld_id = Ident.create_local name.txt;
|
||||
ld_name = name; ld_mutable = mut;
|
||||
ld_type = cty; ld_loc = loc; ld_attributes = attrs}
|
||||
)
|
||||
|
@ -448,7 +448,7 @@ let transl_declaration env sdecl id =
|
|||
> (Config.max_tag + 1) then
|
||||
raise(Error(sdecl.ptype_loc, Too_many_constructors));
|
||||
let make_cstr scstr =
|
||||
let name = Ident.create_var scstr.pcd_name.txt in
|
||||
let name = Ident.create_local scstr.pcd_name.txt in
|
||||
let targs, tret_type, args, ret_type, cstr_params =
|
||||
make_constructor env (Path.Pident id) params
|
||||
scstr.pcd_args scstr.pcd_res
|
||||
|
@ -1281,7 +1281,8 @@ let transl_type_decl env rec_flag sdecl_list =
|
|||
(* Create identifiers. *)
|
||||
let scope = Ctype.get_current_level () in
|
||||
let id_list =
|
||||
List.map (fun sdecl -> Ident.create ~scope sdecl.ptype_name.txt) sdecl_list
|
||||
List.map (fun sdecl -> Ident.create_scoped ~scope sdecl.ptype_name.txt)
|
||||
sdecl_list
|
||||
in
|
||||
(*
|
||||
Since we've introduced fresh idents, make sure the definition
|
||||
|
@ -1410,7 +1411,7 @@ let transl_type_decl env rec_flag sdecl_list =
|
|||
|
||||
let transl_extension_constructor env type_path type_params
|
||||
typext_params priv sext =
|
||||
let id = Ident.create_var sext.pext_name.txt in
|
||||
let id = Ident.create_local sext.pext_name.txt in
|
||||
let args, ret_type, kind =
|
||||
match sext.pext_kind with
|
||||
Pext_decl(sargs, sret_type) ->
|
||||
|
@ -1940,7 +1941,7 @@ let approx_type_decl sdecl_list =
|
|||
let scope = Ctype.get_current_level () in
|
||||
List.map
|
||||
(fun sdecl ->
|
||||
(Ident.create ~scope sdecl.ptype_name.txt,
|
||||
(Ident.create_scoped ~scope sdecl.ptype_name.txt,
|
||||
abstract_type_decl (List.length sdecl.ptype_params)))
|
||||
sdecl_list
|
||||
|
||||
|
|
|
@ -470,7 +470,7 @@ let merge_constraint initial_env remove_aliases loc sg constr =
|
|||
type_immediate = false;
|
||||
type_unboxed = unboxed_false_default_false;
|
||||
}
|
||||
and id_row = Ident.create ~scope:(Ctype.get_current_level ())
|
||||
and id_row = Ident.create_scoped ~scope:(Ctype.get_current_level ())
|
||||
(s^"#row")
|
||||
in
|
||||
let initial_env =
|
||||
|
@ -709,7 +709,7 @@ and approx_sig env ssg =
|
|||
map_rec_type ~rec_flag
|
||||
(fun rs (id, info) -> Sig_type(id, info, rs)) decls rem
|
||||
| Psig_module pmd ->
|
||||
let id = Ident.create ~scope:(Ctype.get_current_level ())
|
||||
let id = Ident.create_scoped ~scope:(Ctype.get_current_level ())
|
||||
pmd.pmd_name.txt in
|
||||
let md = approx_module_declaration env pmd in
|
||||
let newenv = Env.enter_module_declaration id md env in
|
||||
|
@ -718,7 +718,7 @@ and approx_sig env ssg =
|
|||
let decls =
|
||||
List.map
|
||||
(fun pmd ->
|
||||
(Ident.create ~scope:(Ctype.get_current_level ())
|
||||
(Ident.create_scoped ~scope:(Ctype.get_current_level ())
|
||||
pmd.pmd_name.txt,
|
||||
approx_module_declaration env pmd)
|
||||
)
|
||||
|
@ -1059,7 +1059,7 @@ and transl_signature env sg =
|
|||
Text_exception) :: rem,
|
||||
final_env
|
||||
| Psig_module pmd ->
|
||||
let id = Ident.create ~scope:(Ctype.get_current_level ())
|
||||
let id = Ident.create_scoped ~scope:(Ctype.get_current_level ())
|
||||
pmd.pmd_name.txt in
|
||||
check_module names pmd.pmd_name.loc id to_be_removed;
|
||||
let tmty =
|
||||
|
@ -1253,7 +1253,9 @@ and transl_recmodule_modtypes env sdecls =
|
|||
md_loc = mty.mty_loc;
|
||||
md_attributes = mty.mty_attributes})) in
|
||||
let scope = Ctype.get_current_level () in
|
||||
let ids = List.map (fun x -> Ident.create ~scope x.pmd_name.txt) sdecls in
|
||||
let ids =
|
||||
List.map (fun x -> Ident.create_scoped ~scope x.pmd_name.txt) sdecls
|
||||
in
|
||||
let approx_env =
|
||||
(*
|
||||
cf #5965
|
||||
|
@ -1263,7 +1265,9 @@ and transl_recmodule_modtypes env sdecls =
|
|||
*)
|
||||
List.fold_left
|
||||
(fun env id ->
|
||||
let dummy = Mty_ident (Path.Pident (Ident.create ~scope "#recmod#")) in
|
||||
let dummy =
|
||||
Mty_ident (Path.Pident (Ident.create_scoped ~scope "#recmod#"))
|
||||
in
|
||||
Env.add_module ~arg:true id dummy env
|
||||
)
|
||||
env ids
|
||||
|
@ -1584,7 +1588,7 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
|
|||
let scope = Ctype.get_current_level () in
|
||||
let (id, newenv), funct_body =
|
||||
match ty_arg with
|
||||
| None -> (Ident.create ~scope "*", env), false
|
||||
| None -> (Ident.create_scoped ~scope "*", env), false
|
||||
| Some mty -> Env.enter_module ~scope ~arg:true name.txt mty env, true
|
||||
in
|
||||
Ctype.init_def(scope + 1); (* PR#6981 *)
|
||||
|
@ -1781,7 +1785,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
|
|||
pmb_loc;
|
||||
} ->
|
||||
let scope = Ctype.get_current_level () in
|
||||
let id = Ident.create ~scope name.txt in (* create early for PR#6752 *)
|
||||
let id =
|
||||
Ident.create_scoped ~scope name.txt (* create early for PR#6752 *)
|
||||
in
|
||||
check_module names pmb_loc id to_be_removed;
|
||||
let modl =
|
||||
Builtin_attributes.warning_scope attrs
|
||||
|
@ -2061,7 +2067,9 @@ let type_package env m p nl =
|
|||
| Tmod_constraint ({mod_desc=Tmod_ident (mp,_)}, _, Tmodtype_implicit, _)
|
||||
-> (mp, env) (* PR#6982 *)
|
||||
| _ ->
|
||||
let (id, new_env) = Env.enter_module ~scope ~arg:true "%M" modl.mod_type env in
|
||||
let (id, new_env) =
|
||||
Env.enter_module ~scope ~arg:true "%M" modl.mod_type env
|
||||
in
|
||||
(Pident id, new_env)
|
||||
in
|
||||
let rec mkpath mp = function
|
||||
|
@ -2190,7 +2198,7 @@ let rec package_signatures subst = function
|
|||
| (name, sg) :: rem ->
|
||||
let sg' = Subst.signature subst sg in
|
||||
let oldid = Ident.create_persistent name
|
||||
and newid = Ident.create_var name in
|
||||
and newid = Ident.create_local name in
|
||||
Sig_module(newid, {md_type=Mty_signature sg';
|
||||
md_attributes=[];
|
||||
md_loc=Location.none;
|
||||
|
|
Loading…
Reference in New Issue