Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Remove positions from paths

master
Leo White 2018-02-08 17:51:47 +00:00
parent 5daea80728
commit 111d4e1827
57 changed files with 1232 additions and 881 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
asmcomp/cmmgen.ml
View File

@ -861,7 +861,7 @@ let rec expr_size env = function
RHS_block sz
| Uprim (Pduprecord (Record_unboxed _, _), _, _) ->
assert false
| Uprim (Pduprecord (Record_extension, sz), _, _) ->
| Uprim (Pduprecord (Record_extension _, sz), _, _) ->
RHS_block (sz + 1)
| Uprim (Pduprecord (Record_float, sz), _, _) ->
RHS_floatblock sz

4
bytecomp/bytegen.ml
View File

@ -154,7 +154,7 @@ let rec size_of_lambda env = function
| Record_regular | Record_inlined _ -> RHS_block size
| Record_unboxed _ -> assert false
| Record_float -> RHS_floatblock size
| Record_extension -> RHS_block (size + 1)
| Record_extension _ -> RHS_block (size + 1)
end
| Llet(_str, _k, id, arg, body) ->
size_of_lambda (Ident.add id (size_of_lambda env arg) env) body
@ -177,7 +177,7 @@ let rec size_of_lambda env = function
RHS_block size
| Lprim (Pduprecord (Record_unboxed _, _), _, _) ->
assert false
| Lprim (Pduprecord (Record_extension, size), _, _) ->
| Lprim (Pduprecord (Record_extension _, size), _, _) ->
RHS_block (size + 1)
| Lprim (Pduprecord (Record_float, size), _, _) -> RHS_floatblock size
| Levent (lam, _) -> size_of_lambda env lam

2
bytecomp/bytepackager.ml
View File

@ -178,7 +178,7 @@ let rec rename_append_bytecode_list packagename oc mapping defined ofs
let root = Path.Pident (Ident.create_persistent prefix) in
rename_append_bytecode_list packagename oc mapping (id :: defined)
(ofs + size) prefix
(Subst.add_module id (Path.Pdot (root, Ident.name id, Path.nopos))
(Subst.add_module id (Path.Pdot (root, Ident.name id))
subst)
rem

35
bytecomp/lambda.ml
View File

@ -14,7 +14,6 @@
(**************************************************************************)
open Misc
open Path
open Asttypes
type compile_time_constant =
@ -607,29 +606,31 @@ let rec patch_guarded patch = function
(* Translate an access path *)
let rec transl_normal_path = function
Pident id ->
let rec transl_address loc = function
| Env.Aident id ->
if Ident.global id
then Lprim(Pgetglobal id, [], Location.none)
then Lprim(Pgetglobal id, [], loc)
else Lvar id
| Pdot(p, _s, pos) ->
Lprim(Pfield pos, [transl_normal_path p], Location.none)
| Papply _ ->
fatal_error "Lambda.transl_path"
| Env.Adot(addr, pos) ->
Lprim(Pfield pos, [transl_address loc addr], loc)
(* Translation of identifiers *)
let transl_path find loc env path =
match find path env with
| exception Not_found ->
fatal_error ("Cannot find address for: " ^ (Path.name path))
| addr -> transl_address loc addr
let transl_module_path ?(loc=Location.none) env path =
transl_normal_path (Env.normalize_path (Some loc) env path)
let transl_module_path loc env path =
transl_path Env.find_module_address loc env path
let transl_value_path ?(loc=Location.none) env path =
transl_normal_path (Env.normalize_path_prefix (Some loc) env path)
let transl_value_path loc env path =
transl_path Env.find_value_address loc env path
let transl_class_path = transl_value_path
let transl_extension_path = transl_value_path
let transl_extension_path loc env path =
transl_path Env.find_constructor_address loc env path
(* compatibility alias, deprecated in the .mli *)
let transl_path = transl_value_path
let transl_class_path loc env path =
transl_path Env.find_class_address loc env path
(* Compile a sequence of expressions *)

12
bytecomp/lambda.mli
View File

@ -338,14 +338,10 @@ val iter_head_constructor: (lambda -> unit) -> lambda -> unit
val free_variables: lambda -> Ident.Set.t
val transl_normal_path: Path.t -> lambda (* Path.t is already normal *)
val transl_path: ?loc:Location.t -> Env.t -> Path.t -> lambda
[@@ocaml.deprecated "use transl_{module,value,extension,class}_path instead"]
val transl_module_path: ?loc:Location.t -> Env.t -> Path.t -> lambda
val transl_value_path: ?loc:Location.t -> Env.t -> Path.t -> lambda
val transl_extension_path: ?loc:Location.t -> Env.t -> Path.t -> lambda
val transl_class_path: ?loc:Location.t -> Env.t -> Path.t -> lambda
val transl_module_path: Location.t -> Env.t -> Path.t -> lambda
val transl_value_path: Location.t -> Env.t -> Path.t -> lambda
val transl_extension_path: Location.t -> Env.t -> Path.t -> lambda
val transl_class_path: Location.t -> Env.t -> Path.t -> lambda
val make_sequence: ('a -> lambda) -> 'a list -> lambda

39
bytecomp/matching.ml
View File

@ -1477,20 +1477,14 @@ let prim_obj_tag =
let get_mod_field modname field =
lazy (
try
let mod_ident = Ident.create_persistent modname in
let env = Env.open_pers_signature modname Env.initial_safe_string in
let p = try
match Env.open_pers_signature modname Env.initial_safe_string with
| exception Not_found -> fatal_error ("Module "^modname^" unavailable.")
| env -> begin
match Env.lookup_value (Longident.Lident field) env with
| (Path.Pdot(_,_,i), _) -> i
| _ -> fatal_error ("Primitive "^modname^"."^field^" not found.")
with Not_found ->
fatal_error ("Primitive "^modname^"."^field^" not found.")
in
Lprim(Pfield p,
[Lprim(Pgetglobal mod_ident, [], Location.none)],
Location.none)
with Not_found -> fatal_error ("Module "^modname^" unavailable.")
| exception Not_found ->
fatal_error ("Primitive "^modname^"."^field^" not found.")
| (path, _) -> transl_value_path Location.none env path
end
)
let code_force_lazy_block =
@ -1665,7 +1659,7 @@ let make_record_matching loc all_labels def = function
Lprim (Pfield lbl.lbl_pos, [arg], loc)
| Record_unboxed _ -> arg
| Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [arg], loc)
| Record_extension -> Lprim (Pfield (lbl.lbl_pos + 1), [arg], loc)
| Record_extension _ -> Lprim (Pfield (lbl.lbl_pos + 1), [arg], loc)
in
let str =
match lbl.lbl_mut with
@ -2357,7 +2351,7 @@ let combine_constructor loc arg ex_pat cstr partial ctx def
let tests =
List.fold_right
(fun (path, act) rem ->
let ext = transl_extension_path ex_pat.pat_env path in
let ext = transl_extension_path loc ex_pat.pat_env path in
Lifthenelse(Lprim(Pintcomp Ceq, [Lvar tag; ext], loc),
act, rem))
nonconsts
@ -2367,7 +2361,7 @@ let combine_constructor loc arg ex_pat cstr partial ctx def
in
List.fold_right
(fun (path, act) rem ->
let ext = transl_extension_path ex_pat.pat_env path in
let ext = transl_extension_path loc ex_pat.pat_env path in
Lifthenelse(Lprim(Pintcomp Ceq, [arg; ext], loc),
act, rem))
consts
@ -2943,13 +2937,16 @@ let compile_matching repr handler_fun arg pat_act_list partial =
let partial_function loc () =
let slot =
transl_extension_path loc
Env.initial_safe_string Predef.path_match_failure
in
let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in
Lprim(Praise Raise_regular, [Lprim(Pmakeblock(0, Immutable, None),
[transl_normal_path Predef.path_match_failure;
Lconst(Const_block(0,
[Const_base(Const_string (fname, None));
Const_base(Const_int line);
Const_base(Const_int char)]))], loc)], loc)
[slot; Lconst(Const_block(0,
[Const_base(Const_string (fname, None));
Const_base(Const_int line);
Const_base(Const_int char)]))], loc)], loc)
let for_function loc repr param pat_act_list partial =
compile_matching repr (partial_function loc) param pat_act_list partial

2
bytecomp/printlambda.ml
View File

@ -106,7 +106,7 @@ let record_rep ppf r =
| Record_unboxed false -> fprintf ppf "unboxed"
| Record_unboxed true -> fprintf ppf "inlined(unboxed)"
| Record_float -> fprintf ppf "float"
| Record_extension -> fprintf ppf "ext"
| Record_extension path -> fprintf ppf "ext(%a)" Printtyp.path path
;;
let block_shape ppf shape = match shape with

69
bytecomp/translclass.ml
View File

@ -119,12 +119,9 @@ let name_pattern default p =
| Tpat_alias(_, id, _) -> id
| _ -> Ident.create_local default
let normalize_cl_path cl path =
Env.normalize_path (Some cl.cl_loc) cl.cl_env path
let rec build_object_init cl_table obj params inh_init obj_init cl =
match cl.cl_desc with
Tcl_ident ( path, _, _) ->
Tcl_ident (path, _, _) ->
let obj_init = Ident.create_local "obj_init" in
let envs, inh_init = inh_init in
let env =
@ -134,8 +131,8 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
[Lvar envs],
Location.none)]
in
((envs, (obj_init, normalize_cl_path cl path)
::inh_init),
let path_lam = transl_class_path cl.cl_loc cl.cl_env path in
((envs, (path, path_lam, obj_init) :: inh_init),
mkappl(Lvar obj_init, env @ [obj]))
| Tcl_structure str ->
create_object cl_table obj (fun obj ->
@ -263,14 +260,13 @@ let bind_id_as_val (id, _) = ("", id)
let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
match cl.cl_desc with
Tcl_ident ( path, _, _) ->
| Tcl_ident _ ->
begin match inh_init with
(obj_init, _path')::inh_init ->
let lpath = transl_class_path ~loc:cl.cl_loc cl.cl_env path in
| (_, path_lam, obj_init)::inh_init ->
(inh_init,
Llet (Strict, Pgenval, obj_init,
mkappl(Lprim(Pfield 1, [lpath], Location.none), Lvar cla ::
if top then [Lprim(Pfield 3, [lpath], Location.none)]
mkappl(Lprim(Pfield 1, [path_lam], Location.none), Lvar cla ::
if top then [Lprim(Pfield 3, [path_lam], Location.none)]
else []),
bind_super cla super cl_init))
| _ ->
@ -348,9 +344,8 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
transl_meth_list concr_meths] in
let cl = ignore_cstrs cl in
begin match cl.cl_desc, inh_init with
Tcl_ident (path, _, _), (obj_init, path')::inh_init ->
assert (Path.same (normalize_cl_path cl path) path');
let lpath = transl_normal_path path' in
| Tcl_ident (path, _, _), (path', path_lam, obj_init)::inh_init ->
assert (Path.same path path');
let inh = Ident.create_local "inh"
and ofs = List.length vals + 1
and valids, methids = super in
@ -370,7 +365,8 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
(inh_init,
Llet (Strict, Pgenval, inh,
mkappl(oo_prim "inherits", narrow_args @
[lpath; Lconst(Const_pointer(if top then 1 else 0))]),
[path_lam;
Lconst(Const_pointer(if top then 1 else 0))]),
Llet(StrictOpt, Pgenval, obj_init, lfield inh 0, cl_init)))
| _ ->
let core cl_init =
@ -419,9 +415,10 @@ let rec transl_class_rebind obj_init cl vf =
try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit
with Not_found -> raise Exit
end;
(normalize_cl_path cl path, obj_init)
let path_lam = transl_class_path cl.cl_loc cl.cl_env path in
(path, path_lam, obj_init)
| Tcl_fun (_, pat, _, cl, partial) ->
let path, obj_init = transl_class_rebind obj_init cl vf in
let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in
let build params rem =
let param = name_pattern "param" pat in
Lfunction {kind = Curried; params = param::params;
@ -430,37 +427,39 @@ let rec transl_class_rebind obj_init cl vf =
body = Matching.for_function
pat.pat_loc None (Lvar param) [pat, rem] partial}
in
(path,
(path, path_lam,
match obj_init with
Lfunction {kind = Curried; params; body} -> build params body
| rem -> build [] rem)
| Tcl_apply (cl, oexprs) ->
let path, obj_init = transl_class_rebind obj_init cl vf in
(path, transl_apply obj_init oexprs Location.none)
let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in
(path, path_lam, transl_apply obj_init oexprs Location.none)
| Tcl_let (rec_flag, defs, _vals, cl) ->
let path, obj_init = transl_class_rebind obj_init cl vf in
(path, Translcore.transl_let rec_flag defs obj_init)
let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in
(path, path_lam, Translcore.transl_let rec_flag defs obj_init)
| Tcl_structure _ -> raise Exit
| Tcl_constraint (cl', _, _, _, _) ->
let path, obj_init = transl_class_rebind obj_init cl' vf in
let path, path_lam, obj_init = transl_class_rebind obj_init cl' vf in
let rec check_constraint = function
Cty_constr(path', _, _) when Path.same path path' -> ()
| Cty_arrow (_, _, cty) -> check_constraint cty
| _ -> raise Exit
in
check_constraint cl.cl_type;
(path, obj_init)
(path, path_lam, obj_init)
| Tcl_open (_, _, _, _, cl) ->
transl_class_rebind obj_init cl vf
let rec transl_class_rebind_0 self obj_init cl vf =
match cl.cl_desc with
Tcl_let (rec_flag, defs, _vals, cl) ->
let path, obj_init = transl_class_rebind_0 self obj_init cl vf in
(path, Translcore.transl_let rec_flag defs obj_init)
let path, path_lam, obj_init =
transl_class_rebind_0 self obj_init cl vf
in
(path, path_lam, Translcore.transl_let rec_flag defs obj_init)
| _ ->
let path, obj_init = transl_class_rebind obj_init cl vf in
(path, lfunction [self] obj_init)
let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in
(path, path_lam, lfunction [self] obj_init)
let transl_class_rebind cl vf =
try
@ -474,9 +473,9 @@ let transl_class_rebind cl vf =
ap_inlined=Default_inline;
ap_specialised=Default_specialise}
in
let path, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in
let _, path_lam, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in
let id = (obj_init' = lfunction [self] obj_init0) in
if id then transl_normal_path path else
if id then path_lam else
let cla = Ident.create_local "class"
and new_init = Ident.create_local "new_init"
@ -486,7 +485,7 @@ let transl_class_rebind cl vf =
Llet(
Strict, Pgenval, new_init, lfunction [obj_init] obj_init',
Llet(
Alias, Pgenval, cla, transl_normal_path path,
Alias, Pgenval, cla, path_lam,
Lprim(Pmakeblock(0, Immutable, None),
[mkappl(Lvar new_init, [lfield cla 0]);
lfunction [table]
@ -818,7 +817,7 @@ let transl_class ids cl_id pub_meths cl vflag =
Location.none)
and linh_envs =
List.map
(fun (_, p) -> Lprim(Pfield 3, [transl_normal_path p], Location.none))
(fun (_, path_lam, _) -> Lprim(Pfield 3, [path_lam], Location.none))
(List.rev inh_init)
in
let make_envs lam =
@ -834,11 +833,11 @@ let transl_class ids cl_id pub_meths cl vflag =
in
let inh_paths =
List.filter
(fun (_,path) -> List.mem (Path.head path) new_ids) inh_init
(fun (path, _, _) -> List.mem (Path.head path) new_ids) inh_init
in
let inh_keys =
List.map (fun (_,p) -> Lprim(Pfield 1, [transl_normal_path p],
Location.none))
List.map
(fun (_, path_lam, _) -> Lprim(Pfield 1, [path_lam], Location.none))
inh_paths
in
let lclass lam =

91
bytecomp/translcore.ml
View File

@ -65,7 +65,7 @@ let transl_extension_constructor env path ext =
Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))], loc)],
loc)
| Text_rebind(path, _lid) ->
transl_extension_path ~loc env path
transl_extension_path loc env path
(* To propagate structured constants *)
@ -84,7 +84,7 @@ let extract_float = function
type binding =
| Bind_value of value_binding list
| Bind_module of Ident.t * string loc * module_expr
| Bind_module of Ident.t * string loc * module_presence * module_expr
let rec push_defaults loc bindings cases partial =
match cases with
@ -105,8 +105,9 @@ let rec push_defaults loc bindings cases partial =
| [{c_lhs=pat; c_guard=None;
c_rhs={exp_attributes=[{Parsetree.attr_name = {txt="#modulepat"};_}];
exp_desc = Texp_letmodule
(id, name, mexpr, ({exp_desc = Texp_function _} as e2))}}] ->
push_defaults loc (Bind_module (id, name, mexpr) :: bindings)
(id, name, pres, mexpr,
({exp_desc = Texp_function _} as e2))}}] ->
push_defaults loc (Bind_module (id, name, pres, mexpr) :: bindings)
[{c_lhs=pat;c_guard=None;c_rhs=e2}]
partial
| [case] ->
@ -116,23 +117,25 @@ let rec push_defaults loc bindings cases partial =
{exp with exp_desc =
match binds with
| Bind_value binds -> Texp_let(Nonrecursive, binds, exp)
| Bind_module (id, name, mexpr) ->
Texp_letmodule (id, name, mexpr, exp)})
| Bind_module (id, name, pres, mexpr) ->
Texp_letmodule (id, name, pres, mexpr, exp)})
case.c_rhs bindings
in
[{case with c_rhs=exp}]
| {c_lhs=pat; c_rhs=exp; c_guard=_} :: _ when bindings <> [] ->
let param = Typecore.name_cases "param" cases in
let desc =
{val_type = pat.pat_type; val_kind = Val_reg;
val_attributes = []; Types.val_loc = Location.none; }
in
let env = Env.add_value param desc exp.exp_env in
let name = Ident.name param in
let exp =
{ exp with exp_loc = loc; exp_desc =
{ exp with exp_loc = loc; exp_env = env; exp_desc =
Texp_match
({exp with exp_type = pat.pat_type; exp_desc =
Texp_ident (Path.Pident param, mknoloc (Longident.Lident name),
{val_type = pat.pat_type; val_kind = Val_reg;
val_attributes = [];
Types.val_loc = Location.none;
})},
({exp with exp_type = pat.pat_type; exp_env = env; exp_desc =
Texp_ident
(Path.Pident param, mknoloc (Longident.Lident name), desc)},
cases, partial) }
in
push_defaults loc bindings
@ -163,11 +166,16 @@ let event_function exp lam =
(* Assertions *)
let assert_failed exp =
let slot =
transl_extension_path Location.none
Env.initial_safe_string Predef.path_assert_failure
in
let (fname, line, char) =
Location.get_pos_info exp.exp_loc.Location.loc_start in
Location.get_pos_info exp.exp_loc.Location.loc_start
in
Lprim(Praise Raise_regular, [event_after exp
(Lprim(Pmakeblock(0, Immutable, None),
[transl_normal_path Predef.path_assert_failure;
[slot;
Lconst(Const_block(0,
[Const_base(Const_string (fname, None));
Const_base(Const_int line);
@ -207,7 +215,7 @@ and transl_exp0 e =
| Texp_ident(_, _, {val_kind = Val_anc _}) ->
raise(Error(e.exp_loc, Free_super_var))
| Texp_ident(path, _, {val_kind = Val_reg | Val_self _}) ->
transl_value_path ~loc:e.exp_loc e.exp_env path
transl_value_path e.exp_loc e.exp_env path
| Texp_ident _ -> fatal_error "Translcore.transl_exp: bad Texp_ident"
| Texp_constant cst ->
Lconst(Const_base cst)
@ -304,14 +312,14 @@ and transl_exp0 e =
Lprim(Pmakeblock(n, Immutable, Some shape), ll, e.exp_loc)
end
| Cstr_extension(path, is_const) ->
if is_const then
transl_extension_path e.exp_env path
let lam = transl_extension_path e.exp_loc e.exp_env path in
if is_const then lam
else
Lprim(Pmakeblock(0, Immutable, Some (Pgenval :: shape)),
transl_extension_path e.exp_env path :: ll, e.exp_loc)
lam :: ll, e.exp_loc)
end
| Texp_extension_constructor (_, path) ->
transl_extension_path e.exp_env path
transl_extension_path e.exp_loc e.exp_env path
| Texp_variant(l, arg) ->
let tag = Btype.hash_variant l in
begin match arg with
@ -335,7 +343,7 @@ and transl_exp0 e =
Lprim (Pfield lbl.lbl_pos, [targ], e.exp_loc)
| Record_unboxed _ -> targ
| Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [targ], e.exp_loc)
| Record_extension ->
| Record_extension _ ->
Lprim (Pfield (lbl.lbl_pos + 1), [targ], e.exp_loc)
end
| Texp_setfield(arg, _, lbl, newval) ->
@ -346,7 +354,7 @@ and transl_exp0 e =
Psetfield(lbl.lbl_pos, maybe_pointer newval, Assignment)
| Record_unboxed _ -> assert false
| Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment)
| Record_extension ->
| Record_extension _ ->
Psetfield (lbl.lbl_pos + 1, maybe_pointer newval, Assignment)
in
Lprim(access, [transl_exp arg; transl_exp newval], e.exp_loc)
@ -426,31 +434,36 @@ and transl_exp0 e =
Lapply{ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=
Lprim(Pfield 0, [transl_class_path ~loc e.exp_env cl], loc);
Lprim(Pfield 0, [transl_class_path loc e.exp_env cl], loc);
ap_args=[lambda_unit];
ap_inlined=Default_inline;
ap_specialised=Default_specialise}
| Texp_instvar(path_self, path, _) ->
Lprim(Pfield_computed,
[transl_normal_path path_self; transl_normal_path path], e.exp_loc)
let self = transl_value_path e.exp_loc e.exp_env path_self in
let var = transl_value_path e.exp_loc e.exp_env path in
Lprim(Pfield_computed, [self; var], e.exp_loc)
| Texp_setinstvar(path_self, path, _, expr) ->
transl_setinstvar e.exp_loc (transl_normal_path path_self) path expr
let self = transl_value_path e.exp_loc e.exp_env path_self in
let var = transl_value_path e.exp_loc e.exp_env path in
transl_setinstvar e.exp_loc self var expr
| Texp_override(path_self, modifs) ->
let self = transl_value_path e.exp_loc e.exp_env path_self in
let cpy = Ident.create_local "copy" in
Llet(Strict, Pgenval, cpy,
Lapply{ap_should_be_tailcall=false;
ap_loc=Location.none;
ap_func=Translobj.oo_prim "copy";
ap_args=[transl_normal_path path_self];
ap_args=[self];
ap_inlined=Default_inline;
ap_specialised=Default_specialise},
List.fold_right
(fun (path, _, expr) rem ->
let var = transl_value_path e.exp_loc e.exp_env path in
Lsequence(transl_setinstvar Location.none
(Lvar cpy) path expr, rem))
(Lvar cpy) var expr, rem))
modifs
(Lvar cpy))
| Texp_letmodule(id, loc, modl, body) ->
| Texp_letmodule(id, loc, Mp_present, modl, body) ->
let defining_expr =
Levent (!transl_module Tcoerce_none None modl, {
lev_loc = loc.loc;
@ -460,6 +473,8 @@ and transl_exp0 e =
})
in
Llet(Strict, Pgenval, id, defining_expr, transl_exp body)
| Texp_letmodule(_, _, Mp_absent, _, body) ->
transl_exp body
| Texp_letexception(cd, body) ->
Llet(Strict, Pgenval,
cd.ext_id, transl_extension_constructor e.exp_env None cd,
@ -708,7 +723,7 @@ and transl_let rec_flag pat_expr_list =
and transl_setinstvar loc self var expr =
Lprim(Psetfield_computed (maybe_pointer expr, Assignment),
[self; transl_normal_path var; transl_exp expr], loc)
[self; var; transl_exp expr], loc)
and transl_record loc env fields repres opt_init_expr =
let size = Array.length fields in
@ -730,7 +745,7 @@ and transl_record loc env fields repres opt_init_expr =
match repres with
Record_regular | Record_inlined _ -> Pfield i
| Record_unboxed _ -> assert false
| Record_extension -> Pfield (i + 1)
| Record_extension _ -> Pfield (i + 1)
| Record_float -> Pfloatfield i in
Lprim(access, [Lvar init_id], loc), field_kind
| Overridden (_lid, expr) ->
@ -753,7 +768,7 @@ and transl_record loc env fields repres opt_init_expr =
| Record_unboxed _ -> Lconst(match cl with [v] -> v | _ -> assert false)
| Record_float ->
Lconst(Const_float_array(List.map extract_float cl))
| Record_extension ->
| Record_extension _ ->
raise Not_constant
with Not_constant ->
match repres with
@ -764,14 +779,8 @@ and transl_record loc env fields repres opt_init_expr =
| Record_unboxed _ -> (match ll with [v] -> v | _ -> assert false)
| Record_float ->
Lprim(Pmakearray (Pfloatarray, mut), ll, loc)
| Record_extension ->
let path =
let (label, _) = fields.(0) in
match label.lbl_res.desc with
| Tconstr(p, _, _) -> p
| _ -> assert false
in
let slot = transl_extension_path env path in
| Record_extension path ->
let slot = transl_extension_path loc env path in
Lprim(Pmakeblock(0, mut, Some (Pgenval :: shape)), slot :: ll, loc)
in
begin match opt_init_expr with
@ -794,7 +803,7 @@ and transl_record loc env fields repres opt_init_expr =
Psetfield(lbl.lbl_pos, maybe_pointer expr, Assignment)
| Record_unboxed _ -> assert false
| Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment)
| Record_extension ->
| Record_extension _ ->
Psetfield(lbl.lbl_pos + 1, maybe_pointer expr, Assignment)
in
Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr], loc), cont)

256
bytecomp/translmod.ml
View File

@ -51,7 +51,7 @@ let functor_path path param =
let field_path path field =
match path with
None -> None
| Some p -> Some(Pdot(p, Ident.name field, Path.nopos))
| Some p -> Some(Pdot(p, Ident.name field))
(* Compile type extensions *)
@ -86,9 +86,10 @@ let rec apply_coercion loc strict restr arg =
apply_coercion_result loc strict arg [param] [carg] cc_res
| Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } ->
Translprim.transl_primitive pc_loc pc_desc pc_env pc_type None
| Tcoerce_alias (path, cc) ->
| Tcoerce_alias (env, path, cc) ->
let lam = transl_module_path loc env path in
name_lambda strict arg
(fun _ -> apply_coercion loc Alias cc (transl_normal_path path))
(fun _ -> apply_coercion loc Alias cc lam)
and apply_coercion_field loc get_field (pos, cc) =
apply_coercion loc Alias cc (get_field pos)
@ -151,17 +152,22 @@ let rec compose_coercions c1 c2 =
in
Tcoerce_structure
(List.map
(function (p1, Tcoerce_primitive p) ->
(p1, Tcoerce_primitive p)
| (p1, c1) ->
let (p2, c2) = v2.(p1) in (p2, compose_coercions c1 c2))
pc1,
(fun pc ->
match pc with
| _, (Tcoerce_primitive _ | Tcoerce_alias _) ->
(* These cases do not take an argument (the position is -1),
so they do not need adjusting. *)
pc
| (p1, c1) ->
let (p2, c2) = v2.(p1) in
(p2, compose_coercions c1 c2))
pc1,
ids1 @ ids2)
| (Tcoerce_functor(arg1, res1), Tcoerce_functor(arg2, res2)) ->
Tcoerce_functor(compose_coercions arg2 arg1,
compose_coercions res1 res2)
| (c1, Tcoerce_alias (path, c2)) ->
Tcoerce_alias (path, compose_coercions c1 c2)
| (c1, Tcoerce_alias (env, path, c2)) ->
Tcoerce_alias (env, path, compose_coercions c1 c2)
| (_, _) ->
fatal_error "Translmod.compose_coercions"
@ -190,12 +196,12 @@ let record_primitive = function
(* Utilities for compiling "module rec" definitions *)
let mod_prim name =
try
transl_normal_path
(fst (Env.lookup_value (Ldot (Lident "CamlinternalMod", name))
Env.empty))
with Not_found ->
fatal_error ("Primitive " ^ name ^ " not found.")
let env = Env.empty in
let lid = Ldot (Lident "CamlinternalMod", name) in
match Env.lookup_value lid env with
| path, _ -> transl_value_path Location.none env path
| exception Not_found ->
fatal_error ("Primitive " ^ name ^ " not found.")
let undefined_location loc =
let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in
@ -210,10 +216,8 @@ let init_shape id modl =
let rec init_shape_mod subid loc env mty =
match Mtype.scrape env mty with
Mty_ident _
| Mty_alias (Mta_present, _) ->
| Mty_alias _ ->
raise (Initialization_failure {reason=Unsafe_module_binding;loc;subid})
| Mty_alias (Mta_absent, _) ->
Const_block (1, [Const_pointer 0])
| Mty_signature sg ->
Const_block(0, [Const_block(0, init_shape_struct env sg)])
| Mty_functor _ ->
@ -241,10 +245,14 @@ let init_shape id modl =
init_shape_struct (Env.add_type ~check:false id tdecl env) rem
| Sig_typext (subid, {ext_loc=loc},_) :: _ ->
raise (Initialization_failure {reason=Unsafe_typext; loc; subid})
| Sig_module(id, md, _) :: rem ->
| Sig_module(id, Mp_present, md, _) :: rem ->
init_shape_mod id md.md_loc env md.md_type ::
init_shape_struct (Env.add_module_declaration ~check:false
id md env) rem
id Mp_present md env) rem
| Sig_module(id, Mp_absent, md, _) :: rem ->
init_shape_struct
(Env.add_module_declaration ~check:false
id Mp_absent md env) rem
| Sig_modtype(id, minfo) :: rem ->
init_shape_struct (Env.add_modtype id minfo env) rem
| Sig_class _ :: rem ->
@ -373,7 +381,8 @@ let rec bound_value_identifiers = function
| Sig_value(id, {val_kind = Val_reg}) :: rem ->
id :: bound_value_identifiers rem
| Sig_typext(id, _, _) :: rem -> id :: bound_value_identifiers rem
| Sig_module(id, _, _) :: rem -> id :: bound_value_identifiers rem
| Sig_module(id, Mp_present, _, _) :: rem ->
id :: bound_value_identifiers rem
| Sig_class(id, _, _) :: rem -> id :: bound_value_identifiers rem
| _ :: rem -> bound_value_identifiers rem
@ -459,34 +468,31 @@ and transl_module cc rootpath mexp =
List.iter (Translattribute.check_attribute_on_module mexp)
mexp.mod_attributes;
let loc = mexp.mod_loc in
match mexp.mod_type with
Mty_alias (Mta_absent, _) -> apply_coercion loc Alias cc lambda_unit
| _ ->
match mexp.mod_desc with
Tmod_ident (path,_) ->
apply_coercion loc Strict cc
(transl_module_path ~loc mexp.mod_env path)
| Tmod_structure str ->
fst (transl_struct loc [] cc rootpath str)
| Tmod_functor _ ->
oo_wrap mexp.mod_env true (fun () ->
compile_functor mexp cc rootpath loc) ()
| Tmod_apply(funct, arg, ccarg) ->
let inlined_attribute, funct =
Translattribute.get_and_remove_inlined_attribute_on_module funct
in
oo_wrap mexp.mod_env true
(apply_coercion loc Strict cc)
(Lapply{ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=transl_module Tcoerce_none None funct;
ap_args=[transl_module ccarg None arg];
ap_inlined=inlined_attribute;
ap_specialised=Default_specialise})
| Tmod_constraint(arg, _, _, ccarg) ->
transl_module (compose_coercions cc ccarg) rootpath arg
| Tmod_unpack(arg, _) ->
apply_coercion loc Strict cc (Translcore.transl_exp arg)
match mexp.mod_desc with
| Tmod_ident (path,_) ->
apply_coercion loc Strict cc
(transl_module_path loc mexp.mod_env path)
| Tmod_structure str ->
fst (transl_struct loc [] cc rootpath str)
| Tmod_functor _ ->
oo_wrap mexp.mod_env true (fun () ->
compile_functor mexp cc rootpath loc) ()
| Tmod_apply(funct, arg, ccarg) ->
let inlined_attribute, funct =
Translattribute.get_and_remove_inlined_attribute_on_module funct
in
oo_wrap mexp.mod_env true
(apply_coercion loc Strict cc)
(Lapply{ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=transl_module Tcoerce_none None funct;
ap_args=[transl_module ccarg None arg];
ap_inlined=inlined_attribute;
ap_specialised=Default_specialise})
| Tmod_constraint(arg, _, _, ccarg) ->
transl_module (compose_coercions cc ccarg) rootpath arg
| Tmod_unpack(arg, _) ->
apply_coercion loc Strict cc (Translcore.transl_exp arg)
and transl_struct loc fields cc rootpath str =
transl_structure loc fields cc rootpath str.str_final_env str.str_items
@ -509,8 +515,11 @@ and transl_structure loc fields cc rootpath final_env = function
fields;
Format.eprintf "@]@.";*)
let v = Array.of_list (List.rev fields) in
let get_field pos = Lvar v.(pos)
and ids = List.fold_right Ident.Set.add fields Ident.Set.empty in
let get_field pos =
if pos < 0 then lambda_unit
else Lvar v.(pos)
in
let ids = List.fold_right Ident.Set.add fields Ident.Set.empty in
let lam =
Lprim(Pmakeblock(0, Immutable, None),
List.map
@ -581,7 +590,7 @@ and transl_structure loc fields cc rootpath final_env = function
path
ext.tyexn_constructor, body),
size
| Tstr_module mb ->
| Tstr_module ({mb_presence=Mp_present} as mb) ->
let id = mb.mb_id in
(* Translate module first *)
let module_body =
@ -606,6 +615,8 @@ and transl_structure loc fields cc rootpath final_env = function
Llet(pure_module mb.mb_expr, Pgenval, id,
module_body,
body), size
| Tstr_module {mb_presence=Mp_absent} ->
transl_structure loc fields cc rootpath final_env rem
| Tstr_recmodule bindings ->
let ext_fields =
List.rev_append (List.map (fun mb -> mb.mb_id) bindings) fields
@ -749,7 +760,8 @@ let rec defined_idents = function
List.map (fun ext -> ext.ext_id) tyext.tyext_constructors
@ defined_idents rem
| Tstr_exception ext -> ext.tyexn_constructor.ext_id :: defined_idents rem
| Tstr_module mb -> mb.mb_id :: defined_idents rem
| Tstr_module {mb_id; mb_presence=Mp_present} -> mb_id :: defined_idents rem
| Tstr_module {mb_presence=Mp_absent} -> defined_idents rem
| Tstr_recmodule decls ->
List.map (fun mb -> mb.mb_id) decls @ defined_idents rem
| Tstr_modtype _ -> defined_idents rem
@ -783,10 +795,12 @@ let rec more_idents = function
_, _, _)}} ->
all_idents str.str_items @ more_idents rem
| Tstr_include _ -> more_idents rem
| Tstr_module {mb_expr={mod_desc = Tmod_structure str}}
| Tstr_module{mb_expr={mod_desc =
Tmod_constraint ({mod_desc = Tmod_structure str},
_, _, _)}} ->
| Tstr_module
{mb_presence=Mp_present; mb_expr={mod_desc = Tmod_structure str}}
| Tstr_module
{mb_presence=Mp_present;
mb_expr={mod_desc=
Tmod_constraint ({mod_desc = Tmod_structure str}, _, _, _)}} ->
all_idents str.str_items @ more_idents rem
| Tstr_module _ -> more_idents rem
| Tstr_attribute _ -> more_idents rem
@ -821,13 +835,16 @@ and all_idents = function
| Tstr_include incl ->
bound_value_identifiers incl.incl_type @ all_idents rem
| Tstr_module {mb_id;mb_expr={mod_desc = Tmod_structure str}}
| Tstr_module{mb_id;
mb_expr={mod_desc =
Tmod_constraint ({mod_desc = Tmod_structure str},
_, _, _)}} ->
| Tstr_module
{mb_id;mb_presence=Mp_present;mb_expr={mod_desc = Tmod_structure str}}
| Tstr_module
{mb_id;mb_presence=Mp_present;
mb_expr=
{mod_desc =
Tmod_constraint ({mod_desc = Tmod_structure str}, _, _, _)}} ->
mb_id :: all_idents str.str_items @ all_idents rem
| Tstr_module mb -> mb.mb_id :: all_idents rem
| Tstr_module {mb_id;mb_presence=Mp_present} -> mb_id :: all_idents rem
| Tstr_module {mb_presence=Mp_absent} -> all_idents rem
| Tstr_attribute _ -> all_idents rem
@ -860,29 +877,31 @@ let field_of_str loc str =
| _ -> apply_coercion loc Strict cc (Lvar ids.(pos))
let transl_store_structure glob map prims str =
let transl_store_structure glob map prims aliases str =
let no_env_update _ _ env = env in
let rec transl_store rootpath subst = function
let rec transl_store rootpath subst cont = function
[] ->
transl_store_subst := subst;
lambda_unit
Lambda.subst no_env_update subst cont
| item :: rem ->
match item.str_desc with
| Tstr_eval (expr, _attrs) ->
Lsequence(Lambda.subst no_env_update subst (transl_exp expr),
transl_store rootpath subst rem)
transl_store rootpath subst cont rem)
| Tstr_value(rec_flag, pat_expr_list) ->
let ids = let_bound_idents pat_expr_list in
let lam =
transl_let rec_flag pat_expr_list (store_idents Location.none ids)
transl_let rec_flag pat_expr_list
(store_idents Location.none ids)
in
Lsequence(Lambda.subst no_env_update subst lam,
transl_store rootpath (add_idents false ids subst) rem)
transl_store rootpath
(add_idents false ids subst) cont rem)
| Tstr_primitive descr ->
record_primitive descr.val_val;
transl_store rootpath subst rem
transl_store rootpath subst cont rem
| Tstr_type _ ->
transl_store rootpath subst rem
transl_store rootpath subst cont rem
| Tstr_typext(tyext) ->
let ids =
List.map (fun ext -> ext.ext_id) tyext.tyext_constructors
@ -892,7 +911,8 @@ let transl_store_structure glob map prims str =
(store_idents Location.none ids)
in
Lsequence(Lambda.subst no_env_update subst lam,
transl_store rootpath (add_idents false ids subst) rem)
transl_store rootpath
(add_idents false ids subst) cont rem)
| Tstr_exception ext ->
let id = ext.tyexn_constructor.ext_id in
let path = field_path rootpath id in
@ -904,14 +924,16 @@ let transl_store_structure glob map prims str =
Lsequence(Llet(Strict, Pgenval, id,
Lambda.subst no_env_update subst lam,
store_ident ext.tyexn_constructor.ext_loc id),
transl_store rootpath (add_ident false id subst) rem)
| Tstr_module{mb_id=id;mb_loc=loc;
transl_store rootpath
(add_ident false id subst) cont rem)
| Tstr_module{mb_id=id;mb_loc=loc;mb_presence=Mp_present;
mb_expr={mod_desc = Tmod_structure str} as mexp;
mb_attributes} ->
List.iter (Translattribute.check_attribute_on_module mexp)
mb_attributes;
let lam =
transl_store (field_path rootpath id) subst str.str_items
transl_store (field_path rootpath id) subst
lambda_unit str.str_items
in
(* Careful: see next case *)
let subst = !transl_store_subst in
@ -924,9 +946,9 @@ let transl_store_structure glob map prims str =
Lsequence(store_ident loc id,
transl_store rootpath
(add_ident true id subst)
rem)))
cont rem)))
| Tstr_module{
mb_id=id;mb_loc=loc;
mb_id=id;mb_loc=loc;mb_presence=Mp_present;
mb_expr= {
mod_desc = Tmod_constraint (
{mod_desc = Tmod_structure str} as mexp, _, _,
@ -938,7 +960,8 @@ let transl_store_structure glob map prims str =
List.iter (Translattribute.check_attribute_on_module mexp)
mb_attributes;
let lam =
transl_store (field_path rootpath id) subst str.str_items
transl_store (field_path rootpath id) subst
lambda_unit str.str_items
in
(* Careful: see next case *)
let subst = !transl_store_subst in
@ -951,8 +974,10 @@ let transl_store_structure glob map prims str =
Lsequence(store_ident loc id,
transl_store rootpath
(add_ident true id subst)
rem)))
| Tstr_module{mb_id=id; mb_expr=modl; mb_loc=loc; mb_attributes} ->
cont rem)))
| Tstr_module
{mb_id=id; mb_presence=Mp_present; mb_expr=modl;
mb_loc=loc; mb_attributes} ->
let lam =
Translattribute.add_inline_attribute
(transl_module Tcoerce_none (field_path rootpath id) modl)
@ -966,7 +991,10 @@ let transl_store_structure glob map prims str =
(add_ident true adds id -> Pgetglobal... to subst). *)
Llet(Strict, Pgenval, id, Lambda.subst no_env_update subst lam,
Lsequence(store_ident loc id,
transl_store rootpath (add_ident true id subst) rem))
transl_store rootpath (add_ident true id subst)
cont rem))
| Tstr_module {mb_presence=Mp_absent} ->
transl_store rootpath subst cont rem
| Tstr_recmodule bindings ->
let ids = List.map (fun mb -> mb.mb_id) bindings in
compile_recmodule
@ -976,14 +1004,16 @@ let transl_store_structure glob map prims str =
(field_path rootpath id) modl))
bindings
(Lsequence(store_idents Location.none ids,
transl_store rootpath (add_idents true ids subst) rem))
transl_store rootpath (add_idents true ids subst)
cont rem))
| Tstr_class cl_list ->
let (ids, class_bindings) = transl_class_bindings cl_list in
let lam =
Lletrec(class_bindings, store_idents Location.none ids)
in
Lsequence(Lambda.subst no_env_update subst lam,
transl_store rootpath (add_idents false ids subst) rem)
transl_store rootpath (add_idents false ids subst)
cont rem)
| Tstr_include{
incl_loc=loc;
@ -999,7 +1029,7 @@ let transl_store_structure glob map prims str =
(* Shouldn't we use mod_attributes instead of incl_attributes?
Same question for the Tstr_module cases above, btw. *)
let lam =
transl_store None subst str.str_items
transl_store None subst lambda_unit str.str_items
(* It is tempting to pass rootpath instead of None
in order to give a more precise name to exceptions
in the included structured, but this would introduce
@ -1011,7 +1041,8 @@ let transl_store_structure glob map prims str =
let rec loop ids args =
match ids, args with
| [], [] ->
transl_store rootpath (add_idents true ids0 subst) rem
transl_store rootpath (add_idents true ids0 subst)
cont rem
| id :: ids, arg :: args ->
Llet(Alias, Pgenval, id,
Lambda.subst no_env_update subst (field arg),
@ -1028,7 +1059,8 @@ let transl_store_structure glob map prims str =
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
| [] ->
transl_store rootpath (add_idents true ids subst) cont rem
| id :: idl ->
Llet(Alias, Pgenval, id, Lprim(Pfield pos, [Lvar mid], loc),
Lsequence(store_ident loc id,
@ -1042,7 +1074,7 @@ let transl_store_structure glob map prims str =
| Tstr_open _
| Tstr_class_type _
| Tstr_attribute _ ->
transl_store rootpath subst rem
transl_store rootpath subst cont rem
and store_ident loc id =
try
@ -1083,8 +1115,17 @@ let transl_store_structure glob map prims str =
Location.none),
cont)
in List.fold_right store_primitive prims
(transl_store (global_path glob) !transl_store_subst str)
and store_alias (pos, env, path, cc) =
let path_lam = transl_module_path Location.none env path in
let init_val = apply_coercion Location.none Strict cc path_lam in
Lprim(Psetfield(pos, Pointer, Root_initialization),
[Lprim(Pgetglobal glob, [], Location.none);
init_val],
Location.none)
in
let aliases = make_sequence store_alias aliases in
List.fold_right store_primitive prims
(transl_store (global_path glob) !transl_store_subst aliases str)
(* Transform a coercion and the list of value identifiers defined by
a toplevel structure into a table [id -> (pos, coercion)],
@ -1099,34 +1140,39 @@ let transl_store_structure glob map prims str =
and the list of all primitives exported as values. *)
let build_ident_map restr idlist more_ids =
let rec natural_map pos map prims = function
let rec natural_map pos map prims aliases = function
| [] ->
(map, prims, pos)
(map, prims, aliases, pos)
| id :: rem ->
natural_map (pos+1) (Ident.add id (pos, Tcoerce_none) map) prims rem
natural_map (pos+1)
(Ident.add id (pos, Tcoerce_none) map) prims aliases rem
in
let (map, prims, pos) =
let (map, prims, aliases, pos) =
match restr with
| Tcoerce_none ->
natural_map 0 Ident.empty [] idlist
natural_map 0 Ident.empty [] [] idlist
| Tcoerce_structure (pos_cc_list, _id_pos_list) ->
(* ignore _id_pos_list as the ids are already bound *)
let idarray = Array.of_list idlist in
let rec export_map pos map prims undef = function
let rec export_map pos map prims aliases undef = function
| [] ->
natural_map pos map prims undef
natural_map pos map prims aliases undef
| (_source_pos, Tcoerce_primitive p) :: rem ->
export_map (pos + 1) map ((pos, p) :: prims) undef rem
export_map (pos + 1) map
((pos, p) :: prims) aliases undef rem
| (_source_pos, Tcoerce_alias(env, path, cc)) :: rem ->
export_map (pos + 1) map prims
((pos, env, path, cc) :: aliases) undef rem
| (source_pos, cc) :: rem ->
let id = idarray.(source_pos) in
export_map (pos + 1) (Ident.add id (pos, cc) map)
prims (list_remove id undef) rem
prims aliases (list_remove id undef) rem
in
export_map 0 Ident.empty [] idlist pos_cc_list
export_map 0 Ident.empty [] [] idlist pos_cc_list
| _ ->
fatal_error "Translmod.build_ident_map"
in
natural_map pos map prims more_ids
natural_map pos map prims aliases more_ids
(* Compile an implementation using transl_store_structure
(for the native-code compiler). *)
@ -1136,13 +1182,14 @@ let transl_store_gen module_name ({ str_items = str }, restr) topl =
primitive_declarations := [];
Translprim.clear_used_primitives ();
let module_id = Ident.create_persistent module_name in
let (map, prims, size) =
let (map, prims, aliases, size) =
build_ident_map restr (defined_idents str) (more_idents str) in
let f = function
| [ { str_desc = Tstr_eval (expr, _attrs) } ] when topl ->
assert (size = 0);
Lambda.subst (fun _ _ env -> env) !transl_store_subst (transl_exp expr)
| str -> transl_store_structure module_id map prims str in
| str -> transl_store_structure module_id map prims aliases str
in
transl_store_label_init module_id size f str
(*size, transl_label_init (transl_store_structure module_id map prims str)*)
@ -1232,7 +1279,7 @@ let transl_toplevel_item item =
set_toplevel_unique_name ext.tyexn_constructor.ext_id;
toploop_setvalue ext.tyexn_constructor.ext_id
(transl_extension_constructor item.str_env None ext.tyexn_constructor)
| Tstr_module {mb_id=id; mb_expr=modl} ->
| Tstr_module {mb_id=id; mb_presence=Mp_present; mb_expr=modl} ->
(* we need to use the unique name for the module because of issues
with "open" (PR#1672) *)
set_toplevel_unique_name id;
@ -1268,6 +1315,7 @@ let transl_toplevel_item item =
lambda_unit
| Tstr_modtype _
| Tstr_open _
| Tstr_module {mb_presence=Mp_absent}
| Tstr_type _
| Tstr_class_type _
| Tstr_attribute _ ->

11
bytecomp/translobj.ml
View File

@ -21,11 +21,12 @@ open Lambda
(* Get oo primitives identifiers *)
let oo_prim name =
try
transl_normal_path
(fst (Env.lookup_value (Ldot (Lident "CamlinternalOO", name)) Env.empty))
with Not_found ->
fatal_error ("Primitive " ^ name ^ " not found.")
let env = Env.empty in
let lid = Ldot (Lident "CamlinternalOO", name) in
match Env.lookup_value lid env with
| path, _ -> transl_value_path Location.none env path
| exception Not_found ->
fatal_error ("Primitive " ^ name ^ " not found.")
(* Share blocks *)

24
debugger/eval.ml
View File

@ -39,8 +39,8 @@ exception Error of error
let abstract_type =
Btype.newgenty (Tconstr (Pident (Ident.create_local "<abstr>"), [], ref Mnil))
let rec path event = function
Pident id ->
let rec address path event = function
| Env.Aident id ->
if Ident.global id then
try
Debugcom.Remote_value.global (Symtable.get_global_position id)
@ -61,13 +61,17 @@ let rec path event = function
| None ->
raise(Error(Unbound_identifier id))
end
| Pdot(root, _fieldname, pos) ->
let v = path event root in
| Env.Adot(root, pos) ->
let v = address path event root in
if not (Debugcom.Remote_value.is_block v) then
raise(Error(Not_initialized_yet root));
raise(Error(Not_initialized_yet path));
Debugcom.Remote_value.field v pos
| Papply _ ->
fatal_error "Eval.path: Papply"
let value_path event env path =
match Env.find_value_address path env with
| addr -> address path event addr
| exception Not_found ->
fatal_error ("Cannot find address for: " ^ (Path.name path))
let rec expression event env = function
E_ident lid ->
@ -78,11 +82,11 @@ let rec expression event env = function
let (p0, _) =
Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
in
let v = path event p0 in
let i = path event p in
let v = value_path event env p0 in
let i = value_path event env p in
Debugcom.Remote_value.field v (Debugcom.Remote_value.obj i)
| _ ->
path event p
value_path event env p
end,
Ctype.correct_levels valdesc.val_type)
with Not_found ->

17
debugger/loadprinter.ml
View File

@ -17,7 +17,6 @@
open Misc
open Longident
open Path
open Types
(* Error report *)
@ -89,15 +88,17 @@ let loadfile ppf name =
(* Note: evaluation proceeds in the debugger memory space, not in
the debuggee. *)
let rec eval_path = function
Pident id -> Symtable.get_global_value id
| Pdot(p, _, pos) -> Obj.field (eval_path p) pos
| Papply _ -> fatal_error "Loadprinter.eval_path"
let rec eval_address = function
| Env.Aident id -> Symtable.get_global_value id
| Env.Adot(addr, pos) -> Obj.field (eval_address addr) pos
(* PR#7258: get rid of module aliases before evaluating paths *)
let eval_path path =
eval_path (Env.normalize_path (Some Location.none) Env.empty path)
let eval_value_path env path =
match Env.find_value_address path env with
| addr -> eval_address addr
| exception Not_found ->
fatal_error ("Cannot find address for: " ^ (Path.name path))
(* Install, remove a printer (as in toplevel/topdirs) *)
@ -140,7 +141,7 @@ let install_printer ppf lid =
let (ty_arg, path, is_old_style) = find_printer_type lid in
let v =
try
use_debugger_symtable eval_path path
use_debugger_symtable (eval_value_path Env.empty) path
with Symtable.Error(Symtable.Undefined_global s) ->
raise(Error(Unavailable_module(s, lid))) in
let print_function =

11
debugger/printval.ml
View File

@ -18,7 +18,6 @@
open Format
open Parser_aux
open Path
open Types
(* To name printed and ellipsed values *)
@ -50,20 +49,18 @@ module EvalPath =
struct
type valu = Debugcom.Remote_value.t
exception Error
let rec eval_path env = function
Pident id ->
let rec eval_address = function
| Env.Aident id ->
begin try
Debugcom.Remote_value.global (Symtable.get_global_position id)
with Symtable.Error _ ->
raise Error
end
| Pdot(root, _fieldname, pos) ->
let v = eval_path env root in
| Env.Adot(root, pos) ->
let v = eval_address root in
if not (Debugcom.Remote_value.is_block v)
then raise Error
else Debugcom.Remote_value.field v pos
| Papply _ ->
raise Error
let same_value = Debugcom.Remote_value.same
end

2
ocamldoc/odoc_ast.ml
View File

@ -935,7 +935,7 @@ module Analyser =
let f = match ele with
Element_module m ->
(function
Types.Sig_module (ident,md,_) ->
Types.Sig_module (ident,_,md,_) ->
let n1 = Name.simple m.m_name
and n2 = Ident.name ident in
(

2
ocamldoc/odoc_env.ml
View File

@ -56,7 +56,7 @@ let rec add_signature env root ?rel signat =
Types.Sig_value (ident, _) -> { env with env_values = (rel_name ident, qualify ident) :: env.env_values }
| Types.Sig_type (ident,_,_) -> { env with env_types = (rel_name ident, qualify ident) :: env.env_types }
| Types.Sig_typext (ident, _, _) -> { env with env_extensions = (rel_name ident, qualify ident) :: env.env_extensions }
| Types.Sig_module (ident, md, _) ->
| Types.Sig_module (ident, _, md, _) ->
let env2 =
match md.Types.md_type with (* FIXME: we don't have signature for identifiers *)
Types.Mty_signature s -> add_signature env (qualify ident) ~rel: (rel_name ident) s

2
ocamldoc/odoc_name.ml
View File

@ -232,7 +232,7 @@ let to_path n =
(fun acc_opt -> fun s ->
match acc_opt with
None -> Some (Path.Pident (Ident.create_local s))
| Some acc -> Some (Path.Pdot (acc, s, 0)))
| Some acc -> Some (Path.Pdot (acc, s)))
None
(Str.split (Str.regexp "\\.") n)
with

2
ocamldoc/odoc_print.ml
View File

@ -55,7 +55,7 @@ let simpl_module_type ?code t =
let rec iter t =
match t with
Types.Mty_ident _
| Types.Mty_alias(_, _) -> t
| Types.Mty_alias _ -> t
| Types.Mty_signature _ ->
(
match code with

8
ocamldoc/odoc_sig.ml
View File

@ -55,7 +55,7 @@ module Signature_search =
Hashtbl.add table (C (Name.from_ident ident)) signat
| Types.Sig_class_type (ident, _, _) ->
Hashtbl.add table (CT (Name.from_ident ident)) signat
| Types.Sig_module (ident, _, _) ->
| Types.Sig_module (ident, _, _, _) ->
Hashtbl.add table (M (Name.from_ident ident)) signat
| Types.Sig_modtype (ident,_) ->
Hashtbl.add table (MT (Name.from_ident ident)) signat
@ -92,7 +92,7 @@ module Signature_search =
let search_module table name =
match Hashtbl.find table (M name) with
| (Types.Sig_module (_ident, md, _)) -> md.Types.md_type
| (Types.Sig_module (_ident, _, md, _)) -> md.Types.md_type
| _ -> assert false
let search_module_type table name =
@ -1523,7 +1523,7 @@ module Analyser =
| Parsetree.Pmty_alias longident ->
let name =
match sig_module_type with
Types.Mty_alias(_, path) -> Name.from_path path
Types.Mty_alias path -> Name.from_path path
| _ -> Name.from_longident longident.txt
in
(* Wrong naming... *)
@ -1612,7 +1612,7 @@ module Analyser =
| Parsetree.Pmty_alias _longident ->
begin
match sig_module_type with
Types.Mty_alias(_, path) ->
Types.Mty_alias path ->
let ln = !Odoc_global.library_namespace in
let alias_name = Odoc_env.full_module_name env
Name.(alias_unprefix ln @@ from_path path) in

2
testsuite/tests/tool-toplevel/pr6468.compilers.reference
View File

@ -8,5 +8,5 @@ val g : unit -> int = <fun>
Exception: Not_found.
Raised at file "//toplevel//", line 2, characters 17-26
Called from file "//toplevel//", line 1, characters 11-15
Called from file "toplevel/toploop.ml", line 180, characters 17-27
Called from file "toplevel/toploop.ml", line 193, characters 17-27

2
tools/cmt2annot.ml
View File

@ -104,7 +104,7 @@ let rec iterator ~scope rebuild_env =
| Texp_function { cases = f; }
| Texp_try (_, f) ->
bind_cases f
| Texp_letmodule (_, modname, _, body ) ->
| Texp_letmodule (_, modname, _, _, body ) ->
Stypes.record (Stypes.An_ident
(modname.loc,modname.txt,Annot.Idef body.exp_loc))
| _ -> ()

9
toplevel/genprintval.ml
View File

@ -39,7 +39,7 @@ module type OBJ =
module type EVALPATH =
sig
type valu
val eval_path: Env.t -> Path.t -> valu
val eval_address: Env.address -> valu
exception Error
val same_value: valu -> valu -> bool
end
@ -201,7 +201,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
match ty_path with
| Pident _ ->
Oide_ident name
| Pdot(p, _s, _pos) ->
| Pdot(p, _s) ->
if try
match (lookup_fun (Lident (Out_name.print name)) env).desc with
| Tconstr(ty_path', _, _) -> Path.same ty_path ty_path'
@ -427,7 +427,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
| None ->
let pos =
match rep with
| Record_extension -> 1
| Record_extension _ -> 1
| _ -> 0
in
let unbx =
@ -554,10 +554,11 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
Cstr_extension(p, _) -> p
| _ -> raise Not_found
in
let addr = Env.find_constructor_address path env in
(* Make sure this is the right exception and not an homonym,
by evaluating the exception found and comparing with the
identifier contained in the exception bucket *)
if not (EVP.same_value slot (EVP.eval_path env path))
if not (EVP.same_value slot (EVP.eval_address addr))
then raise Not_found;
tree_of_constr_with_args
(fun x -> Oide_ident x) name (cstr.cstr_inlined <> None)

2
toplevel/genprintval.mli
View File

@ -34,7 +34,7 @@ module type OBJ =
module type EVALPATH =
sig
type valu
val eval_path: Env.t -> Path.t -> valu
val eval_address: Env.address -> valu
exception Error
val same_value: valu -> valu -> bool
end

2
toplevel/opttopdirs.ml
View File

@ -147,7 +147,7 @@ let find_printer_type ppf lid =
let dir_install_printer ppf lid =
try
let (ty_arg, path, is_old_style) = find_printer_type ppf lid in
let v = eval_path !toplevel_env path in
let v = eval_value_path !toplevel_env path in
let print_function =
if is_old_style then
(fun _formatter repr -> Obj.obj v (Obj.obj repr))

39
toplevel/opttoploop.ml
View File

@ -15,7 +15,6 @@
(* The interactive toplevel loop *)
open Path
open Format
open Config
open Misc
@ -62,14 +61,12 @@ type directive_fun =
| Directive_bool of (bool -> unit)
(* Return the value referred to by a path *)
let remembered = ref Ident.empty
let rec remember phrase_name i = function
| [] -> ()
| Sig_value (id, _) :: rest
| Sig_module (id, _, _) :: rest
| Sig_module (id, _, _, _) :: rest
| Sig_typext (id, _, _) :: rest
| Sig_class (id, _, _) :: rest ->
remembered := Ident.add id (phrase_name, i) !remembered;
@ -98,25 +95,41 @@ let toplevel_value id =
in
(Obj.magic (global_symbol glob)).(pos)
let rec eval_path = function
| Pident id ->
(* Return the value referred to by a path *)
let rec eval_address = function
| Env.Aident id ->
if Ident.persistent id || Ident.global id
then global_symbol id
else toplevel_value id
| Pdot(p, _s, pos) ->
Obj.field (eval_path p) pos
| Papply _ ->
fatal_error "Toploop.eval_path"
| Env.Adot(a, pos) ->
Obj.field (eval_address a) pos
let eval_path env path =
eval_path (Env.normalize_path (Some Location.none) env path)
let eval_path find env path =
match find path env with
| addr -> eval_address addr
| exception Not_found ->
fatal_error ("Cannot find address for: " ^ (Path.name path))
let eval_module_path env path =
eval_path Env.find_module_address env path
let eval_value_path env path =
eval_path Env.find_value_address env path
let eval_extension_path env path =
eval_path Env.find_constructor_address env path
let eval_class_path env path =
eval_path Env.find_class_address env path
(* To print values *)
module EvalPath = struct
type valu = Obj.t
exception Error
let eval_path env p = try eval_path env p with _ -> raise Error
let eval_address addr =
try eval_address addr with _ -> raise Error
let same_value v1 v2 = (v1 == v2)
end

5
toplevel/opttoploop.mli
View File

@ -61,7 +61,10 @@ val mod_use_file : formatter -> string -> bool
[use_file] prints the types and values of the results.
[use_silently] does not print them.
[mod_use_file] wrap the file contents into a module. *)
val eval_path: Env.t -> Path.t -> Obj.t
val eval_module_path: Env.t -> Path.t -> Obj.t
val eval_value_path: Env.t -> Path.t -> Obj.t
val eval_extension_path: Env.t -> Path.t -> Obj.t
val eval_class_path: Env.t -> Path.t -> Obj.t
(* Return the toplevel object referred to by the given path *)
(* Printing of values *)

15
toplevel/topdirs.ml
View File

@ -348,7 +348,7 @@ let dir_install_printer ppf lid =
try
let ((ty_arg, ty), path, is_old_style) =
find_printer_type ppf lid in
let v = eval_path !toplevel_env path in
let v = eval_value_path !toplevel_env path in
match ty with
| None ->
let print_function =
@ -413,7 +413,7 @@ let dir_trace ppf lid =
fprintf ppf "%a is an external function and cannot be traced.@."
Printtyp.longident lid
| _ ->
let clos = eval_path !toplevel_env path in
let clos = eval_value_path !toplevel_env path in
(* Nothing to do if it's not a closure *)
if Obj.is_block clos
&& (Obj.tag clos = Obj.closure_tag || Obj.tag clos = Obj.infix_tag)
@ -478,14 +478,14 @@ let trim_signature = function
Mty_signature
(List.map
(function
Sig_module (id, md, rs) ->
Sig_module (id, pres, md, rs) ->
let attribute =
Ast_helper.Attr.mk
(Location.mknoloc "...")
(Parsetree.PStr [])
in
Sig_module (id, {md with md_attributes =
attribute :: md.md_attributes},
Sig_module (id, pres, {md with md_attributes =
attribute :: md.md_attributes},
rs)
(*| Sig_modtype (id, Modtype_manifest mty) ->
Sig_modtype (id, Modtype_manifest (trim_modtype mty))*)
@ -571,10 +571,11 @@ let () =
let rec accum_aliases path acc =
let md = Env.find_module path env in
let acc =
Sig_module (id, {md with md_type = trim_signature md.md_type},
Sig_module (id, Mp_present,
{md with md_type = trim_signature md.md_type},
Trec_not) :: acc in
match md.md_type with
| Mty_alias(_, path) -> accum_aliases path acc
| Mty_alias path -> accum_aliases path acc
| Mty_ident _ | Mty_signature _ | Mty_functor _ ->
List.rev acc
in

33
toplevel/toploop.ml
View File

@ -15,7 +15,6 @@
(* The interactive toplevel loop *)
open Path
open Format
open Config
open Misc
@ -53,8 +52,8 @@ let setvalue name v =
(* Return the value referred to by a path *)
let rec eval_path = function
| Pident id ->
let rec eval_address = function
| Env.Aident id ->
if Ident.persistent id || Ident.global id then
Symtable.get_global_value id
else begin
@ -64,20 +63,34 @@ let rec eval_path = function
with Not_found ->
raise (Symtable.Error(Symtable.Undefined_global name))
end
| Pdot(p, _s, pos) ->
Obj.field (eval_path p) pos
| Papply _ ->
fatal_error "Toploop.eval_path"
| Env.Adot(p, pos) ->
Obj.field (eval_address p) pos
let eval_path env path =
eval_path (Env.normalize_path (Some Location.none) env path)
let eval_path find env path =
match find path env with
| addr -> eval_address addr
| exception Not_found ->
fatal_error ("Cannot find address for: " ^ (Path.name path))
let eval_module_path env path =
eval_path Env.find_module_address env path
let eval_value_path env path =
eval_path Env.find_value_address env path
let eval_extension_path env path =
eval_path Env.find_constructor_address env path
let eval_class_path env path =
eval_path Env.find_class_address env path
(* To print values *)
module EvalPath = struct
type valu = Obj.t
exception Error
let eval_path env p = try eval_path env p with Symtable.Error _ -> raise Error
let eval_address addr =
try eval_address addr with Symtable.Error _ -> raise Error
let same_value v1 v2 = (v1 == v2)
end

5
toplevel/toploop.mli
View File

@ -81,7 +81,10 @@ val mod_use_file : formatter -> string -> bool
[use_file] prints the types and values of the results.
[use_silently] does not print them.
[mod_use_file] wrap the file contents into a module. *)
val eval_path: Env.t -> Path.t -> Obj.t
val eval_module_path: Env.t -> Path.t -> Obj.t
val eval_value_path: Env.t -> Path.t -> Obj.t
val eval_extension_path: Env.t -> Path.t -> Obj.t
val eval_class_path: Env.t -> Path.t -> Obj.t
(* Return the toplevel object referred to by the given path *)
val record_backtrace : unit -> unit

6
typing/btype.ml
View File

@ -235,7 +235,7 @@ let is_constr_row ~allow_ident t =
match t.desc with
Tconstr (Path.Pident id, _, _) when allow_ident ->
is_row_name (Ident.name id)
| Tconstr (Path.Pdot (_, s, _), _, _) -> is_row_name s
| Tconstr (Path.Pdot (_, s), _, _) -> is_row_name s
| _ -> false
@ -352,7 +352,7 @@ let type_iterators =
Sig_value (_, vd) -> it.it_value_description it vd
| Sig_type (_, td, _) -> it.it_type_declaration it td
| Sig_typext (_, td, _) -> it.it_extension_constructor it td
| Sig_module (_, md, _) -> it.it_module_declaration it md
| Sig_module (_, _, md, _) -> it.it_module_declaration it md
| Sig_modtype (_, mtd) -> it.it_modtype_declaration it mtd
| Sig_class (_, cd, _) -> it.it_class_declaration it cd
| Sig_class_type (_, ctd, _) -> it.it_class_type_declaration it ctd
@ -382,7 +382,7 @@ let type_iterators =
it.it_path ctd.clty_path
and it_module_type it = function
Mty_ident p
| Mty_alias(_, p) -> it.it_path p
| Mty_alias p -> it.it_path p
| Mty_signature sg -> it.it_signature it sg
| Mty_functor (_, mto, mt) ->
may (it.it_module_type it) mto;

14
typing/ctype.ml
View File

@ -213,7 +213,7 @@ let restore_global_level gl =
let is_object_type path =
let name =
match path with Path.Pident id -> Ident.name id
| Path.Pdot(_, s,_) -> s
| Path.Pdot(_, s) -> s
| Path.Papply _ -> assert false
in name.[0] = '#'
@ -754,11 +754,11 @@ let rec normalize_package_path env p =
| Some (Mty_ident p) -> normalize_package_path env p
| Some (Mty_signature _ | Mty_functor _ | Mty_alias _) | None ->
match p with
Path.Pdot (p1, s, n) ->
Path.Pdot (p1, s) ->
(* For module aliases *)
let p1' = Env.normalize_path None env p1 in
if Path.same p1 p1' then p else
normalize_package_path env (Path.Pdot (p1', s, n))
normalize_package_path env (Path.Pdot (p1', s))
| _ -> p
let check_scope_escape env level ty =
@ -2382,7 +2382,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_local "Pkg" in
let env' = Env.add_module id2 mty2 env in
let env' = Env.add_module id2 Mp_present mty2 env in
let rec complete nl1 ntl2 =
match nl1, ntl2 with
[], _ -> ntl2
@ -3871,7 +3871,7 @@ let memq_warn t visited =
let rec lid_of_path ?(hash="") = function
Path.Pident id ->
Longident.Lident (hash ^ Ident.name id)
| Path.Pdot (p1, s, _) ->
| Path.Pdot (p1, s) ->
Longident.Ldot (lid_of_path p1, hash ^ s)
| Path.Papply (p1, p2) ->
Longident.Lapply (lid_of_path ~hash p1, lid_of_path p2)
@ -4380,10 +4380,10 @@ let rec normalize_type_rec env visited ty =
let tm = row_of_type ty in
begin if not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm then
match tm.desc with (* PR#7348 *)
Tconstr (Path.Pdot(m,i,pos), tl, _abbrev) ->
Tconstr (Path.Pdot(m,i), tl, _abbrev) ->
let i' = String.sub i 0 (String.length i - 4) in
log_type ty;
ty.desc <- Tconstr(Path.Pdot(m,i',pos), tl, ref Mnil)
ty.desc <- Tconstr(Path.Pdot(m,i'), tl, ref Mnil)
| _ -> assert false
else match ty.desc with
| Tvariant row ->

4
typing/datarepr.ml
View File

@ -130,7 +130,7 @@ let constructor_descrs ty_path decl cstrs =
else Record_inlined idx_nonconst
in
constructor_args decl.type_private cd_args cd_res
(Path.Pdot (ty_path, cstr_name, Path.nopos)) representation
(Path.Pdot (ty_path, cstr_name)) representation
in
let cstr =
{ cstr_name;
@ -159,7 +159,7 @@ let extension_descr path_ext ext =
in
let existentials, cstr_args, cstr_inlined =
constructor_args ext.ext_private ext.ext_args ext.ext_ret_type
path_ext Record_extension
path_ext (Record_extension path_ext)
in
{ cstr_name = Path.last path_ext;
cstr_res = ty_res;

644
typing/env.ml
View File

File diff suppressed because it is too large Load Diff

26
typing/env.mli
View File

@ -23,7 +23,7 @@ type summary =
| Env_value of summary * Ident.t * value_description
| Env_type of summary * Ident.t * type_declaration
| Env_extension of summary * Ident.t * extension_constructor
| Env_module of summary * Ident.t * module_declaration
| Env_module of summary * Ident.t * module_presence * module_declaration
| Env_modtype of summary * Ident.t * modtype_declaration
| Env_class of summary * Ident.t * class_declaration
| Env_cltype of summary * Ident.t * class_type_declaration
@ -34,6 +34,10 @@ type summary =
| Env_constraints of summary * type_declaration Path.Map.t
| Env_copy_types of summary * string list
type address =
| Aident of Ident.t
| Adot of address * int
type t
val empty: t
@ -75,6 +79,12 @@ val find_type_expansion_opt:
(* Find the manifest type information associated to a type for the sake
of the compiler's type-based optimisations. *)
val find_modtype_expansion: Path.t -> t -> module_type
val find_value_address: Path.t -> t -> address
val find_module_address: Path.t -> t -> address
val find_class_address: Path.t -> t -> address
val find_constructor_address: Path.t -> t -> address
val add_functor_arg: Ident.t -> t -> t
val is_functor_arg: Path.t -> t -> bool
val normalize_path: Location.t option -> t -> Path.t -> Path.t
@ -142,9 +152,10 @@ val add_value:
?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t
val add_type: check:bool -> Ident.t -> type_declaration -> t -> t
val add_extension: check:bool -> Ident.t -> extension_constructor -> t -> t
val add_module: ?arg:bool -> Ident.t -> module_type -> t -> t
val add_module:
?arg:bool -> Ident.t -> module_presence -> module_type -> t -> t
val add_module_declaration: ?arg:bool -> check:bool -> Ident.t ->
module_declaration -> t -> t
module_presence -> module_declaration -> t -> t
val add_modtype: Ident.t -> modtype_declaration -> t -> t
val add_class: Ident.t -> class_declaration -> t -> t
val add_cltype: Ident.t -> class_type_declaration -> t -> t
@ -192,9 +203,10 @@ val enter_type: scope:int -> string -> type_declaration -> t -> Ident.t * t
val enter_extension:
scope:int -> string -> extension_constructor -> t -> Ident.t * t
val enter_module:
scope:int -> ?arg:bool -> string -> module_type -> t -> Ident.t * t
scope:int -> ?arg:bool -> string -> module_presence ->
module_type -> t -> Ident.t * t
val enter_module_declaration:
?arg:bool -> Ident.t -> module_declaration -> t -> t
?arg:bool -> Ident.t -> module_presence -> module_declaration -> t -> t
val enter_modtype:
scope:int -> string -> modtype_declaration -> t -> Ident.t * t
val enter_class: scope:int -> string -> class_declaration -> t -> Ident.t * t
@ -333,7 +345,7 @@ val fold_modules:
val fold_modtypes:
(string -> Path.t -> modtype_declaration -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
val fold_classs:
val fold_classes:
(string -> Path.t -> class_declaration -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
val fold_cltypes:
@ -344,6 +356,8 @@ val fold_cltypes:
val scrape_alias: t -> module_type -> module_type
val check_value_name: string -> Location.t -> unit
val print_address : Format.formatter -> address -> unit
module Persistent_signature : sig
type t =
{ filename : string; (** Name of the file containing the signature. *)

9
typing/envaux.ml
View File

@ -47,8 +47,8 @@ let rec env_from_summary sum subst =
Env.add_extension ~check:false id
(Subst.extension_constructor subst desc)
(env_from_summary s subst)
| Env_module(s, id, desc) ->
Env.add_module_declaration ~check:false id
| Env_module(s, id, pres, desc) ->
Env.add_module_declaration ~check:false id pres
(Subst.module_declaration subst desc)
(env_from_summary s subst)
| Env_modtype(s, id, desc) ->
@ -69,9 +69,10 @@ let rec env_from_summary sum subst =
| None -> assert false
| exception Not_found -> raise (Error (Module_not_found path'))
end
| Env_functor_arg(Env_module(s, id, desc), id') when Ident.same id id' ->
| Env_functor_arg(Env_module(s, id, pres, desc), id')
when Ident.same id id' ->
Env.add_module_declaration ~check:false
id (Subst.module_declaration subst desc)
id pres (Subst.module_declaration subst desc)
~arg:true (env_from_summary s subst)
| Env_functor_arg _ -> assert false
| Env_constraints(s, map) ->

60
typing/includemod.ml
View File

@ -178,7 +178,7 @@ let item_ident_name = function
Sig_value(id, d) -> (id, d.val_loc, Field_value(Ident.name id))
| Sig_type(id, d, _) -> (id, d.type_loc, Field_type(Ident.name id))
| Sig_typext(id, d, _) -> (id, d.ext_loc, Field_typext(Ident.name id))
| Sig_module(id, d, _) -> (id, d.md_loc, Field_module(Ident.name id))
| Sig_module(id, _, d, _) -> (id, d.md_loc, Field_module(Ident.name id))
| Sig_modtype(id, d) -> (id, d.mtd_loc, Field_modtype(Ident.name id))
| Sig_class(id, d, _) -> (id, d.cty_loc, Field_class(Ident.name id))
| Sig_class_type(id, d, _) -> (id, d.clty_loc, Field_classtype(Ident.name id))
@ -186,11 +186,12 @@ let item_ident_name = function
let is_runtime_component = function
| Sig_value(_,{val_kind = Val_prim _})
| Sig_type(_,_,_)
| Sig_module(_,Mp_absent,_,_)
| Sig_modtype(_,_)
| Sig_class_type(_,_,_) -> false
| Sig_value(_,_)
| Sig_typext(_,_,_)
| Sig_module(_,_,_)
| Sig_module(_,Mp_present,_,_)
| Sig_class(_, _,_) -> true
(* Print a coercion *)
@ -217,7 +218,7 @@ let rec print_coercion ppf c =
| Tcoerce_primitive {pc_desc; pc_env = _; pc_type} ->
pr "prim %s@ (%a)" pc_desc.Primitive.prim_name
Printtyp.raw_type_expr pc_type
| Tcoerce_alias (p, c) ->
| Tcoerce_alias (_, p, c) ->
pr "@[<2>alias %a@ (%a)@]"
Printtyp.path p
print_coercion c
@ -258,8 +259,8 @@ let rec modtypes ~loc env ~mark cxt subst mty1 mty2 =
:: reasons))
and try_modtypes ~loc env ~mark cxt subst mty1 mty2 =
match (mty1, mty2) with
| (Mty_alias(pres1, p1), Mty_alias(pres2, p2)) -> begin
match mty1, mty2 with
| Mty_alias p1, Mty_alias p2 ->
if Env.is_functor_arg p2 env then
raise (Error[cxt, env, Invalid_module_alias p2]);
if not (Path.same p1 p2) then begin
@ -267,21 +268,8 @@ and try_modtypes ~loc env ~mark cxt subst mty1 mty2 =
and p2 = Env.normalize_path None env (Subst.module_path subst p2) in
if not (Path.same p1 p2) then raise Dont_match
end;
match pres1, pres2 with
| Mta_present, Mta_present -> Tcoerce_none
(* Should really be Tcoerce_ignore if it existed *)
| Mta_absent, Mta_absent -> Tcoerce_none
(* Should really be Tcoerce_empty if it existed *)
| Mta_present, Mta_absent -> Tcoerce_none
| Mta_absent, Mta_present ->
let p1 = try
Env.normalize_path (Some Location.none) env p1
with Env.Error (Env.Missing_module (_, _, path)) ->
raise (Error[cxt, env, Unbound_module_path path])
in
Tcoerce_alias (p1, Tcoerce_none)
end
| (Mty_alias(pres1, p1), _) -> begin
Tcoerce_none
| (Mty_alias p1, _) -> begin
let p1 = try
Env.normalize_path (Some Location.none) env p1
with Env.Error (Env.Missing_module (_, _, path)) ->
@ -291,10 +279,7 @@ and try_modtypes ~loc env ~mark cxt subst mty1 mty2 =
Mtype.strengthen ~aliasable:true env
(expand_module_alias env cxt p1) p1
in
let cc = modtypes ~loc env ~mark cxt subst mty1 mty2 in
match pres1 with
| Mta_present -> cc
| Mta_absent -> Tcoerce_alias (p1, cc)
modtypes ~loc env ~mark cxt subst mty1 mty2
end
| (Mty_ident p1, _) when may_expand_module_path env p1 ->
try_modtypes ~loc env ~mark cxt subst
@ -317,7 +302,7 @@ and try_modtypes ~loc env ~mark cxt subst mty1 mty2 =
(Arg param1::cxt) Subst.identity arg2' arg1
in
let cc_res =
modtypes ~loc (Env.add_module param1 arg2' env) ~mark
modtypes ~loc (Env.add_module param1 Mp_present arg2' env) ~mark
(Body param1::cxt)
(Subst.add_module param2 (Path.Pident param1) subst)
res1 res2
@ -352,7 +337,7 @@ and signatures ~loc env ~mark cxt subst sig1 sig2 =
let (id_pos_list,_) =
List.fold_left
(fun (l,pos) -> function
Sig_module (id, _, _) ->
Sig_module (id, Mp_present, _, _) ->
((id,pos,Tcoerce_none)::l , pos+1)
| item -> (l, if is_runtime_component item then pos+1 else pos))
([], 0) sig1 in
@ -362,7 +347,10 @@ and signatures ~loc env ~mark cxt subst sig1 sig2 =
[] -> pos, tbl
| item :: rem ->
let (id, _loc, name) = item_ident_name item in
let nextpos = if is_runtime_component item then pos + 1 else pos in
let pos, nextpos =
if is_runtime_component item then pos, pos + 1
else -1, pos
in
build_component_table nextpos
(FieldMap.add name (id, item, pos) tbl) rem in
let len1, comps1 =
@ -453,9 +441,17 @@ and signature_components ~loc old_env ~mark env cxt subst paired =
:: rem ->
extension_constructors ~loc env ~mark cxt subst id1 ext1 ext2;
(pos, Tcoerce_none) :: comps_rec rem
| (Sig_module(id1, mty1, _), Sig_module(_id2, mty2, _), pos) :: rem ->
| (Sig_module(id1, pres1, mty1, _),
Sig_module(_id2, pres2, mty2, _), pos) :: rem -> begin
let cc = module_declarations ~loc env ~mark cxt subst id1 mty1 mty2 in
(pos, cc) :: comps_rec rem
let rem = comps_rec rem in
match pres1, pres2, mty1.md_type with
| Mp_present, Mp_present, _ -> (pos, cc) :: rem
| _, Mp_absent, _ -> rem
| Mp_absent, Mp_present, Mty_alias p1 ->
(pos, Tcoerce_alias (env, p1, cc)) :: rem
| Mp_absent, Mp_present, _ -> assert false
end
| (Sig_modtype(id1, info1), Sig_modtype(_id2, info2), _pos) :: rem ->
modtype_infos ~loc env ~mark cxt subst id1 info1 info2;
comps_rec rem
@ -520,7 +516,7 @@ and check_modtype_equiv ~loc env ~mark cxt mty1 mty2 =
let can_alias env path =
let rec no_apply = function
| Path.Pident _ -> true
| Path.Pdot(p, _, _) -> no_apply p
| Path.Pdot(p, _) -> no_apply p
| Path.Papply _ -> false
in
no_apply path && not (Env.is_functor_arg path env)
@ -680,8 +676,8 @@ and argname x =
let path_of_context = function
Module id :: rem ->
let rec subm path = function
[] -> path
| Module id :: rem -> subm (Path.Pdot (path, Ident.name id, -1)) rem
| [] -> path
| Module id :: rem -> subm (Path.Pdot (path, Ident.name id)) rem
| _ -> assert false
in subm (Path.Pident id) rem
| _ -> assert false

230
typing/mtype.ml
View File

@ -36,7 +36,7 @@ let freshen mty =
let rec strengthen ~aliasable env mty p =
match scrape env mty with
Mty_signature sg ->
Mty_signature(strengthen_sig ~aliasable env sg p 0)
Mty_signature(strengthen_sig ~aliasable env sg p)
| Mty_functor(param, arg, res)
when !Clflags.applicative_functors && Ident.name param <> "*" ->
Mty_functor(param, arg,
@ -44,20 +44,15 @@ let rec strengthen ~aliasable env mty p =
| mty ->
mty
and strengthen_sig ~aliasable env sg p pos =
and strengthen_sig ~aliasable env sg p =
match sg with
[] -> []
| (Sig_value(_, desc) as sigelt) :: rem ->
let nextpos =
match desc.val_kind with
| Val_prim _ -> pos
| _ -> pos + 1
in
sigelt :: strengthen_sig ~aliasable env rem p nextpos
| (Sig_value(_, _) as sigelt) :: rem ->
sigelt :: strengthen_sig ~aliasable env rem p
| Sig_type(id, {type_kind=Type_abstract}, _) ::
(Sig_type(id', {type_private=Private}, _) :: _ as rem)
when Ident.name id = Ident.name id' ^ "#row" ->
strengthen_sig ~aliasable env rem p pos
strengthen_sig ~aliasable env rem p
| Sig_type(id, decl, rs) :: rem ->
let newdecl =
match decl.type_manifest, decl.type_private, decl.type_kind with
@ -65,74 +60,73 @@ and strengthen_sig ~aliasable env sg p pos =
| Some _, Private, (Type_record _ | Type_variant _) -> decl
| _ ->
let manif =
Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id, nopos),
Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id),
decl.type_params, ref Mnil))) in
if decl.type_kind = Type_abstract then
{ decl with type_private = Public; type_manifest = manif }
else
{ decl with type_manifest = manif }
in
Sig_type(id, newdecl, rs) :: strengthen_sig ~aliasable env rem p pos
Sig_type(id, newdecl, rs) :: strengthen_sig ~aliasable env rem p
| (Sig_typext _ as sigelt) :: rem ->
sigelt :: strengthen_sig ~aliasable env rem p (pos+1)
| Sig_module(id, md, rs) :: rem ->
sigelt :: strengthen_sig ~aliasable env rem p
| Sig_module(id, pres, md, rs) :: rem ->
let str =
strengthen_decl ~aliasable env md (Pdot(p, Ident.name id, pos))
strengthen_decl ~aliasable env md (Pdot(p, Ident.name id))
in
Sig_module(id, str, rs)
Sig_module(id, pres, str, rs)
:: strengthen_sig ~aliasable
(Env.add_module_declaration ~check:false id md env) rem p (pos+1)
(Env.add_module_declaration ~check:false id pres md env) rem p
(* Need to add the module in case it defines manifest module types *)
| Sig_modtype(id, decl) :: rem ->
let newdecl =
match decl.mtd_type with
None ->
{decl with mtd_type = Some(Mty_ident(Pdot(p,Ident.name id,nopos)))}
{decl with mtd_type = Some(Mty_ident(Pdot(p,Ident.name id)))}
| Some _ ->
decl
in
Sig_modtype(id, newdecl) ::
strengthen_sig ~aliasable (Env.add_modtype id decl env) rem p pos
strengthen_sig ~aliasable (Env.add_modtype id decl env) rem p
(* Need to add the module type in case it is manifest *)
| (Sig_class _ as sigelt) :: rem ->
sigelt :: strengthen_sig ~aliasable env rem p (pos+1)
sigelt :: strengthen_sig ~aliasable env rem p
| (Sig_class_type _ as sigelt) :: rem ->
sigelt :: strengthen_sig ~aliasable env rem p pos
sigelt :: strengthen_sig ~aliasable env rem p
and strengthen_decl ~aliasable env md p =
match md.md_type with
| Mty_alias _ -> md
| _ when aliasable -> {md with md_type = Mty_alias(Mta_present, p)}
| _ when aliasable -> {md with md_type = Mty_alias p}
| mty -> {md with md_type = strengthen ~aliasable env mty p}
let () = Env.strengthen := strengthen
let rec make_aliases_absent mty =
let rec make_aliases_absent pres mty =
match mty with
| Mty_alias(_, p) ->
Mty_alias(Mta_absent, p)
| Mty_alias _ -> Mp_absent, mty
| Mty_signature sg ->
Mty_signature(make_aliases_absent_sig sg)
pres, Mty_signature(make_aliases_absent_sig sg)
| Mty_functor(param, arg, res) ->
Mty_functor(param, arg, make_aliases_absent res)
let _, res = make_aliases_absent Mp_present res in
pres, Mty_functor(param, arg, res)
| mty ->
mty
pres, mty
and make_aliases_absent_sig sg =
match sg with
[] -> []
| Sig_module(id, md, rs) :: rem ->
let str =
{ md with md_type = make_aliases_absent md.md_type }
in
Sig_module(id, str, rs) :: make_aliases_absent_sig rem
| Sig_module(id, pres, md, rs) :: rem ->
let pres, md_type = make_aliases_absent pres md.md_type in
let md = { md with md_type } in
Sig_module(id, pres, md, rs) :: make_aliases_absent_sig rem
| sigelt :: rem ->
sigelt :: make_aliases_absent_sig rem
let scrape_for_type_of env mty =
let scrape_for_type_of env pres mty =
let rec loop env path mty =
match mty, path with
| Mty_alias(_, path), _ -> begin
| Mty_alias path, _ -> begin
try
let md = Env.find_module path env in
loop env (Some path) md.md_type
@ -142,7 +136,7 @@ let scrape_for_type_of env mty =
strengthen ~aliasable:false env mty path
| _ -> mty
in
make_aliases_absent (loop env None mty)
make_aliases_absent pres (loop env None mty)
(* In nondep_supertype, env is only used for the type it assigns to id.
Hence there is no need to keep env up-to-date by adding the bindings
@ -150,7 +144,7 @@ let scrape_for_type_of env mty =
type variance = Co | Contra | Strict
let rec nondep_mty env va ids mty =
let rec nondep_mty_with_presence env va ids pres mty =
match mty with
Mty_ident p ->
begin match Path.find_free_opt ids p with
@ -160,10 +154,10 @@ let rec nondep_mty env va ids mty =
with Not_found ->
raise (Ctype.Nondep_cannot_erase id)
in
nondep_mty env va ids expansion
| None -> mty
nondep_mty_with_presence env va ids pres expansion
| None -> pres, mty
end
| Mty_alias(_, p) ->
| Mty_alias p ->
begin match Path.find_free_opt ids p with
| Some id ->
let expansion =
@ -171,18 +165,25 @@ let rec nondep_mty env va ids mty =
with Not_found ->
raise (Ctype.Nondep_cannot_erase id)
in
nondep_mty env va ids expansion.md_type
| None -> mty
nondep_mty_with_presence env va ids Mp_present expansion.md_type
| None -> pres, mty
end
| Mty_signature sg ->
Mty_signature(nondep_sig env va ids sg)
let mty = Mty_signature(nondep_sig env va ids sg) in
pres, mty
| Mty_functor(param, arg, res) ->
let var_inv =
match va with Co -> Contra | Contra -> Co | Strict -> Strict in
Mty_functor(param, Misc.may_map (nondep_mty env var_inv ids) arg,
nondep_mty
(Env.add_module ~arg:true param
(Btype.default_mty arg) env) va ids res)
let mty =
Mty_functor(param, Misc.may_map (nondep_mty env var_inv ids) arg,
nondep_mty
(Env.add_module ~arg:true param Mp_present
(Btype.default_mty arg) env) va ids res)
in
pres, mty
and nondep_mty env va ids mty =
snd (nondep_mty_with_presence env va ids Mp_present mty)
and nondep_sig_item env va ids = function
| Sig_value(id, d) ->
@ -192,8 +193,9 @@ and nondep_sig_item env va ids = function
Sig_type(id, Ctype.nondep_type_decl env ids (va = Co) d, rs)
| Sig_typext(id, ext, es) ->
Sig_typext(id, Ctype.nondep_extension_constructor env ids ext, es)
| Sig_module(id, md, rs) ->
Sig_module(id, {md with md_type=nondep_mty env va ids md.md_type}, rs)
| Sig_module(id, pres, md, rs) ->
let pres, mty = nondep_mty_with_presence env va ids pres md.md_type in
Sig_module(id, pres, {md with md_type = mty}, rs)
| Sig_modtype(id, d) ->
begin try
Sig_modtype(id, nondep_modtype_decl env ids d)
@ -259,12 +261,12 @@ let rec enrich_modtype env p mty =
and enrich_item env p = function
Sig_type(id, decl, rs) ->
Sig_type(id,
enrich_typedecl env (Pdot(p, Ident.name id, nopos)) id decl, rs)
| Sig_module(id, md, rs) ->
Sig_module(id,
enrich_typedecl env (Pdot(p, Ident.name id)) id decl, rs)
| Sig_module(id, pres, md, rs) ->
Sig_module(id, pres,
{md with
md_type = enrich_modtype env
(Pdot(p, Ident.name id, nopos)) md.md_type},
(Pdot(p, Ident.name id)) md.md_type},
rs)
| item -> item
@ -272,35 +274,34 @@ let rec type_paths env p mty =
match scrape env mty with
Mty_ident _ -> []
| Mty_alias _ -> []
| Mty_signature sg -> type_paths_sig env p 0 sg
| Mty_signature sg -> type_paths_sig env p sg
| Mty_functor _ -> []
and type_paths_sig env p pos sg =
and type_paths_sig env p sg =
match sg with
[] -> []
| Sig_value(_id, decl) :: rem ->
let pos' = match decl.val_kind with Val_prim _ -> pos | _ -> pos + 1 in
type_paths_sig env p pos' rem
| Sig_type(id, _decl, _) :: rem ->
Pdot(p, Ident.name id, nopos) :: type_paths_sig env p pos rem
| Sig_module(id, md, _) :: rem ->
type_paths env (Pdot(p, Ident.name id, pos)) md.md_type @
type_paths_sig (Env.add_module_declaration ~check:false id md env)
p (pos+1) rem
Pdot(p, Ident.name id) :: type_paths_sig env p rem
| Sig_module(id, pres, md, _) :: rem ->
type_paths env (Pdot(p, Ident.name id)) md.md_type @
type_paths_sig (Env.add_module_declaration ~check:false id pres md env)
p rem
| Sig_modtype(id, decl) :: rem ->
type_paths_sig (Env.add_modtype id decl env) p pos rem
| (Sig_typext _ | Sig_class _) :: rem ->
type_paths_sig env p (pos+1) rem
| (Sig_class_type _) :: rem ->
type_paths_sig env p pos rem
type_paths_sig (Env.add_modtype id decl env) p rem
| (Sig_value _ | Sig_typext _ | Sig_class _ | Sig_class_type _) :: rem ->
type_paths_sig env p rem
let rec no_code_needed env mty =
match scrape env mty with
Mty_ident _ -> false
| Mty_signature sg -> no_code_needed_sig env sg
| Mty_functor(_, _, _) -> false
| Mty_alias(Mta_absent, _) -> true
| Mty_alias(Mta_present, _) -> false
let rec no_code_needed_mod env pres mty =
match pres with
| Mp_absent -> true
| Mp_present -> begin
match scrape env mty with
Mty_ident _ -> false
| Mty_signature sg -> no_code_needed_sig env sg
| Mty_functor _ -> false
| Mty_alias _ -> false
end
and no_code_needed_sig env sg =
match sg with
@ -310,15 +311,16 @@ and no_code_needed_sig env sg =
| Val_prim _ -> no_code_needed_sig env rem
| _ -> false
end
| Sig_module(id, md, _) :: rem ->
no_code_needed env md.md_type &&
| Sig_module(id, pres, md, _) :: rem ->
no_code_needed_mod env pres md.md_type &&
no_code_needed_sig
(Env.add_module_declaration ~check:false id md env) rem
(Env.add_module_declaration ~check:false id pres md env) rem
| (Sig_type _ | Sig_modtype _ | Sig_class_type _) :: rem ->
no_code_needed_sig env rem
| (Sig_typext _ | Sig_class _) :: _ ->
false
let no_code_needed env mty = no_code_needed_mod env Mp_present mty
(* Check whether a module type may return types *)
@ -349,7 +351,7 @@ and contains_type_item env = function
the current constraints which guarantee that this type
is kept local to expressions. *)
raise Exit
| Sig_module (_, {md_type = mty}, _) ->
| Sig_module (_, _, {md_type = mty}, _) ->
contains_type env mty
| Sig_value _
| Sig_type _
@ -365,13 +367,13 @@ let contains_type env mty =
(* Remove module aliases from a signature *)
let rec get_prefixes = function
Pident _ -> Path.Set.empty
| Pdot (p, _, _)
| Pident _ -> Path.Set.empty
| Pdot (p, _)
| Papply (p, _) -> Path.Set.add p (get_prefixes p)
let rec get_arg_paths = function
Pident _ -> Path.Set.empty
| Pdot (p, _, _) -> get_arg_paths p
| Pident _ -> Path.Set.empty
| Pdot (p, _) -> get_arg_paths p
| Papply (p1, p2) ->
Path.Set.add p2
(Path.Set.union (get_prefixes p2)
@ -382,9 +384,9 @@ let rec rollback_path subst p =
with Not_found ->
match p with
Pident _ | Papply _ -> p
| Pdot (p1, s, n) ->
| Pdot (p1, s) ->
let p1' = rollback_path subst p1 in
if Path.same p1 p1' then p else rollback_path subst (Pdot (p1', s, n))
if Path.same p1 p1' then p else rollback_path subst (Pdot (p1', s))
let rec collect_ids subst bindings p =
begin match rollback_path subst p with
@ -408,13 +410,13 @@ let collect_arg_paths mty =
and it_signature_item it si =
type_iterators.it_signature_item it si;
match si with
Sig_module (id, {md_type=Mty_alias(_, p)}, _) ->
| Sig_module (id, _, {md_type=Mty_alias p}, _) ->
bindings := Ident.add id p !bindings
| Sig_module (id, {md_type=Mty_signature sg}, _) ->
| Sig_module (id, _, {md_type=Mty_signature sg}, _) ->
List.iter
(function Sig_module (id', _, _) ->
(function Sig_module (id', _, _, _) ->
subst :=
Path.Map.add (Pdot (Pident id, Ident.name id', -1)) id' !subst
Path.Map.add (Pdot (Pident id, Ident.name id')) id' !subst
| _ -> ())
sg
| _ -> ()
@ -430,34 +432,43 @@ type remove_alias_args =
exclude: Ident.t -> Path.t -> bool;
scrape: Env.t -> module_type -> module_type }
let rec remove_aliases_mty env args mty =
let rec remove_aliases_mty env args pres mty =
let args' = {args with modified = false} in
let mty' =
let res =
match args.scrape env mty with
Mty_signature sg ->
Mty_signature (remove_aliases_sig env args' sg)
Mp_present, Mty_signature (remove_aliases_sig env args' sg)
| Mty_alias _ ->
let mty' = Env.scrape_alias env mty in
if mty' = mty then mty else
(args'.modified <- true; remove_aliases_mty env args' mty')
if mty' = mty then begin
pres, mty
end else begin
args'.modified <- true;
remove_aliases_mty env args' Mp_present mty'
end
| mty ->
mty
Mp_present, mty
in
if args'.modified then (args.modified <- true; mty') else mty
if args'.modified then begin
args.modified <- true;
res
end else begin
pres, mty
end
and remove_aliases_sig env args sg =
match sg with
[] -> []
| Sig_module(id, md, rs) :: rem ->
let mty =
| Sig_module(id, pres, md, rs) :: rem ->
let pres, mty =
match md.md_type with
Mty_alias (_, p) when args.exclude id p ->
md.md_type
Mty_alias p when args.exclude id p ->
pres, md.md_type
| mty ->
remove_aliases_mty env args mty
remove_aliases_mty env args pres mty
in
Sig_module(id, {md with md_type = mty} , rs) ::
remove_aliases_sig (Env.add_module id mty env) args rem
Sig_module(id, pres, {md with md_type = mty} , rs) ::
remove_aliases_sig (Env.add_module id pres mty env) args rem
| Sig_modtype(id, mtd) :: rem ->
Sig_modtype(id, mtd) ::
remove_aliases_sig (Env.add_modtype id mtd env) args rem
@ -468,16 +479,23 @@ let scrape_for_functor_arg env mty =
let exclude _id p =
try ignore (Env.find_module p env); true with Not_found -> false
in
remove_aliases_mty env {modified=false; exclude; scrape} mty
let _, mty =
remove_aliases_mty env {modified=false; exclude; scrape} Mp_present mty
in
mty
let scrape_for_type_of ~remove_aliases env mty =
if remove_aliases then begin
let excl = collect_arg_paths mty in
let exclude id _p = Ident.Set.mem id excl in
let scrape _ mty = mty in
remove_aliases_mty env {modified=false; exclude; scrape} mty
let _, mty =
remove_aliases_mty env {modified=false; exclude; scrape} Mp_present mty
in
mty
end else begin
scrape_for_type_of env mty
let _, mty = scrape_for_type_of env Mp_present mty in
mty
end
(* Lower non-generalizable type variables *)

2
typing/parmatch.ml
View File

@ -2459,7 +2459,7 @@ let all_rhs_idents exp =
let leave_expression exp =
if is_unpack exp then begin match exp.exp_desc with
| Texp_letmodule
(id_mod,_,
(id_mod,_,_,
{mod_desc=
Tmod_unpack ({exp_desc=Texp_ident (Path.Pident id_exp,_,_)},_)},
_) ->

26
typing/path.ml
View File

@ -15,15 +15,13 @@
type t =
Pident of Ident.t
| Pdot of t * string * int
| Pdot of t * string
| Papply of t * t
let nopos = -1
let rec same p1 p2 =
match (p1, p2) with
(Pident id1, Pident id2) -> Ident.same id1 id2
| (Pdot(p1, s1, _pos1), Pdot(p2, s2, _pos2)) -> s1 = s2 && same p1 p2
| (Pdot(p1, s1), Pdot(p2, s2)) -> s1 = s2 && same p1 p2
| (Papply(fun1, arg1), Papply(fun2, arg2)) ->
same fun1 fun2 && same arg1 arg2
| (_, _) -> false
@ -31,7 +29,7 @@ let rec same p1 p2 =
let rec compare p1 p2 =
match (p1, p2) with
(Pident id1, Pident id2) -> Ident.compare id1 id2
| (Pdot(p1, s1, _pos1), Pdot(p2, s2, _pos2)) ->
| (Pdot(p1, s1), Pdot(p2, s2)) ->
let h = compare p1 p2 in
if h <> 0 then h else String.compare s1 s2
| (Papply(fun1, arg1), Papply(fun2, arg2)) ->
@ -42,7 +40,7 @@ let rec compare p1 p2 =
let rec find_free_opt ids = function
Pident id -> List.find_opt (Ident.same id) ids
| Pdot(p, _s, _pos) -> find_free_opt ids p
| Pdot(p, _s) -> find_free_opt ids p
| Papply(p1, p2) ->
match find_free_opt ids p1 with
| None -> find_free_opt ids p2
@ -55,31 +53,31 @@ let exists_free ids p =
let rec scope = function
Pident id -> Ident.scope id
| Pdot(p, _s, _pos) -> scope p
| Pdot(p, _s) -> scope p
| Papply(p1, p2) -> max (scope p1) (scope p2)
let kfalse _ = false
let rec name ?(paren=kfalse) = function
Pident id -> Ident.name id
| Pdot(p, s, _pos) ->
| Pdot(p, s) ->
name ~paren p ^ if paren s then ".( " ^ s ^ " )" else "." ^ s
| Papply(p1, p2) -> name ~paren p1 ^ "(" ^ name ~paren p2 ^ ")"
let rec print ppf = function
| Pident id -> Ident.print_with_scope ppf id
| Pdot(p, s, _pos) -> Format.fprintf ppf "%a.%s" print p s
| Pdot(p, s) -> Format.fprintf ppf "%a.%s" print p s
| Papply(p1, p2) -> Format.fprintf ppf "%a(%a)" print p1 print p2
let rec head = function
Pident id -> id
| Pdot(p, _s, _pos) -> head p
| Pdot(p, _s) -> head p
| Papply _ -> assert false
let flatten =
let rec flatten acc = function
| Pident id -> `Ok (id, acc)
| Pdot (p, s, _) -> flatten (s :: acc) p
| Pdot (p, s) -> flatten (s :: acc) p
| Papply _ -> `Contains_apply
in
fun t -> flatten [] t
@ -87,14 +85,14 @@ let flatten =
let heads p =
let rec heads p acc = match p with
| Pident id -> id :: acc
| Pdot (p, _s, _pos) -> heads p acc
| Pdot (p, _s) -> heads p acc
| Papply(p1, p2) ->
heads p1 (heads p2 acc)
in heads p []
let rec last = function
| Pident id -> Ident.name id
| Pdot(_, s, _) -> s
| Pdot(_, s) -> s
| Papply(_, p) -> last p
let is_uident s =
@ -111,7 +109,7 @@ type typath =
let constructor_typath = function
| Pident id when is_uident (Ident.name id) -> LocalExt id
| Pdot(ty_path, s, _) when is_uident s ->
| Pdot(ty_path, s) when is_uident s ->
if is_uident (last ty_path) then Ext (ty_path, s)
else Cstr (ty_path, s)
| p -> Regular p

4
typing/path.mli
View File

@ -17,7 +17,7 @@
type t =
Pident of Ident.t
| Pdot of t * string * int
| Pdot of t * string
| Papply of t * t
val same: t -> t -> bool
@ -27,8 +27,6 @@ val exists_free: Ident.t list -> t -> bool
val scope: t -> int
val flatten : t -> [ `Contains_apply | `Ok of Ident.t * string list ]
val nopos: int
val name: ?paren:(string -> bool) -> t -> string
(* [paren] tells whether a path suffix needs parentheses *)
val head: t -> Ident.t

22
typing/printtyp.ml
View File

@ -285,7 +285,7 @@ let ident ppf id = pp_print_string ppf
let ident_stdlib = Ident.create_persistent "Stdlib"
let non_shadowed_pervasive = function
| Pdot(Pident id, s, _) as path ->
| Pdot(Pident id, s) as path ->
Ident.same id ident_stdlib &&
(try Path.same path (Env.lookup_type (Lident s) !printing_env)
with Not_found -> true)
@ -305,7 +305,7 @@ let find_double_underscore s =
let rec module_path_is_an_alias_of env path ~alias_of =
match Env.find_module path env with
| { md_type = Mty_alias (_, path'); _ } ->
| { md_type = Mty_alias path'; _ } ->
Path.same path' alias_of ||
module_path_is_an_alias_of env path' ~alias_of
| _ -> false
@ -315,8 +315,8 @@ let rec module_path_is_an_alias_of env path ~alias_of =
for Foo__bar. This pattern is used by the stdlib. *)
let rec rewrite_double_underscore_paths env p =
match p with
| Pdot (p, s, n) ->
Pdot (rewrite_double_underscore_paths env p, s, n)
| Pdot (p, s) ->
Pdot (rewrite_double_underscore_paths env p, s)
| Papply (a, b) ->
Papply (rewrite_double_underscore_paths env a,
rewrite_double_underscore_paths env b)
@ -348,9 +348,9 @@ let rewrite_double_underscore_paths env p =
let rec tree_of_path namespace = function
| Pident id ->
Oide_ident (ident_name namespace id)
| Pdot(_, s, _pos) as path when non_shadowed_pervasive path ->
| Pdot(_, s) as path when non_shadowed_pervasive path ->
Oide_ident (Naming_context.pervasives_name namespace s)
| Pdot(p, s, _pos) ->
| Pdot(p, s) ->
Oide_dot (tree_of_path Module p, s)
| Papply(p1, p2) ->
Oide_apply (tree_of_path Module p1, tree_of_path Module p2)
@ -579,7 +579,7 @@ let penalty s =
let rec path_size = function
Pident id ->
penalty (Ident.name id), -Ident.scope id
| Pdot (p, _, _) ->
| Pdot (p, _) ->
let (l, b) = path_size p in (1+l, b)
| Papply (p1, p2) ->
let (l, b) = path_size p1 in
@ -1511,7 +1511,7 @@ let recursive_sigitem = function
| Sig_class(id,_,rs) -> Some(id,rs,3)
| Sig_class_type (id,_,rs) -> Some(id,rs,2)
| Sig_type(id, _, rs)
| Sig_module(id, _, rs) -> Some (id,rs,0)
| Sig_module(id, _, _, rs) -> Some (id,rs,0)
| _ -> None
let skip k l = snd (Misc.Stdlib.List.split_at k l)
@ -1542,12 +1542,12 @@ let rec tree_of_modtype ?(ellipsis=false) = function
let res =
match ty_arg with None -> tree_of_modtype ~ellipsis ty_res
| Some mty ->
wrap_env (Env.add_module ~arg:true param mty)
wrap_env (Env.add_module ~arg:true param Mp_present mty)
(tree_of_modtype ~ellipsis) ty_res
in
Omty_functor (Ident.name param,
may_map (tree_of_modtype ~ellipsis:false) ty_arg, res)
| Mty_alias(_, p) ->
| Mty_alias p ->
Omty_alias (tree_of_path Module p)
and tree_of_signature sg =
@ -1574,7 +1574,7 @@ and trees_of_sigitem = function
[tree_of_type_declaration id decl rs]
| Sig_typext(id, ext, es) ->
[tree_of_extension_constructor id ext es]
| Sig_module(id, md, rs) ->
| Sig_module(id, _, md, rs) ->
let ellipsis =
List.exists (function
| Parsetree.{attr_name = {txt="..."}; attr_payload = PStr []} -> true

6
typing/printtyped.ml
View File

@ -46,7 +46,7 @@ let fmt_ident = Ident.print
let rec fmt_path_aux f x =
match x with
| Path.Pident (s) -> fprintf f "%a" fmt_ident s;
| Path.Pdot (y, s, _pos) -> fprintf f "%a.%s" fmt_path_aux y s;
| Path.Pdot (y, s) -> fprintf f "%a.%s" fmt_path_aux y s;
| Path.Papply (y, z) ->
fprintf f "%a(%a)" fmt_path_aux y fmt_path_aux z;
;;
@ -152,7 +152,7 @@ let record_representation i ppf = let open Types in function
| Record_float -> line i ppf "Record_float\n"
| Record_unboxed b -> line i ppf "Record_unboxed %b\n" b
| Record_inlined i -> line i ppf "Record_inlined %d\n" i
| Record_extension -> line i ppf "Record_extension\n"
| Record_extension p -> line i ppf "Record_extension %a\n" fmt_path p
let attribute i ppf k a =
line i ppf "%s \"%s\"\n" k a.Parsetree.attr_name.txt;
@ -391,7 +391,7 @@ and expression i ppf x =
| Texp_override (_, l) ->
line i ppf "Texp_override\n";
list i string_x_expression ppf l;
| Texp_letmodule (s, _, me, e) ->
| Texp_letmodule (s, _, _, me, e) ->
line i ppf "Texp_letmodule \"%a\"\n" fmt_ident s;
module_expr i ppf me;
expression i ppf e;

12
typing/rec_check.ml
View File

@ -151,7 +151,7 @@ let classify_expression : Typedtree.expression -> sd =
classify_path env path
(* non-binding cases *)
| Texp_letmodule (_, _, _, e)
| Texp_letmodule (_, _, _, _, e)
| Texp_sequence (_, e)
| Texp_letexception (_, e) ->
classify_expression env e
@ -511,7 +511,7 @@ let rec expression : Typedtree.expression -> term_judg =
G |- let <bindings> in body : m
*)
value_bindings rec_flag bindings >> expression body
| Texp_letmodule (x, _, mexp, e) ->
| Texp_letmodule (x, _, _, mexp, e) ->
module_binding (x, mexp) >> expression e
| Texp_match (e, cases, _) ->
(*
@ -613,7 +613,7 @@ let rec expression : Typedtree.expression -> term_judg =
| Record_float -> Dereference
| Record_unboxed _ -> Return
| Record_regular | Record_inlined _
| Record_extension -> Guard
| Record_extension _ -> Guard
in
let field (_label, field_def) = match field_def with
Kept _ -> empty
@ -848,7 +848,7 @@ and modexp : Typedtree.module_expr -> term_judg =
(* This corresponds to 'external' declarations,
and the coercion ignores its argument *)
k Ignore
| Tcoerce_alias (pth, coe) ->
| Tcoerce_alias (_, pth, coe) ->
(* Alias coercions ignore their arguments, but they evaluate
their alias module 'pth' under another coercion. *)
coercion coe (fun m -> path pth << m)
@ -876,7 +876,7 @@ and path : Path.t -> term_judg =
fun pth -> match pth with
| Path.Pident x ->
single x
| Path.Pdot (t, _, _) ->
| Path.Pdot (t, _) ->
path t << Dereference
| Path.Papply (f, p) ->
join [
@ -963,7 +963,7 @@ and structure_item : Typedtree.structure_item -> bind_judg =
| Sig_value (id, _)
| Sig_type (id, _, _)
| Sig_typext (id, _, _)
| Sig_module (id, _, _)
| Sig_module (id, _, _, _)
| Sig_modtype (id, _)
| Sig_class (id, _, _)
| Sig_class_type (id, _, _)

36
typing/subst.ml
View File

@ -80,8 +80,8 @@ let rec module_path s path =
with Not_found ->
match path with
| Pident _ -> path
| Pdot(p, n, pos) ->
Pdot(module_path s p, n, pos)
| Pdot(p, n) ->
Pdot(module_path s p, n)
| Papply(p1, p2) ->
Papply(module_path s p1, module_path s p2)
@ -92,8 +92,8 @@ let modtype_path s = function
| Mty_ident p -> p
| _ -> fatal_error "Subst.modtype_path"
with Not_found -> p end
| Pdot(p, n, pos) ->
Pdot(module_path s p, n, pos)
| Pdot(p, n) ->
Pdot(module_path s p, n)
| Papply _ ->
fatal_error "Subst.modtype_path"
@ -104,17 +104,17 @@ let type_path s path =
| exception Not_found ->
match path with
| Pident _ -> path
| Pdot(p, n, pos) ->
Pdot(module_path s p, n, pos)
| Pdot(p, n) ->
Pdot(module_path s p, n)
| Papply _ ->
fatal_error "Subst.type_path"
let type_path s p =
match Path.constructor_typath p with
| Regular p -> type_path s p
| Cstr (ty_path, cstr) -> Pdot(type_path s ty_path, cstr, nopos)
| Cstr (ty_path, cstr) -> Pdot(type_path s ty_path, cstr)
| LocalExt _ -> type_path s p
| Ext (p, cstr) -> Pdot(module_path s p, cstr, nopos)
| Ext (p, cstr) -> Pdot(module_path s p, cstr)
let to_subst_by_type_function s p =
match Path.Map.find p s.types with
@ -175,9 +175,9 @@ let rec typexp s ty =
ty'.desc <-
begin if has_fixed_row then
match tm.desc with (* PR#7348 *)
Tconstr (Pdot(m,i,pos), tl, _abbrev) ->
Tconstr (Pdot(m,i), tl, _abbrev) ->
let i' = String.sub i 0 (String.length i - 4) in
Tconstr(type_path s (Pdot(m,i',pos)), tl, ref Mnil)
Tconstr(type_path s (Pdot(m,i')), tl, ref Mnil)
| _ -> assert false
else match desc with
| Tconstr (p, args, _abbrev) ->
@ -393,11 +393,11 @@ let rec rename_bound_idents s sg = function
(add_type id (Pident id') s)
(Sig_type(id', td, rs) :: sg)
rest
| Sig_module(id, md, rs) :: rest ->
| Sig_module(id, pres, md, rs) :: rest ->
let id' = Ident.rename id in
rename_bound_idents
(add_module id (Pident id') s)
(Sig_module (id', md, rs) :: sg)
(Sig_module (id', pres, md, rs) :: sg)
rest
| Sig_modtype(id, mtd) :: rest ->
let id' = Ident.rename id in
@ -431,8 +431,8 @@ let rec modtype s = function
begin match p with
Pident id ->
begin try Ident.Map.find id s.modtypes with Not_found -> mty end
| Pdot(p, n, pos) ->
Mty_ident(Pdot(module_path s p, n, pos))
| Pdot(p, n) ->
Mty_ident(Pdot(module_path s p, n))
| Papply _ ->
fatal_error "Subst.modtype"
end
@ -442,8 +442,8 @@ let rec modtype s = function
let id' = Ident.rename id in
Mty_functor(id', may_map (modtype s) arg,
modtype (add_module id (Pident id') s) res)
| Mty_alias(pres, p) ->
Mty_alias(pres, module_path s p)
| Mty_alias p ->
Mty_alias (module_path s p)
and signature s sg =
(* Components of signature may be mutually recursive (e.g. type declarations
@ -462,8 +462,8 @@ and signature_item s comp =
Sig_type(id, type_declaration s d, rs)
| Sig_typext(id, ext, es) ->
Sig_typext(id, extension_constructor s ext, es)
| Sig_module(id, d, rs) ->
Sig_module(id, module_declaration s d, rs)
| Sig_module(id, pres, d, rs) ->
Sig_module(id, pres, module_declaration s d, rs)
| Sig_modtype(id, d) ->
Sig_modtype(id, modtype_declaration s d)
| Sig_class(id, d, rs) ->

7
typing/tast_mapper.ml
View File

@ -336,10 +336,11 @@ let expr sub x =
path,
List.map (tuple3 id id (sub.expr sub)) list
)
| Texp_letmodule (id, s, mexpr, exp) ->
| Texp_letmodule (id, s, pres, mexpr, exp) ->
Texp_letmodule (
id,
s,
pres,
sub.module_expr sub mexpr,
sub.expr sub exp
)
@ -446,8 +447,8 @@ let module_coercion sub = function
| Tcoerce_none -> Tcoerce_none
| Tcoerce_functor (c1,c2) ->
Tcoerce_functor (sub.module_coercion sub c1, sub.module_coercion sub c2)
| Tcoerce_alias (p, c1) ->
Tcoerce_alias (p, sub.module_coercion sub c1)
| Tcoerce_alias (env, p, c1) ->
Tcoerce_alias (sub.env sub env, p, sub.module_coercion sub c1)
| Tcoerce_structure (l1, l2) ->
let l1' = List.map (fun (i,c) -> i, sub.module_coercion sub c) l1 in
let l2' =

55
typing/typecore.ml
View File

@ -840,7 +840,7 @@ module Label = NameChoice (struct
let in_env lbl =
match lbl.lbl_repres with
| Record_regular | Record_float | Record_unboxed false -> true
| Record_unboxed true | Record_inlined _ | Record_extension -> false
| Record_unboxed true | Record_inlined _ | Record_extension _ -> false
end)
let disambiguate_label_by_ids keep closed ids labels =
@ -1825,7 +1825,7 @@ let rec is_nonexpansive exp =
Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable)
vars true &&
!count = 0
| Texp_letmodule (_, _, mexp, e) ->
| Texp_letmodule (_, _, _, mexp, e) ->
is_nonexpansive_mod mexp && is_nonexpansive e
| Texp_pack mexp ->
is_nonexpansive_mod mexp
@ -2003,7 +2003,7 @@ let check_partial_application statement exp =
| Texp_let (_, _, e)
| Texp_sequence (_, e)
| Texp_letexception (_, e)
| Texp_letmodule (_, _, _, e) ->
| Texp_letmodule (_, _, _, _, e) ->
loop e
| _ ->
let loc =
@ -2042,7 +2042,7 @@ let check_partial_application statement exp =
| Texp_ifthenelse (_, e1, Some e2) ->
check e1; check e2
| Texp_let (_, _, e) | Texp_sequence (_, e)
| Texp_letexception (_, e) | Texp_letmodule (_, _, _, e) ->
| Texp_letexception (_, e) | Texp_letmodule (_, _, _, _, e) ->
check e
| Texp_apply _ | Texp_send _ | Texp_new _ ->
Location.prerr_warning exp_loc Warnings.Partial_application
@ -2350,7 +2350,8 @@ and type_expect_
let ty_exp = expand_head env ty_expected in
let fmt6_path =
Path.(Pdot (Pident (Ident.create_persistent "CamlinternalFormatBasics"),
"format6", 0)) in
"format6"))
in
let is_format = match ty_exp.desc with
| Tconstr(path, _, _) when Path.same path fmt6_path ->
if !Clflags.principal && ty_exp.level <> generic_level then
@ -2950,30 +2951,34 @@ and type_expect_
let (obj_ty, res_ty) = filter_arrow env method_type Nolabel in
unify env obj_ty desc.val_type;
unify env res_ty (instance typ);
let method_desc =
{val_type = method_type;
val_kind = Val_reg;
val_attributes = [];
Types.val_loc = Location.none}
in
let exp_env = Env.add_value method_id method_desc env in
let exp =
Texp_apply({exp_desc =
Texp_ident(Path.Pident method_id, lid,
{val_type = method_type;
val_kind = Val_reg;
val_attributes = [];
Types.val_loc = Location.none});
Texp_ident(Path.Pident method_id,
lid, method_desc);
exp_loc = loc; exp_extra = [];
exp_type = method_type;
exp_attributes = []; (* check *)
exp_env = env},
exp_env = exp_env},
[ Nolabel,
Some {exp_desc = Texp_ident(path, lid, desc);
exp_loc = obj.exp_loc; exp_extra = [];
exp_type = desc.val_type;
exp_attributes = []; (* check *)
exp_env = env}
exp_env = exp_env}
])
in
(Tmeth_name met, Some (re {exp_desc = exp;
exp_loc = loc; exp_extra = [];
exp_type = typ;
exp_attributes = []; (* check *)
exp_env = env}), typ)
exp_env = exp_env}), typ)
| _ ->
assert false
end
@ -3118,8 +3123,15 @@ and type_expect_
let context = Typetexp.narrow () in
let modl = !type_module env smodl in
Mtype.lower_nongen ty.level modl.mod_type;
let pres =
match modl.mod_type with
| Mty_alias _ -> Mp_absent
| _ -> Mp_present
in
let scope = create_scope () in
let (id, new_env) = Env.enter_module ~scope name.txt modl.mod_type env in
let (id, new_env) =
Env.enter_module ~scope name.txt pres modl.mod_type env
in
Typetexp.widen context;
(* ideally, we should catch Expr_type_clash errors
in type_expect triggered by escaping identifiers from the local module
@ -3130,7 +3142,7 @@ and type_expect_
end_def ();
Ctype.unify_var new_env ty body.exp_type;
re {
exp_desc = Texp_letmodule(id, name, modl, body);
exp_desc = Texp_letmodule(id, name, pres, modl, body);
exp_loc = loc; exp_extra = [];
exp_type = ty;
exp_attributes = sexp.pexp_attributes;
@ -3765,16 +3777,19 @@ and type_argument ?recarg env sarg ty_expected' ty_expected =
(* eta-expand to avoid side effects *)
let var_pair name ty =
let id = Ident.create_local name in
let desc =
{ val_type = ty; val_kind = Val_reg;
val_attributes = [];
Types.val_loc = Location.none}
in
let exp_env = Env.add_value id desc env in
{pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[];
pat_attributes = [];
pat_loc = Location.none; pat_env = env},
{exp_type = ty; exp_loc = Location.none; exp_env = env;
{exp_type = ty; exp_loc = Location.none; exp_env = exp_env;
exp_extra = []; exp_attributes = [];
exp_desc =
Texp_ident(Path.Pident id, mknoloc (Longident.Lident name),
{val_type = ty; val_kind = Val_reg;
val_attributes = [];
Types.val_loc = Location.none})}
Texp_ident(Path.Pident id, mknoloc (Longident.Lident name), desc)}
in
let eta_pat, eta_var = var_pair "eta" ty_arg in
let func texp =

2
typing/typedecl.ml
View File

@ -1568,7 +1568,7 @@ let transl_extension_constructor env type_path type_params
List.iter2 (Ctype.unify env) decl.type_params tl;
let lbls =
match decl.type_kind with
| Type_record (lbls, Record_extension) -> lbls
| Type_record (lbls, Record_extension _) -> lbls
| _ -> assert false
in
Types.Cstr_record lbls

7
typing/typedtree.ml
View File

@ -107,7 +107,8 @@ and expression_desc =
| Texp_instvar of Path.t * Path.t * string loc
| Texp_setinstvar of Path.t * Path.t * string loc * expression
| Texp_override of Path.t * (Path.t * string loc * expression) list
| Texp_letmodule of Ident.t * string loc * module_expr * expression
| Texp_letmodule of
Ident.t * string loc * Types.module_presence * module_expr * expression
| Texp_letexception of extension_constructor * expression
| Texp_assert of expression
| Texp_lazy of expression
@ -241,6 +242,7 @@ and module_binding =
{
mb_id: Ident.t;
mb_name: string loc;
mb_presence: module_presence;
mb_expr: module_expr;
mb_attributes: attribute list;
mb_loc: Location.t;
@ -260,7 +262,7 @@ and module_coercion =
(Ident.t * int * module_coercion) list
| Tcoerce_functor of module_coercion * module_coercion
| Tcoerce_primitive of primitive_coercion
| Tcoerce_alias of Path.t * module_coercion
| Tcoerce_alias of Env.t * Path.t * module_coercion
and module_type =
{ mty_desc: module_type_desc;
@ -318,6 +320,7 @@ and module_declaration =
{
md_id: Ident.t;
md_name: string loc;
md_presence: module_presence;
md_type: module_type;
md_attributes: attribute list;
md_loc: Location.t;

7
typing/typedtree.mli
View File

@ -224,7 +224,8 @@ and expression_desc =
| Texp_instvar of Path.t * Path.t * string loc
| Texp_setinstvar of Path.t * Path.t * string loc * expression
| Texp_override of Path.t * (Path.t * string loc * expression) list
| Texp_letmodule of Ident.t * string loc * module_expr * expression
| Texp_letmodule of
Ident.t * string loc * Types.module_presence * module_expr * expression
| Texp_letexception of extension_constructor * expression
| Texp_assert of expression
| Texp_lazy of expression
@ -364,6 +365,7 @@ and module_binding =
{
mb_id: Ident.t;
mb_name: string loc;
mb_presence: module_presence;
mb_expr: module_expr;
mb_attributes: attributes;
mb_loc: Location.t;
@ -383,7 +385,7 @@ and module_coercion =
(Ident.t * int * module_coercion) list
| Tcoerce_functor of module_coercion * module_coercion
| Tcoerce_primitive of primitive_coercion
| Tcoerce_alias of Path.t * module_coercion
| Tcoerce_alias of Env.t * Path.t * module_coercion
and module_type =
{ mty_desc: module_type_desc;
@ -440,6 +442,7 @@ and module_declaration =
{
md_id: Ident.t;
md_name: string loc;
md_presence: module_presence;
md_type: module_type;
md_attributes: attributes;
md_loc: Location.t;

2
typing/typedtreeIter.ml
View File

@ -350,7 +350,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
List.iter (fun (_path, _, exp) ->
iter_expression exp
) list
| Texp_letmodule (_id, _, mexpr, exp) ->
| Texp_letmodule (_id, _, _, mexpr, exp) ->
iter_module_expr mexpr;
iter_expression exp
| Texp_letexception (cd, exp) ->

4
typing/typedtreeMap.ml
View File

@ -382,9 +382,9 @@ module MakeMap(Map : MapArgument) = struct
(path, lid, map_expression exp)
) list
)
| Texp_letmodule (id, name, mexpr, exp) ->
| Texp_letmodule (id, name, pres, mexpr, exp) ->
Texp_letmodule (
id, name,
id, name, pres,
map_module_expr mexpr,
map_expression exp
)

183
typing/typemod.ml
View File

@ -114,8 +114,8 @@ open Typedtree
let rec path_concat head p =
match p with
Pident tail -> Pdot (Pident head, Ident.name tail, 0)
| Pdot (pre, s, pos) -> Pdot (path_concat head pre, s, pos)
Pident tail -> Pdot (Pident head, Ident.name tail)
| Pdot (pre, s) -> Pdot (path_concat head pre, s)
| Papply _ -> assert false
(* Extract a signature from a module type *)
@ -123,14 +123,14 @@ let rec path_concat head p =
let extract_sig env loc mty =
match Env.scrape_alias env mty with
Mty_signature sg -> sg
| Mty_alias(_, path) ->
| Mty_alias path ->
raise(Error(loc, env, Cannot_scrape_alias path))
| _ -> raise(Error(loc, env, Signature_expected))
let extract_sig_open env loc mty =
match Env.scrape_alias env mty with
Mty_signature sg -> sg
| Mty_alias(_, path) ->
| Mty_alias path ->
raise(Error(loc, env, Cannot_scrape_alias path))
| mty -> raise(Error(loc, env, Structure_expected mty))
@ -246,8 +246,8 @@ let update_rec_next rs rem =
match rem with
Sig_type (id, decl, Trec_next) :: rem ->
Sig_type (id, decl, rs) :: rem
| Sig_module (id, mty, Trec_next) :: rem ->
Sig_module (id, mty, rs) :: rem
| Sig_module (id, pres, mty, Trec_next) :: rem ->
Sig_module (id, pres, mty, rs) :: rem
| _ -> rem
let make_variance p n i =
@ -257,7 +257,7 @@ let make_variance p n i =
let rec iter_path_apply p ~f =
match p with
| Pident _ -> ()
| Pdot (p, _, _) -> iter_path_apply p ~f
| Pdot (p, _) -> iter_path_apply p ~f
| Papply (p1, p2) ->
iter_path_apply p1 ~f;
iter_path_apply p2 ~f;
@ -295,8 +295,8 @@ let iterator_with_env env =
| Mty_functor (param, mty_arg, mty_body) ->
may (self.Btype.it_module_type self) mty_arg;
let env_before = !env in
env := lazy (Env.add_module ~arg:true param (Btype.default_mty mty_arg)
(Lazy.force env_before));
env := lazy (Env.add_module ~arg:true param Mp_present
(Btype.default_mty mty_arg) (Lazy.force env_before));
self.Btype.it_module_type self mty_body;
env := env_before;
| mty ->
@ -327,7 +327,7 @@ let check_usage_of_path_of_substituted_item paths env signature ~loc ~lid =
let env, super = iterator_with_env env in
{ super with
Btype.it_signature_item = (fun self -> function
| Sig_module (id, { md_type = Mty_alias (_, aliased_path); _ }, _)
| Sig_module (id, _, { md_type = Mty_alias aliased_path; _ }, _)
when List.exists
(fun path -> path_is_strict_prefix path ~prefix:aliased_path)
paths
@ -359,7 +359,7 @@ let check_usage_of_path_of_substituted_item paths env signature ~loc ~lid =
(* After substitution one also needs to re-check the well-foundedness
of type declarations in recursive modules *)
let rec extract_next_modules = function
| Sig_module (id, mty, Trec_next) :: rem ->
| Sig_module (id, _, mty, Trec_next) :: rem ->
let (id_mty_l, rem) = extract_next_modules rem in
((id, mty) :: id_mty_l, rem)
| sg -> ([], sg)
@ -371,7 +371,7 @@ let check_well_formed_module env loc context mty =
let iterator =
let rec check_signature env = function
| [] -> ()
| Sig_module (id, mty, Trec_first) :: rem ->
| Sig_module (id, _, mty, Trec_first) :: rem ->
let (id_mty_l, rem) = extract_next_modules rem in
begin try
check_recmod_typedecls (Lazy.force env) ((id, mty) :: id_mty_l)
@ -504,7 +504,7 @@ let merge_constraint initial_env remove_aliases loc sg constr =
real_ids := [Pident id];
(Pident id, lid, Twith_typesubst tdecl),
update_rec_next rs rem
| (Sig_module(id, md, rs) :: rem, [s], Pwith_module (_, lid'))
| (Sig_module(id, pres, md, rs) :: rem, [s], Pwith_module (_, lid'))
when Ident.name id = s ->
let path, md' = Typetexp.find_module initial_env loc lid'.txt in
let mty = md'.md_type in
@ -513,8 +513,8 @@ let merge_constraint initial_env remove_aliases loc sg constr =
let newmd = Mtype.strengthen_decl ~aliasable:false env md'' path in
ignore(Includemod.modtypes ~loc env newmd.md_type md.md_type);
(Pident id, lid, Twith_module (path, lid')),
Sig_module(id, newmd, rs) :: rem
| (Sig_module(id, md, rs) :: rem, [s], Pwith_modsubst (_, lid'))
Sig_module(id, pres, newmd, rs) :: rem
| (Sig_module(id, _, md, rs) :: rem, [s], Pwith_modsubst (_, lid'))
when Ident.name id = s ->
let path, md' = Typetexp.find_module initial_env loc lid'.txt in
let aliasable = not (Env.is_functor_arg path env) in
@ -523,7 +523,7 @@ let merge_constraint initial_env remove_aliases loc sg constr =
real_ids := [Pident id];
(Pident id, lid, Twith_modsubst (path, lid')),
update_rec_next rs rem
| (Sig_module(id, ({md_type = Mty_alias _} as md), _) as item :: rem,
| (Sig_module(id, _, ({md_type = Mty_alias _} as md), _) as item :: rem,
s :: namelist, (Pwith_module _ | Pwith_type _))
when Ident.name id = s ->
let ((path, _, tcstr), _) =
@ -532,14 +532,15 @@ let merge_constraint initial_env remove_aliases loc sg constr =
let path = path_concat id path in
real_ids := path :: !real_ids;
(path, lid, tcstr), item :: rem
| (Sig_module(id, md, rs) :: rem, s :: namelist, _)
| (Sig_module(id, _, md, rs) :: rem, s :: namelist, _)
when Ident.name id = s ->
let ((path, _path_loc, tcstr), newsg) =
merge env (extract_sig env loc md.md_type) namelist None
in
let path = path_concat id path in
real_ids := path :: !real_ids;
let item = Sig_module(id, {md with md_type=Mty_signature newsg}, rs) in
let newmd = {md with md_type=Mty_signature newsg} in
let item = Sig_module(id, Mp_present, newmd, rs) in
(path, lid, tcstr),
item :: rem
| (item :: rem, _, _) ->
@ -657,14 +658,17 @@ let rec approx_modtype env smty =
Mty_ident path
| Pmty_alias lid ->
let path = Typetexp.lookup_module env smty.pmty_loc lid.txt in
Mty_alias(Mta_absent, path)
Mty_alias path
| Pmty_signature ssg ->
Mty_signature(approx_sig env ssg)
| Pmty_functor(param, sarg, sres) ->
let arg = may_map (approx_modtype env) sarg in
let rarg = Mtype.scrape_for_functor_arg env (Btype.default_mty arg) in
let scope = Ctype.create_scope () in
let (id, newenv) = Env.enter_module ~scope ~arg:true param.txt rarg env in
let (id, newenv) =
Env.enter_module ~scope ~arg:true param.txt
Mp_present rarg env
in
let res = approx_modtype newenv sres in
Mty_functor(id, arg, res)
| Pmty_with(sbody, constraints) ->
@ -710,15 +714,25 @@ and approx_sig env ssg =
let scope = Ctype.create_scope () in
let id = Ident.create_scoped ~scope pmd.pmd_name.txt in
let md = approx_module_declaration env pmd in
let newenv = Env.enter_module_declaration id md env in
Sig_module(id, md, Trec_not) :: approx_sig newenv srem
let pres =
match md.Types.md_type with
| Mty_alias _ -> Mp_absent
| _ -> Mp_present
in
let newenv = Env.enter_module_declaration id pres md env in
Sig_module(id, pres, md, Trec_not) :: approx_sig newenv srem
| Psig_modsubst pms ->
let scope = Ctype.create_scope () in
let id = Ident.create_scoped ~scope pms.pms_name.txt in
let _, md =
Typetexp.find_module env pms.pms_manifest.loc pms.pms_manifest.txt
in
let newenv = Env.enter_module_declaration id md env in
let pres =
match md.Types.md_type with
| Mty_alias _ -> Mp_absent
| _ -> Mp_present
in
let newenv = Env.enter_module_declaration id pres md env in
approx_sig newenv srem
| Psig_recmodule sdecls ->
let scope = Ctype.create_scope () in
@ -733,10 +747,12 @@ and approx_sig env ssg =
let newenv =
List.fold_left
(fun env (id, md) -> Env.add_module_declaration ~check:false
id md env)
env decls in
map_rec (fun rs (id, md) -> Sig_module(id, md, rs)) decls
(approx_sig newenv srem)
id Mp_present md env)
env decls
in
map_rec
(fun rs (id, md) -> Sig_module(id, Mp_present, md, rs)) decls
(approx_sig newenv srem)
| Psig_modtype d ->
let info = approx_modtype_info env d in
let scope = Ctype.create_scope () in
@ -910,7 +926,7 @@ end = struct
match component with
| Sig_type(id, _, _) ->
check_type names loc id ~info:(info id loc)
| Sig_module(id, _, _) ->
| Sig_module(id, _, _, _) ->
check_module names loc id ~info:(info id loc)
| Sig_modtype(id, _) ->
check_modtype names loc id ~info:(info id loc)
@ -951,7 +967,7 @@ end = struct
| Sig_value(id, v) -> Value, id, v.val_loc
| Sig_type (id, td, _) -> Type, id, td.type_loc
| Sig_typext (id, te, _) -> Extension_constructor, id, te.ext_loc
| Sig_module (id, md, _) -> Module, id, md.md_loc
| Sig_module (id, _, md, _) -> Module, id, md.md_loc
| Sig_modtype (id, mtd) -> Module_type, id, mtd.mtd_loc
| Sig_class (id, c, _) -> Class, id, c.cty_loc
| Sig_class_type (id, ct, _) -> Class_type, id, ct.clty_loc
@ -1049,7 +1065,7 @@ and transl_modtype_aux env smty =
smty.pmty_attributes
| Pmty_alias lid ->
let path = transl_module_alias loc env lid.txt in
mkmty (Tmty_alias (path, lid)) (Mty_alias(Mta_absent, path)) env loc
mkmty (Tmty_alias (path, lid)) (Mty_alias path) env loc
smty.pmty_attributes
| Pmty_signature ssg ->
let sg = transl_signature env ssg in
@ -1060,8 +1076,9 @@ and transl_modtype_aux env smty =
let ty_arg = Misc.may_map (fun m -> m.mty_type) arg in
let scope = Ctype.create_scope () in
let (id, newenv) =
Env.enter_module ~scope ~arg:true param.txt (Btype.default_mty ty_arg)
env in
Env.enter_module ~scope ~arg:true
param.txt Mp_present (Btype.default_mty ty_arg) env
in
let res = transl_modtype newenv sres in
mkmty (Tmty_functor (id, param, arg, res))
(Mty_functor(id, ty_arg, res.mty_type)) env loc
@ -1178,6 +1195,11 @@ and transl_signature env sg =
Builtin_attributes.warning_scope pmd.pmd_attributes
(fun () -> transl_modtype env pmd.pmd_type)
in
let pres =
match tmty.mty_type with
| Mty_alias _ -> Mp_absent
| _ -> Mp_present
in
let md = {
md_type=tmty.mty_type;
md_attributes=pmd.pmd_attributes;
@ -1185,14 +1207,14 @@ and transl_signature env sg =
}
in
Signature_names.check_module names pmd.pmd_name.loc id;
let newenv = Env.enter_module_declaration id md env in
let newenv = Env.enter_module_declaration id pres md env in
let (trem, rem, final_env) = transl_sig newenv srem in
mksig (Tsig_module {md_id=id; md_name=pmd.pmd_name;
md_type=tmty;
md_presence=pres; md_type=tmty;
md_loc=pmd.pmd_loc;
md_attributes=pmd.pmd_attributes})
env loc :: trem,
Sig_module(id, md, Trec_not) :: rem,
Sig_module(id, pres, md, Trec_not) :: rem,
final_env
| Psig_modsubst pms ->
let scope = Ctype.create_scope () in
@ -1205,15 +1227,20 @@ and transl_signature env sg =
if not aliasable then
md
else
{ md_type = Mty_alias(Mta_absent, path);
{ md_type = Mty_alias path;
md_attributes = pms.pms_attributes;
md_loc = pms.pms_loc }
in
let pres =
match md.md_type with
| Mty_alias _ -> Mp_absent
| _ -> Mp_present
in
let info =
`Substituted_away (Subst.add_module id path Subst.identity)
in
Signature_names.check_module ~info names pms.pms_name.loc id;
let newenv = Env.enter_module_declaration id md env in
let newenv = Env.enter_module_declaration id pres md env in
let (trem, rem, final_env) = transl_sig newenv srem in
mksig (Tsig_modsubst {ms_id=id; ms_name=pms.pms_name;
ms_manifest=path; ms_txt=pms.pms_manifest;
@ -1235,7 +1262,7 @@ and transl_signature env sg =
md_attributes = md.md_attributes;
md_loc = md.md_loc;
} in
Sig_module(md.md_id, d, rs))
Sig_module(md.md_id, Mp_present, d, rs))
decls rem,
final_env
| Psig_modtype pmtd ->
@ -1369,11 +1396,13 @@ and transl_modtype_decl_aux names env
and transl_recmodule_modtypes env sdecls =
let make_env curr =
List.fold_left
(fun env (id, _, mty) -> Env.add_module ~arg:true id mty env)
(fun env (id, _, mty) ->
Env.add_module ~arg:true id Mp_present mty env)
env curr in
let make_env2 curr =
List.fold_left
(fun env (id, _, mty) -> Env.add_module ~arg:true id mty.mty_type env)
(fun env (id, _, mty) ->
Env.add_module ~arg:true id Mp_present mty.mty_type env)
env curr in
let transition env_c curr =
List.map2
@ -1405,7 +1434,7 @@ and transl_recmodule_modtypes env sdecls =
let dummy =
Mty_ident (Path.Pident (Ident.create_scoped ~scope "#recmod#"))
in
Env.add_module ~arg:true id dummy env
Env.add_module ~arg:true id Mp_present dummy env
)
env ids
in
@ -1435,6 +1464,7 @@ and transl_recmodule_modtypes env sdecls =
List.map2
(fun pmd (id, id_loc, mty) ->
{md_id=id; md_name=id_loc; md_type=mty;
md_presence=Mp_present;
md_loc=pmd.pmd_loc;
md_attributes=pmd.pmd_attributes})
sdecls dcl2
@ -1447,7 +1477,7 @@ exception Not_a_path
let rec path_of_module mexp =
match mexp.mod_desc with
Tmod_ident (p,_) -> p
| Tmod_ident (p,_) -> p
| Tmod_apply(funct, arg, _coercion) when !Clflags.applicative_functors ->
Papply(path_of_module funct, path_of_module arg)
| Tmod_constraint (mexp, _, _, _) ->
@ -1466,12 +1496,14 @@ let rec closed_modtype env = function
let env = Env.add_signature sg env in
List.for_all (closed_signature_item env) sg
| Mty_functor(id, param, body) ->
let env = Env.add_module ~arg:true id (Btype.default_mty param) env in
let env =
Env.add_module ~arg:true id Mp_present (Btype.default_mty param) env
in
closed_modtype env body
and closed_signature_item env = function
Sig_value(_id, desc) -> Ctype.closed_schema env desc.val_type
| Sig_module(_id, md, _) -> closed_modtype env md.md_type
| Sig_module(_id, _, md, _) -> closed_modtype env md.md_type
| _ -> true
let check_nongen_scheme env sig_item =
@ -1479,7 +1511,7 @@ let check_nongen_scheme env sig_item =
Sig_value(_id, vd) ->
if not (Ctype.closed_schema env vd.val_type) then
raise (Error (vd.val_loc, env, Non_generalizable vd.val_type))
| Sig_module (_id, md, _) ->
| Sig_module (_id, _, md, _) ->
if not (closed_modtype env md.md_type) then
raise(Error(md.md_loc, env, Non_generalizable_module md.md_type))
| _ -> ()
@ -1490,7 +1522,7 @@ let check_nongen_schemes env sg =
(* Helpers for typing recursive modules *)
let anchor_submodule name anchor =
match anchor with None -> None | Some p -> Some(Pdot(p, name, nopos))
match anchor with None -> None | Some p -> Some(Pdot(p, name))
let anchor_recmodule id =
Some (Pident id)
@ -1502,7 +1534,7 @@ let enrich_type_decls anchor decls oldenv newenv =
(fun e info ->
let id = info.typ_id in
let info' =
Mtype.enrich_typedecl oldenv (Pdot(p, Ident.name id, nopos))
Mtype.enrich_typedecl oldenv (Pdot(p, Ident.name id))
id info.typ_type
in
Env.add_type ~check:true id info' e)
@ -1511,7 +1543,7 @@ let enrich_type_decls anchor decls oldenv newenv =
let enrich_module_type anchor name mty env =
match anchor with
None -> mty
| Some p -> Mtype.enrich_modtype env (Pdot(p, name, nopos)) mty
| Some p -> Mtype.enrich_modtype env (Pdot(p, name)) mty
let check_recmodule_inclusion env bindings =
(* PR#4450, PR#4470: consider
@ -1556,7 +1588,7 @@ let check_recmodule_inclusion env bindings =
if first_time
then mty_actual
else subst_and_strengthen env s id mty_actual in
Env.add_module ~arg:false id' mty_actual' env)
Env.add_module ~arg:false id' Mp_present mty_actual' env)
env bindings1 in
(* Build the output substitution Y_i <- X_i *)
let s' =
@ -1588,6 +1620,7 @@ let check_recmodule_inclusion env bindings =
{
mb_id = id;
mb_name = id_loc;
mb_presence = Mp_present;
mb_expr = modl';
mb_attributes = attrs;
mb_loc = loc;
@ -1609,7 +1642,7 @@ let rec package_constraints env loc mty constrs =
when List.mem_assoc [Ident.name id] constrs ->
let ty = List.assoc [Ident.name id] constrs in
Sig_type (id, {td with type_manifest = Some ty}, rs)
| Sig_module (id, md, rs) ->
| Sig_module (id, _, md, rs) ->
let rec aux = function
| (m :: ((_ :: _) as l), t) :: rest when m = Ident.name id ->
(l, t) :: aux rest
@ -1621,7 +1654,7 @@ let rec package_constraints env loc mty constrs =
md_type = package_constraints env loc md.md_type (aux constrs)
}
in
Sig_module (id, md, rs)
Sig_module (id, Mp_present, md, rs)
| item -> item
)
sg
@ -1680,7 +1713,7 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
let path =
Typetexp.lookup_module ~load:(not alias) env smod.pmod_loc lid.txt in
let md = { mod_desc = Tmod_ident (path, lid);
mod_type = Mty_alias(Mta_absent, path);
mod_type = Mty_alias path;
mod_env = env;
mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc } in
@ -1689,12 +1722,13 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
if alias && aliasable then
(Env.add_required_global (Path.head path); md)
else match (Env.find_module path env).md_type with
Mty_alias(_, p1) when not alias ->
| Mty_alias p1 when not alias ->
let p1 = Env.normalize_path (Some smod.pmod_loc) env p1 in
let mty = Includemod.expand_module_alias env [] p1 in
{ md with
mod_desc = Tmod_constraint (md, mty, Tmodtype_implicit,
Tcoerce_alias (p1, Tcoerce_none));
mod_desc =
Tmod_constraint (md, mty, Tmodtype_implicit,
Tcoerce_alias (env, path, Tcoerce_none));
mod_type =
if sttn then Mtype.strengthen ~aliasable:true env mty p1
else mty }
@ -1726,7 +1760,9 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
let (id, newenv), funct_body =
match ty_arg with
| None -> (Ident.create_scoped ~scope "*", env), false
| Some mty -> Env.enter_module ~scope ~arg:true name.txt mty env, true
| Some mty ->
Env.enter_module ~scope ~arg:true name.txt Mp_present mty env,
true
in
let body = type_module sttn funct_body None newenv sbody in
rm { mod_desc = Tmod_functor(id, name, mty, body);
@ -1761,7 +1797,9 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
mty_res
| None ->
if generative then mty_res else
let env = Env.add_module ~arg:true param arg.mod_type env in
let env =
Env.add_module ~arg:true param Mp_present arg.mod_type env
in
check_well_formed_module env smod.pmod_loc
"the signature of this functor application" mty_res;
let nondep_mty =
@ -1791,7 +1829,7 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
mod_env = env;
mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc }
| Mty_alias(_, path) ->
| Mty_alias path ->
raise(Error(sfunct.pmod_loc, env, Cannot_scrape_alias path))
| _ ->
raise(Error(sfunct.pmod_loc, env, Cannot_apply funct.mod_type))
@ -1932,6 +1970,11 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
(anchor_submodule name.txt anchor) env smodl
)
in
let pres =
match modl.mod_type with
| Mty_alias _ -> Mp_absent
| _ -> Mp_present
in
let md =
{ md_type = enrich_module_type anchor name.txt modl.mod_type env;
md_attributes = attrs;
@ -1940,11 +1983,10 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
in
(*prerr_endline (Ident.unique_toplevel_name id);*)
Mtype.lower_nongen (scope - 1) md.md_type;
let newenv = Env.enter_module_declaration id md env in
let newenv = Env.enter_module_declaration id pres md env in
Tstr_module {mb_id=id; mb_name=name; mb_expr=modl;
mb_attributes=attrs; mb_loc=pmb_loc;
},
[Sig_module(id,
mb_presence=pres; mb_attributes=attrs; mb_loc=pmb_loc; },
[Sig_module(id, pres,
{md_type = modl.mod_type;
md_attributes = attrs;
md_loc = pmb_loc;
@ -2000,7 +2042,8 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
md_loc = md.md_loc;
}
in
Env.add_module_declaration ~check:true md.md_id mdecl env
Env.add_module_declaration ~check:true
md.md_id Mp_present mdecl env
)
env decls
in
@ -2008,7 +2051,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
check_recmodule_inclusion newenv bindings1 in
Tstr_recmodule bindings2,
map_rec (fun rs mb ->
Sig_module(mb.mb_id, {
Sig_module(mb.mb_id, Mp_present, {
md_type=mb.mb_expr.mod_type;
md_attributes=mb.mb_attributes;
md_loc=mb.mb_loc;
@ -2158,7 +2201,7 @@ and normalize_signature env = List.iter (normalize_signature_item env)
and normalize_signature_item env = function
Sig_value(_id, desc) -> Ctype.normalize_type env desc.val_type
| Sig_module(_id, md, _) -> normalize_modtype env md.md_type
| Sig_module(_id, _, md, _) -> normalize_modtype env md.md_type
| _ -> ()
(* Extract the module type of a module expression *)
@ -2194,18 +2237,18 @@ let type_package env m p nl =
Typetexp.widen context;
let (mp, env) =
match modl.mod_desc with
Tmod_ident (mp,_) -> (mp, env)
| Tmod_ident (mp,_) -> (mp, env)
| 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
Env.enter_module ~scope ~arg:true "%M" Mp_present modl.mod_type env
in
(Pident id, new_env)
in
let rec mkpath mp = function
| Lident name -> Pdot(mp, name, nopos)
| Ldot (m, name) -> Pdot(mkpath mp m, name, nopos)
| Lident name -> Pdot(mp, name)
| Ldot (m, name) -> Pdot(mkpath mp m, name)
| _ -> assert false
in
let tl' =
@ -2330,7 +2373,7 @@ let rec package_signatures subst = function
let sg' = Subst.signature subst sg in
let oldid = Ident.create_persistent name
and newid = Ident.create_local name in
Sig_module(newid, {md_type=Mty_signature sg';
Sig_module(newid, Mp_present, {md_type=Mty_signature sg';
md_attributes=[];
md_loc=Location.none;
},

2
typing/typeopt.ml
View File

@ -121,7 +121,7 @@ let array_pattern_kind pat = array_type_kind pat.pat_env pat.pat_type
let bigarray_decode_type env ty tbl dfl =
match scrape env ty with
| Tconstr(Pdot(Pident mod_id, type_name, _), [], _)
| Tconstr(Pdot(Pident mod_id, type_name), [], _)
when Ident.name mod_id = "Stdlib__bigarray" ->
begin try List.assoc type_name tbl with Not_found -> dfl end
| _ ->

12
typing/types.ml
View File

@ -168,7 +168,7 @@ and record_representation =
| Record_float (* All fields are floats *)
| Record_unboxed of bool (* Unboxed single-field record, inlined or not *)
| Record_inlined of int (* Inlined record *)
| Record_extension (* Inlined record under extension *)
| Record_extension of Path.t (* Inlined record under extension *)
and label_declaration =
{
@ -258,11 +258,11 @@ type module_type =
Mty_ident of Path.t
| Mty_signature of signature
| Mty_functor of Ident.t * module_type option * module_type
| Mty_alias of alias_presence * Path.t
| Mty_alias of Path.t
and alias_presence =
| Mta_present
| Mta_absent
and module_presence =
| Mp_present
| Mp_absent
and signature = signature_item list
@ -270,7 +270,7 @@ and signature_item =
Sig_value of Ident.t * value_description
| Sig_type of Ident.t * type_declaration * rec_status
| Sig_typext of Ident.t * extension_constructor * ext_status
| Sig_module of Ident.t * module_declaration * rec_status
| Sig_module of Ident.t * module_presence * module_declaration * rec_status
| Sig_modtype of Ident.t * modtype_declaration
| Sig_class of Ident.t * class_declaration * rec_status
| Sig_class_type of Ident.t * class_type_declaration * rec_status

12
typing/types.mli
View File

@ -315,7 +315,7 @@ and record_representation =
| Record_float (* All fields are floats *)
| Record_unboxed of bool (* Unboxed single-field record, inlined or not *)
| Record_inlined of int (* Inlined record *)
| Record_extension (* Inlined record under extension *)
| Record_extension of Path.t (* Inlined record under extension *)
and label_declaration =
{
@ -410,11 +410,11 @@ type module_type =
Mty_ident of Path.t
| Mty_signature of signature
| Mty_functor of Ident.t * module_type option * module_type
| Mty_alias of alias_presence * Path.t
| Mty_alias of Path.t
and alias_presence =
| Mta_present
| Mta_absent
and module_presence =
| Mp_present
| Mp_absent
and signature = signature_item list
@ -422,7 +422,7 @@ and signature_item =
Sig_value of Ident.t * value_description
| Sig_type of Ident.t * type_declaration * rec_status
| Sig_typext of Ident.t * extension_constructor * ext_status
| Sig_module of Ident.t * module_declaration * rec_status
| Sig_module of Ident.t * module_presence * module_declaration * rec_status
| Sig_modtype of Ident.t * modtype_declaration
| Sig_class of Ident.t * class_declaration * rec_status
| Sig_class_type of Ident.t * class_type_declaration * rec_status

10
typing/typetexp.ml
View File

@ -100,7 +100,7 @@ let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a =
error (Wrong_use_of_module (mlid, `Functor_used_as_structure))
| Mty_ident _ ->
error (Wrong_use_of_module (mlid, `Abstract_used_as_structure))
| Mty_alias(_, p) -> error (Cannot_scrape_alias(mlid, p))
| Mty_alias p -> error (Cannot_scrape_alias(mlid, p))
| Mty_signature _ -> ()
end
| Longident.Lapply (flid, mlid) ->
@ -112,7 +112,7 @@ let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a =
error (Wrong_use_of_module (flid, `Structure_used_as_functor))
| Mty_ident _ ->
error (Wrong_use_of_module (flid, `Abstract_used_as_functor))
| Mty_alias(_, p) -> error (Cannot_scrape_alias(flid, p))
| Mty_alias p -> error (Cannot_scrape_alias(flid, p))
| Mty_functor (_, None, _) ->
error (Wrong_use_of_module (flid, `Generative_used_as_applicative))
| Mty_functor (_, Some mty_param, _) -> mty_param
@ -121,7 +121,7 @@ let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a =
let mpath = Env.lookup_module ~load:true mlid env in
let mmd = Env.find_module mpath env in
begin match Env.scrape_alias env mmd.md_type with
| Mty_alias(_, p) -> error (Cannot_scrape_alias(mlid, p))
| Mty_alias p -> error (Cannot_scrape_alias(mlid, p))
| mty_arg ->
let details =
try Includemod.check_modtype_inclusion
@ -891,7 +891,7 @@ let fold_types = fold_simple Env.fold_types
let fold_modules = fold_simple Env.fold_modules
let fold_constructors = fold_descr Env.fold_constructors (fun d -> d.cstr_name)
let fold_labels = fold_descr Env.fold_labels (fun d -> d.lbl_name)
let fold_classs = fold_simple Env.fold_classs
let fold_classes = fold_simple Env.fold_classes
let fold_modtypes = fold_simple Env.fold_modtypes
let fold_cltypes = fold_simple Env.fold_cltypes
@ -1000,7 +1000,7 @@ let report_error env ppf = function
spellcheck ppf fold_labels env lid;
| Unbound_class lid ->
fprintf ppf "Unbound class %a" longident lid;
spellcheck ppf fold_classs env lid;
spellcheck ppf fold_classes env lid;
| Unbound_modtype lid ->
fprintf ppf "Unbound module type %a" longident lid;
spellcheck ppf fold_modtypes env lid;

4
typing/untypeast.ml
View File

@ -98,7 +98,7 @@ let map_opt f = function None -> None | Some e -> Some (f e)
let rec lident_of_path = function
| Path.Pident id -> Longident.Lident (Ident.name id)
| Path.Pdot (p, s, _) -> Longident.Ldot (lident_of_path p, s)
| Path.Pdot (p, s) -> Longident.Ldot (lident_of_path p, s)
| Path.Papply (p1, p2) ->
Longident.Lapply (lident_of_path p1, lident_of_path p2)
@ -455,7 +455,7 @@ let expression sub exp =
Pexp_override (List.map (fun (_path, lid, exp) ->
(map_loc sub lid, sub.expr sub exp)
) list)
| Texp_letmodule (_id, name, mexpr, exp) ->
| Texp_letmodule (_id, name, _pres, mexpr, exp) ->
Pexp_letmodule (name, sub.module_expr sub mexpr,
sub.expr sub exp)
| Texp_letexception (ext, exp) ->