diff options
79 files changed, 1179 insertions, 443 deletions
@@ -182,11 +182,11 @@ typing/env.cmx : utils/warnings.cmx typing/types.cmx utils/tbl.cmx \ typing/cmi_format.cmx utils/clflags.cmx typing/btype.cmx \ parsing/asttypes.cmi typing/env.cmi typing/envaux.cmo : typing/types.cmi typing/subst.cmi typing/printtyp.cmi \ - typing/path.cmi typing/mtype.cmi utils/misc.cmi typing/env.cmi \ - parsing/asttypes.cmi typing/envaux.cmi + typing/path.cmi typing/mtype.cmi utils/misc.cmi typing/ident.cmi \ + typing/env.cmi parsing/asttypes.cmi typing/envaux.cmi typing/envaux.cmx : typing/types.cmx typing/subst.cmx typing/printtyp.cmx \ - typing/path.cmx typing/mtype.cmx utils/misc.cmx typing/env.cmx \ - parsing/asttypes.cmi typing/envaux.cmi + typing/path.cmx typing/mtype.cmx utils/misc.cmx typing/ident.cmx \ + typing/env.cmx parsing/asttypes.cmi typing/envaux.cmi typing/ident.cmo : typing/ident.cmi typing/ident.cmx : typing/ident.cmi typing/includeclass.cmo : typing/types.cmi typing/printtyp.cmi \ @@ -3,6 +3,11 @@ Next version: (Changes that can break existing programs are marked with a "*") +Language features: +- Attributes and extension nodes +- Generative functors +- Module aliases + Camlp4: - Removed from the official distribution @@ -16,10 +21,9 @@ Type system: - Allow opening a first-class module or applying a generative functor in the body of a generative functor. Allow it also in the body of an applicative functor if no types are created - -Language features: -- Attributes and extension nodes -- Generative functors +* Module aliases are now typed in a specific way, which remembers their + identity. In particular this changes the signature inferred by + "module type of" Compilers: - Experimental native code generator for AArch64 (ARM 64 bits) diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex 56df7508f..838b2c530 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex 5f151ef18..69a0ffeb5 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 03b7d3d21..0b70047a0 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index b64dee2ac..aa56c31fa 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -258,10 +258,10 @@ and sameswitch sw1 sw2 = | (Some a1, Some a2) -> same a1 a2 | _ -> false) -let name_lambda arg fn = +let name_lambda strict arg fn = match arg with Lvar id -> fn id - | _ -> let id = Ident.create "let" in Llet(Strict, id, arg, fn id) + | _ -> let id = Ident.create "let" in Llet(strict, id, arg, fn id) let name_lambda_list args fn = let rec name_list names = function @@ -383,14 +383,19 @@ let rec patch_guarded patch = function (* Translate an access path *) -let rec transl_path = function +let rec transl_normal_path = function Pident id -> if Ident.global id then Lprim(Pgetglobal id, []) else Lvar id | Pdot(p, s, pos) -> - Lprim(Pfield pos, [transl_path p]) + Lprim(Pfield pos, [transl_normal_path p]) | Papply(p1, p2) -> fatal_error "Lambda.transl_path" +(* Translation of value identifiers *) + +let transl_path ?(loc=Location.none) env path = + transl_normal_path (Env.normalize_path (Some loc) env path) + (* Compile a sequence of expressions *) let rec make_sequence fn = function diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index ccc5fc640..904ea6fd7 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -207,7 +207,7 @@ and lambda_event_kind = val same: lambda -> lambda -> bool val const_unit: structured_constant val lambda_unit: lambda -val name_lambda: lambda -> (Ident.t -> lambda) -> lambda +val name_lambda: let_kind -> lambda -> (Ident.t -> lambda) -> lambda val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda val iter: (lambda -> unit) -> lambda -> unit @@ -215,7 +215,8 @@ module IdentSet: Set.S with type elt = Ident.t val free_variables: lambda -> IdentSet.t val free_methods: lambda -> IdentSet.t -val transl_path: Path.t -> lambda +val transl_normal_path: Path.t -> lambda (* Path.t is already normal *) +val transl_path: ?loc:Location.t -> Env.t -> Path.t -> lambda val make_sequence: ('a -> lambda) -> 'a list -> lambda val subst_lambda: lambda Ident.tbl -> lambda -> lambda diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 7387ea64a..b6ba0ac86 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -2163,7 +2163,9 @@ let combine_constructor arg ex_pat cstr partial ctx def else Lprim(Pfield 0, [arg]) in Lifthenelse(Lprim(Pintcomp Ceq, - [slot; transl_path path]), + [slot; + transl_path ~loc:ex_pat.pat_loc + ex_pat.pat_env path]), act, rem) | _ -> assert false) tests default in @@ -2734,7 +2736,7 @@ let partial_function loc () = (* [Location.get_pos_info] is too expensive *) let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in Lprim(Praise Raise_regular, [Lprim(Pmakeblock(0, Immutable), - [transl_path Predef.path_match_failure; + [transl_normal_path Predef.path_match_failure; Lconst(Const_block(0, [Const_base(Const_string (fname, None)); Const_base(Const_int line); diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index 3ef160fe2..beb268480 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -255,12 +255,15 @@ let rec lam ppf = function fprintf ppf ")" in fprintf ppf "@[<2>(function%a@ %a)@]" pr_params params lam body | Llet(str, id, arg, body) -> + let kind = function + Alias -> "a" | Strict -> "" | StrictOpt -> "o" | Variable -> "v" in let rec letbody = function | Llet(str, id, arg, body) -> - fprintf ppf "@ @[<2>%a@ %a@]" Ident.print id lam arg; + fprintf ppf "@ @[<2>%a =%s@ %a@]" Ident.print id (kind str) lam arg; letbody body | expr -> expr in - fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a@ %a@]" Ident.print id lam arg; + fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a =%s@ %a@]" + Ident.print id (kind str) lam arg; let expr = letbody body in fprintf ppf ")@]@ %a)@]" lam expr | Lletrec(id_arg_list, body) -> diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index b22c0adaf..55ddab3bc 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -115,6 +115,9 @@ let name_pattern default p = | Tpat_alias(p, id, _) -> id | _ -> Ident.create default +let normalize_cl_path cl path = + Env.normalize_path (Some cl.cl_loc) cl.cl_env path + let rec build_object_init cl_table obj params inh_init obj_init cl = match cl.cl_desc with Tcl_ident ( path, _, _) -> @@ -124,7 +127,8 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = match envs with None -> [] | Some envs -> [Lprim(Pfield (List.length inh_init + 1), [Lvar envs])] in - ((envs, (obj_init, path)::inh_init), + ((envs, (obj_init, normalize_cl_path cl path) + ::inh_init), mkappl(Lvar obj_init, env @ [obj])) | Tcl_structure str -> create_object cl_table obj (fun obj -> @@ -253,7 +257,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = Tcl_ident ( path, _, _) -> begin match inh_init with (obj_init, path')::inh_init -> - let lpath = transl_path path in + let lpath = transl_path ~loc:cl.cl_loc cl.cl_env path in (inh_init, Llet (Strict, obj_init, mkappl(Lprim(Pfield 1, [lpath]), Lvar cla :: @@ -331,8 +335,8 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = let cl = ignore_cstrs cl in begin match cl.cl_desc, inh_init with Tcl_ident (path, _, _), (obj_init, path')::inh_init -> - assert (Path.same path path'); - let lpath = transl_path path in + assert (Path.same (normalize_cl_path cl path) path'); + let lpath = transl_normal_path path' in let inh = Ident.create "inh" and ofs = List.length vals + 1 and valids, methids = super in @@ -398,7 +402,7 @@ let rec transl_class_rebind obj_init cl vf = try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit with Not_found -> raise Exit end; - (path, obj_init) + (normalize_cl_path cl path, obj_init) | Tcl_fun (_, pat, _, cl, partial) -> let path, obj_init = transl_class_rebind obj_init cl vf in let build params rem = @@ -446,7 +450,7 @@ let transl_class_rebind ids cl vf = if not (Translcore.check_recursive_lambda ids obj_init') then raise(Error(cl.cl_loc, Illegal_class_expr)); let id = (obj_init' = lfunction [self] obj_init0) in - if id then transl_path path else + if id then transl_normal_path path else let cla = Ident.create "class" and new_init = Ident.create "new_init" @@ -456,7 +460,7 @@ let transl_class_rebind ids cl vf = Llet( Strict, new_init, lfunction [obj_init] obj_init', Llet( - Alias, cla, transl_path path, + Alias, cla, transl_normal_path path, Lprim(Pmakeblock(0, Immutable), [mkappl(Lvar new_init, [lfield cla 0]); lfunction [table] @@ -741,7 +745,7 @@ let transl_class ids cl_id pub_meths cl vflag = Lprim(Pmakeblock(0, Immutable), menv :: List.map (fun id -> Lvar id) !new_ids_init) and linh_envs = - List.map (fun (_, p) -> Lprim(Pfield 3, [transl_path p])) + List.map (fun (_, p) -> Lprim(Pfield 3, [transl_normal_path p])) (List.rev inh_init) in let make_envs lam = @@ -758,7 +762,7 @@ let transl_class ids cl_id pub_meths cl vflag = List.filter (fun (_,path) -> List.mem (Path.head path) new_ids) inh_init in let inh_keys = - List.map (fun (_,p) -> Lprim(Pfield 1, [transl_path p])) inh_paths in + List.map (fun (_,p) -> Lprim(Pfield 1, [transl_normal_path p])) inh_paths in let lclass lam = Llet(Strict, class_init, Lfunction(Curried, [cla], def_ids cla cl_init), lam) diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index d63381631..3a6cf7187 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -589,7 +589,7 @@ let assert_failed exp = Location.get_pos_info exp.exp_loc.Location.loc_start in Lprim(Praise Raise_regular, [event_after exp (Lprim(Pmakeblock(0, Immutable), - [transl_path Predef.path_assert_failure; + [transl_normal_path Predef.path_assert_failure; Lconst(Const_block(0, [Const_base(Const_string (fname, None)); Const_base(Const_int line); @@ -635,7 +635,7 @@ and transl_exp0 e = | Texp_ident(path, _, {val_kind = Val_anc _}) -> raise(Error(e.exp_loc, Free_super_var)) | Texp_ident(path, _, {val_kind = Val_reg | Val_self _}) -> - transl_path path + transl_path ~loc:e.exp_loc e.exp_env path | Texp_ident _ -> fatal_error "Translcore.transl_exp: bad Texp_ident" | Texp_constant cst -> Lconst(Const_base cst) @@ -734,7 +734,7 @@ and transl_exp0 e = Lprim(Pmakeblock(n, Immutable), ll) end | Cstr_exception (path, _) -> - let slot = transl_path path in + let slot = transl_path ~loc:e.exp_loc e.exp_env path in if cstr.cstr_arity = 0 then slot else Lprim(Pmakeblock(0, Immutable), slot :: ll) end @@ -813,16 +813,18 @@ and transl_exp0 e = Lsend (kind, tag, obj, cache, e.exp_loc) in event_after e lam - | Texp_new (cl, _, _) -> - Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit], Location.none) + | Texp_new (cl, {Location.loc=loc}, _) -> + Lapply(Lprim(Pfield 0, [transl_path ~loc e.exp_env cl]), + [lambda_unit], Location.none) | Texp_instvar(path_self, path, _) -> - Lprim(Parrayrefu Paddrarray, [transl_path path_self; transl_path path]) + Lprim(Parrayrefu Paddrarray, + [transl_normal_path path_self; transl_normal_path path]) | Texp_setinstvar(path_self, path, _, expr) -> - transl_setinstvar (transl_path path_self) path expr + transl_setinstvar (transl_normal_path path_self) path expr | Texp_override(path_self, modifs) -> let cpy = Ident.create "copy" in Llet(Strict, cpy, - Lapply(Translobj.oo_prim "copy", [transl_path path_self], + Lapply(Translobj.oo_prim "copy", [transl_normal_path path_self], Location.none), List.fold_right (fun (path, _, expr) rem -> @@ -1044,7 +1046,7 @@ and transl_let rec_flag pat_expr_list body = and transl_setinstvar self var expr = Lprim(Parraysetu (if maybe_pointer expr then Paddrarray else Pintarray), - [self; transl_path var; transl_exp expr]) + [self; transl_normal_path var; transl_exp expr]) and transl_record all_labels repres lbl_expr_list opt_init_expr = let size = Array.length all_labels in diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 10915d853..9825e5065 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -50,26 +50,42 @@ let transl_exception path decl = (* Compile a coercion *) -let rec apply_coercion restr arg = +let rec apply_coercion strict restr arg = match restr with Tcoerce_none -> arg - | Tcoerce_structure pos_cc_list -> - name_lambda arg (fun id -> - Lprim(Pmakeblock(0, Immutable), - List.map (apply_coercion_field id) pos_cc_list)) + | Tcoerce_structure(pos_cc_list, id_pos_list) -> + name_lambda strict arg (fun id -> + let lam = + Lprim(Pmakeblock(0, Immutable), + List.map (apply_coercion_field id) pos_cc_list) in + let fv = free_variables lam in + let (lam,s) = + List.fold_left (fun (lam,s) (id',pos,c) -> + if IdentSet.mem id' fv then + let id'' = Ident.create (Ident.name id') in + (Llet(Alias,id'', + apply_coercion Alias c (Lprim(Pfield pos,[Lvar id])),lam), + Ident.add id' (Lvar id'') s) + else (lam,s)) + (lam, Ident.empty) id_pos_list + in + if s == Ident.empty then lam else subst_lambda s lam) | Tcoerce_functor(cc_arg, cc_res) -> let param = Ident.create "funarg" in - name_lambda arg (fun id -> + name_lambda strict arg (fun id -> Lfunction(Curried, [param], - apply_coercion cc_res - (Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)], + apply_coercion Strict cc_res + (Lapply(Lvar id, [apply_coercion Alias cc_arg (Lvar param)], Location.none)))) | Tcoerce_primitive p -> transl_primitive Location.none p + | Tcoerce_alias (path, cc) -> + name_lambda strict arg + (fun id -> apply_coercion Alias cc (transl_normal_path path)) and apply_coercion_field id (pos, cc) = - apply_coercion cc (Lprim(Pfield pos, [Lvar id])) + apply_coercion Alias cc (Lprim(Pfield pos, [Lvar id])) (* Compose two coercions apply_coercion c1 (apply_coercion c2 e) behaves like @@ -79,18 +95,26 @@ let rec compose_coercions c1 c2 = match (c1, c2) with (Tcoerce_none, c2) -> c2 | (c1, Tcoerce_none) -> c1 - | (Tcoerce_structure pc1, Tcoerce_structure pc2) -> + | (Tcoerce_structure (pc1, ids1), Tcoerce_structure (pc2, ids2)) -> let v2 = Array.of_list pc2 in + let ids1 = + List.map (fun (id,pos1,c1) -> + let (pos2,c2) = v2.(pos1) in (id, pos2, compose_coercions c1 c2)) + ids1 + in Tcoerce_structure (List.map (function (p1, Tcoerce_primitive p) -> (p1, Tcoerce_primitive p) | (p1, c1) -> let (p2, c2) = v2.(p1) in (p2, compose_coercions c1 c2)) - pc1) + pc1, + ids1 @ ids2) | (Tcoerce_functor(arg1, res1), Tcoerce_functor(arg2, res2)) -> Tcoerce_functor(compose_coercions arg2 arg1, compose_coercions res1 res2) + | (c1, Tcoerce_alias (path, c2)) -> + Tcoerce_alias (path, compose_coercions c1 c2) | (_, _) -> fatal_error "Translmod.compose_coercions" @@ -119,7 +143,7 @@ let field_path path field = let mod_prim name = try - transl_path + transl_normal_path (fst (Env.lookup_value (Ldot (Lident "CamlinternalMod", name)) Env.empty)) with Not_found -> @@ -135,7 +159,8 @@ let undefined_location loc = let init_shape modl = let rec init_shape_mod env mty = match Mtype.scrape env mty with - Mty_ident _ -> + Mty_ident _ + | Mty_alias _ -> raise Not_found | Mty_signature sg -> Const_block(0, [Const_block(0, init_shape_struct env sg)]) @@ -264,9 +289,13 @@ let rec bound_value_identifiers = function (* Compile a module expression *) let rec transl_module cc rootpath mexp = + match mexp.mod_type with + Mty_alias _ -> apply_coercion Alias cc lambda_unit + | _ -> match mexp.mod_desc with Tmod_ident (path,_) -> - apply_coercion cc (transl_path path) + apply_coercion StrictOpt cc + (transl_path ~loc:mexp.mod_loc mexp.mod_env path) | Tmod_structure str -> transl_struct [] cc rootpath str | Tmod_functor( param, _, mty, body) -> @@ -279,20 +308,21 @@ let rec transl_module cc rootpath mexp = | Tcoerce_functor(ccarg, ccres) -> let param' = Ident.create "funarg" in Lfunction(Curried, [param'], - Llet(Alias, param, apply_coercion ccarg (Lvar param'), + Llet(Alias, param, + apply_coercion Alias ccarg (Lvar param'), transl_module ccres bodypath body)) | _ -> fatal_error "Translmod.transl_module") cc | Tmod_apply(funct, arg, ccarg) -> oo_wrap mexp.mod_env true - (apply_coercion cc) + (apply_coercion Strict cc) (Lapply(transl_module Tcoerce_none None funct, [transl_module ccarg None arg], mexp.mod_loc)) | Tmod_constraint(arg, mty, _, ccarg) -> transl_module (compose_coercions cc ccarg) rootpath arg | Tmod_unpack(arg, _) -> - apply_coercion cc (Translcore.transl_exp arg) + apply_coercion Strict cc (Translcore.transl_exp arg) and transl_struct fields cc rootpath str = transl_structure fields cc rootpath str.str_items @@ -303,15 +333,19 @@ and transl_structure fields cc rootpath = function Tcoerce_none -> Lprim(Pmakeblock(0, Immutable), List.map (fun id -> Lvar id) (List.rev fields)) - | Tcoerce_structure pos_cc_list -> + | Tcoerce_structure(pos_cc_list, id_pos_list) -> + (* ignore id_pos_list as the ids are already bound *) let v = Array.of_list (List.rev fields) in - Lprim(Pmakeblock(0, Immutable), + (*List.fold_left + (fun lam (id, pos) -> Llet(Alias, id, Lvar v.(pos), lam))*) + (Lprim(Pmakeblock(0, Immutable), List.map (fun (pos, cc) -> match cc with Tcoerce_primitive p -> transl_primitive Location.none p - | _ -> apply_coercion cc (Lvar v.(pos))) - pos_cc_list) + | _ -> apply_coercion Strict cc (Lvar v.(pos))) + pos_cc_list)) + (*id_pos_list*) | _ -> fatal_error "Translmod.transl_structure" end @@ -332,12 +366,12 @@ and transl_structure fields cc rootpath = function let id = decl.cd_id in Llet(Strict, id, transl_exception (field_path rootpath id) decl, transl_structure (id :: fields) cc rootpath rem) - | Tstr_exn_rebind( id, _, path, _, _) -> - Llet(Strict, id, transl_path path, + | Tstr_exn_rebind( id, _, path, {Location.loc=loc}, _) -> + Llet(Strict, id, transl_path ~loc item.str_env path, transl_structure (id :: fields) cc rootpath rem) | Tstr_module mb -> let id = mb.mb_id in - Llet(Strict, id, + Llet(pure_module mb.mb_expr, id, transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr, transl_structure (id :: fields) cc rootpath rem) | Tstr_recmodule bindings -> @@ -367,7 +401,7 @@ and transl_structure fields cc rootpath = function | id :: ids -> Llet(Alias, id, Lprim(Pfield pos, [Lvar mid]), rebind_idents (pos + 1) (id :: newfields) ids) in - Llet(Strict, mid, transl_module Tcoerce_none None modl, + Llet(pure_module modl, mid, transl_module Tcoerce_none None modl, rebind_idents 0 fields ids) | Tstr_modtype _ @@ -376,6 +410,12 @@ and transl_structure fields cc rootpath = function | Tstr_attribute _ -> transl_structure fields cc rootpath rem +and pure_module m = + match m.mod_desc with + Tmod_ident _ -> Alias + | Tmod_constraint (m,_,_,_) -> pure_module m + | _ -> Strict + (* Update forward declaration in Translcore *) let _ = Translcore.transl_module := transl_module @@ -509,8 +549,8 @@ let transl_store_structure glob map prims str = let lam = transl_exception (field_path rootpath id) decl in Lsequence(Llet(Strict, id, lam, store_ident id), transl_store rootpath (add_ident false id subst) rem) - | Tstr_exn_rebind( id, _, path, _, _) -> - let lam = subst_lambda subst (transl_path path) in + | Tstr_exn_rebind( id, _, path, {Location.loc=loc}, _) -> + let lam = subst_lambda subst (transl_path ~loc item.str_env path) in Lsequence(Llet(Strict, id, lam, store_ident id), transl_store rootpath (add_ident false id subst) rem) | Tstr_module{mb_id=id; mb_expr={mod_desc = Tmod_structure str}} -> @@ -527,8 +567,7 @@ let transl_store_structure glob map prims str = transl_store rootpath (add_ident true id subst) rem))) | Tstr_module{mb_id=id; mb_expr=modl} -> - let lam = - transl_module Tcoerce_none (field_path rootpath id) modl in + let lam = transl_module Tcoerce_none (field_path rootpath id) modl in (* Careful: the module value stored in the global may be different from the local module value, in case a coercion is applied. If so, keep using the local module value (id) in the remainder of @@ -580,7 +619,7 @@ let transl_store_structure glob map prims str = and store_ident id = try let (pos, cc) = Ident.find_same id map in - let init_val = apply_coercion cc (Lvar id) in + let init_val = apply_coercion Alias cc (Lvar id) in Lprim(Psetfield(pos, false), [Lprim(Pgetglobal glob, []); init_val]) with Not_found -> fatal_error("Translmod.store_ident: " ^ Ident.unique_name id) @@ -633,7 +672,8 @@ let build_ident_map restr idlist more_ids = match restr with Tcoerce_none -> natural_map 0 Ident.empty [] idlist - | Tcoerce_structure pos_cc_list -> + | Tcoerce_structure (pos_cc_list, _id_pos_list) -> + (* ignore _id_pos_list as the ids are already bound *) let idarray = Array.of_list idlist in let rec export_map pos map prims undef = function [] -> @@ -721,14 +761,14 @@ let transl_toplevel_item item = (make_sequence toploop_setvalue_id idents) | Tstr_exception decl -> toploop_setvalue decl.cd_id (transl_exception None decl) - | Tstr_exn_rebind(id, _, path, _, _) -> - toploop_setvalue id (transl_path path) + | Tstr_exn_rebind(id, _, path, {Location.loc=loc}, _) -> + toploop_setvalue id (transl_path ~loc item.str_env path) | Tstr_module {mb_id=id; mb_expr=modl} -> (* we need to use the unique name for the module because of issues with "open" (PR#1672) *) set_toplevel_unique_name id; - toploop_setvalue id - (transl_module Tcoerce_none (Some(Pident id)) modl) + let lam = transl_module Tcoerce_none (Some(Pident id)) modl in + toploop_setvalue id lam | Tstr_recmodule bindings -> let idents = List.map (fun mb -> mb.mb_id) bindings in compile_recmodule @@ -785,10 +825,11 @@ let transl_package component_names target_name coercion = match coercion with Tcoerce_none -> List.map get_component component_names - | Tcoerce_structure pos_cc_list -> + | Tcoerce_structure (pos_cc_list, id_pos_list) -> + (* ignore id_pos_list as the ids are already bound *) let g = Array.of_list component_names in List.map - (fun (pos, cc) -> apply_coercion cc (get_component g.(pos))) + (fun (pos, cc) -> apply_coercion Strict cc (get_component g.(pos))) pos_cc_list | _ -> assert false in @@ -808,14 +849,15 @@ let transl_store_package component_names target_name coercion = [Lprim(Pgetglobal target_name, []); get_component id])) 0 component_names) - | Tcoerce_structure pos_cc_list -> + | Tcoerce_structure (pos_cc_list, id_pos_list) -> + (* ignore id_pos_list as the ids are already bound *) let id = Array.of_list component_names in (List.length pos_cc_list, make_sequence (fun dst (src, cc) -> Lprim(Psetfield(dst, false), [Lprim(Pgetglobal target_name, []); - apply_coercion cc (get_component id.(src))])) + apply_coercion Strict cc (get_component id.(src))])) 0 pos_cc_list) | _ -> assert false diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml index 437c3d71e..7f0d8577e 100644 --- a/bytecomp/translobj.ml +++ b/bytecomp/translobj.ml @@ -20,7 +20,7 @@ open Lambda let oo_prim name = try - transl_path + transl_normal_path (fst (Env.lookup_value (Ldot (Lident "CamlinternalOO", name)) Env.empty)) with Not_found -> fatal_error ("Primitive " ^ name ^ " not found.") @@ -93,12 +93,19 @@ let prim_makearray = { prim_name = "caml_make_vect"; prim_arity = 2; prim_alloc = true; prim_native_name = ""; prim_native_float = false } +(* Also use it for required globals *) let transl_label_init expr = let expr = Hashtbl.fold (fun c id expr -> Llet(Alias, id, Lconst c, expr)) consts expr in + let expr = + List.fold_right + (fun id expr -> Lsequence(Lprim(Pgetglobal id, []), expr)) + (Env.get_required_globals ()) expr + in + Env.reset_required_globals (); reset_labels (); expr diff --git a/debugger/printval.ml b/debugger/printval.ml index 0fa2eced2..5170ef3b2 100644 --- a/debugger/printval.ml +++ b/debugger/printval.ml @@ -47,7 +47,7 @@ module EvalPath = struct type valu = Debugcom.Remote_value.t exception Error - let rec eval_path = function + let rec eval_path env = function Pident id -> begin try Debugcom.Remote_value.global (Symtable.get_global_position id) @@ -55,7 +55,7 @@ module EvalPath = raise Error end | Pdot(root, fieldname, pos) -> - let v = eval_path root in + let v = eval_path env root in if not (Debugcom.Remote_value.is_block v) then raise Error else Debugcom.Remote_value.field v pos diff --git a/driver/compenv.ml b/driver/compenv.ml index 5990a6564..619670764 100644 --- a/driver/compenv.ml +++ b/driver/compenv.ml @@ -167,6 +167,7 @@ let read_OCAMLPARAM ppf position = | "no-app-funct" -> clear "no-app-funct" [ applicative_functors ] v | "nodynlink" -> clear "nodynlink" [ dlcode ] v | "short-paths" -> clear "short-paths" [ real_paths ] v + | "trans-mod" -> set "trans-mod" [ transparent_modules ] v | "pp" -> preprocessor := Some v | "runtime-variant" -> runtime_variant := v diff --git a/driver/main.ml b/driver/main.ml index 2d5bb394f..cbb645999 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -112,6 +112,7 @@ module Options = Main_args.Make_bytecomp_options (struct let _short_paths = unset real_paths let _strict_sequence = set strict_sequence let _thread = set use_threads + let _trans_mod = set transparent_modules let _vmthread = set use_vmthreads let _unsafe = set fast let _use_prims s = use_prims := s diff --git a/driver/main_args.ml b/driver/main_args.ml index d21ec6652..aba306b54 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -265,6 +265,10 @@ let mk_thread f = " Generate code that supports the system threads library" ;; +let mk_trans_mod f = + "-trans-mod", Arg.Unit f, + " Make typing and linking only depend on normalized paths" + let mk_unsafe f = "-unsafe", Arg.Unit f, " Do not compile bounds checking on array and string access" @@ -465,6 +469,7 @@ module type Bytecomp_options = sig val _runtime_variant : string -> unit val _short_paths : unit -> unit val _strict_sequence : unit -> unit + val _trans_mod : unit -> unit val _thread : unit -> unit val _vmthread : unit -> unit val _unsafe : unit -> unit @@ -508,6 +513,7 @@ module type Bytetop_options = sig val _short_paths : unit -> unit val _stdin: unit -> unit val _strict_sequence : unit -> unit + val _trans_mod : unit -> unit val _unsafe : unit -> unit val _version : unit -> unit val _vnum : unit -> unit @@ -566,6 +572,7 @@ module type Optcomp_options = sig val _shared : unit -> unit val _short_paths : unit -> unit val _strict_sequence : unit -> unit + val _trans_mod : unit -> unit val _thread : unit -> unit val _unsafe : unit -> unit val _v : unit -> unit @@ -622,6 +629,7 @@ module type Opttop_options = sig val _short_paths : unit -> unit val _stdin : unit -> unit val _strict_sequence : unit -> unit + val _trans_mod : unit -> unit val _unsafe : unit -> unit val _version : unit -> unit val _vnum : unit -> unit @@ -702,6 +710,7 @@ struct mk_runtime_variant F._runtime_variant; mk_short_paths F._short_paths; mk_strict_sequence F._strict_sequence; + mk_trans_mod F._trans_mod; mk_thread F._thread; mk_unsafe F._unsafe; mk_use_runtime F._use_runtime; @@ -749,6 +758,7 @@ struct mk_short_paths F._short_paths; mk_stdin F._stdin; mk_strict_sequence F._strict_sequence; + mk_trans_mod F._trans_mod; mk_unsafe F._unsafe; mk_version F._version; mk_vnum F._vnum; @@ -811,6 +821,7 @@ struct mk_shared F._shared; mk_short_paths F._short_paths; mk_strict_sequence F._strict_sequence; + mk_trans_mod F._trans_mod; mk_thread F._thread; mk_unsafe F._unsafe; mk_v F._v; @@ -869,6 +880,7 @@ module Make_opttop_options (F : Opttop_options) = struct mk_short_paths F._short_paths; mk_stdin F._stdin; mk_strict_sequence F._strict_sequence; + mk_trans_mod F._trans_mod; mk_unsafe F._unsafe; mk_version F._version; mk_vnum F._vnum; diff --git a/driver/main_args.mli b/driver/main_args.mli index 9372d85de..67a6c681d 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -50,6 +50,7 @@ module type Bytecomp_options = val _runtime_variant : string -> unit val _short_paths : unit -> unit val _strict_sequence : unit -> unit + val _trans_mod : unit -> unit val _thread : unit -> unit val _vmthread : unit -> unit val _unsafe : unit -> unit @@ -94,6 +95,7 @@ module type Bytetop_options = sig val _short_paths : unit -> unit val _stdin : unit -> unit val _strict_sequence : unit -> unit + val _trans_mod : unit -> unit val _unsafe : unit -> unit val _version : unit -> unit val _vnum : unit -> unit @@ -152,6 +154,7 @@ module type Optcomp_options = sig val _shared : unit -> unit val _short_paths : unit -> unit val _strict_sequence : unit -> unit + val _trans_mod : unit -> unit val _thread : unit -> unit val _unsafe : unit -> unit val _v : unit -> unit @@ -208,6 +211,7 @@ module type Opttop_options = sig val _short_paths : unit -> unit val _stdin : unit -> unit val _strict_sequence : unit -> unit + val _trans_mod : unit -> unit val _unsafe : unit -> unit val _version : unit -> unit val _vnum : unit -> unit diff --git a/driver/optmain.ml b/driver/optmain.ml index 84e07183b..d04ad76b1 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -110,6 +110,7 @@ module Options = Main_args.Make_optcomp_options (struct let _runtime_variant s = runtime_variant := s let _short_paths = clear real_paths let _strict_sequence = set strict_sequence + let _trans_mod = set transparent_modules let _shared () = shared := true; dlcode := true let _S = set keep_asm_file let _thread = set use_threads diff --git a/ocamldoc/odoc_env.ml b/ocamldoc/odoc_env.ml index d55ace84c..02d1e3a21 100644 --- a/ocamldoc/odoc_env.ml +++ b/ocamldoc/odoc_env.ml @@ -220,6 +220,7 @@ let subst_module_type env t = Types.Mty_ident p -> let new_p = Odoc_name.to_path (full_module_type_name env (Odoc_name.from_path p)) in Types.Mty_ident new_p + | Types.Mty_alias _ | Types.Mty_signature _ -> t | Types.Mty_functor (id, mt1, mt2) -> diff --git a/ocamldoc/odoc_print.ml b/ocamldoc/odoc_print.ml index d6b56f395..3fa826af9 100644 --- a/ocamldoc/odoc_print.ml +++ b/ocamldoc/odoc_print.ml @@ -55,6 +55,7 @@ let simpl_module_type ?code t = let rec iter t = match t with Types.Mty_ident p -> t + | Types.Mty_alias p -> t | Types.Mty_signature _ -> ( match code with diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index 93f0193e5..627938453 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -870,6 +870,8 @@ module Analyser = let rec f = function Parsetree.Pmty_ident longident -> Name.from_longident longident.txt + | Parsetree.Pmty_alias longident -> + Name.from_longident longident.txt | Parsetree.Pmty_signature _ -> "??" | Parsetree.Pmty_functor _ -> @@ -1060,6 +1062,16 @@ module Analyser = Module_type_alias { mta_name = Odoc_env.full_module_type_name env name ; mta_module = None } + | Parsetree.Pmty_alias longident -> + let name = + match sig_module_type with + Types.Mty_alias path -> Name.from_path path + | _ -> Name.from_longident longident.txt + in + (* Wrong naming... *) + Module_type_alias { mta_name = Odoc_env.full_module_name env name ; + mta_module = None } + | Parsetree.Pmty_signature ast -> ( let ast = filter_out_erased_items_from_signature erased ast in @@ -1136,7 +1148,8 @@ module Analyser = and analyse_module_kind ?(erased = Name.Set.empty) env current_module_name module_type sig_module_type = match module_type.Parsetree.pmty_desc with - Parsetree.Pmty_ident longident -> + Parsetree.Pmty_ident longident + | Parsetree.Pmty_alias longident -> let k = analyse_module_type_kind env current_module_name module_type sig_module_type in Module_with ( k, "" ) diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml index ed49f65a3..6657d5349 100644 --- a/parsing/ast_helper.ml +++ b/parsing/ast_helper.ml @@ -125,6 +125,7 @@ module Mty = struct let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) + let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) let functor_ ?loc ?attrs a b c = mk ?loc ?attrs (Pmty_functor (a, b, c)) let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli index 441e420d1..331b33b52 100644 --- a/parsing/ast_helper.mli +++ b/parsing/ast_helper.mli @@ -144,6 +144,7 @@ module Mty: val attr: module_type -> attribute -> module_type val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type + val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type val functor_: ?loc:loc -> ?attrs:attrs -> str -> module_type option -> module_type -> module_type diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index dac9cbe28..4cf8b84d6 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -159,6 +159,7 @@ module MT = struct let attrs = sub.attributes sub attrs in match desc with | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) + | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) | Pmty_functor (s, mt1, mt2) -> functor_ ~loc ~attrs (map_loc sub s) @@ -427,15 +428,18 @@ let default_mapper = signature_item = MT.map_signature_item; module_type = MT.map; with_constraint = MT.map_with_constraint; - class_declaration = (fun this -> CE.class_infos this (this.class_expr this)); + class_declaration = + (fun this -> CE.class_infos this (this.class_expr this)); class_expr = CE.map; class_field = CE.map_field; class_structure = CE.map_structure; class_type = CT.map; class_type_field = CT.map_field; class_signature = CT.map_signature; - class_type_declaration = (fun this -> CE.class_infos this (this.class_type this)); - class_description = (fun this -> CE.class_infos this (this.class_type this)); + class_type_declaration = + (fun this -> CE.class_infos this (this.class_type this)); + class_description = + (fun this -> CE.class_infos this (this.class_type this)); type_declaration = T.map_type_declaration; type_kind = T.map_type_kind; typ = T.map; diff --git a/parsing/parser.mly b/parsing/parser.mly index 7f23730f3..19d1fd6db 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -676,6 +676,8 @@ module_type: { mkmty(Pmty_with($1, List.rev $3)) } | MODULE TYPE OF module_expr %prec below_LBRACKETAT { mkmty(Pmty_typeof $4) } + | LPAREN MODULE mod_longident RPAREN + { mkmty (Pmty_alias (mkrhs $3 3)) } | LPAREN module_type RPAREN { $2 } | LPAREN module_type error @@ -701,7 +703,8 @@ signature_item: VAL val_ident COLON core_type post_item_attributes { mksig(Psig_value (Val.mk (mkrhs $2 2) $4 ~attrs:$5 ~loc:(symbol_rloc()))) } - | EXTERNAL val_ident COLON core_type EQUAL primitive_declaration post_item_attributes + | EXTERNAL val_ident COLON core_type EQUAL primitive_declaration + post_item_attributes { mksig(Psig_value (Val.mk (mkrhs $2 2) $4 ~prim:$6 ~attrs:$7 ~loc:(symbol_rloc()))) } @@ -711,6 +714,10 @@ signature_item: { mksig(Psig_exception $2) } | MODULE UIDENT module_declaration post_item_attributes { mksig(Psig_module (Md.mk (mkrhs $2 2) $3 ~attrs:$4)) } + | MODULE UIDENT EQUAL mod_longident post_item_attributes + { mksig(Psig_module (Md.mk (mkrhs $2 2) + (Mty.alias ~loc:(rhs_loc 4) (mkrhs $4 4)) + ~attrs:$5)) } | MODULE REC module_rec_declarations { mksig(Psig_recmodule (List.rev $3)) } | MODULE TYPE ident post_item_attributes diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 57f4ae7f3..410d6657a 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -551,6 +551,8 @@ and module_type_desc = (* module type of ME *) | Pmty_extension of extension (* [%id] *) + | Pmty_alias of Longident.t loc + (* (module M) *) and signature = signature_item list diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index 050c9fe1c..12b8fce6c 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -831,6 +831,8 @@ class printer ()= object(self:'self) match x.pmty_desc with | Pmty_ident li -> pp f "%a" self#longident_loc li; + | Pmty_alias li -> + pp f "(module %a)" self#longident_loc li; | Pmty_signature (s) -> pp f "@[<hv0>@[<hv2>sig@ %a@]@ end@]" (* "@[<hov>sig@ %a@ end@]" *) (self#list self#signature_item ) s (* FIXME wrong indentation*) @@ -875,7 +877,8 @@ class printer ()= object(self:'self) pp f "@[<2>%a@]" (fun f vd -> let intro = if vd.pval_prim = [] then "val" else "external" in - if (is_infix (fixity_of_string vd.pval_name.txt)) || List.mem vd.pval_name.txt.[0] prefix_symbols then + if (is_infix (fixity_of_string vd.pval_name.txt)) + || List.mem vd.pval_name.txt.[0] prefix_symbols then pp f "%s@ (@ %s@ )@ :@ " intro vd.pval_name.txt else pp f "%s@ %s@ :@ " intro vd.pval_name.txt; @@ -893,8 +896,13 @@ class printer ()= object(self:'self) (fun f l -> match l with |[] ->() |[x] -> pp f "@[<2>class %a@]" class_description x - |_ -> self#list ~first:"@[<v0>class @[<2>" ~sep:"@]@;and @[" ~last:"@]@]" - class_description f l) l + |_ -> + self#list ~first:"@[<v0>class @[<2>" ~sep:"@]@;and @[" + ~last:"@]@]" class_description f l) + l + | Psig_module {pmd_name; pmd_type={pmty_desc=Pmty_alias alias}} -> + pp f "@[<hov>module@ %s@ =@ %a@]" + pmd_name.txt self#longident_loc alias | Psig_module pmd -> pp f "@[<hov>module@ %s@ :@ %a@]" pmd.pmd_name.txt diff --git a/parsing/printast.ml b/parsing/printast.ml index 5f396e784..48bfe9f5b 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -572,6 +572,7 @@ and module_type i ppf x = let i = i+1 in match x.pmty_desc with | Pmty_ident li -> line i ppf "Pmty_ident %a\n" fmt_longident_loc li; + | Pmty_alias li -> line i ppf "Pmty_alias %a\n" fmt_longident_loc li; | Pmty_signature (s) -> line i ppf "Pmty_signature\n"; signature i ppf s; diff --git a/stdlib/Compflags b/stdlib/Compflags index 707487fd0..d0938af89 100755 --- a/stdlib/Compflags +++ b/stdlib/Compflags @@ -20,9 +20,6 @@ case $1 in # make sure add_char is inlined (PR#5872) buffer.cm[io]|printf.cm[io]|format.cm[io]|scanf.cm[io]) echo ' -w A';; scanf.cmx|scanf.p.cmx) echo ' -inline 9';; - arrayLabels.cm[ox]|arrayLabels.p.cmx) echo ' -nolabels';; - listLabels.cm[ox]|listLabels.p.cmx) echo ' -nolabels';; - stringLabels.cm[ox]|stringLabels.p.cmx) echo ' -nolabels';; - moreLabels.cm[ox]|moreLabels.p.cmx) echo ' -nolabels';; + *Labels.cm[ox]|*Labels.p.cmx) echo ' -nolabels -trans-mod';; *) echo ' ';; esac diff --git a/stdlib/stdLabels.mli b/stdlib/stdLabels.mli index bf9ef6547..144936f17 100644 --- a/stdlib/stdLabels.mli +++ b/stdlib/stdLabels.mli @@ -20,123 +20,6 @@ in [arrayLabels.mli], [listLabels.mli] and [stringLabels.mli]. *) -module Array : - sig - external length : 'a array -> int = "%array_length" - external get : 'a array -> int -> 'a = "%array_safe_get" - external set : 'a array -> int -> 'a -> unit = "%array_safe_set" - external make : int -> 'a -> 'a array = "caml_make_vect" - external create : int -> 'a -> 'a array = "caml_make_vect" - val init : int -> f:(int -> 'a) -> 'a array - val make_matrix : dimx:int -> dimy:int -> 'a -> 'a array array - val create_matrix : dimx:int -> dimy:int -> 'a -> 'a array array - val append : 'a array -> 'a array -> 'a array - val concat : 'a array list -> 'a array - val sub : 'a array -> pos:int -> len:int -> 'a array - val copy : 'a array -> 'a array - val fill : 'a array -> pos:int -> len:int -> 'a -> unit - val blit : - src:'a array -> src_pos:int -> dst:'a array -> dst_pos:int -> len:int -> - unit - val to_list : 'a array -> 'a list - val of_list : 'a list -> 'a array - val iter : f:('a -> unit) -> 'a array -> unit - val map : f:('a -> 'b) -> 'a array -> 'b array - val iteri : f:(int -> 'a -> unit) -> 'a array -> unit - val mapi : f:(int -> 'a -> 'b) -> 'a array -> 'b array - val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b array -> 'a - val fold_right : f:('a -> 'b -> 'b) -> 'a array -> init:'b -> 'b - val sort : cmp:('a -> 'a -> int) -> 'a array -> unit - val stable_sort : cmp:('a -> 'a -> int) -> 'a array -> unit - val fast_sort : cmp:('a -> 'a -> int) -> 'a array -> unit - external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get" - external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set" - end - -module List : - sig - val length : 'a list -> int - val hd : 'a list -> 'a - val tl : 'a list -> 'a list - val nth : 'a list -> int -> 'a - val rev : 'a list -> 'a list - val append : 'a list -> 'a list -> 'a list - val rev_append : 'a list -> 'a list -> 'a list - val concat : 'a list list -> 'a list - val flatten : 'a list list -> 'a list - val iter : f:('a -> unit) -> 'a list -> unit - val map : f:('a -> 'b) -> 'a list -> 'b list - val rev_map : f:('a -> 'b) -> 'a list -> 'b list - val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b list -> 'a - val fold_right : f:('a -> 'b -> 'b) -> 'a list -> init:'b -> 'b - val iter2 : f:('a -> 'b -> unit) -> 'a list -> 'b list -> unit - val map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list - val rev_map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list - val fold_left2 : - f:('a -> 'b -> 'c -> 'a) -> init:'a -> 'b list -> 'c list -> 'a - val fold_right2 : - f:('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> init:'c -> 'c - val for_all : f:('a -> bool) -> 'a list -> bool - val exists : f:('a -> bool) -> 'a list -> bool - val for_all2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool - val exists2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool - val mem : 'a -> set:'a list -> bool - val memq : 'a -> set:'a list -> bool - val find : f:('a -> bool) -> 'a list -> 'a - val filter : f:('a -> bool) -> 'a list -> 'a list - val find_all : f:('a -> bool) -> 'a list -> 'a list - val partition : f:('a -> bool) -> 'a list -> 'a list * 'a list - val assoc : 'a -> ('a * 'b) list -> 'b - val assq : 'a -> ('a * 'b) list -> 'b - val mem_assoc : 'a -> map:('a * 'b) list -> bool - val mem_assq : 'a -> map:('a * 'b) list -> bool - val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list - val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list - val split : ('a * 'b) list -> 'a list * 'b list - val combine : 'a list -> 'b list -> ('a * 'b) list - val sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list - val stable_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list - val fast_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list - val merge : cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list - end - -module String : - sig - external length : string -> int = "%string_length" - external get : string -> int -> char = "%string_safe_get" - external set : string -> int -> char -> unit = "%string_safe_set" - external create : int -> string = "caml_create_string" - val make : int -> char -> string - val copy : string -> string - val sub : string -> pos:int -> len:int -> string - val fill : string -> pos:int -> len:int -> char -> unit - val blit : - src:string -> src_pos:int -> dst:string -> dst_pos:int -> len:int -> - unit - val concat : sep:string -> string list -> string - val iter : f:(char -> unit) -> string -> unit - val iteri : f:(int -> char -> unit) -> string -> unit - val map : f:(char -> char) -> string -> string - val trim : string -> string - val escaped : string -> string - val index : string -> char -> int - val rindex : string -> char -> int - val index_from : string -> int -> char -> int - val rindex_from : string -> int -> char -> int - val contains : string -> char -> bool - val contains_from : string -> int -> char -> bool - val rcontains_from : string -> int -> char -> bool - val uppercase : string -> string - val lowercase : string -> string - val capitalize : string -> string - val uncapitalize : string -> string - type t = string - val compare: t -> t -> int - external unsafe_get : string -> int -> char = "%string_unsafe_get" - external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" - external unsafe_blit : - src:string -> src_pos:int -> dst:string -> dst_pos:int -> len:int -> - unit = "caml_blit_string" "noalloc" - external unsafe_fill : string -> pos:int -> len:int -> char -> unit - = "caml_fill_string" "noalloc" - end +module Array = ArrayLabels +module List = ListLabels +module String = StringLabels diff --git a/testsuite/tests/typing-gadts/test.ml.principal.reference b/testsuite/tests/typing-gadts/test.ml.principal.reference index 551f9cb2d..0d40f674a 100644 --- a/testsuite/tests/typing-gadts/test.ml.principal.reference +++ b/testsuite/tests/typing-gadts/test.ml.principal.reference @@ -311,7 +311,7 @@ Error: This expression has type < bar : int; foo : int; .. > as 'a # val g : 'a ty -> 'a = <fun> # module M : sig type _ t = int end # module M : sig type _ t = T : int t end -# module N : sig type 'a t = 'a M.t = T : int t end +# module N = M # val f : ('a, 'b) eq -> ('a, int) eq -> 'a -> 'b -> unit = <fun> # val f : ('a, 'b) eq -> ('b, int) eq -> 'a -> 'b -> unit = <fun> # diff --git a/testsuite/tests/typing-gadts/test.ml.reference b/testsuite/tests/typing-gadts/test.ml.reference index 41b756766..e6aa47b41 100644 --- a/testsuite/tests/typing-gadts/test.ml.reference +++ b/testsuite/tests/typing-gadts/test.ml.reference @@ -298,7 +298,7 @@ Error: This expression has type < bar : int; foo : int; .. > as 'a # val g : 'a ty -> 'a = <fun> # module M : sig type _ t = int end # module M : sig type _ t = T : int t end -# module N : sig type 'a t = 'a M.t = T : int t end +# module N = M # val f : ('a, 'b) eq -> ('a, int) eq -> 'a -> 'b -> unit = <fun> # val f : ('a, 'b) eq -> ('b, int) eq -> 'a -> 'b -> unit = <fun> # diff --git a/testsuite/tests/typing-modules-bugs/gatien_baron_20131019_ok.ml b/testsuite/tests/typing-modules-bugs/gatien_baron_20131019_ok.ml new file mode 100644 index 000000000..588744549 --- /dev/null +++ b/testsuite/tests/typing-modules-bugs/gatien_baron_20131019_ok.ml @@ -0,0 +1,31 @@ +module Std = struct module Hash = Hashtbl end;; + +open Std;; +module Hash1 : module type of Hash = Hash;; +module Hash2 : sig include (module type of Hash) end = Hash;; +let f1 (x : (_,_) Hash1.t) = (x : (_,_) Hashtbl.t);; +let f2 (x : (_,_) Hash2.t) = (x : (_,_) Hashtbl.t);; + +(* Another case, not using include *) + +module Std2 = struct module M = struct type t end end;; +module Std' = Std2;; +module M' : module type of Std'.M = Std2.M;; +let f3 (x : M'.t) = (x : Std2.M.t);; + +(* original report required Core_kernel: +module type S = sig +open Core_kernel.Std + +module Hashtbl1 : module type of Hashtbl +module Hashtbl2 : sig + include (module type of Hashtbl) +end + +module Coverage : Core_kernel.Std.Hashable + +type types = unit constraint 'a Coverage.Table.t = (Coverage.t, 'a) Hashtbl1.t +type doesnt_type = unit + constraint 'a Coverage.Table.t = (Coverage.t, 'a) Hashtbl2.t +end +*) diff --git a/testsuite/tests/typing-modules/a.mli b/testsuite/tests/typing-modules/a.mli new file mode 100644 index 000000000..ea15bf005 --- /dev/null +++ b/testsuite/tests/typing-modules/a.mli @@ -0,0 +1,3 @@ +module L = List +module S = String +module D' = D diff --git a/testsuite/tests/typing-modules/aliases.ml b/testsuite/tests/typing-modules/aliases.ml new file mode 100644 index 000000000..1c651c4a8 --- /dev/null +++ b/testsuite/tests/typing-modules/aliases.ml @@ -0,0 +1,132 @@ +module C = Char;; +C.chr 66;; + +module C' : module type of Char = C;; +C'.chr 66;; + +module C'' : (module C) = C';; (* fails *) + +module C'' : (module Char) = C;; +C''.chr 66;; + +module C3 = struct include Char end;; +C3.chr 66;; + +let f x = let module M = struct module L = List end in M.L.length x;; +let g x = let module L = List in L.length (L.map succ x);; + +module F(X:sig end) = Char;; +module C4 = F(struct end);; +C4.chr 66;; + +module G(X:sig end) = struct module M = X end;; (* does not alias X *) +module M = G(struct end);; + +module M' = struct + module N = struct let x = 1 end + module N' = N +end;; +M'.N'.x;; + +module M'' : sig module N' : sig val x : int end end = M';; +M''.N'.x;; +module M2 = struct include M' end;; +module M3 : sig module N' : sig val x : int end end = struct include M' end;; +M3.N'.x;; +module M3' : sig module N' : sig val x : int end end = M2;; +M3'.N'.x;; + +module M4 : sig module N' : sig val x : int end end = struct + module N = struct let x = 1 end + module N' = N +end;; +M4.N'.x;; + +module F(X:sig end) = struct + module N = struct let x = 1 end + module N' = N +end;; +module G : functor(X:sig end) -> sig module N' : sig val x : int end end = F;; +module M5 = G(struct end);; +M5.N'.x;; + +module M = struct + module D = struct let y = 3 end + module N = struct let x = 1 end + module N' = N +end;; + +module M1 : sig module N : sig val x : int end module N' = N end = M;; +M1.N'.x;; +module M2 : sig module N' : sig val x : int end end = + (M : sig module N : sig val x : int end module N' = N end);; +M2.N'.x;; + +open M;; +N'.x;; + +module M = struct + module C = Char + module C' = C +end;; +module M1 + : sig module C : sig val escaped : char -> string end module C' = C end + = M;; (* sound, but should probably fail *) +M1.C'.escaped 'A';; +module M2 : sig module C' : sig val chr : int -> char end end = + (M : sig module C : sig val chr : int -> char end module C' = C end);; +M2.C'.chr 66;; + +StdLabels.List.map;; + +module Q = Queue;; +exception QE = Q.Empty;; +try Q.pop (Q.create ()) with QE -> "Ok";; + +module type Complex = module type of Complex with type t = Complex.t;; +module M : sig module C : Complex end = struct module C = Complex end;; + +module C = Complex;; +C.one.Complex.re;; +include C;; + +module F(X:sig module C = Char end) = struct module C = X.C end;; + +(* Applicative functors *) +module S = String +module StringSet = Set.Make(String) +module SSet = Set.Make(S);; +let f (x : StringSet.t) = (x : SSet.t);; + +(* Also using include (cf. Leo's mail 2013-11-16) *) +module F (M : sig end) : sig type t end = struct type t = int end +module T = struct + module M = struct end + include F(M) +end;; +include T;; +let f (x : t) : T.t = x ;; + +(* PR#4049 *) +(* This works thanks to abbreviations *) +module A = struct + module B = struct type t let compare x y = 0 end + module S = Set.Make(B) + let empty = S.empty +end +module A1 = A;; +A1.empty = A.empty;; + +(* PR#3476 *) +(* Does not work yet *) +module FF(X : sig end) = struct type t end +module M = struct + module X = struct end + module Y = FF (X) (* XXX *) + type t = Y.t +end +module F (Y : sig type t end) (M : sig type t = Y.t end) = struct end;; + +module G = F (M.Y);; +(*module N = G (M);; +module N = F (M.Y) (M);;*) diff --git a/testsuite/tests/typing-modules/aliases.ml.reference b/testsuite/tests/typing-modules/aliases.ml.reference new file mode 100644 index 000000000..723f9ef46 --- /dev/null +++ b/testsuite/tests/typing-modules/aliases.ml.reference @@ -0,0 +1,264 @@ + +# module C = Char +# - : char = 'B' +# module C' : + sig + external code : char -> int = "%identity" + val chr : int -> char + val escaped : char -> string + val lowercase : char -> char + val uppercase : char -> char + type t = char + val compare : t -> t -> int + external unsafe_chr : int -> char = "%identity" + end +# - : char = 'B' +# Characters 27-29: + module C'' : (module C) = C';; (* fails *) + ^^ +Error: Signature mismatch: + Modules do not match: (module C') is not included in (module C) +# module C'' = Char +# - : char = 'B' +# module C3 : + sig + external code : char -> int = "%identity" + val chr : int -> char + val escaped : char -> string + val lowercase : char -> char + val uppercase : char -> char + type t = char + val compare : t -> t -> int + external unsafe_chr : int -> char = "%identity" + end +# - : char = 'B' +# val f : 'a list -> int = <fun> +# val g : int list -> int = <fun> +# module F : + functor (X : sig end) -> + sig + external code : char -> int = "%identity" + val chr : int -> char + val escaped : char -> string + val lowercase : char -> char + val uppercase : char -> char + type t = char + val compare : t -> t -> int + external unsafe_chr : int -> char = "%identity" + end +# module C4 : + sig + external code : char -> int = "%identity" + val chr : int -> char + val escaped : char -> string + val lowercase : char -> char + val uppercase : char -> char + type t = char + val compare : t -> t -> int + external unsafe_chr : int -> char = "%identity" + end +# - : char = 'B' +# module G : functor (X : sig end) -> sig module M : sig end end +# module M : sig module M : sig end end +# module M' : sig module N : sig val x : int end module N' = N end +# - : int = 1 +# module M'' : sig module N' : sig val x : int end end +# - : int = 1 +# module M2 : sig module N = M'.N module N' = M'.N' end +# module M3 : sig module N' : sig val x : int end end +# - : int = 1 +# module M3' : sig module N' : sig val x : int end end +# - : int = 1 +# module M4 : sig module N' : sig val x : int end end +# - : int = 1 +# module F : + functor (X : sig end) -> + sig module N : sig val x : int end module N' = N end +# module G : functor (X : sig end) -> sig module N' : sig val x : int end end +# module M5 : sig module N' : sig val x : int end end +# - : int = 1 +# module M : + sig + module D : sig val y : int end + module N : sig val x : int end + module N' = N + end +# module M1 : sig module N : sig val x : int end module N' = N end +# - : int = 1 +# module M2 : sig module N' : sig val x : int end end +# - : int = 1 +# # - : int = 1 +# module M : sig module C = Char module C' = C end +# module M1 : + sig module C : sig val escaped : char -> string end module C' = C end +# - : string = "A" +# module M2 : sig module C' : sig val chr : int -> char end end +# - : char = 'B' +# - : f:('a -> 'b) -> 'a list -> 'b list = <fun> +# module Q = Queue +# exception QE +# - : string = "Ok" +# module type Complex = + sig + type t = Complex.t = { re : float; im : float; } + val zero : t + val one : t + val i : t + val neg : t -> t + val conj : t -> t + val add : t -> t -> t + val sub : t -> t -> t + val mul : t -> t -> t + val inv : t -> t + val div : t -> t -> t + val sqrt : t -> t + val norm2 : t -> float + val norm : t -> float + val arg : t -> float + val polar : float -> float -> t + val exp : t -> t + val log : t -> t + val pow : t -> t -> t + end +# module M : sig module C : Complex end +# module C = Complex +# - : float = 1. +# type t = Complex.t = { re : float; im : float; } +val zero : t = {re = 0.; im = 0.} +val one : t = {re = 1.; im = 0.} +val i : t = {re = 0.; im = 1.} +val neg : t -> t = <fun> +val conj : t -> t = <fun> +val add : t -> t -> t = <fun> +val sub : t -> t -> t = <fun> +val mul : t -> t -> t = <fun> +val inv : t -> t = <fun> +val div : t -> t -> t = <fun> +val sqrt : t -> t = <fun> +val norm2 : t -> float = <fun> +val norm : t -> float = <fun> +val arg : t -> float = <fun> +val polar : float -> float -> t = <fun> +val exp : t -> t = <fun> +val log : t -> t = <fun> +val pow : t -> t -> t = <fun> +# module F : functor (X : sig module C = Char end) -> sig module C = Char end +# module S = String +module StringSet : + sig + type elt = String.t + type t = Set.Make(String).t + val empty : t + val is_empty : t -> bool + val mem : elt -> t -> bool + val add : elt -> t -> t + val singleton : elt -> t + val remove : elt -> t -> t + val union : t -> t -> t + val inter : t -> t -> t + val diff : t -> t -> t + val compare : t -> t -> int + val equal : t -> t -> bool + val subset : t -> t -> bool + val iter : (elt -> unit) -> t -> unit + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a + val for_all : (elt -> bool) -> t -> bool + val exists : (elt -> bool) -> t -> bool + val filter : (elt -> bool) -> t -> t + val partition : (elt -> bool) -> t -> t * t + val cardinal : t -> int + val elements : t -> elt list + val min_elt : t -> elt + val max_elt : t -> elt + val choose : t -> elt + val split : elt -> t -> t * bool * t + val find : elt -> t -> elt + val of_list : elt list -> t + end +module SSet : + sig + type elt = S.t + type t = Set.Make(S).t + val empty : t + val is_empty : t -> bool + val mem : elt -> t -> bool + val add : elt -> t -> t + val singleton : elt -> t + val remove : elt -> t -> t + val union : t -> t -> t + val inter : t -> t -> t + val diff : t -> t -> t + val compare : t -> t -> int + val equal : t -> t -> bool + val subset : t -> t -> bool + val iter : (elt -> unit) -> t -> unit + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a + val for_all : (elt -> bool) -> t -> bool + val exists : (elt -> bool) -> t -> bool + val filter : (elt -> bool) -> t -> t + val partition : (elt -> bool) -> t -> t * t + val cardinal : t -> int + val elements : t -> elt list + val min_elt : t -> elt + val max_elt : t -> elt + val choose : t -> elt + val split : elt -> t -> t * bool * t + val find : elt -> t -> elt + val of_list : elt list -> t + end +# val f : StringSet.t -> SSet.t = <fun> +# module F : functor (M : sig end) -> sig type t end +module T : sig module M : sig end type t = F(M).t end +# module M = T.M +type t = F(M).t +# val f : t -> T.t = <fun> +# module A : + sig + module B : sig type t val compare : 'a -> 'b -> int end + module S : + sig + type elt = B.t + type t = Set.Make(B).t + val empty : t + val is_empty : t -> bool + val mem : elt -> t -> bool + val add : elt -> t -> t + val singleton : elt -> t + val remove : elt -> t -> t + val union : t -> t -> t + val inter : t -> t -> t + val diff : t -> t -> t + val compare : t -> t -> int + val equal : t -> t -> bool + val subset : t -> t -> bool + val iter : (elt -> unit) -> t -> unit + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a + val for_all : (elt -> bool) -> t -> bool + val exists : (elt -> bool) -> t -> bool + val filter : (elt -> bool) -> t -> t + val partition : (elt -> bool) -> t -> t * t + val cardinal : t -> int + val elements : t -> elt list + val min_elt : t -> elt + val max_elt : t -> elt + val choose : t -> elt + val split : elt -> t -> t * bool * t + val find : elt -> t -> elt + val of_list : elt list -> t + end + val empty : S.t + end +module A1 = A +# - : bool = true +# module FF : functor (X : sig end) -> sig type t end +module M : + sig + module X : sig end + module Y : sig type t = FF(X).t end + type t = Y.t + end +module F : + functor (Y : sig type t end) -> + functor (M : sig type t = Y.t end) -> sig end +# module G : functor (M : sig type t = M.Y.t end) -> sig end +# * diff --git a/testsuite/tests/typing-modules/b.ml b/testsuite/tests/typing-modules/b.ml new file mode 100644 index 000000000..4c43e809f --- /dev/null +++ b/testsuite/tests/typing-modules/b.ml @@ -0,0 +1,18 @@ +open A +let f = + L.map S.capitalize + +let () = + L.iter print_endline (f ["jacques"; "garrigue"]) + +module C : sig module L : module type of List end = struct include A end + +(* The following introduces a (useless) dependency on A: +module C : sig module L : module type of List end = A +*) + +include D' +(* +let () = + print_endline (string_of_int D'.M.y) +*) diff --git a/testsuite/tests/typing-modules/b2.ml b/testsuite/tests/typing-modules/b2.ml new file mode 100644 index 000000000..034e432c3 --- /dev/null +++ b/testsuite/tests/typing-modules/b2.ml @@ -0,0 +1,14 @@ +open A +let f = + L.map S.capitalize + +let () = + L.iter print_endline (f ["jacques"; "garrigue"]) + +module C : sig module L : module type of List end = struct include A end + +(* The following introduces a (useless) dependency on A: +module C : sig module L : module type of List end = A +*) + +(* No dependency on D *) diff --git a/testsuite/tests/typing-modules/b3.mli b/testsuite/tests/typing-modules/b3.mli new file mode 100644 index 000000000..04599abe3 --- /dev/null +++ b/testsuite/tests/typing-modules/b3.mli @@ -0,0 +1,4 @@ +open A +(*module type S = module type of D'.M*) +type t = Complex.t +type s = String.t diff --git a/testsuite/tests/typing-modules/d.ml b/testsuite/tests/typing-modules/d.ml new file mode 100644 index 000000000..55d311f40 --- /dev/null +++ b/testsuite/tests/typing-modules/d.ml @@ -0,0 +1,2 @@ +let x = 3 +module M = struct let y = 5 end diff --git a/testsuite/tests/typing-private/private.ml.reference b/testsuite/tests/typing-private/private.ml.reference index 3d217802b..d21ec4a14 100644 --- a/testsuite/tests/typing-private/private.ml.reference +++ b/testsuite/tests/typing-private/private.ml.reference @@ -6,7 +6,7 @@ ^ Error: This expression has type F0.t but an expression was expected of type Foobar.t -# module F : sig type t = Foobar.t end +# module F = Foobar # val f : F.t -> Foobar.t = <fun> # module M : sig type t = < m : int > end # module M1 : sig type t = private < m : int; .. > end diff --git a/testsuite/tests/typing-recmod/t19ok.ml b/testsuite/tests/typing-recmod/t19ok.ml index 62e5f4548..e51fa5c92 100644 --- a/testsuite/tests/typing-recmod/t19ok.ml +++ b/testsuite/tests/typing-recmod/t19ok.ml @@ -5,8 +5,11 @@ module PR_4758 = struct module type Mod = sig module Other : S end - module rec A : S = struct - end and C : sig include Mod with module Other = A end = struct + module rec A : S = struct end + and C : sig include Mod with module Other = A end = struct module Other = A end + module C' = C (* check that we can take an alias *) + module F(X:sig end) = struct type t end + let f (x : F(C).t) = (x : F(C').t) end diff --git a/testsuite/tests/typing-short-paths/short-paths.ml.reference b/testsuite/tests/typing-short-paths/short-paths.ml.reference index 4c1a991a5..657a52145 100644 --- a/testsuite/tests/typing-short-paths/short-paths.ml.reference +++ b/testsuite/tests/typing-short-paths/short-paths.ml.reference @@ -44,52 +44,7 @@ val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t end end - module Std : - sig - module Int : - sig - module T : - sig - type t = int - val compare : 'a -> 'a -> t - val ( + ) : t -> t -> t - end - type t = int - val compare : 'a -> 'a -> t - val ( + ) : t -> t -> t - module Map : - sig - type key = t - type 'a t = 'a Map.Make(T).t - val empty : 'a t - val is_empty : 'a t -> bool - val mem : key -> 'a t -> bool - val add : key -> 'a -> 'a t -> 'a t - val singleton : key -> 'a -> 'a t - val remove : key -> 'a t -> 'a t - val merge : - (key -> 'a option -> 'b option -> 'c option) -> - 'a t -> 'b t -> 'c t - val compare : ('a -> 'a -> key) -> 'a t -> 'a t -> key - val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool - val iter : (key -> 'a -> unit) -> 'a t -> unit - val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - val for_all : (key -> 'a -> bool) -> 'a t -> bool - val exists : (key -> 'a -> bool) -> 'a t -> bool - val filter : (key -> 'a -> bool) -> 'a t -> 'a t - val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t - val cardinal : 'a t -> key - val bindings : 'a t -> (key * 'a) list - val min_binding : 'a t -> key * 'a - val max_binding : 'a t -> key * 'a - val choose : 'a t -> key * 'a - val split : key -> 'a t -> 'a t * 'a option * 'a t - val find : key -> 'a t -> 'a - val map : ('a -> 'b) -> 'a t -> 'b t - val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t - end - end - end + module Std : sig module Int = Int end end # # val x : 'a Int.Map.t = <abstr> # Characters 8-9: diff --git a/tools/depend.ml b/tools/depend.ml index 4c3a94320..bd6efc085 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -199,6 +199,7 @@ and add_bindings recf bv pel = and add_modtype bv mty = match mty.pmty_desc with Pmty_ident l -> add bv l + | Pmty_alias l -> add bv l | Pmty_signature s -> add_signature bv s | Pmty_functor(id, mty1, mty2) -> Misc.may (add_modtype bv) mty1; diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml index 82b0174a8..bca5ae63c 100644 --- a/tools/ocamlcp.ml +++ b/tools/ocamlcp.ml @@ -79,6 +79,7 @@ module Options = Main_args.Make_bytecomp_options (struct let _runtime_variant s = option_with_arg "-runtime-variant" s let _short_paths = option "-short-paths" let _strict_sequence = option "-strict-sequence" + let _trans_mod = option "-trans-mod" let _thread () = option "-thread" () let _vmthread () = option "-vmthread" () let _unsafe = option "-unsafe" diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml index 23a439a11..6d730f2c3 100644 --- a/tools/ocamloptp.ml +++ b/tools/ocamloptp.ml @@ -84,6 +84,7 @@ module Options = Main_args.Make_optcomp_options (struct let _strict_sequence = option "-strict-sequence" let _shared = option "-shared" let _thread = option "-thread" + let _trans_mod = option "-trans-mod" let _unsafe = option "-unsafe" let _v = option "-v" let _version = option "-version" diff --git a/tools/tast_iter.ml b/tools/tast_iter.ml index b6a27a958..c8af13670 100644 --- a/tools/tast_iter.ml +++ b/tools/tast_iter.ml @@ -191,6 +191,7 @@ let class_type_declaration sub cd = let module_type sub mty = match mty.mty_desc with | Tmty_ident (_path, _) -> () + | Tmty_alias (_path, _) -> () | Tmty_signature sg -> sub # signature sg | Tmty_functor (_id, _, mtype1, mtype2) -> Misc.may (sub # module_type) mtype1; sub # module_type mtype2 diff --git a/tools/untypeast.ml b/tools/untypeast.ml index 74ffb92c9..61d68e9ac 100644 --- a/tools/untypeast.ml +++ b/tools/untypeast.ml @@ -374,6 +374,7 @@ and untype_class_type_declaration cd = and untype_module_type mty = let desc = match mty.mty_desc with Tmty_ident (_path, lid) -> Pmty_ident (lid) + | Tmty_alias (_path, lid) -> Pmty_alias (lid) | Tmty_signature sg -> Pmty_signature (untype_signature sg) | Tmty_functor (_id, name, mtype1, mtype2) -> Pmty_functor (name, Misc.may_map untype_module_type mtype1, diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index c37b2884c..10f4fdeb7 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -32,7 +32,7 @@ module type OBJ = module type EVALPATH = sig type valu - val eval_path: Path.t -> valu + val eval_path: Env.t -> Path.t -> valu exception Error val same_value: valu -> valu -> bool end @@ -368,7 +368,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct (* Make sure this is the right exception and not an homonym, by evaluating the exception found and comparing with the identifier contained in the exception bucket *) - if not (EVP.same_value slot (EVP.eval_path path)) + if not (EVP.same_value slot (EVP.eval_path env path)) then raise Not_found; tree_of_constr_with_args (fun x -> Oide_ident x) name 1 depth bucket cstr.cstr_args diff --git a/toplevel/genprintval.mli b/toplevel/genprintval.mli index 8ddf0796b..3f7b85ab6 100644 --- a/toplevel/genprintval.mli +++ b/toplevel/genprintval.mli @@ -28,7 +28,7 @@ module type OBJ = module type EVALPATH = sig type valu - val eval_path: Path.t -> valu + val eval_path: Env.t -> Path.t -> valu exception Error val same_value: valu -> valu -> bool end diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index 044e94da9..20fe39b26 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -221,7 +221,7 @@ let find_printer_type ppf lid = let dir_install_printer ppf lid = try let (ty_arg, path, is_old_style) = find_printer_type ppf lid in - let v = eval_path path in + let v = eval_path !toplevel_env path in let print_function = if is_old_style then (fun formatter repr -> Obj.obj v (Obj.obj repr)) @@ -262,7 +262,7 @@ let dir_trace ppf lid = fprintf ppf "%a is an external function and cannot be traced.@." Printtyp.longident lid | _ -> - let clos = eval_path path in + let clos = eval_path !toplevel_env path in (* Nothing to do if it's not a closure *) if Obj.is_block clos && (Obj.tag clos = Obj.closure_tag || Obj.tag clos = Obj.infix_tag) diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index f556fb65e..503a11e5e 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -61,12 +61,15 @@ let rec eval_path = function | Papply(p1, p2) -> fatal_error "Toploop.eval_path" +let eval_path env path = + eval_path (Env.normalize_path (Some Location.none) env path) + (* To print values *) module EvalPath = struct type valu = Obj.t exception Error - let eval_path p = try eval_path p with Symtable.Error _ -> raise Error + let eval_path env p = try eval_path env p with Symtable.Error _ -> raise Error let same_value v1 v2 = (v1 == v2) end diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli index da607de9d..324857a83 100644 --- a/toplevel/toploop.mli +++ b/toplevel/toploop.mli @@ -60,7 +60,7 @@ val mod_use_file : formatter -> string -> bool [use_file] prints the types and values of the results. [use_silently] does not print them. [mod_use_file] wrap the file contents into a module. *) -val eval_path: Path.t -> Obj.t +val eval_path: Env.t -> Path.t -> Obj.t (* Return the toplevel object referred to by the given path *) (* Printing of values *) diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml index 3091ca0d2..0f3ac66f9 100644 --- a/toplevel/topmain.ml +++ b/toplevel/topmain.ml @@ -79,6 +79,7 @@ module Options = Main_args.Make_bytetop_options (struct let _short_paths = clear real_paths let _stdin () = file_argument "" let _strict_sequence = set strict_sequence + let _trans_mod = set transparent_modules let _unsafe = set fast let _version () = print_version () let _vnum () = print_version_num () diff --git a/typing/ctype.ml b/typing/ctype.ml index c00228ffe..b109cc020 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -1379,7 +1379,7 @@ let expand_abbrev_gen kind find_type_expansion env ty = ty | None -> let (params, body, lv) = - try find_type_expansion level path env with Not_found -> + try find_type_expansion path env with Not_found -> raise Cannot_expand in (* prerr_endline @@ -1405,10 +1405,9 @@ let expand_abbrev_gen kind find_type_expansion env ty = | _ -> assert false -(* inside objects and variants we do not want to - use local constraints *) +(* Expand respecting privacy *) let expand_abbrev ty = - expand_abbrev_gen Public (fun level -> Env.find_type_expansion ~level) ty + expand_abbrev_gen Public Env.find_type_expansion ty (* Expand once the head of a type *) let expand_head_once env ty = @@ -1486,7 +1485,7 @@ let rec extract_concrete_typedecl env ty = the private abbreviation. *) let expand_abbrev_opt = - expand_abbrev_gen Private (fun level -> Env.find_type_expansion_opt) + expand_abbrev_gen Private Env.find_type_expansion_opt let try_expand_once_opt env ty = let ty = repr ty in @@ -2176,7 +2175,7 @@ let rec normalize_package_path env p = in match t with | Some (Mty_ident p) -> normalize_package_path env p - | Some (Mty_signature _ | Mty_functor _) | None -> p + | Some (Mty_signature _ | Mty_functor _ | Mty_alias _) | None -> p let eq_package_path env p1 p2 = Path.same p1 p2 || diff --git a/typing/env.ml b/typing/env.ml index 6cfd62c4e..f9e214556 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -57,6 +57,7 @@ type error = | Illegal_renaming of string * string * string | Inconsistent_import of string * string * string | Need_recursive_types of string * string + | Missing_module of Location.t * Path.t * Path.t exception Error of error @@ -111,6 +112,7 @@ type summary = | Env_class of summary * Ident.t * class_declaration | Env_cltype of summary * Ident.t * class_type_declaration | Env_open of summary * Path.t + | Env_functor_arg of summary * Ident.t module EnvTbl = struct @@ -172,6 +174,7 @@ type t = { components: (Path.t * module_components) EnvTbl.t; classes: (Path.t * class_declaration) EnvTbl.t; cltypes: (Path.t * class_type_declaration) EnvTbl.t; + functor_args: unit Ident.tbl; summary: summary; local_constraints: bool; gadt_instances: (int * TypeSet.t ref) list; @@ -218,6 +221,7 @@ let empty = { cltypes = EnvTbl.empty; summary = Env_empty; local_constraints = false; gadt_instances = []; in_signature = false; + functor_args = Ident.empty; } let in_signature env = {env with in_signature = true} @@ -262,6 +266,10 @@ let check_modtype_inclusion = (* to be filled with Includemod.check_modtype_inclusion *) ref ((fun env mty1 path1 mty2 -> assert false) : t -> module_type -> Path.t -> module_type -> unit) +let strengthen = + (* to be filled with Mtype.strengthen *) + ref ((fun env mty path -> assert false) : + t -> module_type -> Path.t -> module_type) let md md_type = {md_type; md_attributes=[]} @@ -279,7 +287,8 @@ type pers_struct = ps_comps: module_components; ps_crcs: (string * Digest.t) list; ps_filename: string; - ps_flags: pers_flags list } + ps_flags: pers_flags list; + mutable ps_crcs_checked: bool } let persistent_structures = (Hashtbl.create 17 : (string, pers_struct option) Hashtbl.t) @@ -288,17 +297,19 @@ let persistent_structures = let crc_units = Consistbl.create() -let check_consistency filename crcs = +let check_consistency ps = + if ps.ps_crcs_checked then () else try List.iter - (fun (name, crc) -> Consistbl.check crc_units name crc filename) - crcs + (fun (name, crc) -> Consistbl.check crc_units name crc ps.ps_filename) + ps.ps_crcs; + ps.ps_crcs_checked <- true with Consistbl.Inconsistency(name, source, auth) -> error (Inconsistent_import(name, auth, source)) (* Reading persistent structures from .cmi files *) -let read_pers_struct modname filename = ( +let read_pers_struct modname filename = let cmi = read_cmi filename in let name = cmi.cmi_name in let sign = cmi.cmi_sign in @@ -307,35 +318,37 @@ let read_pers_struct modname filename = ( let comps = !components_of_module' empty Subst.identity (Pident(Ident.create_persistent name)) - (Mty_signature sign) in - let ps = { ps_name = name; - ps_sig = sign; - ps_comps = comps; - ps_crcs = crcs; - ps_filename = filename; - ps_flags = flags } in - if ps.ps_name <> modname then - error (Illegal_renaming(modname, ps.ps_name, filename)); - check_consistency filename ps.ps_crcs; - List.iter - (function Rectypes -> - if not !Clflags.recursive_types then - error (Need_recursive_types(ps.ps_name, !current_unit))) - ps.ps_flags; - Hashtbl.add persistent_structures modname (Some ps); - ps -) - -let find_pers_struct name = + (Mty_signature sign) + in + let ps = { ps_name = name; + ps_sig = sign; + ps_comps = comps; + ps_crcs = crcs; + ps_crcs_checked = false; + ps_filename = filename; + ps_flags = flags } in + if ps.ps_name <> modname then + error (Illegal_renaming(modname, ps.ps_name, filename)); + if not !Clflags.transparent_modules then check_consistency ps; + List.iter + (function Rectypes -> + if not !Clflags.recursive_types then + error (Need_recursive_types(ps.ps_name, !current_unit))) + ps.ps_flags; + Hashtbl.add persistent_structures modname (Some ps); + ps + +let find_pers_struct ?(check=true) name = if name = "*predef*" then raise Not_found; let r = try Some (Hashtbl.find persistent_structures name) with Not_found -> None in - match r with - | Some None -> raise Not_found - | Some (Some sg) -> sg - | None -> + let ps = + match r with + | Some None -> raise Not_found + | Some (Some sg) -> sg + | None -> let filename = try find_in_path_uncap !load_path (name ^ ".cmi") with Not_found -> @@ -343,6 +356,9 @@ let find_pers_struct name = raise Not_found in read_pers_struct name filename + in + if check then check_consistency ps; + ps let reset_cache () = current_unit := ""; @@ -436,10 +452,81 @@ let find_type p env = let find_type_descrs p env = snd (find_type_full p env) +let find_module path env = + match path with + Pident id -> + begin try + let (p, data) = EnvTbl.find_same id env.modules + in data + with Not_found -> + if Ident.persistent id then + let ps = find_pers_struct (Ident.name id) in + md (Mty_signature(ps.ps_sig)) + else raise Not_found + end + | Pdot(p, s, pos) -> + begin match + EnvLazy.force !components_of_module_maker' (find_module_descr p env) + with + Structure_comps c -> + let (data, pos) = Tbl.find s c.comp_modules in + md (EnvLazy.force subst_modtype_maker data) + | Functor_comps f -> + raise Not_found + end + | Papply(p1, p2) -> + let desc1 = find_module_descr p1 env in + begin match EnvLazy.force !components_of_module_maker' desc1 with + Functor_comps f -> + let mty = + Subst.modtype (Subst.add_module f.fcomp_param p2 f.fcomp_subst) + f.fcomp_res in + md mty + | Structure_comps c -> + raise Not_found + end + +let required_globals = ref [] +let reset_required_globals () = required_globals := [] +let get_required_globals () = !required_globals +let add_required_global id = + if Ident.global id && not !Clflags.transparent_modules + && not (List.exists (Ident.same id) !required_globals) + then required_globals := id :: !required_globals + +let rec normalize_path lax env path = + let path = + match path with + Pdot(p, s, pos) -> + Pdot(normalize_path lax env p, s, pos) + | Papply(p1, p2) -> + Papply(normalize_path lax env p1, normalize_path true env p2) + | _ -> path + in + try match find_module path env with + {md_type=Mty_alias path1} -> + let path' = normalize_path lax env path1 in + if lax || !Clflags.transparent_modules then path' else + let id = Path.head path in + if Ident.global id && not (Ident.same id (Path.head path')) + then add_required_global id; + path' + | _ -> path + with Not_found when lax + || (match path with Pident id -> not (Ident.persistent id) | _ -> true) -> + path + +let normalize_path oloc env path = + try normalize_path (oloc = None) env path + with Not_found -> + match oloc with None -> assert false + | Some loc -> + raise (Error(Missing_module(loc, path, normalize_path true env path))) + (* Find the manifest type associated to a type when appropriate: - the type should be public or should have a private row, - the type should have an associated manifest type. *) -let find_type_expansion ?level path env = +let find_type_expansion path env = let decl = find_type path env in match decl.type_manifest with | Some body when decl.type_private = Public @@ -450,7 +537,13 @@ let find_type_expansion ?level path env = private row are still considered unknown to the type system. Hence, this case is caught by the following clause that also handles purely abstract data types without manifest type definition. *) - | _ -> raise Not_found + | _ -> + (* another way to expand is to normalize the path itself *) + let path' = normalize_path None env path in + if Path.same path path' then raise Not_found else + (decl.type_params, + newgenty (Tconstr (path', decl.type_params, ref Mnil)), + may_map snd decl.type_newtype_level) (* Find the manifest type information associated to a type, i.e. the necessary information for the compiler's type-based optimisations. @@ -462,37 +555,26 @@ let find_type_expansion_opt path env = (* The manifest type of Private abstract data types can still get an approximation using their manifest type. *) | Some body -> (decl.type_params, body, may_map snd decl.type_newtype_level) - | _ -> raise Not_found + | _ -> + let path' = normalize_path None env path in + if Path.same path path' then raise Not_found else + (decl.type_params, + newgenty (Tconstr (path', decl.type_params, ref Mnil)), + may_map snd decl.type_newtype_level) let find_modtype_expansion path env = match (find_modtype path env).mtd_type with | None -> raise Not_found | Some mty -> mty -let find_module path env = +let rec is_functor_arg path env = match path with Pident id -> - begin try - let (p, data) = EnvTbl.find_same id env.modules - in data - with Not_found -> - if Ident.persistent id then - let ps = find_pers_struct (Ident.name id) in - md (Mty_signature(ps.ps_sig)) - else raise Not_found - end - | Pdot(p, s, pos) -> - begin match - EnvLazy.force !components_of_module_maker' (find_module_descr p env) - with - Structure_comps c -> - let (data, pos) = Tbl.find s c.comp_modules in - md (EnvLazy.force subst_modtype_maker data) - | Functor_comps f -> - raise Not_found + begin try Ident.find_same id env.functor_args; true + with Not_found -> false end - | Papply(p1, p2) -> - raise Not_found (* not right *) + | Pdot (p, s, _) -> is_functor_arg p env + | Papply _ -> true (* Lookup by name *) @@ -519,7 +601,8 @@ let rec lookup_module_descr lid env = end | Lapply(l1, l2) -> let (p1, desc1) = lookup_module_descr l1 env in - let (p2, {md_type=mty2}) = lookup_module l2 env in + let p2 = lookup_module l2 env in + let {md_type=mty2} = find_module p2 env in begin match EnvLazy.force !components_of_module_maker' desc1 with Functor_comps f -> Misc.may (!check_modtype_inclusion env mty2 p2) f.fcomp_arg; @@ -528,45 +611,41 @@ let rec lookup_module_descr lid env = raise Not_found end -and lookup_module lid env : Path.t * module_declaration = +and lookup_module lid env : Path.t = match lid with Lident s -> begin try - let (_, {md_type}) as r = EnvTbl.find_name s env.modules in + let (p, {md_type}) as r = EnvTbl.find_name s env.modules in begin match md_type with | Mty_ident (Path.Pident id) when Ident.name id = "#recmod#" -> (* see #5965 *) raise Recmodule | _ -> () end; - r + p with Not_found -> if s = !current_unit then raise Not_found; - let ps = find_pers_struct s in - (Pident(Ident.create_persistent s), - md (Mty_signature ps.ps_sig) - ) + ignore (find_pers_struct ~check:false s); + Pident(Ident.create_persistent s) end | Ldot(l, s) -> let (p, descr) = lookup_module_descr l env in begin match EnvLazy.force !components_of_module_maker' descr with Structure_comps c -> let (data, pos) = Tbl.find s c.comp_modules in - (Pdot(p, s, pos), md (EnvLazy.force subst_modtype_maker data)) + Pdot(p, s, pos) | Functor_comps f -> raise Not_found end | Lapply(l1, l2) -> let (p1, desc1) = lookup_module_descr l1 env in - let (p2, {md_type=mty2}) = lookup_module l2 env in + let p2 = lookup_module l2 env in + let {md_type=mty2} = find_module p2 env in let p = Papply(p1, p2) in begin match EnvLazy.force !components_of_module_maker' desc1 with Functor_comps f -> Misc.may (!check_modtype_inclusion env mty2 p2) f.fcomp_arg; - let mty = - Subst.modtype (Subst.add_module f.fcomp_param p2 f.fcomp_subst) - f.fcomp_res in - (p, md mty) + p | Structure_comps c -> raise Not_found end @@ -915,16 +994,29 @@ let add_gadt_instance_chain env lv t = (* Expand manifest module type names at the top of the given module type *) -let rec scrape_modtype mty env = - match mty with - Mty_ident path -> +let rec scrape_alias env ?path mty = + match mty, path with + Mty_ident path, _ -> begin try - scrape_modtype (find_modtype_expansion path env) env + scrape_alias env (find_modtype_expansion path env) with Not_found -> mty end + | Mty_alias path, _ -> + begin try + scrape_alias env (find_module path env).md_type ~path + with Not_found -> + Location.prerr_warning Location.none + (Warnings.Deprecated + ("module " ^ Path.name path ^ " cannot be accessed")); + mty + end + | mty, Some path -> + !strengthen env mty path | _ -> mty +let scrape_alias env mty = scrape_alias env mty + (* Compute constructor descriptions *) let constructors_of_type ty_path decl = @@ -1042,7 +1134,7 @@ let rec components_of_module env sub path mty = EnvLazy.create (env, sub, path, mty) and components_of_module_maker (env, sub, path, mty) = - (match scrape_modtype mty env with + (match scrape_alias env mty with Mty_signature sg -> let c = { comp_values = Tbl.empty; @@ -1126,7 +1218,8 @@ and components_of_module_maker (env, sub, path, mty) = fcomp_env = env; fcomp_subst = sub; fcomp_cache = Hashtbl.create 17 } - | Mty_ident p -> + | Mty_ident _ + | Mty_alias _ -> Structure_comps { comp_values = Tbl.empty; comp_constrs = Tbl.empty; @@ -1290,6 +1383,12 @@ let _ = (* Insertion of bindings by identifier *) +let add_functor_arg ?(arg=false) id env = + if not arg then env else + {env with + functor_args = Ident.add id () env.functor_args; + summary = Env_functor_arg (env.summary, id)} + let add_value ?check id desc env = store_value None ?check id (Pident id) desc env env @@ -1299,8 +1398,14 @@ let add_type ~check id info env = and add_exception ~check id decl env = store_exception ~check None id (Pident id) decl env env -and add_module_declaration id md env = - store_module None id (Pident id) md env env +and add_module_declaration ?arg id md env = + let path = + (*match md.md_type with + Mty_alias path -> normalize_path env path + | _ ->*) Pident id + in + let env = store_module None id path md env env in + add_functor_arg ?arg id env and add_modtype id info env = store_modtype None id (Pident id) info env env @@ -1311,8 +1416,8 @@ and add_class id ty env = and add_cltype id ty env = store_cltype None id (Pident id) ty env env -let add_module id mty env = - add_module_declaration id (md mty) env +let add_module ?arg id mty env = + add_module_declaration ?arg id (md mty) env let add_local_constraint id info elv env = match info with @@ -1332,13 +1437,17 @@ let enter store_fun name data env = let enter_value ?check = enter (store_value ?check) and enter_type = enter (store_type ~check:true) and enter_exception = enter (store_exception ~check:true) -and enter_module_declaration = enter store_module +and enter_module_declaration ?arg name md env = + let id = Ident.create name in + (id, add_module_declaration ?arg id md env) + (* let (id, env) = enter store_module name md env in + (id, add_functor_arg ?arg id env) *) and enter_modtype = enter store_modtype and enter_class = enter store_class and enter_cltype = enter store_cltype -let enter_module s mty env = - enter_module_declaration s (md mty) env +let enter_module ?arg s mty env = + enter_module_declaration ?arg s (md mty) env (* Insertion of all components of a signature *) @@ -1427,12 +1536,14 @@ let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root sg env = (* Read a signature from a file *) let read_signature modname filename = - let ps = read_pers_struct modname filename in ps.ps_sig + let ps = read_pers_struct modname filename in + check_consistency ps; + ps.ps_sig (* Return the CRC of the interface of the given compilation unit *) let crc_of_unit name = - let ps = find_pers_struct name in + let ps = find_pers_struct ~check:false name in try List.assoc name ps.ps_crcs with Not_found -> @@ -1446,6 +1557,8 @@ let imported_units() = (* Save a signature to a file *) let save_signature_with_imports sg modname filename imports = + (*prerr_endline filename; + List.iter (fun (name, crc) -> prerr_endline name) imports;*) Btype.cleanup_abbrev (); Subst.reset_for_saving (); let sg = Subst.signature (Subst.for_saving Subst.identity) sg in @@ -1470,7 +1583,8 @@ let save_signature_with_imports sg modname filename imports = ps_comps = comps; ps_crcs = (cmi.cmi_name, crc) :: imports; ps_filename = filename; - ps_flags = cmi.cmi_flags } in + ps_flags = cmi.cmi_flags; + ps_crcs_checked = true } in Hashtbl.add persistent_structures modname (Some ps); Consistbl.set crc_units modname crc filename; sg @@ -1625,10 +1739,22 @@ let report_error ppf = function fprintf ppf "@[<hov>Unit %s imports from %s, which uses recursive types.@ %s@]" export import "The compilation flag -rectypes is required" + | Missing_module(_, path1, path2) -> + fprintf ppf "@[@[<hov>"; + if Path.same path1 path2 then + fprintf ppf "Internal path@ %s@ is dangling." (Path.name path1) + else + fprintf ppf "Internal path@ %s@ expands to@ %s@ which is dangling." + (Path.name path1) (Path.name path2); + fprintf ppf "@]@ @[%s@ %s@ %s.@]@]" + "The compiled interface for module" (Ident.name (Path.head path2)) + "was not found" let () = Location.register_error_of_exn (function + | Error (Missing_module (loc, _, _) as err) when loc <> Location.none -> + Some (Location.error_of_printer loc report_error err) | Error err -> Some (Location.error_of_printer_file report_error err) | _ -> None ) diff --git a/typing/env.mli b/typing/env.mli index 5aea53385..888869ebf 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -24,6 +24,7 @@ type summary = | Env_class of summary * Ident.t * class_declaration | Env_cltype of summary * Ident.t * class_type_declaration | Env_open of summary * Path.t + | Env_functor_arg of summary * Ident.t type t @@ -53,12 +54,21 @@ val find_class: Path.t -> t -> class_declaration val find_cltype: Path.t -> t -> class_type_declaration val find_type_expansion: - ?level:int -> Path.t -> t -> type_expr list * type_expr * int option + Path.t -> t -> type_expr list * type_expr * int option val find_type_expansion_opt: Path.t -> t -> type_expr list * type_expr * int option (* Find the manifest type information associated to a type for the sake of the compiler's type-based optimisations. *) val find_modtype_expansion: Path.t -> t -> module_type +val is_functor_arg: Path.t -> t -> bool +val normalize_path: Location.t option -> t -> Path.t -> Path.t +(* Normalize the path to a concrete value or module. + If the option is None, allow returning dangling paths. + Otherwise raise a Missing_module error, and may add forgotten + head as required global. *) +val reset_required_globals: unit -> unit +val get_required_globals: unit -> Ident.t list +val add_required_global: Ident.t -> unit val has_local_constraints: t -> bool val add_gadt_instance_level: int -> t -> t @@ -76,7 +86,7 @@ val lookup_label: Longident.t -> t -> label_description val lookup_all_labels: Longident.t -> t -> (label_description * (unit -> unit)) list val lookup_type: Longident.t -> t -> Path.t * type_declaration -val lookup_module: Longident.t -> t -> Path.t * module_declaration +val lookup_module: Longident.t -> t -> Path.t val lookup_modtype: Longident.t -> t -> Path.t * modtype_declaration val lookup_class: Longident.t -> t -> Path.t * class_declaration val lookup_cltype: Longident.t -> t -> Path.t * class_type_declaration @@ -92,8 +102,8 @@ val add_value: ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t val add_type: check:bool -> Ident.t -> type_declaration -> t -> t val add_exception: check:bool -> Ident.t -> exception_declaration -> t -> t -val add_module: Ident.t -> module_type -> t -> t -val add_module_declaration: Ident.t -> module_declaration -> t -> t +val add_module: ?arg:bool -> Ident.t -> module_type -> t -> t +val add_module_declaration: ?arg:bool -> Ident.t -> module_declaration -> t -> t val add_modtype: Ident.t -> modtype_declaration -> t -> t val add_class: Ident.t -> class_declaration -> t -> t val add_cltype: Ident.t -> class_type_declaration -> t -> t @@ -119,8 +129,9 @@ val enter_value: string -> value_description -> t -> Ident.t * t val enter_type: string -> type_declaration -> t -> Ident.t * t val enter_exception: string -> exception_declaration -> t -> Ident.t * t -val enter_module: string -> module_type -> t -> Ident.t * t -val enter_module_declaration: string -> module_declaration -> t -> Ident.t * t +val enter_module: ?arg:bool -> string -> module_type -> t -> Ident.t * t +val enter_module_declaration: + ?arg:bool -> string -> module_declaration -> t -> Ident.t * t val enter_modtype: string -> modtype_declaration -> t -> Ident.t * t val enter_class: string -> class_declaration -> t -> Ident.t * t val enter_cltype: string -> class_type_declaration -> t -> Ident.t * t @@ -175,6 +186,7 @@ type error = | Illegal_renaming of string * string * string | Inconsistent_import of string * string * string | Need_recursive_types of string * string + | Missing_module of Location.t * Path.t * Path.t exception Error of error @@ -206,6 +218,8 @@ val check_modtype_inclusion: (t -> module_type -> Path.t -> module_type -> unit) ref (* Forward declaration to break mutual recursion with Typecore. *) val add_delayed_check_forward: ((unit -> unit) -> unit) ref +(* Forward declaration to break mutual recursion with Mtype. *) +val strengthen: (t -> module_type -> Path.t -> module_type) ref (** Folding over all identifiers (for analysis purpose) *) @@ -236,3 +250,6 @@ val fold_classs: val fold_cltypes: (string -> Path.t -> class_type_declaration -> 'a -> 'a) -> Longident.t option -> t -> 'a -> 'a + +(** Utilities *) +val scrape_alias: t -> module_type -> module_type diff --git a/typing/envaux.ml b/typing/envaux.ml index 6e13502d6..04d6d256f 100644 --- a/typing/envaux.ml +++ b/typing/envaux.ml @@ -75,6 +75,10 @@ let rec env_from_summary sum subst = in Env.open_signature Asttypes.Override path' (extract_sig env md.md_type) env + | Env_functor_arg(Env_module(s, id, desc), id') when Ident.same id id' -> + Env.add_module_declaration id (Subst.module_declaration subst desc) + ~arg:true (env_from_summary s subst) + | Env_functor_arg _ -> assert false in Hashtbl.add env_cache (sum, subst) env; env diff --git a/typing/includemod.ml b/typing/includemod.ml index 321c0b1ac..77e5c6c3f 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -35,6 +35,7 @@ type symptom = Ident.t * class_declaration * class_declaration * Ctype.class_match_failure list | Unbound_modtype_path of Path.t + | Unbound_module_path of Path.t type pos = Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t @@ -104,6 +105,18 @@ let expand_module_path env cxt path = with Not_found -> raise(Error[cxt, env, Unbound_modtype_path path]) +let expand_module_alias env cxt path = + try (Env.find_module path env).md_type + with Not_found -> + raise(Error[cxt, env, Unbound_module_path path]) + +(* +let rec normalize_module_path env cxt path = + match expand_module_alias env cxt path with + Mty_alias path' -> normalize_module_path env cxt path' + | _ -> path +*) + (* Extract name, kind and ident from a signature item *) type field_desc = @@ -136,7 +149,7 @@ let is_runtime_component = function (* Simplify a structure coercion *) -let simplify_structure_coercion cc = +let simplify_structure_coercion cc id_pos_list = let rec is_identity_coercion pos = function | [] -> true @@ -144,7 +157,7 @@ let simplify_structure_coercion cc = n = pos && c = Tcoerce_none && is_identity_coercion (pos + 1) rem in if is_identity_coercion 0 cc then Tcoerce_none - else Tcoerce_structure cc + else Tcoerce_structure (cc, id_pos_list) (* Inclusion between module types. Return the restriction that transforms a value of the smaller type @@ -156,13 +169,31 @@ let rec modtypes env cxt subst mty1 mty2 = with Dont_match -> raise(Error[cxt, env, Module_types(mty1, Subst.modtype subst mty2)]) - | Error reasons -> - raise(Error((cxt, env, Module_types(mty1, Subst.modtype subst mty2)) - :: reasons)) + | Error reasons as err -> + match mty1, mty2 with + Mty_alias _, _ + | _, Mty_alias _ -> raise err + | _ -> + raise(Error((cxt, env, Module_types(mty1, Subst.modtype subst mty2)) + :: reasons)) and try_modtypes env cxt subst mty1 mty2 = match (mty1, mty2) with - (Mty_ident p1, _) when may_expand_module_path env p1 -> + (Mty_alias p1, Mty_alias p2) -> + if Path.same p1 p2 then Tcoerce_none else + let p1 = Env.normalize_path None env p1 + and p2 = Env.normalize_path None env (Subst.module_path subst p2) in + (* Should actually be Tcoerce_ignore, if it existed *) + if Path.same p1 p2 then Tcoerce_none else raise Dont_match + | (Mty_alias p1, _) -> + 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 + let mty1 = Mtype.strengthen env (expand_module_alias env cxt p1) p1 in + Tcoerce_alias (p1, modtypes env cxt subst mty1 mty2) + | (Mty_ident p1, _) when may_expand_module_path env p1 -> try_modtypes env cxt subst (expand_module_path env cxt p1) mty2 | (_, Mty_ident p2) -> try_modtypes2 env cxt mty1 (Subst.modtype subst mty2) @@ -203,6 +234,14 @@ and signatures env cxt subst sig1 sig2 = (* Environment used to check inclusion of components *) let new_env = Env.add_signature sig1 (Env.in_signature env) in + (* Keep ids for module aliases *) + let (id_pos_list,_) = + List.fold_left + (fun (l,pos) -> function + Sig_module (id, _, _) -> + ((id,pos,Tcoerce_none)::l , pos+1) + | item -> (l, if is_runtime_component item then pos+1 else pos)) + ([], 0) sig1 in (* Build a table of the components of sig1, along with their positions. The table is indexed by kind and name of component *) let rec build_component_table pos tbl = function @@ -233,9 +272,9 @@ and signatures env cxt subst sig1 sig2 = signature_components new_env cxt subst (List.rev paired) in if len1 = len2 then (* see PR#5098 *) - simplify_structure_coercion cc + simplify_structure_coercion cc id_pos_list else - Tcoerce_structure cc + Tcoerce_structure (cc, id_pos_list) | _ -> raise(Error unpaired) end | item2 :: rem -> @@ -432,6 +471,8 @@ let include_err ppf = function Includeclass.report_error reason | Unbound_modtype_path path -> fprintf ppf "Unbound module type %a" Printtyp.path path + | Unbound_module_path path -> + fprintf ppf "Unbound module %a" Printtyp.path path let rec context ppf = function Module id :: rem -> diff --git a/typing/includemod.mli b/typing/includemod.mli index 75afef574..f0b248b39 100644 --- a/typing/includemod.mli +++ b/typing/includemod.mli @@ -40,6 +40,7 @@ type symptom = Ident.t * class_declaration * class_declaration * Ctype.class_match_failure list | Unbound_modtype_path of Path.t + | Unbound_module_path of Path.t type pos = Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t @@ -48,3 +49,4 @@ type error = pos list * Env.t * symptom exception Error of error list val report_error: formatter -> error list -> unit +val expand_module_alias: Env.t -> pos list -> Path.t -> Types.module_type diff --git a/typing/mtype.ml b/typing/mtype.ml index 67f912585..6781511dd 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -86,6 +86,7 @@ and strengthen_sig env sg p = and strengthen_decl env md p = {md with md_type = strengthen env md.md_type p} +let () = Env.strengthen := strengthen (* 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 @@ -101,6 +102,10 @@ let nondep_supertype env mid mty = if Path.isfree mid p then nondep_mty env va (Env.find_modtype_expansion p env) else mty + | Mty_alias p -> + if Path.isfree mid p then + nondep_mty env va (Env.find_module p env).md_type + else mty | Mty_signature sg -> Mty_signature(nondep_sig env va sg) | Mty_functor(param, arg, res) -> @@ -108,7 +113,8 @@ let nondep_supertype env mid mty = match va with Co -> Contra | Contra -> Co | Strict -> Strict in Mty_functor(param, Misc.may_map (nondep_mty env var_inv) arg, nondep_mty - (Env.add_module param (Btype.default_mty arg) env) va res) + (Env.add_module ~arg:true param + (Btype.default_mty arg) env) va res) and nondep_sig env va = function [] -> [] @@ -188,6 +194,7 @@ and enrich_item env p = function let rec type_paths env p mty = match scrape env mty with Mty_ident p -> [] + | Mty_alias p -> [] | Mty_signature sg -> type_paths_sig env p 0 sg | Mty_functor(param, arg, res) -> [] @@ -214,6 +221,7 @@ let rec no_code_needed env mty = Mty_ident p -> false | Mty_signature sg -> no_code_needed_sig env sg | Mty_functor(_, _, _) -> false + | Mty_alias p -> true and no_code_needed_sig env sg = match sg with @@ -242,6 +250,8 @@ let rec contains_type env = function contains_type_sig env sg | Mty_functor (_, _, body) -> contains_type env body + | Mty_alias _ -> + () and contains_type_sig env = List.iter (contains_type_item env) diff --git a/typing/oprint.ml b/typing/oprint.ml index 8414fe84f..49deb3456 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -352,6 +352,7 @@ let rec print_out_module_type ppf = | Omty_ident id -> fprintf ppf "%a" print_ident id | Omty_signature sg -> fprintf ppf "@[<hv 2>sig@ %a@;<1 -2>end@]" !out_signature sg + | Omty_alias id -> fprintf ppf "(module %a)" print_ident id and print_out_signature ppf = function [] -> () @@ -376,6 +377,8 @@ and print_out_sig_item ppf = fprintf ppf "@[<2>module type %s@]" name | Osig_modtype (name, mty) -> fprintf ppf "@[<2>module type %s =@ %a@]" name !out_module_type mty + | Osig_module (name, Omty_alias id, _) -> + fprintf ppf "@[<2>module %s =@ %a@]" name print_ident id | Osig_module (name, mty, rs) -> fprintf ppf "@[<2>%s %s :@ %a@]" (match rs with Orec_not -> "module" diff --git a/typing/outcometree.mli b/typing/outcometree.mli index 2a725a009..eae7b2fbe 100644 --- a/typing/outcometree.mli +++ b/typing/outcometree.mli @@ -78,6 +78,7 @@ type out_module_type = | Omty_functor of string * out_module_type option * out_module_type | Omty_ident of out_ident | Omty_signature of out_sig_item list + | Omty_alias of out_ident and out_sig_item = | Osig_class of bool * string * (string * (bool * bool)) list * out_class_type * diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 62be2486d..cd3a631b8 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -247,28 +247,22 @@ let rec uniq = function let rec normalize_type_path ?(cache=false) env p = try - let desc = Env.find_type p env in - if desc.type_private = Private || desc.type_newtype_level <> None then - (p, Id) - else match desc.type_manifest with - Some ty -> - let params = List.map repr desc.type_params in - begin match repr ty with - {desc = Tconstr (p1, tyl, _)} -> - let tyl = List.map repr tyl in - if List.length params = List.length tyl - && List.for_all2 (==) params tyl - then normalize_type_path ~cache env p1 - else if cache || List.length params <= List.length tyl - || not (uniq tyl) then (p, Id) - else - let l1 = List.map (index params) tyl in - let (p2, s2) = normalize_type_path ~cache env p1 in - (p2, compose l1 s2) - | ty -> - (p, Nth (index params ty)) - end - | None -> (p, Id) + let (params, ty, _) = Env.find_type_expansion p env in + let params = List.map repr params in + match repr ty with + {desc = Tconstr (p1, tyl, _)} -> + let tyl = List.map repr tyl in + if List.length params = List.length tyl + && List.for_all2 (==) params tyl + then normalize_type_path ~cache env p1 + else if cache || List.length params <= List.length tyl + || not (uniq tyl) then (p, Id) + else + let l1 = List.map (index params) tyl in + let (p2, s2) = normalize_type_path ~cache env p1 in + (p2, compose l1 s2) + | ty -> + (p, Nth (index params ty)) with Not_found -> (p, Id) @@ -1119,9 +1113,11 @@ let rec tree_of_modtype = function let res = match ty_arg with None -> tree_of_modtype ty_res | Some mty -> - wrap_env (Env.add_module param mty) tree_of_modtype ty_res + wrap_env (Env.add_module ~arg:true param mty) tree_of_modtype ty_res in Omty_functor (Ident.name param, may_map tree_of_modtype ty_arg, res) + | Mty_alias p -> + Omty_alias (tree_of_path p) and tree_of_signature sg = wrap_env (fun env -> env) (tree_of_signature_rec !printing_env) sg diff --git a/typing/printtyped.ml b/typing/printtyped.ml index e7e0d30bb..209121e83 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -1,4 +1,4 @@ -(***********************************************************************) +2(***********************************************************************) (* *) (* OCaml *) (* *) @@ -557,6 +557,7 @@ and module_type i ppf x = let i = i+1 in match x.mty_desc with | Tmty_ident (li,_) -> line i ppf "Pmty_ident %a\n" fmt_path li; + | Tmty_alias (li,_) -> line i ppf "Pmty_alias %a\n" fmt_path li; | Tmty_signature (s) -> line i ppf "Pmty_signature\n"; signature i ppf s; diff --git a/typing/subst.ml b/typing/subst.ml index a8a25de07..57d2e9f21 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -329,6 +329,8 @@ let rec modtype s = function let id' = Ident.rename id in Mty_functor(id', may_map (modtype s) arg, modtype (add_module id (Pident id') s) res) + | Mty_alias p -> + Mty_alias(module_path s p) and signature s sg = (* Components of signature may be mutually recursive (e.g. type declarations diff --git a/typing/typecore.ml b/typing/typecore.ml index 416ba3e4a..3770b1b40 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -563,7 +563,9 @@ let rec expand_path env p = {desc=Tconstr(p,_,_)} -> expand_path env p | _ -> assert false end - | _ -> p + | _ -> + let p' = Env.normalize_path None env p in + if Path.same p p' then p else expand_path env p' let compare_type_path env tpath1 tpath2 = Path.same (expand_path env tpath1) (expand_path env tpath2) @@ -1422,7 +1424,8 @@ and is_nonexpansive_mod mexp = | Tstr_open _ | Tstr_class_type _ | Tstr_exn_rebind _ -> true | Tstr_value (_, pat_exp_list) -> List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list - | Tstr_module {mb_expr=m;_} | Tstr_include (m, _, _) -> is_nonexpansive_mod m + | Tstr_module {mb_expr=m;_} + | Tstr_include (m, _, _) -> is_nonexpansive_mod m | Tstr_recmodule id_mod_list -> List.for_all (fun {mb_expr=m;_} -> is_nonexpansive_mod m) id_mod_list diff --git a/typing/typedtree.ml b/typing/typedtree.ml index c271f5706..d2a02a67d 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -238,9 +238,11 @@ and value_binding = and module_coercion = Tcoerce_none - | Tcoerce_structure of (int * module_coercion) list + | Tcoerce_structure of (int * module_coercion) list * + (Ident.t * int * module_coercion) list | Tcoerce_functor of module_coercion * module_coercion | Tcoerce_primitive of Primitive.description + | Tcoerce_alias of Path.t * module_coercion and module_type = { mty_desc: module_type_desc; @@ -256,6 +258,7 @@ and module_type_desc = | Tmty_functor of Ident.t * string loc * module_type option * module_type | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list | Tmty_typeof of module_expr + | Tmty_alias of Path.t * Longident.t loc and signature = { sig_items : signature_item list; diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 9daf448e9..59c2d956a 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -237,9 +237,11 @@ and value_binding = and module_coercion = Tcoerce_none - | Tcoerce_structure of (int * module_coercion) list + | Tcoerce_structure of (int * module_coercion) list * + (Ident.t * int * module_coercion) list | Tcoerce_functor of module_coercion * module_coercion | Tcoerce_primitive of Primitive.description + | Tcoerce_alias of Path.t * module_coercion and module_type = { mty_desc: module_type_desc; @@ -255,6 +257,7 @@ and module_type_desc = | Tmty_functor of Ident.t * string loc * module_type option * module_type | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list | Tmty_typeof of module_expr + | Tmty_alias of Path.t * Longident.t loc and signature = { sig_items : signature_item list; diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml index 9be5ed9b1..c0d61297d 100644 --- a/typing/typedtreeIter.ml +++ b/typing/typedtreeIter.ml @@ -381,6 +381,7 @@ module MakeIterator(Iter : IteratorArgument) : sig begin match mty.mty_desc with Tmty_ident (path, _) -> () + | Tmty_alias (path, _) -> () | Tmty_signature sg -> iter_signature sg | Tmty_functor (id, _, mtype1, mtype2) -> Misc.may iter_module_type mtype1; iter_module_type mtype2 diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml index 669fd2eac..93881a0f1 100644 --- a/typing/typedtreeMap.ml +++ b/typing/typedtreeMap.ml @@ -423,7 +423,8 @@ module MakeMap(Map : MapArgument) = struct let mty = Map.enter_module_type mty in let mty_desc = match mty.mty_desc with - Tmty_ident (path, lid) -> mty.mty_desc + Tmty_ident _ -> mty.mty_desc + | Tmty_alias _ -> mty.mty_desc | Tmty_signature sg -> Tmty_signature (map_signature sg) | Tmty_functor (id, name, mtype1, mtype2) -> Tmty_functor (id, name, Misc.may_map map_module_type mtype1, diff --git a/typing/typemod.ml b/typing/typemod.ml index fc380610b..88185791b 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -56,19 +56,20 @@ let rec path_concat head p = (* Extract a signature from a module type *) let extract_sig env loc mty = - match Mtype.scrape env mty with + match Env.scrape_alias env mty with Mty_signature sg -> sg | _ -> raise(Error(loc, env, Signature_expected)) let extract_sig_open env loc mty = - match Mtype.scrape env mty with + match Env.scrape_alias env mty with Mty_signature sg -> sg | _ -> raise(Error(loc, env, Structure_expected mty)) (* Compute the environment after opening a module *) let type_open ?toplevel ovf env loc lid = - let (path, md) = Typetexp.find_module env loc lid.txt in + let path = Typetexp.find_module env loc lid.txt in + let md = Env.find_module path env in let sg = extract_sig_open env loc md.md_type in path, Env.open_signature ~loc ?toplevel ovf path sg env @@ -195,14 +196,16 @@ let merge_constraint initial_env loc sg constr = make_next_first rs rem | (Sig_module(id, md, rs) :: rem, [s], Pwith_module (_, lid)) when Ident.name id = s -> - let (path, md') = Typetexp.find_module initial_env loc lid.txt in + let path = Typetexp.find_module initial_env loc lid.txt in + let md' = Env.find_module path env in let newmd = Mtype.strengthen_decl env md' path in ignore(Includemod.modtypes env newmd.md_type md.md_type); (Pident id, lid, Twith_module (path, lid)), Sig_module(id, newmd, rs) :: rem | (Sig_module(id, md, rs) :: rem, [s], Pwith_modsubst (_, lid)) when Ident.name id = s -> - let (path, md') = Typetexp.find_module initial_env loc lid.txt in + let path = Typetexp.find_module initial_env loc lid.txt in + let md' = Env.find_module path env in let newmd = Mtype.strengthen_decl env md' path in ignore(Includemod.modtypes env newmd.md_type md.md_type); real_id := Some id; @@ -253,7 +256,7 @@ let merge_constraint initial_env loc sg constr = | [s], Pwith_modsubst (_, lid) -> let id = match !real_id with None -> assert false | Some id -> id in - let (path, _) = Typetexp.find_module initial_env loc lid.txt in + let path = Typetexp.find_module initial_env loc lid.txt in let sub = Subst.add_module id path Subst.identity in Subst.signature sub sg | _ -> @@ -297,12 +300,15 @@ let rec approx_modtype env smty = Pmty_ident lid -> let (path, info) = Typetexp.find_modtype env smty.pmty_loc lid.txt in Mty_ident path + | Pmty_alias lid -> + let path = Typetexp.find_module env smty.pmty_loc lid.txt in + Mty_alias path | Pmty_signature ssg -> Mty_signature(approx_sig env ssg) | Pmty_functor(param, sarg, sres) -> let arg = may_map (approx_modtype env) sarg in let (id, newenv) = - Env.enter_module param.txt (Btype.default_mty arg) env in + Env.enter_module ~arg:true param.txt (Btype.default_mty arg) env in let res = approx_modtype newenv sres in Mty_functor(id, arg, res) | Pmty_with(sbody, constraints) -> @@ -347,8 +353,9 @@ and approx_sig env ssg = sdecls in let newenv = - List.fold_left (fun env (id, md) -> Env.add_module_declaration id md env) - env decls in + List.fold_left + (fun env (id, md) -> Env.add_module_declaration id md env) + env decls in map_rec (fun rs (id, md) -> Sig_module(id, md, rs)) decls (approx_sig newenv srem) | Psig_modtype d -> @@ -444,6 +451,9 @@ let transl_modtype_longident loc env lid = let (path, info) = Typetexp.find_modtype env loc lid in path +let transl_module_alias loc env lid = + Typetexp.find_module env loc lid + let mkmty desc typ env loc attrs = let mty = { mty_desc = desc; @@ -469,6 +479,10 @@ let rec transl_modtype env smty = let path = transl_modtype_longident loc env lid.txt in mkmty (Tmty_ident (path, lid)) (Mty_ident path) env loc smty.pmty_attributes + | Pmty_alias lid -> + let path = transl_module_alias loc env lid.txt in + mkmty (Tmty_alias (path, lid)) (Mty_alias path) env loc + smty.pmty_attributes | Pmty_signature ssg -> let sg = transl_signature env ssg in mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc @@ -477,7 +491,7 @@ let rec transl_modtype env smty = let arg = Misc.may_map (transl_modtype env) sarg in let ty_arg = Misc.may_map (fun m -> m.mty_type) arg in let (id, newenv) = - Env.enter_module param.txt (Btype.default_mty ty_arg) env in + Env.enter_module ~arg:true param.txt (Btype.default_mty ty_arg) env in let res = transl_modtype newenv sres in mkmty (Tmty_functor (id, param, arg, res)) (Mty_functor(id, ty_arg, res.mty_type)) env loc @@ -515,7 +529,8 @@ and transl_signature env sg = let loc = item.psig_loc in match item.psig_desc with | Psig_value sdesc -> - let (tdesc, newenv) = Typedecl.transl_value_decl env item.psig_loc sdesc in + let (tdesc, newenv) = + Typedecl.transl_value_decl env item.psig_loc sdesc in let (trem,rem, final_env) = transl_sig newenv srem in mksig (Tsig_value tdesc) env loc :: trem, (if List.exists (Ident.equal tdesc.val_id) (get_values rem) then rem @@ -548,11 +563,12 @@ and transl_signature env sg = md_attributes=pmd.pmd_attributes } in - let (id, newenv) = Env.enter_module_declaration pmd.pmd_name.txt md env in + let (id, newenv) = + Env.enter_module_declaration pmd.pmd_name.txt md env in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_module {md_id=id; md_name=pmd.pmd_name; md_type=tmty; - md_attributes=pmd.pmd_attributes} - ) env loc :: trem, + md_attributes=pmd.pmd_attributes}) + env loc :: trem, Sig_module(id, md, Trec_not) :: rem, final_env | Psig_recmodule sdecls -> @@ -677,15 +693,16 @@ and transl_modtype_decl modtype_names env loc and transl_recmodule_modtypes loc env sdecls = let make_env curr = List.fold_left - (fun env (id, _, mty) -> Env.add_module id mty env) + (fun env (id, _, mty) -> Env.add_module ~arg:true id mty env) env curr in let make_env2 curr = List.fold_left - (fun env (id, _, mty) -> Env.add_module id mty.mty_type env) + (fun env (id, _, mty) -> Env.add_module ~arg:true id mty.mty_type env) env curr in let transition env_c curr = List.map2 - (fun pmd (id, id_loc, mty) -> (id, id_loc, transl_modtype env_c pmd.pmd_type)) + (fun pmd (id, id_loc, mty) -> + (id, id_loc, transl_modtype env_c pmd.pmd_type)) sdecls curr in let ids = List.map (fun x -> Ident.create x.pmd_name.txt) sdecls in let approx_env = @@ -698,7 +715,7 @@ and transl_recmodule_modtypes loc env sdecls = List.fold_left (fun env id -> let dummy = Mty_ident (Path.Pident (Ident.create "#recmod#")) in - Env.add_module id dummy env + Env.add_module ~arg:true id dummy env ) env ids in @@ -739,12 +756,15 @@ let rec path_of_module mexp = Tmod_ident (p,_) -> p | Tmod_apply(funct, arg, coercion) when !Clflags.applicative_functors -> Papply(path_of_module funct, path_of_module arg) + | Tmod_constraint (mexp, _, _, _) -> + path_of_module mexp | _ -> raise Not_a_path (* Check that all core type schemes in a structure are closed *) let rec closed_modtype = function Mty_ident p -> true + | Mty_alias p -> true | Mty_signature sg -> List.for_all closed_signature_item sg | Mty_functor(id, param, body) -> closed_modtype body @@ -837,7 +857,7 @@ let check_recmodule_inclusion env bindings = if first_time then mty_actual else subst_and_strengthen env s id mty_actual in - Env.add_module id' mty_actual' env) + Env.add_module ~arg:false id' mty_actual' env) env bindings1 in (* Build the output substitution Y_i <- X_i *) let s' = @@ -934,16 +954,31 @@ let wrap_constraint env arg mty explicit = (* Type a module value expression *) -let rec type_module sttn funct_body anchor env smod = +let rec type_module ?(alias=false) sttn funct_body anchor env smod = match smod.pmod_desc with Pmod_ident lid -> - let (path, md) = Typetexp.find_module env smod.pmod_loc lid.txt in - let mty = md.md_type in - rm { mod_desc = Tmod_ident (path, lid); - mod_type = if sttn then Mtype.strengthen env mty path else mty; - mod_env = env; - mod_attributes = smod.pmod_attributes; - mod_loc = smod.pmod_loc } + let path = Typetexp.find_module env smod.pmod_loc lid.txt in + let md = { mod_desc = Tmod_ident (path, lid); + mod_type = Mty_alias path; + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc } in + let md = + if alias && not (Env.is_functor_arg path env) then + (Env.add_required_global (Path.head path); md) + else match (Env.find_module path env).md_type with + Mty_alias p1 when not alias -> + let p1 = Env.normalize_path (Some smod.pmod_loc) env p1 in + let mty = Includemod.expand_module_alias env [] p1 in + { md with + mod_desc = Tmod_constraint (md, mty, Tmodtype_implicit, + Tcoerce_alias (p1, Tcoerce_none)); + mod_type = if sttn then Mtype.strengthen env mty p1 else mty } + | mty -> + let mty = + if sttn then Mtype.strengthen env mty path else mty in + { md with mod_type = mty } + in rm md | Pmod_structure sstr -> let (str, sg, finalenv) = type_structure funct_body anchor env sstr smod.pmod_loc in @@ -957,7 +992,7 @@ let rec type_module sttn funct_body anchor env smod = let ty_arg = may_map (fun m -> m.mty_type) mty in let (id, newenv), funct_body = match ty_arg with None -> (Ident.create "*", env), false - | Some mty -> Env.enter_module name.txt mty env, true in + | Some mty -> Env.enter_module ~arg:true name.txt mty env, true in let body = type_module sttn funct_body None newenv sbody in rm { mod_desc = Tmod_functor(id, name, mty, body); mod_type = Mty_functor(id, ty_arg, body.mod_type); @@ -969,7 +1004,7 @@ let rec type_module sttn funct_body anchor env smod = let path = try Some (path_of_module arg) with Not_a_path -> None in let funct = type_module (sttn && path <> None) funct_body None env sfunct in - begin match Mtype.scrape env funct.mod_type with + begin match Env.scrape_alias env funct.mod_type with Mty_functor(param, mty_param, mty_res) as mty_functor -> let generative, mty_param = (mty_param = None, Btype.default_mty mty_param) in @@ -993,7 +1028,8 @@ let rec type_module sttn funct_body anchor env smod = if generative then mty_res else try Mtype.nondep_supertype - (Env.add_module param arg.mod_type env) param mty_res + (Env.add_module ~arg:true param arg.mod_type env) + param mty_res with Not_found -> raise(Error(smod.pmod_loc, env, Cannot_eliminate_dependency mty_functor)) @@ -1007,7 +1043,7 @@ let rec type_module sttn funct_body anchor env smod = raise(Error(sfunct.pmod_loc, env, Cannot_apply funct.mod_type)) end | Pmod_constraint(sarg, smty) -> - let arg = type_module true funct_body anchor env sarg in + let arg = type_module ~alias true funct_body anchor env sarg in let mty = transl_modtype env smty in rm {(wrap_constraint env arg mty.mty_type (Tmodtype_explicit mty)) with mod_loc = smod.pmod_loc; @@ -1104,8 +1140,8 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs} -> check "module" loc module_names name.txt; let modl = - type_module true funct_body (anchor_submodule name.txt anchor) env - smodl in + type_module ~alias:true true funct_body + (anchor_submodule name.txt anchor) env smodl in let md = { md_type = enrich_module_type anchor name.txt modl.mod_type env; md_attributes = attrs; @@ -1121,10 +1157,13 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = let sbind = List.map (function - | {pmb_name = name; pmb_expr = {pmod_desc=Pmod_constraint(expr, typ)}; pmb_attributes = attrs} -> + | {pmb_name = name; + pmb_expr = {pmod_desc=Pmod_constraint(expr, typ)}; + pmb_attributes = attrs} -> name, typ, expr, attrs | mb -> - raise (Error (mb.pmb_expr.pmod_loc, env, Recursive_module_require_explicit_type)) + raise (Error (mb.pmb_expr.pmod_loc, env, + Recursive_module_require_explicit_type)) ) sbind in @@ -1147,6 +1186,11 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = in (id, name, mty, modl, mty', attrs)) decls sbind in + let newenv = (* allow aliasing recursive modules from outside *) + List.fold_left + (fun env md -> Env.add_module md.md_id md.md_type.mty_type env) + env decls + in let bindings2 = check_recmodule_inclusion newenv bindings1 in Tstr_recmodule bindings2, @@ -1219,6 +1263,27 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = (* Rename all identifiers bound by this signature to avoid clashes *) let sg = Subst.signature Subst.identity (extract_sig_open env smodl.pmod_loc modl.mod_type) in + let sg = + match modl.mod_desc with + Tmod_ident (p, _) when not (Env.is_functor_arg p env) -> + Env.add_required_global (Path.head p); + let pos = ref 0 in + List.map + (function + | Sig_module (id, md, rs) -> + let n = !pos in incr pos; + Sig_module (id, {md with md_type = + Mty_alias (Pdot(p,Ident.name id,n))}, + rs) + | Sig_value (_, {val_kind=Val_reg}) | Sig_exception _ + | Sig_class _ as it -> + incr pos; it + | Sig_value _ | Sig_type _ | Sig_modtype _ + | Sig_class_type _ as it -> + it) + sg + | _ -> sg + in List.iter (check_sig_item type_names module_names modtype_names loc) sg; let new_env = Env.add_signature sg env in @@ -1253,7 +1318,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = str, sg, final_env let type_toplevel_phrase env s = + Env.reset_required_globals (); type_structure ~toplevel:true false None env s Location.none +(*let type_module_alias = type_module ~alias:true true false None*) let type_module = type_module true false None let type_structure = type_structure false None @@ -1261,6 +1328,7 @@ let type_structure = type_structure false None let rec normalize_modtype env = function Mty_ident p -> () + | Mty_alias p -> () | Mty_signature sg -> normalize_signature env sg | Mty_functor(id, param, body) -> normalize_modtype env body @@ -1279,6 +1347,7 @@ and normalize_signature_item env = function let rec simplify_modtype mty = match mty with Mty_ident path -> mty + | Mty_alias path -> mty | Mty_functor(id, arg, res) -> Mty_functor(id, arg, simplify_modtype res) | Mty_signature sg -> Mty_signature(simplify_signature sg) @@ -1310,7 +1379,8 @@ let type_module_type_of env smod = let tmty = match smod.pmod_desc with | Pmod_ident lid -> (* turn off strengthening in this case *) - let (path, md) = Typetexp.find_module env smod.pmod_loc lid.txt in + let path = Typetexp.find_module env smod.pmod_loc lid.txt in + let md = Env.find_module path env in rm { mod_desc = Tmod_ident (path, lid); mod_type = md.md_type; mod_env = env; @@ -1318,6 +1388,8 @@ let type_module_type_of env smod = mod_loc = smod.pmod_loc } | _ -> type_module env smod in let mty = tmty.mod_type in + (* expand modtype identifiers and aliases (at root) *) + let mty = Env.scrape_alias env mty in (* PR#5037: clean up inferred signature to remove duplicate specs *) let mty = simplify_modtype mty in (* PR#5036: must not contain non-generalized type variables *) @@ -1347,7 +1419,7 @@ let type_package env m p nl tl = match modl.mod_desc with Tmod_ident (mp,_) -> (mp, env) | _ -> - let (id, new_env) = Env.enter_module "%M" modl.mod_type env in + let (id, new_env) = Env.enter_module ~arg:true "%M" modl.mod_type env in (Pident id, new_env) in let rec mkpath mp = function @@ -1356,7 +1428,9 @@ let type_package env m p nl tl = | _ -> assert false in let tl' = - List.map (fun name -> Ctype.newconstr (mkpath mp name) []) nl in + List.map + (fun name -> Btype.newgenty (Tconstr (mkpath mp name,[],ref Mnil))) + nl in (* go back to original level *) Ctype.end_def (); if nl = [] then @@ -1385,6 +1459,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = Cmt_format.set_saved_types []; try Typecore.reset_delayed_checks (); + Env.reset_required_globals (); let (str, sg, finalenv) = type_structure initial_env ast (Location.in_file sourcefile) in let simple_sg = simplify_signature sg in diff --git a/typing/types.ml b/typing/types.ml index b28801c2a..fecf47ed6 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -265,6 +265,7 @@ type module_type = Mty_ident of Path.t | Mty_signature of signature | Mty_functor of Ident.t * module_type option * module_type + | Mty_alias of Path.t and signature = signature_item list diff --git a/typing/types.mli b/typing/types.mli index c38c928a8..6c955c6e5 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -252,6 +252,7 @@ type module_type = Mty_ident of Path.t | Mty_signature of signature | Mty_functor of Ident.t * module_type option * module_type + | Mty_alias of Path.t and signature = signature_item list diff --git a/typing/typetexp.ml b/typing/typetexp.ml index e6b6dfdeb..6f53ab159 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -166,10 +166,11 @@ let find_value env loc lid = let find_module env loc lid = let (path, decl) as r = - find_component Env.lookup_module (fun lid -> Unbound_module lid) env loc lid + find_component (fun lid env -> (Env.lookup_module lid env, ())) + (fun lid -> Unbound_module lid) env loc lid in - check_deprecated loc decl.md_attributes (Path.name path); - r + (* check_deprecated loc decl.md_attributes (Path.name path); *) + path let find_modtype env loc lid = let (path, decl) as r = diff --git a/typing/typetexp.mli b/typing/typetexp.mli index d475b03e2..1d90eb759 100644 --- a/typing/typetexp.mli +++ b/typing/typetexp.mli @@ -95,7 +95,7 @@ val find_value: val find_class: Env.t -> Location.t -> Longident.t -> Path.t * class_declaration val find_module: - Env.t -> Location.t -> Longident.t -> Path.t * module_declaration + Env.t -> Location.t -> Longident.t -> Path.t val find_modtype: Env.t -> Location.t -> Longident.t -> Path.t * modtype_declaration val find_class_type: diff --git a/utils/clflags.ml b/utils/clflags.ml index b44b7491f..829393a00 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -58,6 +58,7 @@ and dllpaths = ref ([] : string list) (* -dllpath *) and make_package = ref false (* -pack *) and for_package = ref (None: string option) (* -for-pack *) and error_size = ref 500 (* -error-size *) +and transparent_modules = ref false (* -trans-mod *) let dump_source = ref false (* -dsource *) let dump_parsetree = ref false (* -dparsetree *) and dump_typedtree = ref false (* -dtypedtree *) diff --git a/utils/clflags.mli b/utils/clflags.mli index 038c3aacb..876776acd 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -55,6 +55,7 @@ val dllpaths : string list ref val make_package : bool ref val for_package : string option ref val error_size : int ref +val transparent_modules : bool ref val dump_source : bool ref val dump_parsetree : bool ref val dump_typedtree : bool ref |