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 RHS_block sz
| Uprim (Pduprecord (Record_unboxed _, _), _, _) -> | Uprim (Pduprecord (Record_unboxed _, _), _, _) ->
assert false assert false
| Uprim (Pduprecord (Record_extension, sz), _, _) -> | Uprim (Pduprecord (Record_extension _, sz), _, _) ->
RHS_block (sz + 1) RHS_block (sz + 1)
| Uprim (Pduprecord (Record_float, sz), _, _) -> | Uprim (Pduprecord (Record_float, sz), _, _) ->
RHS_floatblock 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_regular | Record_inlined _ -> RHS_block size
| Record_unboxed _ -> assert false | Record_unboxed _ -> assert false
| Record_float -> RHS_floatblock size | Record_float -> RHS_floatblock size
| Record_extension -> RHS_block (size + 1) | Record_extension _ -> RHS_block (size + 1)
end end
| Llet(_str, _k, id, arg, body) -> | Llet(_str, _k, id, arg, body) ->
size_of_lambda (Ident.add id (size_of_lambda env arg) env) 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 RHS_block size
| Lprim (Pduprecord (Record_unboxed _, _), _, _) -> | Lprim (Pduprecord (Record_unboxed _, _), _, _) ->
assert false assert false
| Lprim (Pduprecord (Record_extension, size), _, _) -> | Lprim (Pduprecord (Record_extension _, size), _, _) ->
RHS_block (size + 1) RHS_block (size + 1)
| Lprim (Pduprecord (Record_float, size), _, _) -> RHS_floatblock size | Lprim (Pduprecord (Record_float, size), _, _) -> RHS_floatblock size
| Levent (lam, _) -> size_of_lambda env lam | 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 let root = Path.Pident (Ident.create_persistent prefix) in
rename_append_bytecode_list packagename oc mapping (id :: defined) rename_append_bytecode_list packagename oc mapping (id :: defined)
(ofs + size) prefix (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) subst)
rem rem

35
bytecomp/lambda.ml
View File

@ -14,7 +14,6 @@
(**************************************************************************) (**************************************************************************)
open Misc open Misc
open Path
open Asttypes open Asttypes
type compile_time_constant = type compile_time_constant =
@ -607,29 +606,31 @@ let rec patch_guarded patch = function
(* Translate an access path *) (* Translate an access path *)
let rec transl_normal_path = function let rec transl_address loc = function
Pident id -> | Env.Aident id ->
if Ident.global id if Ident.global id
then Lprim(Pgetglobal id, [], Location.none) then Lprim(Pgetglobal id, [], loc)
else Lvar id else Lvar id
| Pdot(p, _s, pos) -> | Env.Adot(addr, pos) ->
Lprim(Pfield pos, [transl_normal_path p], Location.none) Lprim(Pfield pos, [transl_address loc addr], loc)
| Papply _ ->
fatal_error "Lambda.transl_path"
(* 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 = let transl_module_path loc env path =
transl_normal_path (Env.normalize_path (Some loc) env path) transl_path Env.find_module_address loc env path
let transl_value_path ?(loc=Location.none) env path = let transl_value_path loc env path =
transl_normal_path (Env.normalize_path_prefix (Some loc) env path) transl_path Env.find_value_address loc env path
let transl_class_path = transl_value_path let transl_extension_path loc env path =
let transl_extension_path = transl_value_path transl_path Env.find_constructor_address loc env path
(* compatibility alias, deprecated in the .mli *) let transl_class_path loc env path =
let transl_path = transl_value_path transl_path Env.find_class_address loc env path
(* Compile a sequence of expressions *) (* 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 free_variables: lambda -> Ident.Set.t
val transl_normal_path: Path.t -> lambda (* Path.t is already normal *) val transl_module_path: Location.t -> Env.t -> Path.t -> lambda
val transl_path: ?loc:Location.t -> Env.t -> Path.t -> lambda val transl_value_path: Location.t -> Env.t -> Path.t -> lambda
[@@ocaml.deprecated "use transl_{module,value,extension,class}_path instead"] val transl_extension_path: Location.t -> Env.t -> Path.t -> lambda
val transl_class_path: Location.t -> Env.t -> Path.t -> lambda
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 make_sequence: ('a -> lambda) -> 'a list -> 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 = let get_mod_field modname field =
lazy ( lazy (
try match Env.open_pers_signature modname Env.initial_safe_string with
let mod_ident = Ident.create_persistent modname in | exception Not_found -> fatal_error ("Module "^modname^" unavailable.")
let env = Env.open_pers_signature modname Env.initial_safe_string in | env -> begin
let p = try
match Env.lookup_value (Longident.Lident field) env with match Env.lookup_value (Longident.Lident field) env with
| (Path.Pdot(_,_,i), _) -> i | exception Not_found ->
| _ -> fatal_error ("Primitive "^modname^"."^field^" not found.") fatal_error ("Primitive "^modname^"."^field^" not found.")
with Not_found -> | (path, _) -> transl_value_path Location.none env path
fatal_error ("Primitive "^modname^"."^field^" not found.") end
in
Lprim(Pfield p,
[Lprim(Pgetglobal mod_ident, [], Location.none)],
Location.none)
with Not_found -> fatal_error ("Module "^modname^" unavailable.")
) )
let code_force_lazy_block = 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) Lprim (Pfield lbl.lbl_pos, [arg], loc)
| Record_unboxed _ -> arg | Record_unboxed _ -> arg
| Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [arg], loc) | 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 in
let str = let str =
match lbl.lbl_mut with match lbl.lbl_mut with
@ -2357,7 +2351,7 @@ let combine_constructor loc arg ex_pat cstr partial ctx def
let tests = let tests =
List.fold_right List.fold_right
(fun (path, act) rem -> (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), Lifthenelse(Lprim(Pintcomp Ceq, [Lvar tag; ext], loc),
act, rem)) act, rem))
nonconsts nonconsts
@ -2367,7 +2361,7 @@ let combine_constructor loc arg ex_pat cstr partial ctx def
in in
List.fold_right List.fold_right
(fun (path, act) rem -> (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), Lifthenelse(Lprim(Pintcomp Ceq, [arg; ext], loc),
act, rem)) act, rem))
consts consts
@ -2943,13 +2937,16 @@ let compile_matching repr handler_fun arg pat_act_list partial =
let partial_function loc () = 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 let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in
Lprim(Praise Raise_regular, [Lprim(Pmakeblock(0, Immutable, None), Lprim(Praise Raise_regular, [Lprim(Pmakeblock(0, Immutable, None),
[transl_normal_path Predef.path_match_failure; [slot; Lconst(Const_block(0,
Lconst(Const_block(0, [Const_base(Const_string (fname, None));
[Const_base(Const_string (fname, None)); Const_base(Const_int line);
Const_base(Const_int line); Const_base(Const_int char)]))], loc)], loc)
Const_base(Const_int char)]))], loc)], loc)
let for_function loc repr param pat_act_list partial = let for_function loc repr param pat_act_list partial =
compile_matching repr (partial_function loc) 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 false -> fprintf ppf "unboxed"
| Record_unboxed true -> fprintf ppf "inlined(unboxed)" | Record_unboxed true -> fprintf ppf "inlined(unboxed)"
| Record_float -> fprintf ppf "float" | 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 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 | Tpat_alias(_, id, _) -> id
| _ -> Ident.create_local default | _ -> 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 = let rec build_object_init cl_table obj params inh_init obj_init cl =
match cl.cl_desc with match cl.cl_desc with
Tcl_ident ( path, _, _) -> Tcl_ident (path, _, _) ->
let obj_init = Ident.create_local "obj_init" in let obj_init = Ident.create_local "obj_init" in
let envs, inh_init = inh_init in let envs, inh_init = inh_init in
let env = let env =
@ -134,8 +131,8 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
[Lvar envs], [Lvar envs],
Location.none)] Location.none)]
in in
((envs, (obj_init, normalize_cl_path cl path) let path_lam = transl_class_path cl.cl_loc cl.cl_env path in
::inh_init), ((envs, (path, path_lam, obj_init) :: inh_init),
mkappl(Lvar obj_init, env @ [obj])) mkappl(Lvar obj_init, env @ [obj]))
| Tcl_structure str -> | Tcl_structure str ->
create_object cl_table obj (fun obj -> 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 = let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
match cl.cl_desc with match cl.cl_desc with
Tcl_ident ( path, _, _) -> | Tcl_ident _ ->
begin match inh_init with begin match inh_init with
(obj_init, _path')::inh_init -> | (_, path_lam, obj_init)::inh_init ->
let lpath = transl_class_path ~loc:cl.cl_loc cl.cl_env path in
(inh_init, (inh_init,
Llet (Strict, Pgenval, obj_init, Llet (Strict, Pgenval, obj_init,
mkappl(Lprim(Pfield 1, [lpath], Location.none), Lvar cla :: mkappl(Lprim(Pfield 1, [path_lam], Location.none), Lvar cla ::
if top then [Lprim(Pfield 3, [lpath], Location.none)] if top then [Lprim(Pfield 3, [path_lam], Location.none)]
else []), else []),
bind_super cla super cl_init)) 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 transl_meth_list concr_meths] in
let cl = ignore_cstrs cl in let cl = ignore_cstrs cl in
begin match cl.cl_desc, inh_init with begin match cl.cl_desc, inh_init with
Tcl_ident (path, _, _), (obj_init, path')::inh_init -> | Tcl_ident (path, _, _), (path', path_lam, obj_init)::inh_init ->
assert (Path.same (normalize_cl_path cl path) path'); assert (Path.same path path');
let lpath = transl_normal_path path' in
let inh = Ident.create_local "inh" let inh = Ident.create_local "inh"
and ofs = List.length vals + 1 and ofs = List.length vals + 1
and valids, methids = super in 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, (inh_init,
Llet (Strict, Pgenval, inh, Llet (Strict, Pgenval, inh,
mkappl(oo_prim "inherits", narrow_args @ 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))) Llet(StrictOpt, Pgenval, obj_init, lfield inh 0, cl_init)))
| _ -> | _ ->
let core 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 try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit
with Not_found -> raise Exit with Not_found -> raise Exit
end; 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) -> | 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 build params rem =
let param = name_pattern "param" pat in let param = name_pattern "param" pat in
Lfunction {kind = Curried; params = param::params; Lfunction {kind = Curried; params = param::params;
@ -430,37 +427,39 @@ let rec transl_class_rebind obj_init cl vf =
body = Matching.for_function body = Matching.for_function
pat.pat_loc None (Lvar param) [pat, rem] partial} pat.pat_loc None (Lvar param) [pat, rem] partial}
in in
(path, (path, path_lam,
match obj_init with match obj_init with
Lfunction {kind = Curried; params; body} -> build params body Lfunction {kind = Curried; params; body} -> build params body
| rem -> build [] rem) | rem -> build [] rem)
| Tcl_apply (cl, oexprs) -> | Tcl_apply (cl, oexprs) ->
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
(path, transl_apply obj_init oexprs Location.none) (path, path_lam, transl_apply obj_init oexprs Location.none)
| Tcl_let (rec_flag, defs, _vals, cl) -> | Tcl_let (rec_flag, defs, _vals, 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
(path, Translcore.transl_let rec_flag defs obj_init) (path, path_lam, Translcore.transl_let rec_flag defs obj_init)
| Tcl_structure _ -> raise Exit | Tcl_structure _ -> raise Exit
| Tcl_constraint (cl', _, _, _, _) -> | 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 let rec check_constraint = function
Cty_constr(path', _, _) when Path.same path path' -> () Cty_constr(path', _, _) when Path.same path path' -> ()
| Cty_arrow (_, _, cty) -> check_constraint cty | Cty_arrow (_, _, cty) -> check_constraint cty
| _ -> raise Exit | _ -> raise Exit
in in
check_constraint cl.cl_type; check_constraint cl.cl_type;
(path, obj_init) (path, path_lam, obj_init)
| Tcl_open (_, _, _, _, cl) -> | Tcl_open (_, _, _, _, cl) ->
transl_class_rebind obj_init cl vf transl_class_rebind obj_init cl vf
let rec transl_class_rebind_0 self obj_init cl vf = let rec transl_class_rebind_0 self obj_init cl vf =
match cl.cl_desc with match cl.cl_desc with
Tcl_let (rec_flag, defs, _vals, cl) -> Tcl_let (rec_flag, defs, _vals, cl) ->
let path, obj_init = transl_class_rebind_0 self obj_init cl vf in let path, path_lam, obj_init =
(path, Translcore.transl_let rec_flag defs 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 let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in
(path, lfunction [self] obj_init) (path, path_lam, lfunction [self] obj_init)
let transl_class_rebind cl vf = let transl_class_rebind cl vf =
try try
@ -474,9 +473,9 @@ let transl_class_rebind cl vf =
ap_inlined=Default_inline; ap_inlined=Default_inline;
ap_specialised=Default_specialise} ap_specialised=Default_specialise}
in 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 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" let cla = Ident.create_local "class"
and new_init = Ident.create_local "new_init" and new_init = Ident.create_local "new_init"
@ -486,7 +485,7 @@ let transl_class_rebind cl vf =
Llet( Llet(
Strict, Pgenval, new_init, lfunction [obj_init] obj_init', Strict, Pgenval, new_init, lfunction [obj_init] obj_init',
Llet( Llet(
Alias, Pgenval, cla, transl_normal_path path, Alias, Pgenval, cla, path_lam,
Lprim(Pmakeblock(0, Immutable, None), Lprim(Pmakeblock(0, Immutable, None),
[mkappl(Lvar new_init, [lfield cla 0]); [mkappl(Lvar new_init, [lfield cla 0]);
lfunction [table] lfunction [table]
@ -818,7 +817,7 @@ let transl_class ids cl_id pub_meths cl vflag =
Location.none) Location.none)
and linh_envs = and linh_envs =
List.map 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) (List.rev inh_init)
in in
let make_envs lam = let make_envs lam =
@ -834,11 +833,11 @@ let transl_class ids cl_id pub_meths cl vflag =
in in
let inh_paths = let inh_paths =
List.filter 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 in
let inh_keys = let inh_keys =
List.map (fun (_,p) -> Lprim(Pfield 1, [transl_normal_path p], List.map
Location.none)) (fun (_, path_lam, _) -> Lprim(Pfield 1, [path_lam], Location.none))
inh_paths inh_paths
in in
let lclass lam = 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)], Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))], loc)],
loc) loc)
| Text_rebind(path, _lid) -> | Text_rebind(path, _lid) ->
transl_extension_path ~loc env path transl_extension_path loc env path
(* To propagate structured constants *) (* To propagate structured constants *)
@ -84,7 +84,7 @@ let extract_float = function
type binding = type binding =
| Bind_value of value_binding list | 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 = let rec push_defaults loc bindings cases partial =
match cases with match cases with
@ -105,8 +105,9 @@ let rec push_defaults loc bindings cases partial =
| [{c_lhs=pat; c_guard=None; | [{c_lhs=pat; c_guard=None;
c_rhs={exp_attributes=[{Parsetree.attr_name = {txt="#modulepat"};_}]; c_rhs={exp_attributes=[{Parsetree.attr_name = {txt="#modulepat"};_}];
exp_desc = Texp_letmodule exp_desc = Texp_letmodule
(id, name, mexpr, ({exp_desc = Texp_function _} as e2))}}] -> (id, name, pres, mexpr,
push_defaults loc (Bind_module (id, name, mexpr) :: bindings) ({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}] [{c_lhs=pat;c_guard=None;c_rhs=e2}]
partial partial
| [case] -> | [case] ->
@ -116,23 +117,25 @@ let rec push_defaults loc bindings cases partial =
{exp with exp_desc = {exp with exp_desc =
match binds with match binds with
| Bind_value binds -> Texp_let(Nonrecursive, binds, exp) | Bind_value binds -> Texp_let(Nonrecursive, binds, exp)
| Bind_module (id, name, mexpr) -> | Bind_module (id, name, pres, mexpr) ->
Texp_letmodule (id, name, mexpr, exp)}) Texp_letmodule (id, name, pres, mexpr, exp)})
case.c_rhs bindings case.c_rhs bindings
in in
[{case with c_rhs=exp}] [{case with c_rhs=exp}]
| {c_lhs=pat; c_rhs=exp; c_guard=_} :: _ when bindings <> [] -> | {c_lhs=pat; c_rhs=exp; c_guard=_} :: _ when bindings <> [] ->
let param = Typecore.name_cases "param" cases in 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 name = Ident.name param in
let exp = let exp =
{ exp with exp_loc = loc; exp_desc = { exp with exp_loc = loc; exp_env = env; exp_desc =
Texp_match Texp_match
({exp with exp_type = pat.pat_type; exp_desc = ({exp with exp_type = pat.pat_type; exp_env = env; exp_desc =
Texp_ident (Path.Pident param, mknoloc (Longident.Lident name), Texp_ident
{val_type = pat.pat_type; val_kind = Val_reg; (Path.Pident param, mknoloc (Longident.Lident name), desc)},
val_attributes = [];
Types.val_loc = Location.none;
})},
cases, partial) } cases, partial) }
in in
push_defaults loc bindings push_defaults loc bindings
@ -163,11 +166,16 @@ let event_function exp lam =
(* Assertions *) (* Assertions *)
let assert_failed exp = let assert_failed exp =
let slot =
transl_extension_path Location.none
Env.initial_safe_string Predef.path_assert_failure
in
let (fname, line, char) = 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(Praise Raise_regular, [event_after exp
(Lprim(Pmakeblock(0, Immutable, None), (Lprim(Pmakeblock(0, Immutable, None),
[transl_normal_path Predef.path_assert_failure; [slot;
Lconst(Const_block(0, Lconst(Const_block(0,
[Const_base(Const_string (fname, None)); [Const_base(Const_string (fname, None));
Const_base(Const_int line); Const_base(Const_int line);
@ -207,7 +215,7 @@ and transl_exp0 e =
| Texp_ident(_, _, {val_kind = Val_anc _}) -> | Texp_ident(_, _, {val_kind = Val_anc _}) ->
raise(Error(e.exp_loc, Free_super_var)) raise(Error(e.exp_loc, Free_super_var))
| Texp_ident(path, _, {val_kind = Val_reg | Val_self _}) -> | 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_ident _ -> fatal_error "Translcore.transl_exp: bad Texp_ident"
| Texp_constant cst -> | Texp_constant cst ->
Lconst(Const_base cst) Lconst(Const_base cst)
@ -304,14 +312,14 @@ and transl_exp0 e =
Lprim(Pmakeblock(n, Immutable, Some shape), ll, e.exp_loc) Lprim(Pmakeblock(n, Immutable, Some shape), ll, e.exp_loc)
end end
| Cstr_extension(path, is_const) -> | Cstr_extension(path, is_const) ->
if is_const then let lam = transl_extension_path e.exp_loc e.exp_env path in
transl_extension_path e.exp_env path if is_const then lam
else else
Lprim(Pmakeblock(0, Immutable, Some (Pgenval :: shape)), Lprim(Pmakeblock(0, Immutable, Some (Pgenval :: shape)),
transl_extension_path e.exp_env path :: ll, e.exp_loc) lam :: ll, e.exp_loc)
end end
| Texp_extension_constructor (_, path) -> | 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) -> | Texp_variant(l, arg) ->
let tag = Btype.hash_variant l in let tag = Btype.hash_variant l in
begin match arg with begin match arg with
@ -335,7 +343,7 @@ and transl_exp0 e =
Lprim (Pfield lbl.lbl_pos, [targ], e.exp_loc) Lprim (Pfield lbl.lbl_pos, [targ], e.exp_loc)
| Record_unboxed _ -> targ | Record_unboxed _ -> targ
| Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [targ], e.exp_loc) | 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) Lprim (Pfield (lbl.lbl_pos + 1), [targ], e.exp_loc)
end end
| Texp_setfield(arg, _, lbl, newval) -> | Texp_setfield(arg, _, lbl, newval) ->
@ -346,7 +354,7 @@ and transl_exp0 e =
Psetfield(lbl.lbl_pos, maybe_pointer newval, Assignment) Psetfield(lbl.lbl_pos, maybe_pointer newval, Assignment)
| Record_unboxed _ -> assert false | Record_unboxed _ -> assert false
| Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment) | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment)
| Record_extension -> | Record_extension _ ->
Psetfield (lbl.lbl_pos + 1, maybe_pointer newval, Assignment) Psetfield (lbl.lbl_pos + 1, maybe_pointer newval, Assignment)
in in
Lprim(access, [transl_exp arg; transl_exp newval], e.exp_loc) 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; Lapply{ap_should_be_tailcall=false;
ap_loc=loc; ap_loc=loc;
ap_func= 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_args=[lambda_unit];
ap_inlined=Default_inline; ap_inlined=Default_inline;
ap_specialised=Default_specialise} ap_specialised=Default_specialise}
| Texp_instvar(path_self, path, _) -> | Texp_instvar(path_self, path, _) ->
Lprim(Pfield_computed, let self = transl_value_path e.exp_loc e.exp_env path_self in
[transl_normal_path path_self; transl_normal_path path], e.exp_loc) 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) -> | 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) -> | 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 let cpy = Ident.create_local "copy" in
Llet(Strict, Pgenval, cpy, Llet(Strict, Pgenval, cpy,
Lapply{ap_should_be_tailcall=false; Lapply{ap_should_be_tailcall=false;
ap_loc=Location.none; ap_loc=Location.none;
ap_func=Translobj.oo_prim "copy"; ap_func=Translobj.oo_prim "copy";
ap_args=[transl_normal_path path_self]; ap_args=[self];
ap_inlined=Default_inline; ap_inlined=Default_inline;
ap_specialised=Default_specialise}, ap_specialised=Default_specialise},
List.fold_right List.fold_right
(fun (path, _, expr) rem -> (fun (path, _, expr) rem ->
let var = transl_value_path e.exp_loc e.exp_env path in
Lsequence(transl_setinstvar Location.none Lsequence(transl_setinstvar Location.none
(Lvar cpy) path expr, rem)) (Lvar cpy) var expr, rem))
modifs modifs
(Lvar cpy)) (Lvar cpy))
| Texp_letmodule(id, loc, modl, body) -> | Texp_letmodule(id, loc, Mp_present, modl, body) ->
let defining_expr = let defining_expr =
Levent (!transl_module Tcoerce_none None modl, { Levent (!transl_module Tcoerce_none None modl, {
lev_loc = loc.loc; lev_loc = loc.loc;
@ -460,6 +473,8 @@ and transl_exp0 e =
}) })
in in
Llet(Strict, Pgenval, id, defining_expr, transl_exp body) Llet(Strict, Pgenval, id, defining_expr, transl_exp body)
| Texp_letmodule(_, _, Mp_absent, _, body) ->
transl_exp body
| Texp_letexception(cd, body) -> | Texp_letexception(cd, body) ->
Llet(Strict, Pgenval, Llet(Strict, Pgenval,
cd.ext_id, transl_extension_constructor e.exp_env None cd, 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 = and transl_setinstvar loc self var expr =
Lprim(Psetfield_computed (maybe_pointer expr, Assignment), 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 = and transl_record loc env fields repres opt_init_expr =
let size = Array.length fields in let size = Array.length fields in
@ -730,7 +745,7 @@ and transl_record loc env fields repres opt_init_expr =
match repres with match repres with
Record_regular | Record_inlined _ -> Pfield i Record_regular | Record_inlined _ -> Pfield i
| Record_unboxed _ -> assert false | Record_unboxed _ -> assert false
| Record_extension -> Pfield (i + 1) | Record_extension _ -> Pfield (i + 1)
| Record_float -> Pfloatfield i in | Record_float -> Pfloatfield i in
Lprim(access, [Lvar init_id], loc), field_kind Lprim(access, [Lvar init_id], loc), field_kind
| Overridden (_lid, expr) -> | 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_unboxed _ -> Lconst(match cl with [v] -> v | _ -> assert false)
| Record_float -> | Record_float ->
Lconst(Const_float_array(List.map extract_float cl)) Lconst(Const_float_array(List.map extract_float cl))
| Record_extension -> | Record_extension _ ->
raise Not_constant raise Not_constant
with Not_constant -> with Not_constant ->
match repres with 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_unboxed _ -> (match ll with [v] -> v | _ -> assert false)
| Record_float -> | Record_float ->
Lprim(Pmakearray (Pfloatarray, mut), ll, loc) Lprim(Pmakearray (Pfloatarray, mut), ll, loc)
| Record_extension -> | Record_extension path ->
let path = let slot = transl_extension_path loc env path in
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
Lprim(Pmakeblock(0, mut, Some (Pgenval :: shape)), slot :: ll, loc) Lprim(Pmakeblock(0, mut, Some (Pgenval :: shape)), slot :: ll, loc)
in in
begin match opt_init_expr with 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) Psetfield(lbl.lbl_pos, maybe_pointer expr, Assignment)
| Record_unboxed _ -> assert false | Record_unboxed _ -> assert false
| Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment) | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment)
| Record_extension -> | Record_extension _ ->
Psetfield(lbl.lbl_pos + 1, maybe_pointer expr, Assignment) Psetfield(lbl.lbl_pos + 1, maybe_pointer expr, Assignment)
in in
Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr], loc), cont) 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 = let field_path path field =
match path with match path with
None -> None None -> None
| Some p -> Some(Pdot(p, Ident.name field, Path.nopos)) | Some p -> Some(Pdot(p, Ident.name field))
(* Compile type extensions *) (* 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 apply_coercion_result loc strict arg [param] [carg] cc_res
| Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } -> | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } ->
Translprim.transl_primitive pc_loc pc_desc pc_env pc_type None 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 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) = and apply_coercion_field loc get_field (pos, cc) =
apply_coercion loc Alias cc (get_field pos) apply_coercion loc Alias cc (get_field pos)
@ -151,17 +152,22 @@ let rec compose_coercions c1 c2 =
in in
Tcoerce_structure Tcoerce_structure
(List.map (List.map
(function (p1, Tcoerce_primitive p) -> (fun pc ->
(p1, Tcoerce_primitive p) match pc with
| (p1, c1) -> | _, (Tcoerce_primitive _ | Tcoerce_alias _) ->
let (p2, c2) = v2.(p1) in (p2, compose_coercions c1 c2)) (* These cases do not take an argument (the position is -1),
pc1, so they do not need adjusting. *)
pc
| (p1, c1) ->
let (p2, c2) = v2.(p1) in
(p2, compose_coercions c1 c2))
pc1,
ids1 @ ids2) ids1 @ ids2)
| (Tcoerce_functor(arg1, res1), Tcoerce_functor(arg2, res2)) -> | (Tcoerce_functor(arg1, res1), Tcoerce_functor(arg2, res2)) ->
Tcoerce_functor(compose_coercions arg2 arg1, Tcoerce_functor(compose_coercions arg2 arg1,
compose_coercions res1 res2) compose_coercions res1 res2)
| (c1, Tcoerce_alias (path, c2)) -> | (c1, Tcoerce_alias (env, path, c2)) ->
Tcoerce_alias (path, compose_coercions c1 c2) Tcoerce_alias (env, path, compose_coercions c1 c2)
| (_, _) -> | (_, _) ->
fatal_error "Translmod.compose_coercions" fatal_error "Translmod.compose_coercions"
@ -190,12 +196,12 @@ let record_primitive = function
(* Utilities for compiling "module rec" definitions *) (* Utilities for compiling "module rec" definitions *)
let mod_prim name = let mod_prim name =
try let env = Env.empty in
transl_normal_path let lid = Ldot (Lident "CamlinternalMod", name) in
(fst (Env.lookup_value (Ldot (Lident "CamlinternalMod", name)) match Env.lookup_value lid env with
Env.empty)) | path, _ -> transl_value_path Location.none env path
with Not_found -> | exception Not_found ->
fatal_error ("Primitive " ^ name ^ " not found.") fatal_error ("Primitive " ^ name ^ " not found.")
let undefined_location loc = let undefined_location loc =
let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in 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 = let rec init_shape_mod subid loc env mty =
match Mtype.scrape env mty with match Mtype.scrape env mty with
Mty_ident _ Mty_ident _
| Mty_alias (Mta_present, _) -> | Mty_alias _ ->
raise (Initialization_failure {reason=Unsafe_module_binding;loc;subid}) raise (Initialization_failure {reason=Unsafe_module_binding;loc;subid})
| Mty_alias (Mta_absent, _) ->
Const_block (1, [Const_pointer 0])
| Mty_signature sg -> | Mty_signature sg ->
Const_block(0, [Const_block(0, init_shape_struct env sg)]) Const_block(0, [Const_block(0, init_shape_struct env sg)])
| Mty_functor _ -> | Mty_functor _ ->
@ -241,10 +245,14 @@ let init_shape id modl =
init_shape_struct (Env.add_type ~check:false id tdecl env) rem init_shape_struct (Env.add_type ~check:false id tdecl env) rem
| Sig_typext (subid, {ext_loc=loc},_) :: _ -> | Sig_typext (subid, {ext_loc=loc},_) :: _ ->
raise (Initialization_failure {reason=Unsafe_typext; loc; subid}) 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_mod id md.md_loc env md.md_type ::
init_shape_struct (Env.add_module_declaration ~check:false 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 -> | Sig_modtype(id, minfo) :: rem ->
init_shape_struct (Env.add_modtype id minfo env) rem init_shape_struct (Env.add_modtype id minfo env) rem
| Sig_class _ :: rem -> | Sig_class _ :: rem ->
@ -373,7 +381,8 @@ let rec bound_value_identifiers = function
| Sig_value(id, {val_kind = Val_reg}) :: rem -> | Sig_value(id, {val_kind = Val_reg}) :: rem ->
id :: bound_value_identifiers rem id :: bound_value_identifiers rem
| Sig_typext(id, _, _) :: 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 | Sig_class(id, _, _) :: rem -> id :: bound_value_identifiers rem
| _ :: rem -> 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) List.iter (Translattribute.check_attribute_on_module mexp)
mexp.mod_attributes; mexp.mod_attributes;
let loc = mexp.mod_loc in let loc = mexp.mod_loc in
match mexp.mod_type with match mexp.mod_desc with
Mty_alias (Mta_absent, _) -> apply_coercion loc Alias cc lambda_unit | Tmod_ident (path,_) ->
| _ -> apply_coercion loc Strict cc
match mexp.mod_desc with (transl_module_path loc mexp.mod_env path)
Tmod_ident (path,_) -> | Tmod_structure str ->
apply_coercion loc Strict cc fst (transl_struct loc [] cc rootpath str)
(transl_module_path ~loc mexp.mod_env path) | Tmod_functor _ ->
| Tmod_structure str -> oo_wrap mexp.mod_env true (fun () ->
fst (transl_struct loc [] cc rootpath str) compile_functor mexp cc rootpath loc) ()
| Tmod_functor _ -> | Tmod_apply(funct, arg, ccarg) ->
oo_wrap mexp.mod_env true (fun () -> let inlined_attribute, funct =
compile_functor mexp cc rootpath loc) () Translattribute.get_and_remove_inlined_attribute_on_module funct
| Tmod_apply(funct, arg, ccarg) -> in
let inlined_attribute, funct = oo_wrap mexp.mod_env true
Translattribute.get_and_remove_inlined_attribute_on_module funct (apply_coercion loc Strict cc)
in (Lapply{ap_should_be_tailcall=false;
oo_wrap mexp.mod_env true ap_loc=loc;
(apply_coercion loc Strict cc) ap_func=transl_module Tcoerce_none None funct;
(Lapply{ap_should_be_tailcall=false; ap_args=[transl_module ccarg None arg];
ap_loc=loc; ap_inlined=inlined_attribute;
ap_func=transl_module Tcoerce_none None funct; ap_specialised=Default_specialise})
ap_args=[transl_module ccarg None arg]; | Tmod_constraint(arg, _, _, ccarg) ->
ap_inlined=inlined_attribute; transl_module (compose_coercions cc ccarg) rootpath arg
ap_specialised=Default_specialise}) | Tmod_unpack(arg, _) ->
| Tmod_constraint(arg, _, _, ccarg) -> apply_coercion loc Strict cc (Translcore.transl_exp arg)
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 = and transl_struct loc fields cc rootpath str =
transl_structure loc fields cc rootpath str.str_final_env str.str_items 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; fields;
Format.eprintf "@]@.";*) Format.eprintf "@]@.";*)
let v = Array.of_list (List.rev fields) in let v = Array.of_list (List.rev fields) in
let get_field pos = Lvar v.(pos) let get_field pos =
and ids = List.fold_right Ident.Set.add fields Ident.Set.empty in 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 = let lam =
Lprim(Pmakeblock(0, Immutable, None), Lprim(Pmakeblock(0, Immutable, None),
List.map List.map
@ -581,7 +590,7 @@ and transl_structure loc fields cc rootpath final_env = function
path path
ext.tyexn_constructor, body), ext.tyexn_constructor, body),
size size
| Tstr_module mb -> | Tstr_module ({mb_presence=Mp_present} as mb) ->
let id = mb.mb_id in let id = mb.mb_id in
(* Translate module first *) (* Translate module first *)
let module_body = 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, Llet(pure_module mb.mb_expr, Pgenval, id,
module_body, module_body,
body), size body), size
| Tstr_module {mb_presence=Mp_absent} ->
transl_structure loc fields cc rootpath final_env rem
| Tstr_recmodule bindings -> | Tstr_recmodule bindings ->
let ext_fields = let ext_fields =
List.rev_append (List.map (fun mb -> mb.mb_id) bindings) 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 List.map (fun ext -> ext.ext_id) tyext.tyext_constructors
@ defined_idents rem @ defined_idents rem
| Tstr_exception ext -> ext.tyexn_constructor.ext_id :: 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 -> | Tstr_recmodule decls ->
List.map (fun mb -> mb.mb_id) decls @ defined_idents rem List.map (fun mb -> mb.mb_id) decls @ defined_idents rem
| Tstr_modtype _ -> 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 all_idents str.str_items @ more_idents rem
| Tstr_include _ -> more_idents rem | Tstr_include _ -> more_idents rem
| Tstr_module {mb_expr={mod_desc = Tmod_structure str}} | Tstr_module
| Tstr_module{mb_expr={mod_desc = {mb_presence=Mp_present; mb_expr={mod_desc = Tmod_structure str}}
Tmod_constraint ({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 all_idents str.str_items @ more_idents rem
| Tstr_module _ -> more_idents rem | Tstr_module _ -> more_idents rem
| Tstr_attribute _ -> more_idents rem | Tstr_attribute _ -> more_idents rem
@ -821,13 +835,16 @@ and all_idents = function
| Tstr_include incl -> | Tstr_include incl ->
bound_value_identifiers incl.incl_type @ all_idents rem bound_value_identifiers incl.incl_type @ all_idents rem
| Tstr_module {mb_id;mb_expr={mod_desc = Tmod_structure str}} | Tstr_module
| Tstr_module{mb_id; {mb_id;mb_presence=Mp_present;mb_expr={mod_desc = Tmod_structure str}}
mb_expr={mod_desc = | Tstr_module
Tmod_constraint ({mod_desc = Tmod_structure str}, {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 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 | Tstr_attribute _ -> all_idents rem
@ -860,29 +877,31 @@ let field_of_str loc str =
| _ -> apply_coercion loc Strict cc (Lvar ids.(pos)) | _ -> 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 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; transl_store_subst := subst;
lambda_unit Lambda.subst no_env_update subst cont
| item :: rem -> | item :: rem ->
match item.str_desc with match item.str_desc with
| Tstr_eval (expr, _attrs) -> | Tstr_eval (expr, _attrs) ->
Lsequence(Lambda.subst no_env_update subst (transl_exp expr), 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) -> | Tstr_value(rec_flag, pat_expr_list) ->
let ids = let_bound_idents pat_expr_list in let ids = let_bound_idents pat_expr_list in
let lam = 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 in
Lsequence(Lambda.subst no_env_update subst lam, 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 -> | Tstr_primitive descr ->
record_primitive descr.val_val; record_primitive descr.val_val;
transl_store rootpath subst rem transl_store rootpath subst cont rem
| Tstr_type _ -> | Tstr_type _ ->
transl_store rootpath subst rem transl_store rootpath subst cont rem
| Tstr_typext(tyext) -> | Tstr_typext(tyext) ->
let ids = let ids =
List.map (fun ext -> ext.ext_id) tyext.tyext_constructors 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) (store_idents Location.none ids)
in in
Lsequence(Lambda.subst no_env_update subst lam, 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 -> | Tstr_exception ext ->
let id = ext.tyexn_constructor.ext_id in let id = ext.tyexn_constructor.ext_id in
let path = field_path rootpath 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, Lsequence(Llet(Strict, Pgenval, id,
Lambda.subst no_env_update subst lam, Lambda.subst no_env_update subst lam,
store_ident ext.tyexn_constructor.ext_loc id), store_ident ext.tyexn_constructor.ext_loc id),
transl_store rootpath (add_ident false id subst) rem) transl_store rootpath
| Tstr_module{mb_id=id;mb_loc=loc; (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_expr={mod_desc = Tmod_structure str} as mexp;
mb_attributes} -> mb_attributes} ->
List.iter (Translattribute.check_attribute_on_module mexp) List.iter (Translattribute.check_attribute_on_module mexp)
mb_attributes; mb_attributes;
let lam = 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 in
(* Careful: see next case *) (* Careful: see next case *)
let subst = !transl_store_subst in let subst = !transl_store_subst in
@ -924,9 +946,9 @@ let transl_store_structure glob map prims str =
Lsequence(store_ident loc id, Lsequence(store_ident loc id,
transl_store rootpath transl_store rootpath
(add_ident true id subst) (add_ident true id subst)
rem))) cont rem)))
| Tstr_module{ | Tstr_module{
mb_id=id;mb_loc=loc; mb_id=id;mb_loc=loc;mb_presence=Mp_present;
mb_expr= { mb_expr= {
mod_desc = Tmod_constraint ( mod_desc = Tmod_constraint (
{mod_desc = Tmod_structure str} as mexp, _, _, {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) List.iter (Translattribute.check_attribute_on_module mexp)
mb_attributes; mb_attributes;
let lam = 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 in
(* Careful: see next case *) (* Careful: see next case *)
let subst = !transl_store_subst in let subst = !transl_store_subst in
@ -951,8 +974,10 @@ let transl_store_structure glob map prims str =
Lsequence(store_ident loc id, Lsequence(store_ident loc id,
transl_store rootpath transl_store rootpath
(add_ident true id subst) (add_ident true id subst)
rem))) cont rem)))
| Tstr_module{mb_id=id; mb_expr=modl; mb_loc=loc; mb_attributes} -> | Tstr_module
{mb_id=id; mb_presence=Mp_present; mb_expr=modl;
mb_loc=loc; mb_attributes} ->
let lam = let lam =
Translattribute.add_inline_attribute Translattribute.add_inline_attribute
(transl_module Tcoerce_none (field_path rootpath id) modl) (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). *) (add_ident true adds id -> Pgetglobal... to subst). *)
Llet(Strict, Pgenval, id, Lambda.subst no_env_update subst lam, Llet(Strict, Pgenval, id, Lambda.subst no_env_update subst lam,
Lsequence(store_ident loc id, 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 -> | Tstr_recmodule bindings ->
let ids = List.map (fun mb -> mb.mb_id) bindings in let ids = List.map (fun mb -> mb.mb_id) bindings in
compile_recmodule compile_recmodule
@ -976,14 +1004,16 @@ let transl_store_structure glob map prims str =
(field_path rootpath id) modl)) (field_path rootpath id) modl))
bindings bindings
(Lsequence(store_idents Location.none ids, (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 -> | Tstr_class cl_list ->
let (ids, class_bindings) = transl_class_bindings cl_list in let (ids, class_bindings) = transl_class_bindings cl_list in
let lam = let lam =
Lletrec(class_bindings, store_idents Location.none ids) Lletrec(class_bindings, store_idents Location.none ids)
in in
Lsequence(Lambda.subst no_env_update subst lam, 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{ | Tstr_include{
incl_loc=loc; 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? (* Shouldn't we use mod_attributes instead of incl_attributes?
Same question for the Tstr_module cases above, btw. *) Same question for the Tstr_module cases above, btw. *)
let lam = 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 (* It is tempting to pass rootpath instead of None
in order to give a more precise name to exceptions in order to give a more precise name to exceptions
in the included structured, but this would introduce 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 = let rec loop ids args =
match ids, args with 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 -> | id :: ids, arg :: args ->
Llet(Alias, Pgenval, id, Llet(Alias, Pgenval, id,
Lambda.subst no_env_update subst (field arg), 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 mid = Ident.create_local "include" in
let loc = incl.incl_loc in let loc = incl.incl_loc in
let rec store_idents pos = function 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 -> | id :: idl ->
Llet(Alias, Pgenval, id, Lprim(Pfield pos, [Lvar mid], loc), Llet(Alias, Pgenval, id, Lprim(Pfield pos, [Lvar mid], loc),
Lsequence(store_ident loc id, Lsequence(store_ident loc id,
@ -1042,7 +1074,7 @@ let transl_store_structure glob map prims str =
| Tstr_open _ | Tstr_open _
| Tstr_class_type _ | Tstr_class_type _
| Tstr_attribute _ -> | Tstr_attribute _ ->
transl_store rootpath subst rem transl_store rootpath subst cont rem
and store_ident loc id = and store_ident loc id =
try try
@ -1083,8 +1115,17 @@ let transl_store_structure glob map prims str =
Location.none), Location.none),
cont) cont)
in List.fold_right store_primitive prims and store_alias (pos, env, path, cc) =
(transl_store (global_path glob) !transl_store_subst str) 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 (* Transform a coercion and the list of value identifiers defined by
a toplevel structure into a table [id -> (pos, coercion)], 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. *) and the list of all primitives exported as values. *)
let build_ident_map restr idlist more_ids = 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 -> | 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 in
let (map, prims, pos) = let (map, prims, aliases, pos) =
match restr with match restr with
| Tcoerce_none -> | Tcoerce_none ->
natural_map 0 Ident.empty [] idlist natural_map 0 Ident.empty [] [] idlist
| Tcoerce_structure (pos_cc_list, _id_pos_list) -> | Tcoerce_structure (pos_cc_list, _id_pos_list) ->
(* ignore _id_pos_list as the ids are already bound *) (* ignore _id_pos_list as the ids are already bound *)
let idarray = Array.of_list idlist in 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 -> | (_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 -> | (source_pos, cc) :: rem ->
let id = idarray.(source_pos) in let id = idarray.(source_pos) in
export_map (pos + 1) (Ident.add id (pos, cc) map) export_map (pos + 1) (Ident.add id (pos, cc) map)
prims (list_remove id undef) rem prims aliases (list_remove id undef) rem
in 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" fatal_error "Translmod.build_ident_map"
in in
natural_map pos map prims more_ids natural_map pos map prims aliases more_ids
(* Compile an implementation using transl_store_structure (* Compile an implementation using transl_store_structure
(for the native-code compiler). *) (for the native-code compiler). *)
@ -1136,13 +1182,14 @@ let transl_store_gen module_name ({ str_items = str }, restr) topl =
primitive_declarations := []; primitive_declarations := [];
Translprim.clear_used_primitives (); Translprim.clear_used_primitives ();
let module_id = Ident.create_persistent module_name in 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 build_ident_map restr (defined_idents str) (more_idents str) in
let f = function let f = function
| [ { str_desc = Tstr_eval (expr, _attrs) } ] when topl -> | [ { str_desc = Tstr_eval (expr, _attrs) } ] when topl ->
assert (size = 0); assert (size = 0);
Lambda.subst (fun _ _ env -> env) !transl_store_subst (transl_exp expr) 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 transl_store_label_init module_id size f str
(*size, transl_label_init (transl_store_structure module_id map prims 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; set_toplevel_unique_name ext.tyexn_constructor.ext_id;
toploop_setvalue ext.tyexn_constructor.ext_id toploop_setvalue ext.tyexn_constructor.ext_id
(transl_extension_constructor item.str_env None ext.tyexn_constructor) (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 (* we need to use the unique name for the module because of issues
with "open" (PR#1672) *) with "open" (PR#1672) *)
set_toplevel_unique_name id; set_toplevel_unique_name id;
@ -1268,6 +1315,7 @@ let transl_toplevel_item item =
lambda_unit lambda_unit
| Tstr_modtype _ | Tstr_modtype _
| Tstr_open _ | Tstr_open _
| Tstr_module {mb_presence=Mp_absent}
| Tstr_type _ | Tstr_type _
| Tstr_class_type _ | Tstr_class_type _
| Tstr_attribute _ -> | Tstr_attribute _ ->

11
bytecomp/translobj.ml
View File

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

24
debugger/eval.ml
View File

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

17
debugger/loadprinter.ml
View File

@ -17,7 +17,6 @@
open Misc open Misc
open Longident open Longident
open Path
open Types open Types
(* Error report *) (* Error report *)
@ -89,15 +88,17 @@ let loadfile ppf name =
(* Note: evaluation proceeds in the debugger memory space, not in (* Note: evaluation proceeds in the debugger memory space, not in
the debuggee. *) the debuggee. *)
let rec eval_path = function let rec eval_address = function
Pident id -> Symtable.get_global_value id | Env.Aident id -> Symtable.get_global_value id
| Pdot(p, _, pos) -> Obj.field (eval_path p) pos | Env.Adot(addr, pos) -> Obj.field (eval_address addr) pos
| Papply _ -> fatal_error "Loadprinter.eval_path"
(* PR#7258: get rid of module aliases before evaluating paths *) (* PR#7258: get rid of module aliases before evaluating paths *)
let eval_path path = let eval_value_path env path =
eval_path (Env.normalize_path (Some Location.none) Env.empty 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) *) (* 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 (ty_arg, path, is_old_style) = find_printer_type lid in
let v = let v =
try try
use_debugger_symtable eval_path path use_debugger_symtable (eval_value_path Env.empty) path
with Symtable.Error(Symtable.Undefined_global s) -> with Symtable.Error(Symtable.Undefined_global s) ->
raise(Error(Unavailable_module(s, lid))) in raise(Error(Unavailable_module(s, lid))) in
let print_function = let print_function =

11
debugger/printval.ml
View File

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

2
ocamldoc/odoc_ast.ml
View File

@ -935,7 +935,7 @@ module Analyser =
let f = match ele with let f = match ele with
Element_module m -> Element_module m ->
(function (function
Types.Sig_module (ident,md,_) -> Types.Sig_module (ident,_,md,_) ->
let n1 = Name.simple m.m_name let n1 = Name.simple m.m_name
and n2 = Ident.name ident in 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_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_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_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 = let env2 =
match md.Types.md_type with (* FIXME: we don't have signature for identifiers *) 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 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 -> (fun acc_opt -> fun s ->
match acc_opt with match acc_opt with
None -> Some (Path.Pident (Ident.create_local s)) None -> Some (Path.Pident (Ident.create_local s))
| Some acc -> Some (Path.Pdot (acc, s, 0))) | Some acc -> Some (Path.Pdot (acc, s)))
None None
(Str.split (Str.regexp "\\.") n) (Str.split (Str.regexp "\\.") n)
with with

2
ocamldoc/odoc_print.ml
View File

@ -55,7 +55,7 @@ let simpl_module_type ?code t =
let rec iter t = let rec iter t =
match t with match t with
Types.Mty_ident _ Types.Mty_ident _
| Types.Mty_alias(_, _) -> t | Types.Mty_alias _ -> t
| Types.Mty_signature _ -> | Types.Mty_signature _ ->
( (
match code with 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 Hashtbl.add table (C (Name.from_ident ident)) signat
| Types.Sig_class_type (ident, _, _) -> | Types.Sig_class_type (ident, _, _) ->
Hashtbl.add table (CT (Name.from_ident ident)) signat 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 Hashtbl.add table (M (Name.from_ident ident)) signat
| Types.Sig_modtype (ident,_) -> | Types.Sig_modtype (ident,_) ->
Hashtbl.add table (MT (Name.from_ident ident)) signat Hashtbl.add table (MT (Name.from_ident ident)) signat
@ -92,7 +92,7 @@ module Signature_search =
let search_module table name = let search_module table name =
match Hashtbl.find table (M name) with 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 | _ -> assert false
let search_module_type table name = let search_module_type table name =
@ -1523,7 +1523,7 @@ module Analyser =
| Parsetree.Pmty_alias longident -> | Parsetree.Pmty_alias longident ->
let name = let name =
match sig_module_type with 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 | _ -> Name.from_longident longident.txt
in in
(* Wrong naming... *) (* Wrong naming... *)
@ -1612,7 +1612,7 @@ module Analyser =
| Parsetree.Pmty_alias _longident -> | Parsetree.Pmty_alias _longident ->
begin begin
match sig_module_type with match sig_module_type with
Types.Mty_alias(_, path) -> Types.Mty_alias path ->
let ln = !Odoc_global.library_namespace in let ln = !Odoc_global.library_namespace in
let alias_name = Odoc_env.full_module_name env let alias_name = Odoc_env.full_module_name env
Name.(alias_unprefix ln @@ from_path path) in 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. Exception: Not_found.
Raised at file "//toplevel//", line 2, characters 17-26 Raised at file "//toplevel//", line 2, characters 17-26
Called from file "//toplevel//", line 1, characters 11-15 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_function { cases = f; }
| Texp_try (_, f) -> | Texp_try (_, f) ->
bind_cases f bind_cases f
| Texp_letmodule (_, modname, _, body ) -> | Texp_letmodule (_, modname, _, _, body ) ->
Stypes.record (Stypes.An_ident Stypes.record (Stypes.An_ident
(modname.loc,modname.txt,Annot.Idef body.exp_loc)) (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 = module type EVALPATH =
sig sig
type valu type valu
val eval_path: Env.t -> Path.t -> valu val eval_address: Env.address -> valu
exception Error exception Error
val same_value: valu -> valu -> bool val same_value: valu -> valu -> bool
end end
@ -201,7 +201,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
match ty_path with match ty_path with
| Pident _ -> | Pident _ ->
Oide_ident name Oide_ident name
| Pdot(p, _s, _pos) -> | Pdot(p, _s) ->
if try if try
match (lookup_fun (Lident (Out_name.print name)) env).desc with match (lookup_fun (Lident (Out_name.print name)) env).desc with
| Tconstr(ty_path', _, _) -> Path.same ty_path ty_path' | 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 -> | None ->
let pos = let pos =
match rep with match rep with
| Record_extension -> 1 | Record_extension _ -> 1
| _ -> 0 | _ -> 0
in in
let unbx = let unbx =
@ -554,10 +554,11 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
Cstr_extension(p, _) -> p Cstr_extension(p, _) -> p
| _ -> raise Not_found | _ -> raise Not_found
in in
let addr = Env.find_constructor_address path env in
(* Make sure this is the right exception and not an homonym, (* Make sure this is the right exception and not an homonym,
by evaluating the exception found and comparing with the by evaluating the exception found and comparing with the
identifier contained in the exception bucket *) 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; then raise Not_found;
tree_of_constr_with_args tree_of_constr_with_args
(fun x -> Oide_ident x) name (cstr.cstr_inlined <> None) (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 = module type EVALPATH =
sig sig
type valu type valu
val eval_path: Env.t -> Path.t -> valu val eval_address: Env.address -> valu
exception Error exception Error
val same_value: valu -> valu -> bool val same_value: valu -> valu -> bool
end end

2
toplevel/opttopdirs.ml
View File

@ -147,7 +147,7 @@ let find_printer_type ppf lid =
let dir_install_printer ppf lid = let dir_install_printer ppf lid =
try try
let (ty_arg, path, is_old_style) = find_printer_type ppf lid in 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 = let print_function =
if is_old_style then if is_old_style then
(fun _formatter repr -> Obj.obj v (Obj.obj repr)) (fun _formatter repr -> Obj.obj v (Obj.obj repr))

39
toplevel/opttoploop.ml
View File

@ -15,7 +15,6 @@
(* The interactive toplevel loop *) (* The interactive toplevel loop *)
open Path
open Format open Format
open Config open Config
open Misc open Misc
@ -62,14 +61,12 @@ type directive_fun =
| Directive_bool of (bool -> unit) | Directive_bool of (bool -> unit)
(* Return the value referred to by a path *)
let remembered = ref Ident.empty let remembered = ref Ident.empty
let rec remember phrase_name i = function let rec remember phrase_name i = function
| [] -> () | [] -> ()
| Sig_value (id, _) :: rest | Sig_value (id, _) :: rest
| Sig_module (id, _, _) :: rest | Sig_module (id, _, _, _) :: rest
| Sig_typext (id, _, _) :: rest | Sig_typext (id, _, _) :: rest
| Sig_class (id, _, _) :: rest -> | Sig_class (id, _, _) :: rest ->
remembered := Ident.add id (phrase_name, i) !remembered; remembered := Ident.add id (phrase_name, i) !remembered;
@ -98,25 +95,41 @@ let toplevel_value id =
in in
(Obj.magic (global_symbol glob)).(pos) (Obj.magic (global_symbol glob)).(pos)
let rec eval_path = function (* Return the value referred to by a path *)
| Pident id ->
let rec eval_address = function
| Env.Aident id ->
if Ident.persistent id || Ident.global id if Ident.persistent id || Ident.global id
then global_symbol id then global_symbol id
else toplevel_value id else toplevel_value id
| Pdot(p, _s, pos) -> | Env.Adot(a, pos) ->
Obj.field (eval_path p) pos Obj.field (eval_address a) pos
| Papply _ ->
fatal_error "Toploop.eval_path"
let eval_path env path = let eval_path find env path =
eval_path (Env.normalize_path (Some Location.none) 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 *) (* To print values *)
module EvalPath = struct module EvalPath = struct
type valu = Obj.t type valu = Obj.t
exception Error 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) let same_value v1 v2 = (v1 == v2)
end 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_file] prints the types and values of the results.
[use_silently] does not print them. [use_silently] does not print them.
[mod_use_file] wrap the file contents into a module. *) [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 *) (* Return the toplevel object referred to by the given path *)
(* Printing of values *) (* Printing of values *)

15
toplevel/topdirs.ml
View File

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

33
toplevel/toploop.ml
View File

@ -15,7 +15,6 @@
(* The interactive toplevel loop *) (* The interactive toplevel loop *)
open Path
open Format open Format
open Config open Config
open Misc open Misc
@ -53,8 +52,8 @@ let setvalue name v =
(* Return the value referred to by a path *) (* Return the value referred to by a path *)
let rec eval_path = function let rec eval_address = function
| Pident id -> | Env.Aident id ->
if Ident.persistent id || Ident.global id then if Ident.persistent id || Ident.global id then
Symtable.get_global_value id Symtable.get_global_value id
else begin else begin
@ -64,20 +63,34 @@ let rec eval_path = function
with Not_found -> with Not_found ->
raise (Symtable.Error(Symtable.Undefined_global name)) raise (Symtable.Error(Symtable.Undefined_global name))
end end
| Pdot(p, _s, pos) -> | Env.Adot(p, pos) ->
Obj.field (eval_path p) pos Obj.field (eval_address p) pos
| Papply _ ->
fatal_error "Toploop.eval_path"
let eval_path env path = let eval_path find env path =
eval_path (Env.normalize_path (Some Location.none) 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 *) (* To print values *)
module EvalPath = struct module EvalPath = struct
type valu = Obj.t type valu = Obj.t
exception Error 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) let same_value v1 v2 = (v1 == v2)
end 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_file] prints the types and values of the results.
[use_silently] does not print them. [use_silently] does not print them.
[mod_use_file] wrap the file contents into a module. *) [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 *) (* Return the toplevel object referred to by the given path *)
val record_backtrace : unit -> unit 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 match t.desc with
Tconstr (Path.Pident id, _, _) when allow_ident -> Tconstr (Path.Pident id, _, _) when allow_ident ->
is_row_name (Ident.name id) is_row_name (Ident.name id)
| Tconstr (Path.Pdot (_, s, _), _, _) -> is_row_name s | Tconstr (Path.Pdot (_, s), _, _) -> is_row_name s
| _ -> false | _ -> false
@ -352,7 +352,7 @@ let type_iterators =
Sig_value (_, vd) -> it.it_value_description it vd Sig_value (_, vd) -> it.it_value_description it vd
| Sig_type (_, td, _) -> it.it_type_declaration it td | Sig_type (_, td, _) -> it.it_type_declaration it td
| Sig_typext (_, td, _) -> it.it_extension_constructor 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_modtype (_, mtd) -> it.it_modtype_declaration it mtd
| Sig_class (_, cd, _) -> it.it_class_declaration it cd | Sig_class (_, cd, _) -> it.it_class_declaration it cd
| Sig_class_type (_, ctd, _) -> it.it_class_type_declaration it ctd | Sig_class_type (_, ctd, _) -> it.it_class_type_declaration it ctd
@ -382,7 +382,7 @@ let type_iterators =
it.it_path ctd.clty_path it.it_path ctd.clty_path
and it_module_type it = function and it_module_type it = function
Mty_ident p 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_signature sg -> it.it_signature it sg
| Mty_functor (_, mto, mt) -> | Mty_functor (_, mto, mt) ->
may (it.it_module_type it) mto; 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 is_object_type path =
let name = let name =
match path with Path.Pident id -> Ident.name id match path with Path.Pident id -> Ident.name id
| Path.Pdot(_, s,_) -> s | Path.Pdot(_, s) -> s
| Path.Papply _ -> assert false | Path.Papply _ -> assert false
in name.[0] = '#' 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_ident p) -> normalize_package_path env p
| Some (Mty_signature _ | Mty_functor _ | Mty_alias _) | None -> | Some (Mty_signature _ | Mty_functor _ | Mty_alias _) | None ->
match p with match p with
Path.Pdot (p1, s, n) -> Path.Pdot (p1, s) ->
(* For module aliases *) (* For module aliases *)
let p1' = Env.normalize_path None env p1 in let p1' = Env.normalize_path None env p1 in
if Path.same p1 p1' then p else 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 | _ -> p
let check_scope_escape env level ty = 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 It'd be nice if we avoided creating such temporary dummy modules and broken
environments though. *) environments though. *)
let id2 = Ident.create_local "Pkg" in 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 = let rec complete nl1 ntl2 =
match nl1, ntl2 with match nl1, ntl2 with
[], _ -> ntl2 [], _ -> ntl2
@ -3871,7 +3871,7 @@ let memq_warn t visited =
let rec lid_of_path ?(hash="") = function let rec lid_of_path ?(hash="") = function
Path.Pident id -> Path.Pident id ->
Longident.Lident (hash ^ Ident.name id) Longident.Lident (hash ^ Ident.name id)
| Path.Pdot (p1, s, _) -> | Path.Pdot (p1, s) ->
Longident.Ldot (lid_of_path p1, hash ^ s) Longident.Ldot (lid_of_path p1, hash ^ s)
| Path.Papply (p1, p2) -> | Path.Papply (p1, p2) ->
Longident.Lapply (lid_of_path ~hash p1, lid_of_path 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 let tm = row_of_type ty in
begin if not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm then begin if not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm then
match tm.desc with (* PR#7348 *) 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 let i' = String.sub i 0 (String.length i - 4) in
log_type ty; 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 | _ -> assert false
else match ty.desc with else match ty.desc with
| Tvariant row -> | Tvariant row ->

4
typing/datarepr.ml
View File

@ -130,7 +130,7 @@ let constructor_descrs ty_path decl cstrs =
else Record_inlined idx_nonconst else Record_inlined idx_nonconst
in in
constructor_args decl.type_private cd_args cd_res 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 in
let cstr = let cstr =
{ cstr_name; { cstr_name;
@ -159,7 +159,7 @@ let extension_descr path_ext ext =
in in
let existentials, cstr_args, cstr_inlined = let existentials, cstr_args, cstr_inlined =
constructor_args ext.ext_private ext.ext_args ext.ext_ret_type constructor_args ext.ext_private ext.ext_args ext.ext_ret_type
path_ext Record_extension path_ext (Record_extension path_ext)
in in
{ cstr_name = Path.last path_ext; { cstr_name = Path.last path_ext;
cstr_res = ty_res; 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_value of summary * Ident.t * value_description
| Env_type of summary * Ident.t * type_declaration | Env_type of summary * Ident.t * type_declaration
| Env_extension of summary * Ident.t * extension_constructor | 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_modtype of summary * Ident.t * modtype_declaration
| Env_class of summary * Ident.t * class_declaration | Env_class of summary * Ident.t * class_declaration
| Env_cltype of summary * Ident.t * class_type_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_constraints of summary * type_declaration Path.Map.t
| Env_copy_types of summary * string list | Env_copy_types of summary * string list
type address =
| Aident of Ident.t
| Adot of address * int
type t type t
val empty: 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 (* Find the manifest type information associated to a type for the sake
of the compiler's type-based optimisations. *) of the compiler's type-based optimisations. *)
val find_modtype_expansion: Path.t -> t -> module_type 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 add_functor_arg: Ident.t -> t -> t
val is_functor_arg: Path.t -> t -> bool val is_functor_arg: Path.t -> t -> bool
val normalize_path: Location.t option -> t -> Path.t -> Path.t 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 ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t
val add_type: check:bool -> Ident.t -> type_declaration -> 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_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 -> 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_modtype: Ident.t -> modtype_declaration -> t -> t
val add_class: Ident.t -> class_declaration -> t -> t val add_class: Ident.t -> class_declaration -> t -> t
val add_cltype: Ident.t -> class_type_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: val enter_extension:
scope:int -> string -> extension_constructor -> t -> Ident.t * t scope:int -> string -> extension_constructor -> t -> Ident.t * t
val enter_module: 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: 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: val enter_modtype:
scope:int -> string -> modtype_declaration -> t -> Ident.t * t scope:int -> string -> modtype_declaration -> t -> Ident.t * t
val enter_class: scope:int -> string -> class_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: val fold_modtypes:
(string -> Path.t -> modtype_declaration -> 'a -> 'a) -> (string -> Path.t -> modtype_declaration -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a Longident.t option -> t -> 'a -> 'a
val fold_classs: val fold_classes:
(string -> Path.t -> class_declaration -> 'a -> 'a) -> (string -> Path.t -> class_declaration -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a Longident.t option -> t -> 'a -> 'a
val fold_cltypes: val fold_cltypes:
@ -344,6 +356,8 @@ val fold_cltypes:
val scrape_alias: t -> module_type -> module_type val scrape_alias: t -> module_type -> module_type
val check_value_name: string -> Location.t -> unit val check_value_name: string -> Location.t -> unit
val print_address : Format.formatter -> address -> unit
module Persistent_signature : sig module Persistent_signature : sig
type t = type t =
{ filename : string; (** Name of the file containing the signature. *) { 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 Env.add_extension ~check:false id
(Subst.extension_constructor subst desc) (Subst.extension_constructor subst desc)
(env_from_summary s subst) (env_from_summary s subst)
| Env_module(s, id, desc) -> | Env_module(s, id, pres, desc) ->
Env.add_module_declaration ~check:false id Env.add_module_declaration ~check:false id pres
(Subst.module_declaration subst desc) (Subst.module_declaration subst desc)
(env_from_summary s subst) (env_from_summary s subst)
| Env_modtype(s, id, desc) -> | Env_modtype(s, id, desc) ->
@ -69,9 +69,10 @@ let rec env_from_summary sum subst =
| None -> assert false | None -> assert false
| exception Not_found -> raise (Error (Module_not_found path')) | exception Not_found -> raise (Error (Module_not_found path'))
end 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 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) ~arg:true (env_from_summary s subst)
| Env_functor_arg _ -> assert false | Env_functor_arg _ -> assert false
| Env_constraints(s, map) -> | 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_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_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_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_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(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)) | 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 let is_runtime_component = function
| Sig_value(_,{val_kind = Val_prim _}) | Sig_value(_,{val_kind = Val_prim _})
| Sig_type(_,_,_) | Sig_type(_,_,_)
| Sig_module(_,Mp_absent,_,_)
| Sig_modtype(_,_) | Sig_modtype(_,_)
| Sig_class_type(_,_,_) -> false | Sig_class_type(_,_,_) -> false
| Sig_value(_,_) | Sig_value(_,_)
| Sig_typext(_,_,_) | Sig_typext(_,_,_)
| Sig_module(_,_,_) | Sig_module(_,Mp_present,_,_)
| Sig_class(_, _,_) -> true | Sig_class(_, _,_) -> true
(* Print a coercion *) (* Print a coercion *)
@ -217,7 +218,7 @@ let rec print_coercion ppf c =
| Tcoerce_primitive {pc_desc; pc_env = _; pc_type} -> | Tcoerce_primitive {pc_desc; pc_env = _; pc_type} ->
pr "prim %s@ (%a)" pc_desc.Primitive.prim_name pr "prim %s@ (%a)" pc_desc.Primitive.prim_name
Printtyp.raw_type_expr pc_type Printtyp.raw_type_expr pc_type
| Tcoerce_alias (p, c) -> | Tcoerce_alias (_, p, c) ->
pr "@[<2>alias %a@ (%a)@]" pr "@[<2>alias %a@ (%a)@]"
Printtyp.path p Printtyp.path p
print_coercion c print_coercion c
@ -258,8 +259,8 @@ let rec modtypes ~loc env ~mark cxt subst mty1 mty2 =
:: reasons)) :: reasons))
and try_modtypes ~loc env ~mark cxt subst mty1 mty2 = and try_modtypes ~loc env ~mark cxt subst mty1 mty2 =
match (mty1, mty2) with match mty1, mty2 with
| (Mty_alias(pres1, p1), Mty_alias(pres2, p2)) -> begin | Mty_alias p1, Mty_alias p2 ->
if Env.is_functor_arg p2 env then if Env.is_functor_arg p2 env then
raise (Error[cxt, env, Invalid_module_alias p2]); raise (Error[cxt, env, Invalid_module_alias p2]);
if not (Path.same p1 p2) then begin 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 and p2 = Env.normalize_path None env (Subst.module_path subst p2) in
if not (Path.same p1 p2) then raise Dont_match if not (Path.same p1 p2) then raise Dont_match
end; end;
match pres1, pres2 with Tcoerce_none
| Mta_present, Mta_present -> Tcoerce_none | (Mty_alias p1, _) -> begin
(* 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
let p1 = try let p1 = try
Env.normalize_path (Some Location.none) env p1 Env.normalize_path (Some Location.none) env p1
with Env.Error (Env.Missing_module (_, _, path)) -> 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 Mtype.strengthen ~aliasable:true env
(expand_module_alias env cxt p1) p1 (expand_module_alias env cxt p1) p1
in in
let cc = modtypes ~loc env ~mark cxt subst mty1 mty2 in modtypes ~loc env ~mark cxt subst mty1 mty2
match pres1 with
| Mta_present -> cc
| Mta_absent -> Tcoerce_alias (p1, cc)
end end
| (Mty_ident p1, _) when may_expand_module_path env p1 -> | (Mty_ident p1, _) when may_expand_module_path env p1 ->
try_modtypes ~loc env ~mark cxt subst 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 (Arg param1::cxt) Subst.identity arg2' arg1
in in
let cc_res = 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) (Body param1::cxt)
(Subst.add_module param2 (Path.Pident param1) subst) (Subst.add_module param2 (Path.Pident param1) subst)
res1 res2 res1 res2
@ -352,7 +337,7 @@ and signatures ~loc env ~mark cxt subst sig1 sig2 =
let (id_pos_list,_) = let (id_pos_list,_) =
List.fold_left List.fold_left
(fun (l,pos) -> function (fun (l,pos) -> function
Sig_module (id, _, _) -> Sig_module (id, Mp_present, _, _) ->
((id,pos,Tcoerce_none)::l , pos+1) ((id,pos,Tcoerce_none)::l , pos+1)
| item -> (l, if is_runtime_component item then pos+1 else pos)) | item -> (l, if is_runtime_component item then pos+1 else pos))
([], 0) sig1 in ([], 0) sig1 in
@ -362,7 +347,10 @@ and signatures ~loc env ~mark cxt subst sig1 sig2 =
[] -> pos, tbl [] -> pos, tbl
| item :: rem -> | item :: rem ->
let (id, _loc, name) = item_ident_name item in 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 build_component_table nextpos
(FieldMap.add name (id, item, pos) tbl) rem in (FieldMap.add name (id, item, pos) tbl) rem in
let len1, comps1 = let len1, comps1 =
@ -453,9 +441,17 @@ and signature_components ~loc old_env ~mark env cxt subst paired =
:: rem -> :: rem ->
extension_constructors ~loc env ~mark cxt subst id1 ext1 ext2; extension_constructors ~loc env ~mark cxt subst id1 ext1 ext2;
(pos, Tcoerce_none) :: comps_rec rem (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 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 -> | (Sig_modtype(id1, info1), Sig_modtype(_id2, info2), _pos) :: rem ->
modtype_infos ~loc env ~mark cxt subst id1 info1 info2; modtype_infos ~loc env ~mark cxt subst id1 info1 info2;
comps_rec rem comps_rec rem
@ -520,7 +516,7 @@ and check_modtype_equiv ~loc env ~mark cxt mty1 mty2 =
let can_alias env path = let can_alias env path =
let rec no_apply = function let rec no_apply = function
| Path.Pident _ -> true | Path.Pident _ -> true
| Path.Pdot(p, _, _) -> no_apply p | Path.Pdot(p, _) -> no_apply p
| Path.Papply _ -> false | Path.Papply _ -> false
in in
no_apply path && not (Env.is_functor_arg path env) no_apply path && not (Env.is_functor_arg path env)
@ -680,8 +676,8 @@ and argname x =
let path_of_context = function let path_of_context = function
Module id :: rem -> Module id :: rem ->
let rec subm path = function let rec subm path = function
[] -> path | [] -> path
| Module id :: rem -> subm (Path.Pdot (path, Ident.name id, -1)) rem | Module id :: rem -> subm (Path.Pdot (path, Ident.name id)) rem
| _ -> assert false | _ -> assert false
in subm (Path.Pident id) rem in subm (Path.Pident id) rem
| _ -> assert false | _ -> assert false

230
typing/mtype.ml
View File

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

2
typing/parmatch.ml
View File

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

26
typing/path.ml
View File

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

4
typing/path.mli
View File

@ -17,7 +17,7 @@
type t = type t =
Pident of Ident.t Pident of Ident.t
| Pdot of t * string * int | Pdot of t * string
| Papply of t * t | Papply of t * t
val same: t -> t -> bool val same: t -> t -> bool
@ -27,8 +27,6 @@ val exists_free: Ident.t list -> t -> bool
val scope: t -> int val scope: t -> int
val flatten : t -> [ `Contains_apply | `Ok of Ident.t * string list ] val flatten : t -> [ `Contains_apply | `Ok of Ident.t * string list ]
val nopos: int
val name: ?paren:(string -> bool) -> t -> string val name: ?paren:(string -> bool) -> t -> string
(* [paren] tells whether a path suffix needs parentheses *) (* [paren] tells whether a path suffix needs parentheses *)
val head: t -> Ident.t 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 ident_stdlib = Ident.create_persistent "Stdlib"
let non_shadowed_pervasive = function let non_shadowed_pervasive = function
| Pdot(Pident id, s, _) as path -> | Pdot(Pident id, s) as path ->
Ident.same id ident_stdlib && Ident.same id ident_stdlib &&
(try Path.same path (Env.lookup_type (Lident s) !printing_env) (try Path.same path (Env.lookup_type (Lident s) !printing_env)
with Not_found -> true) 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 = let rec module_path_is_an_alias_of env path ~alias_of =
match Env.find_module path env with match Env.find_module path env with
| { md_type = Mty_alias (_, path'); _ } -> | { md_type = Mty_alias path'; _ } ->
Path.same path' alias_of || Path.same path' alias_of ||
module_path_is_an_alias_of env path' ~alias_of module_path_is_an_alias_of env path' ~alias_of
| _ -> false | _ -> 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. *) for Foo__bar. This pattern is used by the stdlib. *)
let rec rewrite_double_underscore_paths env p = let rec rewrite_double_underscore_paths env p =
match p with match p with
| Pdot (p, s, n) -> | Pdot (p, s) ->
Pdot (rewrite_double_underscore_paths env p, s, n) Pdot (rewrite_double_underscore_paths env p, s)
| Papply (a, b) -> | Papply (a, b) ->
Papply (rewrite_double_underscore_paths env a, Papply (rewrite_double_underscore_paths env a,
rewrite_double_underscore_paths env b) rewrite_double_underscore_paths env b)
@ -348,9 +348,9 @@ let rewrite_double_underscore_paths env p =
let rec tree_of_path namespace = function let rec tree_of_path namespace = function
| Pident id -> | Pident id ->
Oide_ident (ident_name namespace 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) Oide_ident (Naming_context.pervasives_name namespace s)
| Pdot(p, s, _pos) -> | Pdot(p, s) ->
Oide_dot (tree_of_path Module p, s) Oide_dot (tree_of_path Module p, s)
| Papply(p1, p2) -> | Papply(p1, p2) ->
Oide_apply (tree_of_path Module p1, tree_of_path Module 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 let rec path_size = function
Pident id -> Pident id ->
penalty (Ident.name id), -Ident.scope id penalty (Ident.name id), -Ident.scope id
| Pdot (p, _, _) -> | Pdot (p, _) ->
let (l, b) = path_size p in (1+l, b) let (l, b) = path_size p in (1+l, b)
| Papply (p1, p2) -> | Papply (p1, p2) ->
let (l, b) = path_size p1 in 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(id,_,rs) -> Some(id,rs,3)
| Sig_class_type (id,_,rs) -> Some(id,rs,2) | Sig_class_type (id,_,rs) -> Some(id,rs,2)
| Sig_type(id, _, rs) | Sig_type(id, _, rs)
| Sig_module(id, _, rs) -> Some (id,rs,0) | Sig_module(id, _, _, rs) -> Some (id,rs,0)
| _ -> None | _ -> None
let skip k l = snd (Misc.Stdlib.List.split_at k l) 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 = let res =
match ty_arg with None -> tree_of_modtype ~ellipsis ty_res match ty_arg with None -> tree_of_modtype ~ellipsis ty_res
| Some mty -> | 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 (tree_of_modtype ~ellipsis) ty_res
in in
Omty_functor (Ident.name param, Omty_functor (Ident.name param,
may_map (tree_of_modtype ~ellipsis:false) ty_arg, res) may_map (tree_of_modtype ~ellipsis:false) ty_arg, res)
| Mty_alias(_, p) -> | Mty_alias p ->
Omty_alias (tree_of_path Module p) Omty_alias (tree_of_path Module p)
and tree_of_signature sg = and tree_of_signature sg =
@ -1574,7 +1574,7 @@ and trees_of_sigitem = function
[tree_of_type_declaration id decl rs] [tree_of_type_declaration id decl rs]
| Sig_typext(id, ext, es) -> | Sig_typext(id, ext, es) ->
[tree_of_extension_constructor id ext es] [tree_of_extension_constructor id ext es]
| Sig_module(id, md, rs) -> | Sig_module(id, _, md, rs) ->
let ellipsis = let ellipsis =
List.exists (function List.exists (function
| Parsetree.{attr_name = {txt="..."}; attr_payload = PStr []} -> true | 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 = let rec fmt_path_aux f x =
match x with match x with
| Path.Pident (s) -> fprintf f "%a" fmt_ident s; | 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) -> | Path.Papply (y, z) ->
fprintf f "%a(%a)" fmt_path_aux y fmt_path_aux 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_float -> line i ppf "Record_float\n"
| Record_unboxed b -> line i ppf "Record_unboxed %b\n" b | Record_unboxed b -> line i ppf "Record_unboxed %b\n" b
| Record_inlined i -> line i ppf "Record_inlined %d\n" i | 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 = let attribute i ppf k a =
line i ppf "%s \"%s\"\n" k a.Parsetree.attr_name.txt; line i ppf "%s \"%s\"\n" k a.Parsetree.attr_name.txt;
@ -391,7 +391,7 @@ and expression i ppf x =
| Texp_override (_, l) -> | Texp_override (_, l) ->
line i ppf "Texp_override\n"; line i ppf "Texp_override\n";
list i string_x_expression ppf l; 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; line i ppf "Texp_letmodule \"%a\"\n" fmt_ident s;
module_expr i ppf me; module_expr i ppf me;
expression i ppf e; 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 classify_path env path
(* non-binding cases *) (* non-binding cases *)
| Texp_letmodule (_, _, _, e) | Texp_letmodule (_, _, _, _, e)
| Texp_sequence (_, e) | Texp_sequence (_, e)
| Texp_letexception (_, e) -> | Texp_letexception (_, e) ->
classify_expression env e classify_expression env e
@ -511,7 +511,7 @@ let rec expression : Typedtree.expression -> term_judg =
G |- let <bindings> in body : m G |- let <bindings> in body : m
*) *)
value_bindings rec_flag bindings >> expression body value_bindings rec_flag bindings >> expression body
| Texp_letmodule (x, _, mexp, e) -> | Texp_letmodule (x, _, _, mexp, e) ->
module_binding (x, mexp) >> expression e module_binding (x, mexp) >> expression e
| Texp_match (e, cases, _) -> | Texp_match (e, cases, _) ->
(* (*
@ -613,7 +613,7 @@ let rec expression : Typedtree.expression -> term_judg =
| Record_float -> Dereference | Record_float -> Dereference
| Record_unboxed _ -> Return | Record_unboxed _ -> Return
| Record_regular | Record_inlined _ | Record_regular | Record_inlined _
| Record_extension -> Guard | Record_extension _ -> Guard
in in
let field (_label, field_def) = match field_def with let field (_label, field_def) = match field_def with
Kept _ -> empty Kept _ -> empty
@ -848,7 +848,7 @@ and modexp : Typedtree.module_expr -> term_judg =
(* This corresponds to 'external' declarations, (* This corresponds to 'external' declarations,
and the coercion ignores its argument *) and the coercion ignores its argument *)
k Ignore k Ignore
| Tcoerce_alias (pth, coe) -> | Tcoerce_alias (_, pth, coe) ->
(* Alias coercions ignore their arguments, but they evaluate (* Alias coercions ignore their arguments, but they evaluate
their alias module 'pth' under another coercion. *) their alias module 'pth' under another coercion. *)
coercion coe (fun m -> path pth << m) coercion coe (fun m -> path pth << m)
@ -876,7 +876,7 @@ and path : Path.t -> term_judg =
fun pth -> match pth with fun pth -> match pth with
| Path.Pident x -> | Path.Pident x ->
single x single x
| Path.Pdot (t, _, _) -> | Path.Pdot (t, _) ->
path t << Dereference path t << Dereference
| Path.Papply (f, p) -> | Path.Papply (f, p) ->
join [ join [
@ -963,7 +963,7 @@ and structure_item : Typedtree.structure_item -> bind_judg =
| Sig_value (id, _) | Sig_value (id, _)
| Sig_type (id, _, _) | Sig_type (id, _, _)
| Sig_typext (id, _, _) | Sig_typext (id, _, _)
| Sig_module (id, _, _) | Sig_module (id, _, _, _)
| Sig_modtype (id, _) | Sig_modtype (id, _)
| Sig_class (id, _, _) | Sig_class (id, _, _)
| Sig_class_type (id, _, _) | Sig_class_type (id, _, _)

36
typing/subst.ml
View File

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

7
typing/tast_mapper.ml
View File

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

55
typing/typecore.ml
View File

@ -840,7 +840,7 @@ module Label = NameChoice (struct
let in_env lbl = let in_env lbl =
match lbl.lbl_repres with match lbl.lbl_repres with
| Record_regular | Record_float | Record_unboxed false -> true | 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) end)
let disambiguate_label_by_ids keep closed ids labels = 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.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable)
vars true && vars true &&
!count = 0 !count = 0
| Texp_letmodule (_, _, mexp, e) -> | Texp_letmodule (_, _, _, mexp, e) ->
is_nonexpansive_mod mexp && is_nonexpansive e is_nonexpansive_mod mexp && is_nonexpansive e
| Texp_pack mexp -> | Texp_pack mexp ->
is_nonexpansive_mod mexp is_nonexpansive_mod mexp
@ -2003,7 +2003,7 @@ let check_partial_application statement exp =
| Texp_let (_, _, e) | Texp_let (_, _, e)
| Texp_sequence (_, e) | Texp_sequence (_, e)
| Texp_letexception (_, e) | Texp_letexception (_, e)
| Texp_letmodule (_, _, _, e) -> | Texp_letmodule (_, _, _, _, e) ->
loop e loop e
| _ -> | _ ->
let loc = let loc =
@ -2042,7 +2042,7 @@ let check_partial_application statement exp =
| Texp_ifthenelse (_, e1, Some e2) -> | Texp_ifthenelse (_, e1, Some e2) ->
check e1; check e2 check e1; check e2
| Texp_let (_, _, e) | Texp_sequence (_, e) | Texp_let (_, _, e) | Texp_sequence (_, e)
| Texp_letexception (_, e) | Texp_letmodule (_, _, _, e) -> | Texp_letexception (_, e) | Texp_letmodule (_, _, _, _, e) ->
check e check e
| Texp_apply _ | Texp_send _ | Texp_new _ -> | Texp_apply _ | Texp_send _ | Texp_new _ ->
Location.prerr_warning exp_loc Warnings.Partial_application 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 ty_exp = expand_head env ty_expected in
let fmt6_path = let fmt6_path =
Path.(Pdot (Pident (Ident.create_persistent "CamlinternalFormatBasics"), Path.(Pdot (Pident (Ident.create_persistent "CamlinternalFormatBasics"),
"format6", 0)) in "format6"))
in
let is_format = match ty_exp.desc with let is_format = match ty_exp.desc with
| Tconstr(path, _, _) when Path.same path fmt6_path -> | Tconstr(path, _, _) when Path.same path fmt6_path ->
if !Clflags.principal && ty_exp.level <> generic_level then 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 let (obj_ty, res_ty) = filter_arrow env method_type Nolabel in
unify env obj_ty desc.val_type; unify env obj_ty desc.val_type;
unify env res_ty (instance typ); 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 = let exp =
Texp_apply({exp_desc = Texp_apply({exp_desc =
Texp_ident(Path.Pident method_id, lid, Texp_ident(Path.Pident method_id,
{val_type = method_type; lid, method_desc);
val_kind = Val_reg;
val_attributes = [];
Types.val_loc = Location.none});
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = method_type; exp_type = method_type;
exp_attributes = []; (* check *) exp_attributes = []; (* check *)
exp_env = env}, exp_env = exp_env},
[ Nolabel, [ Nolabel,
Some {exp_desc = Texp_ident(path, lid, desc); Some {exp_desc = Texp_ident(path, lid, desc);
exp_loc = obj.exp_loc; exp_extra = []; exp_loc = obj.exp_loc; exp_extra = [];
exp_type = desc.val_type; exp_type = desc.val_type;
exp_attributes = []; (* check *) exp_attributes = []; (* check *)
exp_env = env} exp_env = exp_env}
]) ])
in in
(Tmeth_name met, Some (re {exp_desc = exp; (Tmeth_name met, Some (re {exp_desc = exp;
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = typ; exp_type = typ;
exp_attributes = []; (* check *) exp_attributes = []; (* check *)
exp_env = env}), typ) exp_env = exp_env}), typ)
| _ -> | _ ->
assert false assert false
end end
@ -3118,8 +3123,15 @@ and type_expect_
let context = Typetexp.narrow () in let context = Typetexp.narrow () in
let modl = !type_module env smodl in let modl = !type_module env smodl in
Mtype.lower_nongen ty.level modl.mod_type; 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 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; Typetexp.widen context;
(* ideally, we should catch Expr_type_clash errors (* ideally, we should catch Expr_type_clash errors
in type_expect triggered by escaping identifiers from the local module in type_expect triggered by escaping identifiers from the local module
@ -3130,7 +3142,7 @@ and type_expect_
end_def (); end_def ();
Ctype.unify_var new_env ty body.exp_type; Ctype.unify_var new_env ty body.exp_type;
re { re {
exp_desc = Texp_letmodule(id, name, modl, body); exp_desc = Texp_letmodule(id, name, pres, modl, body);
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = ty; exp_type = ty;
exp_attributes = sexp.pexp_attributes; 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 *) (* eta-expand to avoid side effects *)
let var_pair name ty = let var_pair name ty =
let id = Ident.create_local name in 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_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[];
pat_attributes = []; pat_attributes = [];
pat_loc = Location.none; pat_env = env}, 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_extra = []; exp_attributes = [];
exp_desc = exp_desc =
Texp_ident(Path.Pident id, mknoloc (Longident.Lident name), Texp_ident(Path.Pident id, mknoloc (Longident.Lident name), desc)}
{val_type = ty; val_kind = Val_reg;
val_attributes = [];
Types.val_loc = Location.none})}
in in
let eta_pat, eta_var = var_pair "eta" ty_arg in let eta_pat, eta_var = var_pair "eta" ty_arg in
let func texp = 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; List.iter2 (Ctype.unify env) decl.type_params tl;
let lbls = let lbls =
match decl.type_kind with match decl.type_kind with
| Type_record (lbls, Record_extension) -> lbls | Type_record (lbls, Record_extension _) -> lbls
| _ -> assert false | _ -> assert false
in in
Types.Cstr_record lbls 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_instvar of Path.t * Path.t * string loc
| Texp_setinstvar of Path.t * Path.t * string loc * expression | Texp_setinstvar of Path.t * Path.t * string loc * expression
| Texp_override of Path.t * (Path.t * string loc * expression) list | 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_letexception of extension_constructor * expression
| Texp_assert of expression | Texp_assert of expression
| Texp_lazy of expression | Texp_lazy of expression
@ -241,6 +242,7 @@ and module_binding =
{ {
mb_id: Ident.t; mb_id: Ident.t;
mb_name: string loc; mb_name: string loc;
mb_presence: module_presence;
mb_expr: module_expr; mb_expr: module_expr;
mb_attributes: attribute list; mb_attributes: attribute list;
mb_loc: Location.t; mb_loc: Location.t;
@ -260,7 +262,7 @@ and module_coercion =
(Ident.t * int * module_coercion) list (Ident.t * int * module_coercion) list
| Tcoerce_functor of module_coercion * module_coercion | Tcoerce_functor of module_coercion * module_coercion
| Tcoerce_primitive of primitive_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 = and module_type =
{ mty_desc: module_type_desc; { mty_desc: module_type_desc;
@ -318,6 +320,7 @@ and module_declaration =
{ {
md_id: Ident.t; md_id: Ident.t;
md_name: string loc; md_name: string loc;
md_presence: module_presence;
md_type: module_type; md_type: module_type;
md_attributes: attribute list; md_attributes: attribute list;
md_loc: Location.t; 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_instvar of Path.t * Path.t * string loc
| Texp_setinstvar of Path.t * Path.t * string loc * expression | Texp_setinstvar of Path.t * Path.t * string loc * expression
| Texp_override of Path.t * (Path.t * string loc * expression) list | 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_letexception of extension_constructor * expression
| Texp_assert of expression | Texp_assert of expression
| Texp_lazy of expression | Texp_lazy of expression
@ -364,6 +365,7 @@ and module_binding =
{ {
mb_id: Ident.t; mb_id: Ident.t;
mb_name: string loc; mb_name: string loc;
mb_presence: module_presence;
mb_expr: module_expr; mb_expr: module_expr;
mb_attributes: attributes; mb_attributes: attributes;
mb_loc: Location.t; mb_loc: Location.t;
@ -383,7 +385,7 @@ and module_coercion =
(Ident.t * int * module_coercion) list (Ident.t * int * module_coercion) list
| Tcoerce_functor of module_coercion * module_coercion | Tcoerce_functor of module_coercion * module_coercion
| Tcoerce_primitive of primitive_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 = and module_type =
{ mty_desc: module_type_desc; { mty_desc: module_type_desc;
@ -440,6 +442,7 @@ and module_declaration =
{ {
md_id: Ident.t; md_id: Ident.t;
md_name: string loc; md_name: string loc;
md_presence: module_presence;
md_type: module_type; md_type: module_type;
md_attributes: attributes; md_attributes: attributes;
md_loc: Location.t; md_loc: Location.t;

2
typing/typedtreeIter.ml
View File

@ -350,7 +350,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
List.iter (fun (_path, _, exp) -> List.iter (fun (_path, _, exp) ->
iter_expression exp iter_expression exp
) list ) list
| Texp_letmodule (_id, _, mexpr, exp) -> | Texp_letmodule (_id, _, _, mexpr, exp) ->
iter_module_expr mexpr; iter_module_expr mexpr;
iter_expression exp iter_expression exp
| Texp_letexception (cd, 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) (path, lid, map_expression exp)
) list ) list
) )
| Texp_letmodule (id, name, mexpr, exp) -> | Texp_letmodule (id, name, pres, mexpr, exp) ->
Texp_letmodule ( Texp_letmodule (
id, name, id, name, pres,
map_module_expr mexpr, map_module_expr mexpr,
map_expression exp map_expression exp
) )

183
typing/typemod.ml
View File

@ -114,8 +114,8 @@ open Typedtree
let rec path_concat head p = let rec path_concat head p =
match p with match p with
Pident tail -> Pdot (Pident head, Ident.name tail, 0) Pident tail -> Pdot (Pident head, Ident.name tail)
| Pdot (pre, s, pos) -> Pdot (path_concat head pre, s, pos) | Pdot (pre, s) -> Pdot (path_concat head pre, s)
| Papply _ -> assert false | Papply _ -> assert false
(* Extract a signature from a module type *) (* Extract a signature from a module type *)
@ -123,14 +123,14 @@ let rec path_concat head p =
let extract_sig env loc mty = let extract_sig env loc mty =
match Env.scrape_alias env mty with match Env.scrape_alias env mty with
Mty_signature sg -> sg Mty_signature sg -> sg
| Mty_alias(_, path) -> | Mty_alias path ->
raise(Error(loc, env, Cannot_scrape_alias path)) raise(Error(loc, env, Cannot_scrape_alias path))
| _ -> raise(Error(loc, env, Signature_expected)) | _ -> raise(Error(loc, env, Signature_expected))
let extract_sig_open env loc mty = let extract_sig_open env loc mty =
match Env.scrape_alias env mty with match Env.scrape_alias env mty with
Mty_signature sg -> sg Mty_signature sg -> sg
| Mty_alias(_, path) -> | Mty_alias path ->
raise(Error(loc, env, Cannot_scrape_alias path)) raise(Error(loc, env, Cannot_scrape_alias path))
| mty -> raise(Error(loc, env, Structure_expected mty)) | mty -> raise(Error(loc, env, Structure_expected mty))
@ -246,8 +246,8 @@ let update_rec_next rs rem =
match rem with match rem with
Sig_type (id, decl, Trec_next) :: rem -> Sig_type (id, decl, Trec_next) :: rem ->
Sig_type (id, decl, rs) :: rem Sig_type (id, decl, rs) :: rem
| Sig_module (id, mty, Trec_next) :: rem -> | Sig_module (id, pres, mty, Trec_next) :: rem ->
Sig_module (id, mty, rs) :: rem Sig_module (id, pres, mty, rs) :: rem
| _ -> rem | _ -> rem
let make_variance p n i = let make_variance p n i =
@ -257,7 +257,7 @@ let make_variance p n i =
let rec iter_path_apply p ~f = let rec iter_path_apply p ~f =
match p with match p with
| Pident _ -> () | Pident _ -> ()
| Pdot (p, _, _) -> iter_path_apply p ~f | Pdot (p, _) -> iter_path_apply p ~f
| Papply (p1, p2) -> | Papply (p1, p2) ->
iter_path_apply p1 ~f; iter_path_apply p1 ~f;
iter_path_apply p2 ~f; iter_path_apply p2 ~f;
@ -295,8 +295,8 @@ let iterator_with_env env =
| Mty_functor (param, mty_arg, mty_body) -> | Mty_functor (param, mty_arg, mty_body) ->
may (self.Btype.it_module_type self) mty_arg; may (self.Btype.it_module_type self) mty_arg;
let env_before = !env in let env_before = !env in
env := lazy (Env.add_module ~arg:true param (Btype.default_mty mty_arg) env := lazy (Env.add_module ~arg:true param Mp_present
(Lazy.force env_before)); (Btype.default_mty mty_arg) (Lazy.force env_before));
self.Btype.it_module_type self mty_body; self.Btype.it_module_type self mty_body;
env := env_before; env := env_before;
| mty -> | 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 let env, super = iterator_with_env env in
{ super with { super with
Btype.it_signature_item = (fun self -> function 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 when List.exists
(fun path -> path_is_strict_prefix path ~prefix:aliased_path) (fun path -> path_is_strict_prefix path ~prefix:aliased_path)
paths 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 (* After substitution one also needs to re-check the well-foundedness
of type declarations in recursive modules *) of type declarations in recursive modules *)
let rec extract_next_modules = function 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 let (id_mty_l, rem) = extract_next_modules rem in
((id, mty) :: id_mty_l, rem) ((id, mty) :: id_mty_l, rem)
| sg -> ([], sg) | sg -> ([], sg)
@ -371,7 +371,7 @@ let check_well_formed_module env loc context mty =
let iterator = let iterator =
let rec check_signature env = function 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 let (id_mty_l, rem) = extract_next_modules rem in
begin try begin try
check_recmod_typedecls (Lazy.force env) ((id, mty) :: id_mty_l) 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]; real_ids := [Pident id];
(Pident id, lid, Twith_typesubst tdecl), (Pident id, lid, Twith_typesubst tdecl),
update_rec_next rs rem 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 -> when Ident.name id = s ->
let path, md' = Typetexp.find_module initial_env loc lid'.txt in let path, md' = Typetexp.find_module initial_env loc lid'.txt in
let mty = md'.md_type 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 let newmd = Mtype.strengthen_decl ~aliasable:false env md'' path in
ignore(Includemod.modtypes ~loc env newmd.md_type md.md_type); ignore(Includemod.modtypes ~loc env newmd.md_type md.md_type);
(Pident id, lid, Twith_module (path, lid')), (Pident id, lid, Twith_module (path, lid')),
Sig_module(id, newmd, rs) :: rem Sig_module(id, pres, newmd, rs) :: rem
| (Sig_module(id, md, rs) :: rem, [s], Pwith_modsubst (_, lid')) | (Sig_module(id, _, md, rs) :: rem, [s], Pwith_modsubst (_, lid'))
when Ident.name id = s -> when Ident.name id = s ->
let path, md' = Typetexp.find_module initial_env loc lid'.txt in let path, md' = Typetexp.find_module initial_env loc lid'.txt in
let aliasable = not (Env.is_functor_arg path env) 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]; real_ids := [Pident id];
(Pident id, lid, Twith_modsubst (path, lid')), (Pident id, lid, Twith_modsubst (path, lid')),
update_rec_next rs rem 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 _)) s :: namelist, (Pwith_module _ | Pwith_type _))
when Ident.name id = s -> when Ident.name id = s ->
let ((path, _, tcstr), _) = let ((path, _, tcstr), _) =
@ -532,14 +532,15 @@ let merge_constraint initial_env remove_aliases loc sg constr =
let path = path_concat id path in let path = path_concat id path in
real_ids := path :: !real_ids; real_ids := path :: !real_ids;
(path, lid, tcstr), item :: rem (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 -> when Ident.name id = s ->
let ((path, _path_loc, tcstr), newsg) = let ((path, _path_loc, tcstr), newsg) =
merge env (extract_sig env loc md.md_type) namelist None merge env (extract_sig env loc md.md_type) namelist None
in in
let path = path_concat id path in let path = path_concat id path in
real_ids := path :: !real_ids; 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), (path, lid, tcstr),
item :: rem item :: rem
| (item :: rem, _, _) -> | (item :: rem, _, _) ->
@ -657,14 +658,17 @@ let rec approx_modtype env smty =
Mty_ident path Mty_ident path
| Pmty_alias lid -> | Pmty_alias lid ->
let path = Typetexp.lookup_module env smty.pmty_loc lid.txt in let path = Typetexp.lookup_module env smty.pmty_loc lid.txt in
Mty_alias(Mta_absent, path) Mty_alias path
| Pmty_signature ssg -> | Pmty_signature ssg ->
Mty_signature(approx_sig env ssg) Mty_signature(approx_sig env ssg)
| Pmty_functor(param, sarg, sres) -> | Pmty_functor(param, sarg, sres) ->
let arg = may_map (approx_modtype env) sarg in let arg = may_map (approx_modtype env) sarg in
let rarg = Mtype.scrape_for_functor_arg env (Btype.default_mty arg) in let rarg = Mtype.scrape_for_functor_arg env (Btype.default_mty arg) in
let scope = Ctype.create_scope () 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 let res = approx_modtype newenv sres in
Mty_functor(id, arg, res) Mty_functor(id, arg, res)
| Pmty_with(sbody, constraints) -> | Pmty_with(sbody, constraints) ->
@ -710,15 +714,25 @@ and approx_sig env ssg =
let scope = Ctype.create_scope () in let scope = Ctype.create_scope () in
let id = Ident.create_scoped ~scope pmd.pmd_name.txt in let id = Ident.create_scoped ~scope pmd.pmd_name.txt in
let md = approx_module_declaration env pmd in let md = approx_module_declaration env pmd in
let newenv = Env.enter_module_declaration id md env in let pres =
Sig_module(id, md, Trec_not) :: approx_sig newenv srem 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 -> | Psig_modsubst pms ->
let scope = Ctype.create_scope () in let scope = Ctype.create_scope () in
let id = Ident.create_scoped ~scope pms.pms_name.txt in let id = Ident.create_scoped ~scope pms.pms_name.txt in
let _, md = let _, md =
Typetexp.find_module env pms.pms_manifest.loc pms.pms_manifest.txt Typetexp.find_module env pms.pms_manifest.loc pms.pms_manifest.txt
in 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 approx_sig newenv srem
| Psig_recmodule sdecls -> | Psig_recmodule sdecls ->
let scope = Ctype.create_scope () in let scope = Ctype.create_scope () in
@ -733,10 +747,12 @@ and approx_sig env ssg =
let newenv = let newenv =
List.fold_left List.fold_left
(fun env (id, md) -> Env.add_module_declaration ~check:false (fun env (id, md) -> Env.add_module_declaration ~check:false
id md env) id Mp_present md env)
env decls in env decls
map_rec (fun rs (id, md) -> Sig_module(id, md, rs)) decls in
(approx_sig newenv srem) map_rec
(fun rs (id, md) -> Sig_module(id, Mp_present, md, rs)) decls
(approx_sig newenv srem)
| Psig_modtype d -> | Psig_modtype d ->
let info = approx_modtype_info env d in let info = approx_modtype_info env d in
let scope = Ctype.create_scope () in let scope = Ctype.create_scope () in
@ -910,7 +926,7 @@ end = struct
match component with match component with
| Sig_type(id, _, _) -> | Sig_type(id, _, _) ->
check_type names loc id ~info:(info id loc) check_type names loc id ~info:(info id loc)
| Sig_module(id, _, _) -> | Sig_module(id, _, _, _) ->
check_module names loc id ~info:(info id loc) check_module names loc id ~info:(info id loc)
| Sig_modtype(id, _) -> | Sig_modtype(id, _) ->
check_modtype names loc id ~info:(info id loc) 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_value(id, v) -> Value, id, v.val_loc
| Sig_type (id, td, _) -> Type, id, td.type_loc | Sig_type (id, td, _) -> Type, id, td.type_loc
| Sig_typext (id, te, _) -> Extension_constructor, id, te.ext_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_modtype (id, mtd) -> Module_type, id, mtd.mtd_loc
| Sig_class (id, c, _) -> Class, id, c.cty_loc | Sig_class (id, c, _) -> Class, id, c.cty_loc
| Sig_class_type (id, ct, _) -> Class_type, id, ct.clty_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 smty.pmty_attributes
| Pmty_alias lid -> | Pmty_alias lid ->
let path = transl_module_alias loc env lid.txt in 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 smty.pmty_attributes
| Pmty_signature ssg -> | Pmty_signature ssg ->
let sg = transl_signature env ssg in 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 ty_arg = Misc.may_map (fun m -> m.mty_type) arg in
let scope = Ctype.create_scope () in let scope = Ctype.create_scope () in
let (id, newenv) = let (id, newenv) =
Env.enter_module ~scope ~arg:true param.txt (Btype.default_mty ty_arg) Env.enter_module ~scope ~arg:true
env in param.txt Mp_present (Btype.default_mty ty_arg) env
in
let res = transl_modtype newenv sres in let res = transl_modtype newenv sres in
mkmty (Tmty_functor (id, param, arg, res)) mkmty (Tmty_functor (id, param, arg, res))
(Mty_functor(id, ty_arg, res.mty_type)) env loc (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 Builtin_attributes.warning_scope pmd.pmd_attributes
(fun () -> transl_modtype env pmd.pmd_type) (fun () -> transl_modtype env pmd.pmd_type)
in in
let pres =
match tmty.mty_type with
| Mty_alias _ -> Mp_absent
| _ -> Mp_present
in
let md = { let md = {
md_type=tmty.mty_type; md_type=tmty.mty_type;
md_attributes=pmd.pmd_attributes; md_attributes=pmd.pmd_attributes;
@ -1185,14 +1207,14 @@ and transl_signature env sg =
} }
in in
Signature_names.check_module names pmd.pmd_name.loc id; 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 let (trem, rem, final_env) = transl_sig newenv srem in
mksig (Tsig_module {md_id=id; md_name=pmd.pmd_name; 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_loc=pmd.pmd_loc;
md_attributes=pmd.pmd_attributes}) md_attributes=pmd.pmd_attributes})
env loc :: trem, env loc :: trem,
Sig_module(id, md, Trec_not) :: rem, Sig_module(id, pres, md, Trec_not) :: rem,
final_env final_env
| Psig_modsubst pms -> | Psig_modsubst pms ->
let scope = Ctype.create_scope () in let scope = Ctype.create_scope () in
@ -1205,15 +1227,20 @@ and transl_signature env sg =
if not aliasable then if not aliasable then
md md
else else
{ md_type = Mty_alias(Mta_absent, path); { md_type = Mty_alias path;
md_attributes = pms.pms_attributes; md_attributes = pms.pms_attributes;
md_loc = pms.pms_loc } md_loc = pms.pms_loc }
in in
let pres =
match md.md_type with
| Mty_alias _ -> Mp_absent
| _ -> Mp_present
in
let info = let info =
`Substituted_away (Subst.add_module id path Subst.identity) `Substituted_away (Subst.add_module id path Subst.identity)
in in
Signature_names.check_module ~info names pms.pms_name.loc id; 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 let (trem, rem, final_env) = transl_sig newenv srem in
mksig (Tsig_modsubst {ms_id=id; ms_name=pms.pms_name; mksig (Tsig_modsubst {ms_id=id; ms_name=pms.pms_name;
ms_manifest=path; ms_txt=pms.pms_manifest; ms_manifest=path; ms_txt=pms.pms_manifest;
@ -1235,7 +1262,7 @@ and transl_signature env sg =
md_attributes = md.md_attributes; md_attributes = md.md_attributes;
md_loc = md.md_loc; md_loc = md.md_loc;
} in } in
Sig_module(md.md_id, d, rs)) Sig_module(md.md_id, Mp_present, d, rs))
decls rem, decls rem,
final_env final_env
| Psig_modtype pmtd -> | Psig_modtype pmtd ->
@ -1369,11 +1396,13 @@ and transl_modtype_decl_aux names env
and transl_recmodule_modtypes env sdecls = and transl_recmodule_modtypes env sdecls =
let make_env curr = let make_env curr =
List.fold_left 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 env curr in
let make_env2 curr = let make_env2 curr =
List.fold_left 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 env curr in
let transition env_c curr = let transition env_c curr =
List.map2 List.map2
@ -1405,7 +1434,7 @@ and transl_recmodule_modtypes env sdecls =
let dummy = let dummy =
Mty_ident (Path.Pident (Ident.create_scoped ~scope "#recmod#")) Mty_ident (Path.Pident (Ident.create_scoped ~scope "#recmod#"))
in in
Env.add_module ~arg:true id dummy env Env.add_module ~arg:true id Mp_present dummy env
) )
env ids env ids
in in
@ -1435,6 +1464,7 @@ and transl_recmodule_modtypes env sdecls =
List.map2 List.map2
(fun pmd (id, id_loc, mty) -> (fun pmd (id, id_loc, mty) ->
{md_id=id; md_name=id_loc; md_type=mty; {md_id=id; md_name=id_loc; md_type=mty;
md_presence=Mp_present;
md_loc=pmd.pmd_loc; md_loc=pmd.pmd_loc;
md_attributes=pmd.pmd_attributes}) md_attributes=pmd.pmd_attributes})
sdecls dcl2 sdecls dcl2
@ -1447,7 +1477,7 @@ exception Not_a_path
let rec path_of_module mexp = let rec path_of_module mexp =
match mexp.mod_desc with match mexp.mod_desc with
Tmod_ident (p,_) -> p | Tmod_ident (p,_) -> p
| Tmod_apply(funct, arg, _coercion) when !Clflags.applicative_functors -> | Tmod_apply(funct, arg, _coercion) when !Clflags.applicative_functors ->
Papply(path_of_module funct, path_of_module arg) Papply(path_of_module funct, path_of_module arg)
| Tmod_constraint (mexp, _, _, _) -> | Tmod_constraint (mexp, _, _, _) ->
@ -1466,12 +1496,14 @@ let rec closed_modtype env = function
let env = Env.add_signature sg env in let env = Env.add_signature sg env in
List.for_all (closed_signature_item env) sg List.for_all (closed_signature_item env) sg
| Mty_functor(id, param, body) -> | 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 closed_modtype env body
and closed_signature_item env = function and closed_signature_item env = function
Sig_value(_id, desc) -> Ctype.closed_schema env desc.val_type 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 | _ -> true
let check_nongen_scheme env sig_item = let check_nongen_scheme env sig_item =
@ -1479,7 +1511,7 @@ let check_nongen_scheme env sig_item =
Sig_value(_id, vd) -> Sig_value(_id, vd) ->
if not (Ctype.closed_schema env vd.val_type) then if not (Ctype.closed_schema env vd.val_type) then
raise (Error (vd.val_loc, env, Non_generalizable vd.val_type)) 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 if not (closed_modtype env md.md_type) then
raise(Error(md.md_loc, env, Non_generalizable_module md.md_type)) 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 *) (* Helpers for typing recursive modules *)
let anchor_submodule name anchor = 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 = let anchor_recmodule id =
Some (Pident id) Some (Pident id)
@ -1502,7 +1534,7 @@ let enrich_type_decls anchor decls oldenv newenv =
(fun e info -> (fun e info ->
let id = info.typ_id in let id = info.typ_id in
let info' = 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 id info.typ_type
in in
Env.add_type ~check:true id info' e) 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 = let enrich_module_type anchor name mty env =
match anchor with match anchor with
None -> mty 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 = let check_recmodule_inclusion env bindings =
(* PR#4450, PR#4470: consider (* PR#4450, PR#4470: consider
@ -1556,7 +1588,7 @@ let check_recmodule_inclusion env bindings =
if first_time if first_time
then mty_actual then mty_actual
else subst_and_strengthen env s id mty_actual in 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 env bindings1 in
(* Build the output substitution Y_i <- X_i *) (* Build the output substitution Y_i <- X_i *)
let s' = let s' =
@ -1588,6 +1620,7 @@ let check_recmodule_inclusion env bindings =
{ {
mb_id = id; mb_id = id;
mb_name = id_loc; mb_name = id_loc;
mb_presence = Mp_present;
mb_expr = modl'; mb_expr = modl';
mb_attributes = attrs; mb_attributes = attrs;
mb_loc = loc; mb_loc = loc;
@ -1609,7 +1642,7 @@ let rec package_constraints env loc mty constrs =
when List.mem_assoc [Ident.name id] constrs -> when List.mem_assoc [Ident.name id] constrs ->
let ty = List.assoc [Ident.name id] constrs in let ty = List.assoc [Ident.name id] constrs in
Sig_type (id, {td with type_manifest = Some ty}, rs) Sig_type (id, {td with type_manifest = Some ty}, rs)
| Sig_module (id, md, rs) -> | Sig_module (id, _, md, rs) ->
let rec aux = function let rec aux = function
| (m :: ((_ :: _) as l), t) :: rest when m = Ident.name id -> | (m :: ((_ :: _) as l), t) :: rest when m = Ident.name id ->
(l, t) :: aux rest (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) md_type = package_constraints env loc md.md_type (aux constrs)
} }
in in
Sig_module (id, md, rs) Sig_module (id, Mp_present, md, rs)
| item -> item | item -> item
) )
sg sg
@ -1680,7 +1713,7 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
let path = let path =
Typetexp.lookup_module ~load:(not alias) env smod.pmod_loc lid.txt in Typetexp.lookup_module ~load:(not alias) env smod.pmod_loc lid.txt in
let md = { mod_desc = Tmod_ident (path, lid); let md = { mod_desc = Tmod_ident (path, lid);
mod_type = Mty_alias(Mta_absent, path); mod_type = Mty_alias path;
mod_env = env; mod_env = env;
mod_attributes = smod.pmod_attributes; mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc } in 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 if alias && aliasable then
(Env.add_required_global (Path.head path); md) (Env.add_required_global (Path.head path); md)
else match (Env.find_module path env).md_type with 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 p1 = Env.normalize_path (Some smod.pmod_loc) env p1 in
let mty = Includemod.expand_module_alias env [] p1 in let mty = Includemod.expand_module_alias env [] p1 in
{ md with { md with
mod_desc = Tmod_constraint (md, mty, Tmodtype_implicit, mod_desc =
Tcoerce_alias (p1, Tcoerce_none)); Tmod_constraint (md, mty, Tmodtype_implicit,
Tcoerce_alias (env, path, Tcoerce_none));
mod_type = mod_type =
if sttn then Mtype.strengthen ~aliasable:true env mty p1 if sttn then Mtype.strengthen ~aliasable:true env mty p1
else mty } else mty }
@ -1726,7 +1760,9 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
let (id, newenv), funct_body = let (id, newenv), funct_body =
match ty_arg with match ty_arg with
| None -> (Ident.create_scoped ~scope "*", env), false | 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 in
let body = type_module sttn funct_body None newenv sbody in let body = type_module sttn funct_body None newenv sbody in
rm { mod_desc = Tmod_functor(id, name, mty, body); 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 mty_res
| None -> | None ->
if generative then mty_res else 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 check_well_formed_module env smod.pmod_loc
"the signature of this functor application" mty_res; "the signature of this functor application" mty_res;
let nondep_mty = let nondep_mty =
@ -1791,7 +1829,7 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
mod_env = env; mod_env = env;
mod_attributes = smod.pmod_attributes; mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc } 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_scrape_alias path))
| _ -> | _ ->
raise(Error(sfunct.pmod_loc, env, Cannot_apply funct.mod_type)) 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 (anchor_submodule name.txt anchor) env smodl
) )
in in
let pres =
match modl.mod_type with
| Mty_alias _ -> Mp_absent
| _ -> Mp_present
in
let md = let md =
{ md_type = enrich_module_type anchor name.txt modl.mod_type env; { md_type = enrich_module_type anchor name.txt modl.mod_type env;
md_attributes = attrs; md_attributes = attrs;
@ -1940,11 +1983,10 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
in in
(*prerr_endline (Ident.unique_toplevel_name id);*) (*prerr_endline (Ident.unique_toplevel_name id);*)
Mtype.lower_nongen (scope - 1) md.md_type; 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; Tstr_module {mb_id=id; mb_name=name; mb_expr=modl;
mb_attributes=attrs; mb_loc=pmb_loc; mb_presence=pres; mb_attributes=attrs; mb_loc=pmb_loc; },
}, [Sig_module(id, pres,
[Sig_module(id,
{md_type = modl.mod_type; {md_type = modl.mod_type;
md_attributes = attrs; md_attributes = attrs;
md_loc = pmb_loc; md_loc = pmb_loc;
@ -2000,7 +2042,8 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
md_loc = md.md_loc; md_loc = md.md_loc;
} }
in 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 env decls
in in
@ -2008,7 +2051,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
check_recmodule_inclusion newenv bindings1 in check_recmodule_inclusion newenv bindings1 in
Tstr_recmodule bindings2, Tstr_recmodule bindings2,
map_rec (fun rs mb -> 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_type=mb.mb_expr.mod_type;
md_attributes=mb.mb_attributes; md_attributes=mb.mb_attributes;
md_loc=mb.mb_loc; 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 and normalize_signature_item env = function
Sig_value(_id, desc) -> Ctype.normalize_type env desc.val_type 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 *) (* Extract the module type of a module expression *)
@ -2194,18 +2237,18 @@ let type_package env m p nl =
Typetexp.widen context; Typetexp.widen context;
let (mp, env) = let (mp, env) =
match modl.mod_desc with match modl.mod_desc with
Tmod_ident (mp,_) -> (mp, env) | Tmod_ident (mp,_) -> (mp, env)
| Tmod_constraint ({mod_desc=Tmod_ident (mp,_)}, _, Tmodtype_implicit, _) | Tmod_constraint ({mod_desc=Tmod_ident (mp,_)}, _, Tmodtype_implicit, _)
-> (mp, env) (* PR#6982 *) -> (mp, env) (* PR#6982 *)
| _ -> | _ ->
let (id, new_env) = 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 in
(Pident id, new_env) (Pident id, new_env)
in in
let rec mkpath mp = function let rec mkpath mp = function
| Lident name -> Pdot(mp, name, nopos) | Lident name -> Pdot(mp, name)
| Ldot (m, name) -> Pdot(mkpath mp m, name, nopos) | Ldot (m, name) -> Pdot(mkpath mp m, name)
| _ -> assert false | _ -> assert false
in in
let tl' = let tl' =
@ -2330,7 +2373,7 @@ let rec package_signatures subst = function
let sg' = Subst.signature subst sg in let sg' = Subst.signature subst sg in
let oldid = Ident.create_persistent name let oldid = Ident.create_persistent name
and newid = Ident.create_local name in 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_attributes=[];
md_loc=Location.none; 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 = let bigarray_decode_type env ty tbl dfl =
match scrape env ty with 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" -> when Ident.name mod_id = "Stdlib__bigarray" ->
begin try List.assoc type_name tbl with Not_found -> dfl end 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_float (* All fields are floats *)
| Record_unboxed of bool (* Unboxed single-field record, inlined or not *) | Record_unboxed of bool (* Unboxed single-field record, inlined or not *)
| Record_inlined of int (* Inlined record *) | Record_inlined of int (* Inlined record *)
| Record_extension (* Inlined record under extension *) | Record_extension of Path.t (* Inlined record under extension *)
and label_declaration = and label_declaration =
{ {
@ -258,11 +258,11 @@ type module_type =
Mty_ident of Path.t Mty_ident of Path.t
| Mty_signature of signature | Mty_signature of signature
| Mty_functor of Ident.t * module_type option * module_type | 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 = and module_presence =
| Mta_present | Mp_present
| Mta_absent | Mp_absent
and signature = signature_item list and signature = signature_item list
@ -270,7 +270,7 @@ and signature_item =
Sig_value of Ident.t * value_description Sig_value of Ident.t * value_description
| Sig_type of Ident.t * type_declaration * rec_status | Sig_type of Ident.t * type_declaration * rec_status
| Sig_typext of Ident.t * extension_constructor * ext_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_modtype of Ident.t * modtype_declaration
| Sig_class of Ident.t * class_declaration * rec_status | Sig_class of Ident.t * class_declaration * rec_status
| Sig_class_type of Ident.t * class_type_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_float (* All fields are floats *)
| Record_unboxed of bool (* Unboxed single-field record, inlined or not *) | Record_unboxed of bool (* Unboxed single-field record, inlined or not *)
| Record_inlined of int (* Inlined record *) | Record_inlined of int (* Inlined record *)
| Record_extension (* Inlined record under extension *) | Record_extension of Path.t (* Inlined record under extension *)
and label_declaration = and label_declaration =
{ {
@ -410,11 +410,11 @@ type module_type =
Mty_ident of Path.t Mty_ident of Path.t
| Mty_signature of signature | Mty_signature of signature
| Mty_functor of Ident.t * module_type option * module_type | 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 = and module_presence =
| Mta_present | Mp_present
| Mta_absent | Mp_absent
and signature = signature_item list and signature = signature_item list
@ -422,7 +422,7 @@ and signature_item =
Sig_value of Ident.t * value_description Sig_value of Ident.t * value_description
| Sig_type of Ident.t * type_declaration * rec_status | Sig_type of Ident.t * type_declaration * rec_status
| Sig_typext of Ident.t * extension_constructor * ext_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_modtype of Ident.t * modtype_declaration
| Sig_class of Ident.t * class_declaration * rec_status | Sig_class of Ident.t * class_declaration * rec_status
| Sig_class_type of Ident.t * class_type_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)) error (Wrong_use_of_module (mlid, `Functor_used_as_structure))
| Mty_ident _ -> | Mty_ident _ ->
error (Wrong_use_of_module (mlid, `Abstract_used_as_structure)) 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 _ -> () | Mty_signature _ -> ()
end end
| Longident.Lapply (flid, mlid) -> | 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)) error (Wrong_use_of_module (flid, `Structure_used_as_functor))
| Mty_ident _ -> | Mty_ident _ ->
error (Wrong_use_of_module (flid, `Abstract_used_as_functor)) 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, _) -> | Mty_functor (_, None, _) ->
error (Wrong_use_of_module (flid, `Generative_used_as_applicative)) error (Wrong_use_of_module (flid, `Generative_used_as_applicative))
| Mty_functor (_, Some mty_param, _) -> mty_param | 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 mpath = Env.lookup_module ~load:true mlid env in
let mmd = Env.find_module mpath env in let mmd = Env.find_module mpath env in
begin match Env.scrape_alias env mmd.md_type with 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 -> | mty_arg ->
let details = let details =
try Includemod.check_modtype_inclusion 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_modules = fold_simple Env.fold_modules
let fold_constructors = fold_descr Env.fold_constructors (fun d -> d.cstr_name) 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_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_modtypes = fold_simple Env.fold_modtypes
let fold_cltypes = fold_simple Env.fold_cltypes let fold_cltypes = fold_simple Env.fold_cltypes
@ -1000,7 +1000,7 @@ let report_error env ppf = function
spellcheck ppf fold_labels env lid; spellcheck ppf fold_labels env lid;
| Unbound_class lid -> | Unbound_class lid ->
fprintf ppf "Unbound class %a" longident lid; fprintf ppf "Unbound class %a" longident lid;
spellcheck ppf fold_classs env lid; spellcheck ppf fold_classes env lid;
| Unbound_modtype lid -> | Unbound_modtype lid ->
fprintf ppf "Unbound module type %a" longident lid; fprintf ppf "Unbound module type %a" longident lid;
spellcheck ppf fold_modtypes env 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 let rec lident_of_path = function
| Path.Pident id -> Longident.Lident (Ident.name id) | 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) -> | Path.Papply (p1, p2) ->
Longident.Lapply (lident_of_path p1, lident_of_path 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) -> Pexp_override (List.map (fun (_path, lid, exp) ->
(map_loc sub lid, sub.expr sub exp) (map_loc sub lid, sub.expr sub exp)
) list) ) list)
| Texp_letmodule (_id, name, mexpr, exp) -> | Texp_letmodule (_id, name, _pres, mexpr, exp) ->
Pexp_letmodule (name, sub.module_expr sub mexpr, Pexp_letmodule (name, sub.module_expr sub mexpr,
sub.expr sub exp) sub.expr sub exp)
| Texp_letexception (ext, exp) -> | Texp_letexception (ext, exp) ->