diff options
44 files changed, 837 insertions, 589 deletions
@@ -43,12 +43,10 @@ parsing/ast_helper.cmo : parsing/parsetree.cmi parsing/longident.cmi \ parsing/location.cmi parsing/asttypes.cmi parsing/ast_helper.cmi parsing/ast_helper.cmx : parsing/parsetree.cmi parsing/longident.cmx \ parsing/location.cmx parsing/asttypes.cmi parsing/ast_helper.cmi -parsing/ast_mapper.cmo : parsing/parsetree.cmi parsing/longident.cmi \ - parsing/location.cmi utils/config.cmi parsing/asttypes.cmi \ - parsing/ast_helper.cmi parsing/ast_mapper.cmi -parsing/ast_mapper.cmx : parsing/parsetree.cmi parsing/longident.cmx \ - parsing/location.cmx utils/config.cmx parsing/asttypes.cmi \ - parsing/ast_helper.cmx parsing/ast_mapper.cmi +parsing/ast_mapper.cmo : parsing/parsetree.cmi parsing/location.cmi \ + utils/config.cmi parsing/ast_helper.cmi parsing/ast_mapper.cmi +parsing/ast_mapper.cmx : parsing/parsetree.cmi parsing/location.cmx \ + utils/config.cmx parsing/ast_helper.cmx parsing/ast_mapper.cmi parsing/lexer.cmo : utils/warnings.cmi parsing/parser.cmi utils/misc.cmi \ parsing/location.cmi parsing/lexer.cmi parsing/lexer.cmx : utils/warnings.cmx parsing/parser.cmx utils/misc.cmx \ @@ -136,8 +134,8 @@ typing/typemod.cmi : typing/types.cmi typing/typedtree.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ typing/includemod.cmi typing/ident.cmi typing/env.cmi typing/types.cmi : typing/primitive.cmi typing/path.cmi \ - parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ - parsing/asttypes.cmi + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi parsing/asttypes.cmi typing/typetexp.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ typing/env.cmi parsing/asttypes.cmi @@ -166,11 +164,11 @@ typing/ctype.cmx : typing/types.cmx typing/subst.cmx typing/path.cmx \ typing/ident.cmx typing/env.cmx utils/clflags.cmx typing/btype.cmx \ parsing/asttypes.cmi typing/ctype.cmi typing/datarepr.cmo : typing/types.cmi typing/predef.cmi typing/path.cmi \ - typing/ident.cmi typing/btype.cmi parsing/asttypes.cmi \ - typing/datarepr.cmi + parsing/location.cmi typing/ident.cmi typing/btype.cmi \ + parsing/asttypes.cmi typing/datarepr.cmi typing/datarepr.cmx : typing/types.cmx typing/predef.cmx typing/path.cmx \ - typing/ident.cmx typing/btype.cmx parsing/asttypes.cmi \ - typing/datarepr.cmi + parsing/location.cmx typing/ident.cmx typing/btype.cmx \ + parsing/asttypes.cmi typing/datarepr.cmi typing/env.cmo : utils/warnings.cmi typing/types.cmi utils/tbl.cmi \ typing/subst.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ @@ -266,11 +264,11 @@ typing/stypes.cmo : typing/typedtree.cmi typing/printtyp.cmi \ typing/stypes.cmx : typing/typedtree.cmx typing/printtyp.cmx \ parsing/location.cmx utils/clflags.cmx typing/annot.cmi typing/stypes.cmi typing/subst.cmo : typing/types.cmi utils/tbl.cmi typing/path.cmi \ - utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/btype.cmi \ - typing/subst.cmi + utils/misc.cmi parsing/location.cmi typing/ident.cmi utils/clflags.cmi \ + typing/btype.cmi parsing/ast_mapper.cmi typing/subst.cmi typing/subst.cmx : typing/types.cmx utils/tbl.cmx typing/path.cmx \ - utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/btype.cmx \ - typing/subst.cmi + utils/misc.cmx parsing/location.cmx typing/ident.cmx utils/clflags.cmx \ + typing/btype.cmx parsing/ast_mapper.cmx typing/subst.cmi typing/typeclass.cmo : utils/warnings.cmi typing/typetexp.cmi \ typing/types.cmi typing/typedtree.cmi typing/typedecl.cmi \ typing/typecore.cmi typing/subst.cmi typing/stypes.cmi \ @@ -358,11 +356,11 @@ typing/typemod.cmx : utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \ utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \ typing/typemod.cmi typing/types.cmo : typing/primitive.cmi typing/path.cmi \ - parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ - parsing/asttypes.cmi typing/types.cmi + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi parsing/asttypes.cmi typing/types.cmi typing/types.cmx : typing/primitive.cmx typing/path.cmx \ - parsing/longident.cmx parsing/location.cmx typing/ident.cmx \ - parsing/asttypes.cmi typing/types.cmi + parsing/parsetree.cmi parsing/longident.cmx parsing/location.cmx \ + typing/ident.cmx parsing/asttypes.cmi typing/types.cmi typing/typetexp.cmo : utils/warnings.cmi typing/types.cmi \ typing/typedtree.cmi utils/tbl.cmi typing/printtyp.cmi typing/path.cmi \ parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \ @@ -512,15 +510,15 @@ bytecomp/simplif.cmx : utils/tbl.cmx typing/stypes.cmx bytecomp/lambda.cmx \ bytecomp/switch.cmo : bytecomp/switch.cmi bytecomp/switch.cmx : bytecomp/switch.cmi bytecomp/symtable.cmo : utils/tbl.cmi bytecomp/runtimedef.cmi \ - typing/predef.cmi utils/misc.cmi bytecomp/meta.cmi bytecomp/lambda.cmi \ - typing/ident.cmi bytecomp/dll.cmi bytecomp/cmo_format.cmi \ - utils/clflags.cmi bytecomp/bytesections.cmi parsing/asttypes.cmi \ - bytecomp/symtable.cmi + typing/predef.cmi utils/misc.cmi bytecomp/meta.cmi parsing/location.cmi \ + bytecomp/lambda.cmi typing/ident.cmi bytecomp/dll.cmi \ + bytecomp/cmo_format.cmi utils/clflags.cmi bytecomp/bytesections.cmi \ + parsing/asttypes.cmi bytecomp/symtable.cmi bytecomp/symtable.cmx : utils/tbl.cmx bytecomp/runtimedef.cmx \ - typing/predef.cmx utils/misc.cmx bytecomp/meta.cmx bytecomp/lambda.cmx \ - typing/ident.cmx bytecomp/dll.cmx bytecomp/cmo_format.cmi \ - utils/clflags.cmx bytecomp/bytesections.cmx parsing/asttypes.cmi \ - bytecomp/symtable.cmi + typing/predef.cmx utils/misc.cmx bytecomp/meta.cmx parsing/location.cmx \ + bytecomp/lambda.cmx typing/ident.cmx bytecomp/dll.cmx \ + bytecomp/cmo_format.cmi utils/clflags.cmx bytecomp/bytesections.cmx \ + parsing/asttypes.cmi bytecomp/symtable.cmi bytecomp/translclass.cmo : typing/types.cmi bytecomp/typeopt.cmi \ typing/typedtree.cmi bytecomp/translobj.cmi bytecomp/translcore.cmi \ typing/path.cmi bytecomp/matching.cmi parsing/location.cmi \ @@ -633,13 +631,13 @@ asmcomp/asmgen.cmx : bytecomp/translmod.cmx asmcomp/split.cmx \ asmcomp/compilenv.cmx asmcomp/comballoc.cmx asmcomp/coloring.cmx \ asmcomp/cmmgen.cmx asmcomp/cmm.cmx asmcomp/closure.cmx utils/clflags.cmx \ asmcomp/asmgen.cmi -asmcomp/asmlibrarian.cmo : utils/misc.cmi utils/config.cmi \ - asmcomp/compilenv.cmi asmcomp/cmx_format.cmi utils/clflags.cmi \ - asmcomp/clambda.cmi utils/ccomp.cmi asmcomp/asmlink.cmi \ +asmcomp/asmlibrarian.cmo : utils/misc.cmi parsing/location.cmi \ + utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmx_format.cmi \ + utils/clflags.cmi asmcomp/clambda.cmi utils/ccomp.cmi asmcomp/asmlink.cmi \ asmcomp/asmlibrarian.cmi -asmcomp/asmlibrarian.cmx : utils/misc.cmx utils/config.cmx \ - asmcomp/compilenv.cmx asmcomp/cmx_format.cmi utils/clflags.cmx \ - asmcomp/clambda.cmx utils/ccomp.cmx asmcomp/asmlink.cmx \ +asmcomp/asmlibrarian.cmx : utils/misc.cmx parsing/location.cmx \ + utils/config.cmx asmcomp/compilenv.cmx asmcomp/cmx_format.cmi \ + utils/clflags.cmx asmcomp/clambda.cmx utils/ccomp.cmx asmcomp/asmlink.cmx \ asmcomp/asmlibrarian.cmi asmcomp/asmlink.cmo : bytecomp/runtimedef.cmi asmcomp/proc.cmi \ utils/misc.cmi parsing/location.cmi asmcomp/emitaux.cmi asmcomp/emit.cmi \ @@ -847,31 +845,17 @@ driver/compmisc.cmo : utils/misc.cmi typing/ident.cmi typing/env.cmi \ utils/config.cmi driver/compenv.cmi utils/clflags.cmi driver/compmisc.cmi driver/compmisc.cmx : utils/misc.cmx typing/ident.cmx typing/env.cmx \ utils/config.cmx driver/compenv.cmx utils/clflags.cmx driver/compmisc.cmi -driver/errors.cmo : utils/warnings.cmi typing/typetexp.cmi \ - typing/typemod.cmi typing/typedecl.cmi typing/typecore.cmi \ - typing/typeclass.cmi bytecomp/translmod.cmi bytecomp/translcore.cmi \ - bytecomp/translclass.cmi parsing/syntaxerr.cmi bytecomp/symtable.cmi \ - driver/pparse.cmi parsing/location.cmi parsing/lexer.cmi \ - typing/includemod.cmi typing/env.cmi typing/ctype.cmi \ - typing/cmi_format.cmi bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \ - bytecomp/bytelibrarian.cmi driver/errors.cmi -driver/errors.cmx : utils/warnings.cmx typing/typetexp.cmx \ - typing/typemod.cmx typing/typedecl.cmx typing/typecore.cmx \ - typing/typeclass.cmx bytecomp/translmod.cmx bytecomp/translcore.cmx \ - bytecomp/translclass.cmx parsing/syntaxerr.cmx bytecomp/symtable.cmx \ - driver/pparse.cmx parsing/location.cmx parsing/lexer.cmx \ - typing/includemod.cmx typing/env.cmx typing/ctype.cmx \ - typing/cmi_format.cmx bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \ - bytecomp/bytelibrarian.cmx driver/errors.cmi +driver/errors.cmo : parsing/location.cmi driver/errors.cmi +driver/errors.cmx : parsing/location.cmx driver/errors.cmi driver/main.cmo : utils/warnings.cmi utils/misc.cmi driver/main_args.cmi \ - parsing/location.cmi driver/errors.cmi utils/config.cmi \ - driver/compmisc.cmi driver/compile.cmi driver/compenv.cmi \ - utils/clflags.cmi bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \ + parsing/location.cmi utils/config.cmi driver/compmisc.cmi \ + driver/compile.cmi driver/compenv.cmi utils/clflags.cmi \ + bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \ bytecomp/bytelibrarian.cmi driver/main.cmi driver/main.cmx : utils/warnings.cmx utils/misc.cmx driver/main_args.cmx \ - parsing/location.cmx driver/errors.cmx utils/config.cmx \ - driver/compmisc.cmx driver/compile.cmx driver/compenv.cmx \ - utils/clflags.cmx bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \ + parsing/location.cmx utils/config.cmx driver/compmisc.cmx \ + driver/compile.cmx driver/compenv.cmx utils/clflags.cmx \ + bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \ bytecomp/bytelibrarian.cmx driver/main.cmi driver/main_args.cmo : utils/warnings.cmi driver/main_args.cmi driver/main_args.cmx : utils/warnings.cmx driver/main_args.cmi @@ -891,34 +875,20 @@ driver/optcompile.cmx : utils/warnings.cmx typing/typemod.cmx \ typing/includemod.cmx typing/env.cmx utils/config.cmx driver/compmisc.cmx \ asmcomp/compilenv.cmx driver/compenv.cmx utils/clflags.cmx \ utils/ccomp.cmx asmcomp/asmgen.cmx driver/optcompile.cmi -driver/opterrors.cmo : utils/warnings.cmi typing/typetexp.cmi \ - typing/typemod.cmi typing/typedecl.cmi typing/typecore.cmi \ - typing/typeclass.cmi bytecomp/translmod.cmi bytecomp/translcore.cmi \ - bytecomp/translclass.cmi parsing/syntaxerr.cmi driver/pparse.cmi \ - parsing/location.cmi parsing/lexer.cmi typing/includemod.cmi \ - typing/env.cmi typing/ctype.cmi asmcomp/compilenv.cmi \ - typing/cmi_format.cmi asmcomp/asmpackager.cmi asmcomp/asmlink.cmi \ - asmcomp/asmlibrarian.cmi asmcomp/asmgen.cmi driver/opterrors.cmi -driver/opterrors.cmx : utils/warnings.cmx typing/typetexp.cmx \ - typing/typemod.cmx typing/typedecl.cmx typing/typecore.cmx \ - typing/typeclass.cmx bytecomp/translmod.cmx bytecomp/translcore.cmx \ - bytecomp/translclass.cmx parsing/syntaxerr.cmx driver/pparse.cmx \ - parsing/location.cmx parsing/lexer.cmx typing/includemod.cmx \ - typing/env.cmx typing/ctype.cmx asmcomp/compilenv.cmx \ - typing/cmi_format.cmx asmcomp/asmpackager.cmx asmcomp/asmlink.cmx \ - asmcomp/asmlibrarian.cmx asmcomp/asmgen.cmx driver/opterrors.cmi +driver/opterrors.cmo : parsing/location.cmi driver/opterrors.cmi +driver/opterrors.cmx : parsing/location.cmx driver/opterrors.cmi driver/optmain.cmo : utils/warnings.cmi asmcomp/printmach.cmi \ - driver/opterrors.cmi driver/optcompile.cmi utils/misc.cmi \ - driver/main_args.cmi parsing/location.cmi utils/config.cmi \ - driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi \ - asmcomp/asmpackager.cmi asmcomp/asmlink.cmi asmcomp/asmlibrarian.cmi \ - asmcomp/arch.cmo driver/optmain.cmi + driver/optcompile.cmi utils/misc.cmi driver/main_args.cmi \ + parsing/location.cmi utils/config.cmi driver/compmisc.cmi \ + driver/compenv.cmi utils/clflags.cmi asmcomp/asmpackager.cmi \ + asmcomp/asmlink.cmi asmcomp/asmlibrarian.cmi asmcomp/arch.cmo \ + driver/optmain.cmi driver/optmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \ - driver/opterrors.cmx driver/optcompile.cmx utils/misc.cmx \ - driver/main_args.cmx parsing/location.cmx utils/config.cmx \ - driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx \ - asmcomp/asmpackager.cmx asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmx \ - asmcomp/arch.cmx driver/optmain.cmi + driver/optcompile.cmx utils/misc.cmx driver/main_args.cmx \ + parsing/location.cmx utils/config.cmx driver/compmisc.cmx \ + driver/compenv.cmx utils/clflags.cmx asmcomp/asmpackager.cmx \ + asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmx asmcomp/arch.cmx \ + driver/optmain.cmi driver/pparse.cmo : parsing/parse.cmi utils/misc.cmi parsing/location.cmi \ utils/config.cmi utils/clflags.cmi utils/ccomp.cmi driver/pparse.cmi driver/pparse.cmx : parsing/parse.cmx utils/misc.cmx parsing/location.cmx \ @@ -965,9 +935,9 @@ toplevel/opttoploop.cmo : utils/warnings.cmi typing/types.cmi \ typing/printtyp.cmi bytecomp/printlambda.cmi parsing/printast.cmi \ typing/predef.cmi parsing/pprintast.cmi typing/path.cmi \ parsing/parsetree.cmi parsing/parse.cmi typing/outcometree.cmi \ - driver/opterrors.cmi typing/oprint.cmi utils/misc.cmi \ - parsing/longident.cmi parsing/location.cmi parsing/lexer.cmi \ - typing/ident.cmi toplevel/genprintval.cmi typing/env.cmi utils/config.cmi \ + typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \ + parsing/location.cmi parsing/lexer.cmi typing/ident.cmi \ + toplevel/genprintval.cmi typing/env.cmi utils/config.cmi \ driver/compmisc.cmi asmcomp/compilenv.cmi utils/clflags.cmi \ typing/btype.cmi asmcomp/asmlink.cmi asmcomp/asmgen.cmi \ toplevel/opttoploop.cmi @@ -977,19 +947,19 @@ toplevel/opttoploop.cmx : utils/warnings.cmx typing/types.cmx \ typing/printtyp.cmx bytecomp/printlambda.cmx parsing/printast.cmx \ typing/predef.cmx parsing/pprintast.cmx typing/path.cmx \ parsing/parsetree.cmi parsing/parse.cmx typing/outcometree.cmi \ - driver/opterrors.cmx typing/oprint.cmx utils/misc.cmx \ - parsing/longident.cmx parsing/location.cmx parsing/lexer.cmx \ - typing/ident.cmx toplevel/genprintval.cmx typing/env.cmx utils/config.cmx \ + typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \ + parsing/location.cmx parsing/lexer.cmx typing/ident.cmx \ + toplevel/genprintval.cmx typing/env.cmx utils/config.cmx \ driver/compmisc.cmx asmcomp/compilenv.cmx utils/clflags.cmx \ typing/btype.cmx asmcomp/asmlink.cmx asmcomp/asmgen.cmx \ toplevel/opttoploop.cmi toplevel/opttopmain.cmo : utils/warnings.cmi asmcomp/printmach.cmi \ - toplevel/opttoploop.cmi toplevel/opttopdirs.cmi driver/opterrors.cmi \ - utils/misc.cmi driver/main_args.cmi parsing/location.cmi utils/config.cmi \ + toplevel/opttoploop.cmi toplevel/opttopdirs.cmi utils/misc.cmi \ + driver/main_args.cmi parsing/location.cmi utils/config.cmi \ driver/compenv.cmi utils/clflags.cmi toplevel/opttopmain.cmi toplevel/opttopmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \ - toplevel/opttoploop.cmx toplevel/opttopdirs.cmx driver/opterrors.cmx \ - utils/misc.cmx driver/main_args.cmx parsing/location.cmx utils/config.cmx \ + toplevel/opttoploop.cmx toplevel/opttopdirs.cmx utils/misc.cmx \ + driver/main_args.cmx parsing/location.cmx utils/config.cmx \ driver/compenv.cmx utils/clflags.cmx toplevel/opttopmain.cmi toplevel/opttopstart.cmo : toplevel/opttopmain.cmi toplevel/opttopstart.cmx : toplevel/opttopmain.cmx @@ -1014,8 +984,8 @@ toplevel/toploop.cmo : utils/warnings.cmi typing/types.cmi \ parsing/parsetree.cmi parsing/parse.cmi typing/outcometree.cmi \ typing/oprint.cmi utils/misc.cmi bytecomp/meta.cmi parsing/longident.cmi \ parsing/location.cmi parsing/lexer.cmi typing/includemod.cmi \ - typing/ident.cmi toplevel/genprintval.cmi driver/errors.cmi \ - typing/env.cmi bytecomp/emitcode.cmi bytecomp/dll.cmi utils/consistbl.cmi \ + typing/ident.cmi toplevel/genprintval.cmi typing/env.cmi \ + bytecomp/emitcode.cmi bytecomp/dll.cmi utils/consistbl.cmi \ utils/config.cmi driver/compmisc.cmi utils/clflags.cmi \ bytecomp/bytegen.cmi typing/btype.cmi parsing/ast_helper.cmi \ toplevel/toploop.cmi @@ -1028,19 +998,19 @@ toplevel/toploop.cmx : utils/warnings.cmx typing/types.cmx \ parsing/parsetree.cmi parsing/parse.cmx typing/outcometree.cmi \ typing/oprint.cmx utils/misc.cmx bytecomp/meta.cmx parsing/longident.cmx \ parsing/location.cmx parsing/lexer.cmx typing/includemod.cmx \ - typing/ident.cmx toplevel/genprintval.cmx driver/errors.cmx \ - typing/env.cmx bytecomp/emitcode.cmx bytecomp/dll.cmx utils/consistbl.cmx \ + typing/ident.cmx toplevel/genprintval.cmx typing/env.cmx \ + bytecomp/emitcode.cmx bytecomp/dll.cmx utils/consistbl.cmx \ utils/config.cmx driver/compmisc.cmx utils/clflags.cmx \ bytecomp/bytegen.cmx typing/btype.cmx parsing/ast_helper.cmx \ toplevel/toploop.cmi toplevel/topmain.cmo : utils/warnings.cmi toplevel/toploop.cmi \ toplevel/topdirs.cmi utils/misc.cmi driver/main_args.cmi \ - parsing/location.cmi driver/errors.cmi utils/config.cmi \ - driver/compenv.cmi utils/clflags.cmi toplevel/topmain.cmi + parsing/location.cmi utils/config.cmi driver/compenv.cmi \ + utils/clflags.cmi toplevel/topmain.cmi toplevel/topmain.cmx : utils/warnings.cmx toplevel/toploop.cmx \ toplevel/topdirs.cmx utils/misc.cmx driver/main_args.cmx \ - parsing/location.cmx driver/errors.cmx utils/config.cmx \ - driver/compenv.cmx utils/clflags.cmx toplevel/topmain.cmi + parsing/location.cmx utils/config.cmx driver/compenv.cmx \ + utils/clflags.cmx toplevel/topmain.cmi toplevel/topstart.cmo : toplevel/topmain.cmi toplevel/topstart.cmx : toplevel/topmain.cmx toplevel/trace.cmo : typing/types.cmi toplevel/toploop.cmi \ diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex ff670166b..ca330237e 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex d048187a7..cad3c8e58 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 69f789bda..3777e1e77 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 1dc89a1b5..482a4e94c 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -156,9 +156,9 @@ let init_shape modl = init_shape_struct (Env.add_type ~check:false id tdecl env) rem | Sig_exception(id, edecl) :: rem -> raise Not_found - | Sig_module(id, mty, _) :: rem -> - init_shape_mod env mty :: - init_shape_struct (Env.add_module id mty env) rem + | Sig_module(id, md, _) :: rem -> + init_shape_mod env md.md_type :: + init_shape_struct (Env.add_module_declaration id md env) rem | Sig_modtype(id, minfo) :: rem -> init_shape_struct (Env.add_modtype id minfo env) rem | Sig_class(id, cdecl, _) :: rem -> diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml index e9b7405fa..c96e32b66 100644 --- a/bytecomp/typeopt.ml +++ b/bytecomp/typeopt.ml @@ -34,7 +34,7 @@ let maybe_pointer exp = match Env.find_type p exp.exp_env with | {type_kind = Type_variant []} -> true (* type exn *) | {type_kind = Type_variant cstrs} -> - List.exists (fun (name, args,_) -> args <> []) cstrs + List.exists (fun c -> c.Types.cd_args <> []) cstrs | _ -> true with Not_found -> true (* This can happen due to e.g. missing -I options, @@ -64,7 +64,7 @@ let array_element_kind env ty = {type_kind = Type_abstract} -> Pgenarray | {type_kind = Type_variant cstrs} - when List.for_all (fun (name, args,_) -> args = []) cstrs -> + when List.for_all (fun c -> c.Types.cd_args = []) cstrs -> Pintarray | {type_kind = _} -> Paddrarray diff --git a/debugger/eval.ml b/debugger/eval.ml index aa006332b..1d1ab3886 100644 --- a/debugger/eval.ml +++ b/debugger/eval.ml @@ -147,13 +147,13 @@ let rec expression event env = function and find_label lbl env ty path tydesc pos = function [] -> raise(Error(Wrong_label(ty, lbl))) - | (name, mut, ty_arg) :: rem -> - if Ident.name name = lbl then begin + | {ld_id; ld_type} :: rem -> + if Ident.name ld_id = lbl then begin let ty_res = Btype.newgenty(Tconstr(path, tydesc.type_params, ref Mnil)) in (pos, - try Ctype.apply env [ty_res] ty_arg [ty] with Ctype.Cannot_apply -> + try Ctype.apply env [ty_res] ld_type [ty] with Ctype.Cannot_apply -> abstract_type) end else find_label lbl env ty path tydesc (pos + 1) rem diff --git a/ocamldoc/Makefile.nt b/ocamldoc/Makefile.nt index ee155e793..e03bb6b19 100644 --- a/ocamldoc/Makefile.nt +++ b/ocamldoc/Makefile.nt @@ -143,6 +143,7 @@ OCAMLCMOFILES=$(OCAMLSRCDIR)/parsing/printast.cmo \ $(OCAMLSRCDIR)/parsing/parser.cmo \ $(OCAMLSRCDIR)/parsing/lexer.cmo \ $(OCAMLSRCDIR)/parsing/parse.cmo \ + $(OCAMLSRCDIR)/parsing/ast_mapper.cmo \ $(OCAMLSRCDIR)/typing/types.cmo \ $(OCAMLSRCDIR)/typing/path.cmo \ $(OCAMLSRCDIR)/typing/btype.cmo \ diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml index a4da0f73a..dd106b4f0 100644 --- a/ocamldoc/odoc_ast.ml +++ b/ocamldoc/odoc_ast.ml @@ -944,12 +944,12 @@ module Analyser = let f = match ele with Element_module m -> (function - Types.Sig_module (ident,t,_) -> + Types.Sig_module (ident,md,_) -> let n1 = Name.simple m.m_name and n2 = Ident.name ident in ( match n1 = n2 with - true -> filter_module_with_module_type_constraint m t; true + true -> filter_module_with_module_type_constraint m md.md_type; true | false -> false ) | _ -> false) diff --git a/ocamldoc/odoc_env.ml b/ocamldoc/odoc_env.ml index d6a595bd7..7a9c86edd 100644 --- a/ocamldoc/odoc_env.ml +++ b/ocamldoc/odoc_env.ml @@ -53,9 +53,9 @@ let rec add_signature env root ?rel signat = Types.Sig_value (ident, _) -> { env with env_values = (rel_name ident, qualify ident) :: env.env_values } | Types.Sig_type (ident,_,_) -> { env with env_types = (rel_name ident, qualify ident) :: env.env_types } | Types.Sig_exception (ident, _) -> { env with env_exceptions = (rel_name ident, qualify ident) :: env.env_exceptions } - | Types.Sig_module (ident, modtype, _) -> + | Types.Sig_module (ident, md, _) -> let env2 = - match modtype with (* A VOIR : le cas ou c'est un identificateur, dans ce cas on n'a pas de signature *) + match md.Types.md_type with (* A VOIR : le cas ou c'est un identificateur, dans ce cas on n'a pas de signature *) Types.Mty_signature s -> add_signature env (qualify ident) ~rel: (rel_name ident) s | _ -> env in diff --git a/ocamldoc/odoc_print.ml b/ocamldoc/odoc_print.ml index d09bc9324..aa6dea128 100644 --- a/ocamldoc/odoc_print.ml +++ b/ocamldoc/odoc_print.ml @@ -84,11 +84,11 @@ let simpl_class_type t = (* on vire les vals et methods pour ne pas qu'elles soient imprimees quand on affichera le type *) let tnil = { Types.desc = Types.Tnil ; Types.level = 0; Types.id = 0 } in - Types.Cty_signature { Types.cty_self = { cs.Types.cty_self with + Types.Cty_signature { Types.csig_self = { cs.Types.csig_self with Types.desc = Types.Tobject (tnil, ref None) }; - Types.cty_vars = Types.Vars.empty ; - Types.cty_concr = Types.Concr.empty ; - Types.cty_inher = [] + csig_vars = Types.Vars.empty ; + csig_concr = Types.Concr.empty ; + csig_inher = [] } | Types.Cty_arrow (l, texp, ct) -> let new_ct = iter ct in diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index da70778c4..4ea352174 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -94,7 +94,7 @@ module Signature_search = let search_module table name = match Hashtbl.find table (M name) with - | (Types.Sig_module (ident, module_type, _)) -> module_type + | (Types.Sig_module (ident, md, _)) -> md.Types.md_type | _ -> assert false let search_module_type table name = @@ -106,11 +106,11 @@ module Signature_search = | _ -> assert false let search_attribute_type name class_sig = - let (_, _, type_expr) = Types.Vars.find name class_sig.Types.cty_vars in + let (_, _, type_expr) = Types.Vars.find name class_sig.Types.csig_vars in type_expr let search_method_type name class_sig = - let fields = Odoc_misc.get_fields class_sig.Types.cty_self in + let fields = Odoc_misc.get_fields class_sig.Types.csig_self in List.assoc name fields end @@ -219,7 +219,7 @@ module Analyser = Types.Type_abstract -> Odoc_type.Type_abstract | Types.Type_variant l -> - let f (constructor_name, type_expr_list, ret_type) = + let f {Types.cd_id=constructor_name;cd_args=type_expr_list;cd_res=ret_type} = let constructor_name = Ident.name constructor_name in let comment_opt = try @@ -238,7 +238,7 @@ module Analyser = Odoc_type.Type_variant (List.map f l) | Types.Type_record (l, _) -> - let f (field_name, mutable_flag, type_expr) = + let f {Types.ld_id=field_name;ld_mutable=mutable_flag;ld_type=type_expr} = let field_name = Ident.name field_name in let comment_opt = try diff --git a/testsuite/tests/asmcomp/Makefile b/testsuite/tests/asmcomp/Makefile index d0752351a..d83b79d2d 100644 --- a/testsuite/tests/asmcomp/Makefile +++ b/testsuite/tests/asmcomp/Makefile @@ -34,6 +34,7 @@ OTHEROBJS=\ $(OTOPDIR)/parsing/longident.cmo \ $(OTOPDIR)/parsing/syntaxerr.cmo \ $(OTOPDIR)/parsing/ast_helper.cmo \ + $(OTOPDIR)/parsing/ast_mapper.cmo \ $(OTOPDIR)/parsing/parser.cmo \ $(OTOPDIR)/parsing/lexer.cmo \ $(OTOPDIR)/parsing/parse.cmo \ 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/aliases.ml b/testsuite/tests/typing-modules/aliases.ml index 36a5a4144..b2ebba1f6 100644 --- a/testsuite/tests/typing-modules/aliases.ml +++ b/testsuite/tests/typing-modules/aliases.ml @@ -75,3 +75,5 @@ M1.C'.chr 66;; 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;; 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/untypeast.ml b/tools/untypeast.ml index e5f037515..ccbd3bb8e 100644 --- a/tools/untypeast.ml +++ b/tools/untypeast.ml @@ -329,7 +329,9 @@ and untype_signature_item item = | Tsig_exception decl -> Psig_exception (untype_constructor_declaration decl) | Tsig_module md -> - Psig_module {pmd_name = md.md_name; pmd_type = untype_module_type md.md_type; pmd_attributes = md.md_attributes} + Psig_module {pmd_name = md.md_name; pmd_type = untype_module_type md.md_type; + pmd_attributes = md.md_attributes; + } | Tsig_recmodule list -> Psig_recmodule (List.map (fun md -> {pmd_name = md.md_name; pmd_type = untype_module_type md.md_type; diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index 4472155ab..8c1bc0bf3 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -245,10 +245,10 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct if O.is_block obj then Cstr_block(O.tag obj) else Cstr_constant(O.obj obj) in - let (constr_name, constr_args,ret_type) = + let {cd_id;cd_args;cd_res} = Datarepr.find_constr_by_tag tag constr_list in let type_params = - match ret_type with + match cd_res with Some t -> begin match (Ctype.repr t).desc with Tconstr (_,params,_) -> @@ -261,23 +261,23 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct (function ty -> try Ctype.apply env type_params ty ty_list with Ctype.Cannot_apply -> abstract_type) - constr_args in + cd_args in tree_of_constr_with_args (tree_of_constr env path) - (Ident.name constr_name) 0 depth obj ty_args + (Ident.name cd_id) 0 depth obj ty_args | {type_kind = Type_record(lbl_list, rep)} -> begin match check_depth depth obj ty with Some x -> x | None -> let rec tree_of_fields pos = function | [] -> [] - | (lbl_name, _, lbl_arg) :: remainder -> + | {ld_id; ld_type} :: remainder -> let ty_arg = try - Ctype.apply env decl.type_params lbl_arg + Ctype.apply env decl.type_params ld_type ty_list with Ctype.Cannot_apply -> abstract_type in - let name = Ident.name lbl_name in + let name = Ident.name ld_id in (* PR#5722: print full module path only for first record field *) let lid = diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index 78c6eca32..f556fb65e 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -190,8 +190,8 @@ let rec pr_item env items = | Sig_exception(id, decl) :: rem -> let tree = Printtyp.tree_of_exception_declaration id decl in Some (tree, None, rem) - | Sig_module(id, mty, rs) :: rem -> - let tree = Printtyp.tree_of_module id mty rs in + | Sig_module(id, md, rs) :: rem -> + let tree = Printtyp.tree_of_module id md.md_type rs in Some (tree, None, rem) | Sig_modtype(id, decl) :: rem -> let tree = Printtyp.tree_of_modtype_declaration id decl in diff --git a/typing/btype.ml b/typing/btype.ml index e6458f650..c76639d56 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -345,12 +345,12 @@ let unmark_type_decl decl = Type_abstract -> () | Type_variant cstrs -> List.iter - (fun (c, tl, ret_type_opt) -> - List.iter unmark_type tl; - Misc.may unmark_type ret_type_opt) + (fun d -> + List.iter unmark_type d.cd_args; + Misc.may unmark_type d.cd_res) cstrs | Type_record(lbls, rep) -> - List.iter (fun (c, mut, t) -> unmark_type t) lbls + List.iter (fun d -> unmark_type d.ld_type) lbls end; begin match decl.type_manifest with None -> () @@ -358,8 +358,8 @@ let unmark_type_decl decl = end let unmark_class_signature sign = - unmark_type sign.cty_self; - Vars.iter (fun l (m, v, t) -> unmark_type t) sign.cty_vars + unmark_type sign.csig_self; + Vars.iter (fun l (m, v, t) -> unmark_type t) sign.csig_vars let rec unmark_class_type = function diff --git a/typing/ctype.ml b/typing/ctype.ml index 4d4d84432..aa67a9181 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -383,7 +383,7 @@ let rec signature_of_class_type = | Cty_arrow (_, ty, cty) -> signature_of_class_type cty let self_type cty = - repr (signature_of_class_type cty).cty_self + repr (signature_of_class_type cty).csig_self let rec class_type_arity = function @@ -532,14 +532,13 @@ let closed_type_decl decl = () | Type_variant v -> List.iter - (fun (_, tyl,ret_type_opt) -> - match ret_type_opt with + (fun {cd_args; cd_res; _} -> + match cd_res with | Some _ -> () - | None -> - List.iter closed_type tyl) + | None -> List.iter closed_type cd_args) v | Type_record(r, rep) -> - List.iter (fun (_, _, ty) -> closed_type ty) r + List.iter (fun l -> closed_type l.ld_type) r end; begin match decl.type_manifest with None -> () @@ -558,7 +557,7 @@ type closed_class_failure = exception Failure of closed_class_failure let closed_class params sign = - let ty = object_fields (repr sign.cty_self) in + let ty = object_fields (repr sign.csig_self) in let (fields, rest) = flatten_fields ty in List.iter mark_type params; mark_type rest; @@ -566,19 +565,19 @@ let closed_class params sign = (fun (lab, _, ty) -> if lab = dummy_method then mark_type ty) fields; try - mark_type_node (repr sign.cty_self); + mark_type_node (repr sign.csig_self); List.iter (fun (lab, kind, ty) -> if field_kind_repr kind = Fpresent then try closed_type ty with Non_closed (ty0, real) -> raise (Failure (CC_Method (ty0, real, lab, ty)))) fields; - mark_type_params (repr sign.cty_self); + mark_type_params (repr sign.csig_self); List.iter unmark_type params; unmark_class_signature sign; None with Failure reason -> - mark_type_params (repr sign.cty_self); + mark_type_params (repr sign.csig_self); List.iter unmark_type params; unmark_class_signature sign; Some reason @@ -1090,6 +1089,7 @@ let new_declaration newtype manifest = type_variance = []; type_newtype_level = newtype; type_loc = Location.none; + type_attributes = []; } let instance_constructor ?in_pattern cstr = @@ -1139,10 +1139,18 @@ let instance_declaration decl = | Type_abstract -> Type_abstract | Type_variant cl -> Type_variant ( - List.map (fun (s,tl,ot) -> (s, List.map copy tl, may_map copy ot)) - cl) + List.map + (fun c -> + {c with cd_args=List.map copy c.cd_args; + cd_res=may_map copy c.cd_res}) + cl) | Type_record (fl, rr) -> - Type_record (List.map (fun (s,m,ty) -> (s, m, copy ty)) fl, rr)} + Type_record ( + List.map + (fun l -> + {l with ld_type = copy l.ld_type} + ) fl, rr) + } in cleanup_types (); decl @@ -1154,12 +1162,12 @@ let instance_class params cty = Cty_constr (path, List.map copy tyl, copy_class_type cty) | Cty_signature sign -> Cty_signature - {cty_self = copy sign.cty_self; - cty_vars = - Vars.map (function (m, v, ty) -> (m, v, copy ty)) sign.cty_vars; - cty_concr = sign.cty_concr; - cty_inher = - List.map (fun (p,tl) -> (p, List.map copy tl)) sign.cty_inher} + {csig_self = copy sign.csig_self; + csig_vars = + Vars.map (function (m, v, ty) -> (m, v, copy ty)) sign.csig_vars; + csig_concr = sign.csig_concr; + csig_inher = + List.map (fun (p,tl) -> (p, List.map copy tl)) sign.csig_inher} | Cty_arrow (l, ty, cty) -> Cty_arrow (l, copy ty, copy_class_type cty) in @@ -2087,10 +2095,10 @@ and mcomp_type_option type_pairs env t t' = and mcomp_variant_description type_pairs env xs ys = let rec iter = fun x y -> match x, y with - (id, tl, t) :: xs, (id', tl', t') :: ys -> - mcomp_type_option type_pairs env t t'; - mcomp_list type_pairs env tl tl'; - if Ident.name id = Ident.name id' + | c1 :: xs, c2 :: ys -> + mcomp_type_option type_pairs env c1.cd_res c2.cd_res; + mcomp_list type_pairs env c1.cd_args c2.cd_args; + if Ident.name c1.cd_id = Ident.name c2.cd_id then iter xs ys else raise (Unify []) | [],[] -> () @@ -2099,11 +2107,12 @@ and mcomp_variant_description type_pairs env xs ys = iter xs ys and mcomp_record_description type_pairs env = - let rec iter = fun x y -> + let rec iter x y = match x, y with - (id, mutable_flag, t) :: xs, (id', mutable_flag', t') :: ys -> - mcomp type_pairs env t t'; - if Ident.name id = Ident.name id' && mutable_flag = mutable_flag' + | l1 :: xs, l2 :: ys -> + mcomp type_pairs env l1.ld_type l2.ld_type; + if Ident.name l1.ld_id = Ident.name l2.ld_id && + l1.ld_mutable = l2.ld_mutable then iter xs ys else raise (Unify []) | [], [] -> () @@ -3221,8 +3230,8 @@ let rec moregen_clty trace type_pairs env cty1 cty2 = end; moregen_clty false type_pairs env cty1' cty2' | Cty_signature sign1, Cty_signature sign2 -> - let ty1 = object_fields (repr sign1.cty_self) in - let ty2 = object_fields (repr sign2.cty_self) in + let ty1 = object_fields (repr sign1.csig_self) in + let ty2 = object_fields (repr sign2.csig_self) in let (fields1, rest1) = flatten_fields ty1 and (fields2, rest2) = flatten_fields ty2 in let (pairs, miss1, miss2) = associate_fields fields1 fields2 in @@ -3235,11 +3244,11 @@ let rec moregen_clty trace type_pairs env cty1 cty2 = pairs; Vars.iter (fun lab (mut, v, ty) -> - let (mut', v', ty') = Vars.find lab sign1.cty_vars in + let (mut', v', ty') = Vars.find lab sign1.csig_vars in try moregen true type_pairs env ty' ty with Unify trace -> raise (Failure [CM_Val_type_mismatch (lab, env, expand_trace env trace)])) - sign2.cty_vars + sign2.csig_vars | _ -> raise (Failure []) with @@ -3264,8 +3273,8 @@ let match_class_types ?(trace=true) env pat_sch subj_sch = let res = let sign1 = signature_of_class_type patt in let sign2 = signature_of_class_type subj in - let t1 = repr sign1.cty_self in - let t2 = repr sign2.cty_self in + let t1 = repr sign1.csig_self in + let t2 = repr sign2.csig_self in TypePairs.add type_pairs (t1, t2) (); let (fields1, rest1) = flatten_fields (object_fields t1) and (fields2, rest2) = flatten_fields (object_fields t2) in @@ -3280,7 +3289,7 @@ let match_class_types ?(trace=true) env pat_sch subj_sch = | _ -> CM_Hide_public lab::err end in - if Concr.mem lab sign1.cty_concr then err + if Concr.mem lab sign1.csig_concr then err else CM_Hide_virtual ("method", lab) :: err) miss1 [] in @@ -3301,7 +3310,7 @@ let match_class_types ?(trace=true) env pat_sch subj_sch = Vars.fold (fun lab (mut, vr, ty) err -> try - let (mut', vr', ty') = Vars.find lab sign1.cty_vars in + let (mut', vr', ty') = Vars.find lab sign1.csig_vars in if mut = Mutable && mut' <> Mutable then CM_Non_mutable_value lab::err else if vr = Concrete && vr' <> Concrete then @@ -3310,21 +3319,21 @@ let match_class_types ?(trace=true) env pat_sch subj_sch = err with Not_found -> CM_Missing_value lab::err) - sign2.cty_vars error + sign2.csig_vars error in let error = Vars.fold (fun lab (_,vr,_) err -> - if vr = Virtual && not (Vars.mem lab sign2.cty_vars) then + if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then CM_Hide_virtual ("instance variable", lab) :: err else err) - sign1.cty_vars error + sign1.csig_vars error in let error = List.fold_right (fun e l -> if List.mem e missing_method then l else CM_Virtual_method e::l) - (Concr.elements (Concr.diff sign2.cty_concr sign1.cty_concr)) + (Concr.elements (Concr.diff sign2.csig_concr sign1.csig_concr)) error in match error with @@ -3356,8 +3365,8 @@ let rec equal_clty trace type_pairs subst env cty1 cty2 = end; equal_clty false type_pairs subst env cty1' cty2' | Cty_signature sign1, Cty_signature sign2 -> - let ty1 = object_fields (repr sign1.cty_self) in - let ty2 = object_fields (repr sign2.cty_self) in + let ty1 = object_fields (repr sign1.csig_self) in + let ty2 = object_fields (repr sign2.csig_self) in let (fields1, rest1) = flatten_fields ty1 and (fields2, rest2) = flatten_fields ty2 in let (pairs, miss1, miss2) = associate_fields fields1 fields2 in @@ -3371,11 +3380,11 @@ let rec equal_clty trace type_pairs subst env cty1 cty2 = pairs; Vars.iter (fun lab (_, _, ty) -> - let (_, _, ty') = Vars.find lab sign1.cty_vars in + let (_, _, ty') = Vars.find lab sign1.csig_vars in try eqtype true type_pairs subst env ty' ty with Unify trace -> raise (Failure [CM_Val_type_mismatch (lab, env, expand_trace env trace)])) - sign2.cty_vars + sign2.csig_vars | _ -> raise (Failure (if trace then [] @@ -3389,8 +3398,8 @@ let match_class_declarations env patt_params patt_type subj_params subj_type = let subst = ref [] in let sign1 = signature_of_class_type patt_type in let sign2 = signature_of_class_type subj_type in - let t1 = repr sign1.cty_self in - let t2 = repr sign2.cty_self in + let t1 = repr sign1.csig_self in + let t2 = repr sign2.csig_self in TypePairs.add type_pairs (t1, t2) (); let (fields1, rest1) = flatten_fields (object_fields t1) and (fields2, rest2) = flatten_fields (object_fields t2) in @@ -3405,7 +3414,7 @@ let match_class_declarations env patt_params patt_type subj_params subj_type = | _ -> CM_Hide_public lab::err end in - if Concr.mem lab sign1.cty_concr then err + if Concr.mem lab sign1.csig_concr then err else CM_Hide_virtual ("method", lab) :: err) miss1 [] in @@ -3432,7 +3441,7 @@ let match_class_declarations env patt_params patt_type subj_params subj_type = Vars.fold (fun lab (mut, vr, ty) err -> try - let (mut', vr', ty') = Vars.find lab sign1.cty_vars in + let (mut', vr', ty') = Vars.find lab sign1.csig_vars in if mut = Mutable && mut' <> Mutable then CM_Non_mutable_value lab::err else if vr = Concrete && vr' <> Concrete then @@ -3441,21 +3450,21 @@ let match_class_declarations env patt_params patt_type subj_params subj_type = err with Not_found -> CM_Missing_value lab::err) - sign2.cty_vars error + sign2.csig_vars error in let error = Vars.fold (fun lab (_,vr,_) err -> - if vr = Virtual && not (Vars.mem lab sign2.cty_vars) then + if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then CM_Hide_virtual ("instance variable", lab) :: err else err) - sign1.cty_vars error + sign1.csig_vars error in let error = List.fold_right (fun e l -> if List.mem e missing_method then l else CM_Virtual_method e::l) - (Concr.elements (Concr.diff sign2.cty_concr sign1.cty_concr)) + (Concr.elements (Concr.diff sign2.csig_concr sign1.csig_concr)) error in match error with @@ -4139,16 +4148,19 @@ let nondep_type_decl env mid id is_covariant decl = | Type_variant cstrs -> Type_variant (List.map - (fun (c, tl,ret_type_opt) -> - let ret_type_opt = - may_map (nondep_type_rec env mid) ret_type_opt - in - (c, List.map (nondep_type_rec env mid) tl,ret_type_opt)) + (fun c -> + {c with + cd_args = List.map (nondep_type_rec env mid) c.cd_args; + cd_res = may_map (nondep_type_rec env mid) c.cd_res; + } + ) cstrs) | Type_record(lbls, rep) -> Type_record (List.map - (fun (c, mut, t) -> (c, mut, nondep_type_rec env mid t)) + (fun l -> + {l with ld_type = nondep_type_rec env mid l.ld_type} + ) lbls, rep) with Not_found when is_covariant -> Type_abstract @@ -4174,6 +4186,7 @@ let nondep_type_decl env mid id is_covariant decl = type_variance = decl.type_variance; type_newtype_level = None; type_loc = decl.type_loc; + type_attributes = decl.type_attributes; } with Not_found -> clear_hash (); @@ -4181,14 +4194,14 @@ let nondep_type_decl env mid id is_covariant decl = (* Preserve sharing inside class types. *) let nondep_class_signature env id sign = - { cty_self = nondep_type_rec env id sign.cty_self; - cty_vars = + { csig_self = nondep_type_rec env id sign.csig_self; + csig_vars = Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t)) - sign.cty_vars; - cty_concr = sign.cty_concr; - cty_inher = + sign.csig_vars; + csig_concr = sign.csig_concr; + csig_inher = List.map (fun (p,tl) -> (p, List.map (nondep_type_rec env id) tl)) - sign.cty_inher } + sign.csig_inher } let rec nondep_class_type env id = function @@ -4213,7 +4226,10 @@ let nondep_class_declaration env id decl = begin match decl.cty_new with None -> None | Some ty -> Some (nondep_type_rec env id ty) - end } + end; + cty_loc = decl.cty_loc; + cty_attributes = decl.cty_attributes; + } in clear_hash (); decl @@ -4224,7 +4240,10 @@ let nondep_cltype_declaration env id decl = { clty_params = List.map (nondep_type_rec env id) decl.clty_params; clty_variance = decl.clty_variance; clty_type = nondep_class_type env id decl.clty_type; - clty_path = decl.clty_path } + clty_path = decl.clty_path; + clty_loc = decl.clty_loc; + clty_attributes = decl.clty_attributes; + } in clear_hash (); decl diff --git a/typing/datarepr.ml b/typing/datarepr.ml index 8013407e2..13b7bf531 100644 --- a/typing/datarepr.ml +++ b/typing/datarepr.ml @@ -42,46 +42,48 @@ let free_vars ty = let constructor_descrs ty_res cstrs priv = let num_consts = ref 0 and num_nonconsts = ref 0 and num_normal = ref 0 in List.iter - (fun (name, args, ret) -> - if args = [] then incr num_consts else incr num_nonconsts; - if ret = None then incr num_normal) + (fun {cd_args; cd_res; _} -> + if cd_args = [] then incr num_consts else incr num_nonconsts; + if cd_res = None then incr num_normal) cstrs; let rec describe_constructors idx_const idx_nonconst = function [] -> [] - | (id, ty_args, ty_res_opt) :: rem -> + | {cd_id; cd_args; cd_res; cd_loc; cd_attributes} :: rem -> let ty_res = - match ty_res_opt with + match cd_res with | Some ty_res' -> ty_res' | None -> ty_res in let (tag, descr_rem) = - match ty_args with + match cd_args with [] -> (Cstr_constant idx_const, describe_constructors (idx_const+1) idx_nonconst rem) | _ -> (Cstr_block idx_nonconst, describe_constructors idx_const (idx_nonconst+1) rem) in let existentials = - match ty_res_opt with + match cd_res with | None -> [] | Some type_ret -> let res_vars = free_vars type_ret in - let arg_vars = free_vars (newgenty (Ttuple ty_args)) in + let arg_vars = free_vars (newgenty (Ttuple cd_args)) in TypeSet.elements (TypeSet.diff arg_vars res_vars) in let cstr = - { cstr_name = Ident.name id; + { cstr_name = Ident.name cd_id; cstr_res = ty_res; cstr_existentials = existentials; - cstr_args = ty_args; - cstr_arity = List.length ty_args; + cstr_args = cd_args; + cstr_arity = List.length cd_args; cstr_tag = tag; cstr_consts = !num_consts; cstr_nonconsts = !num_nonconsts; cstr_normal = !num_normal; cstr_private = priv; - cstr_generalized = ty_res_opt <> None + cstr_generalized = cd_res <> None; + cstr_loc = cd_loc; + cstr_attributes = cd_attributes; } in - (id, cstr) :: descr_rem in + (cd_id, cstr) :: descr_rem in describe_constructors 0 0 cstrs let exception_descr path_exc decl = @@ -95,31 +97,40 @@ let exception_descr path_exc decl = cstr_nonconsts = -1; cstr_private = Public; cstr_normal = -1; - cstr_generalized = false } + cstr_generalized = false; + cstr_loc = decl.exn_loc; + cstr_attributes = decl.exn_attributes; + } let none = {desc = Ttuple []; level = -1; id = -1} (* Clearly ill-formed type *) let dummy_label = { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable; lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular; - lbl_private = Public } + lbl_private = Public; + lbl_loc = Location.none; + lbl_attributes = []; + } let label_descrs ty_res lbls repres priv = let all_labels = Array.create (List.length lbls) dummy_label in let rec describe_labels num = function [] -> [] - | (id, mut_flag, ty_arg) :: rest -> + | l :: rest -> let lbl = - { lbl_name = Ident.name id; + { lbl_name = Ident.name l.ld_id; lbl_res = ty_res; - lbl_arg = ty_arg; - lbl_mut = mut_flag; + lbl_arg = l.ld_type; + lbl_mut = l.ld_mutable; lbl_pos = num; lbl_all = all_labels; lbl_repres = repres; - lbl_private = priv } in + lbl_private = priv; + lbl_loc = l.ld_loc; + lbl_attributes = l.ld_attributes; + } in all_labels.(num) <- lbl; - (id, lbl) :: describe_labels (num+1) rest in + (l.ld_id, lbl) :: describe_labels (num+1) rest in describe_labels 0 lbls exception Constr_not_found @@ -127,13 +138,13 @@ exception Constr_not_found let rec find_constr tag num_const num_nonconst = function [] -> raise Constr_not_found - | (name, ([] as cstr),(_ as ret_type_opt)) :: rem -> + | {cd_args = []; _} as c :: rem -> if tag = Cstr_constant num_const - then (name,cstr,ret_type_opt) + then c else find_constr tag (num_const + 1) num_nonconst rem - | (name, (_ as cstr),(_ as ret_type_opt)) :: rem -> + | c :: rem -> if tag = Cstr_block num_nonconst - then (name,cstr,ret_type_opt) + then c else find_constr tag num_const (num_nonconst + 1) rem let find_constr_by_tag tag cstrlist = diff --git a/typing/datarepr.mli b/typing/datarepr.mli index 30754cb6e..13ced4609 100644 --- a/typing/datarepr.mli +++ b/typing/datarepr.mli @@ -17,17 +17,17 @@ open Asttypes open Types val constructor_descrs: - type_expr -> (Ident.t * type_expr list * type_expr option) list -> + type_expr -> constructor_declaration list -> private_flag -> (Ident.t * constructor_description) list val exception_descr: Path.t -> exception_declaration -> constructor_description val label_descrs: - type_expr -> (Ident.t * mutable_flag * type_expr) list -> + type_expr -> label_declaration list -> record_representation -> private_flag -> (Ident.t * label_description) list exception Constr_not_found val find_constr_by_tag: - constructor_tag -> (Ident.t * type_expr list * type_expr option) list -> - Ident.t * type_expr list * type_expr option + constructor_tag -> constructor_declaration list -> + constructor_declaration diff --git a/typing/env.ml b/typing/env.ml index f9be752c5..127e48dcf 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -106,7 +106,7 @@ type summary = | Env_value of summary * Ident.t * value_description | Env_type of summary * Ident.t * type_declaration | Env_exception of summary * Ident.t * exception_declaration - | Env_module of summary * Ident.t * module_type + | Env_module of summary * Ident.t * module_declaration | Env_modtype of summary * Ident.t * modtype_declaration | Env_class of summary * Ident.t * class_declaration | Env_cltype of summary * Ident.t * class_type_declaration @@ -168,7 +168,7 @@ type t = { constrs: constructor_description EnvTbl.t; labels: label_description EnvTbl.t; types: (Path.t * (type_declaration * type_descriptions)) EnvTbl.t; - modules: (Path.t * module_type) EnvTbl.t; + modules: (Path.t * module_declaration) EnvTbl.t; modtypes: (Path.t * modtype_declaration) EnvTbl.t; components: (Path.t * module_components) EnvTbl.t; classes: (Path.t * class_declaration) EnvTbl.t; @@ -266,6 +266,9 @@ let check_modtype_inclusion = ref ((fun env mty1 path1 mty2 -> assert false) : t -> module_type -> Path.t -> module_type -> unit) +let md md_type = + {md_type; md_attributes=[]} + (* The name of the compilation unit currently compiled. "" if outside a compilation unit. *) @@ -478,7 +481,7 @@ let find_module path env = with Not_found -> if Ident.persistent id then let ps = find_pers_struct (Ident.name id) in - Mty_signature(ps.ps_sig) + md (Mty_signature(ps.ps_sig)) else raise Not_found end | Pdot(p, s, pos) -> @@ -487,7 +490,7 @@ let find_module path env = with Structure_comps c -> let (data, pos) = Tbl.find s c.comp_modules in - EnvLazy.force subst_modtype_maker data + md (EnvLazy.force subst_modtype_maker data) | Functor_comps f -> raise Not_found end @@ -524,7 +527,7 @@ let rec lookup_module_descr lid env = end | Lapply(l1, l2) -> let (p1, desc1) = lookup_module_descr l1 env in - let (p2, mty2) = lookup_module l2 env in + let (p2, {md_type=mty2}) = lookup_module l2 env in begin match EnvLazy.force !components_of_module_maker' desc1 with Functor_comps f -> !check_modtype_inclusion env mty2 p2 f.fcomp_arg; @@ -533,12 +536,12 @@ let rec lookup_module_descr lid env = raise Not_found end -and lookup_module lid env = +and lookup_module lid env : Path.t * module_declaration = match lid with Lident s -> begin try - let (_, ty) as r = EnvTbl.find_name s env.modules in - begin match ty with + let (_, {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 @@ -548,26 +551,30 @@ and lookup_module lid env = with Not_found -> if s = !current_unit then raise Not_found; let ps = find_pers_struct s in - (Pident(Ident.create_persistent s), Mty_signature ps.ps_sig) + (Pident(Ident.create_persistent s), + md (Mty_signature ps.ps_sig) + ) 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), EnvLazy.force subst_modtype_maker data) + (Pdot(p, s, pos), md (EnvLazy.force subst_modtype_maker data)) | Functor_comps f -> raise Not_found end | Lapply(l1, l2) -> let (p1, desc1) = lookup_module_descr l1 env in - let (p2, mty2) = lookup_module l2 env in + let (p2, {md_type=mty2}) = lookup_module l2 env in let p = Papply(p1, p2) in begin match EnvLazy.force !components_of_module_maker' desc1 with Functor_comps f -> !check_modtype_inclusion env mty2 p2 f.fcomp_arg; - (p, Subst.modtype (Subst.add_module f.fcomp_param p2 f.fcomp_subst) - f.fcomp_res) + let mty = + Subst.modtype (Subst.add_module f.fcomp_param p2 f.fcomp_subst) + f.fcomp_res in + (p, md mty) | Structure_comps c -> raise Not_found end @@ -926,7 +933,7 @@ let rec scrape_alias env mty = end | Mty_alias path -> begin try - scrape_alias env (find_module path env) + scrape_alias env (find_module path env).md_type with Not_found -> assert false end @@ -1004,7 +1011,7 @@ let subst_signature sub sg = | Sig_exception(id, decl) -> Sig_exception (id, Subst.exception_declaration sub decl) | Sig_module(id, mty, x) -> - Sig_module(id, Subst.modtype sub mty,x) + Sig_module(id, Subst.module_declaration sub mty,x) | Sig_modtype(id, decl) -> Sig_modtype(id, Subst.modtype_declaration sub decl) | Sig_class(id, decl, x) -> @@ -1096,14 +1103,15 @@ and components_of_module_maker (env, sub, path, mty) = c.comp_constrs <- add_to_tbl s (cstr, !pos) c.comp_constrs; incr pos - | Sig_module(id, mty, _) -> + | Sig_module(id, md, _) -> + let mty = md.md_type in let mty' = EnvLazy.create (sub, mty) in c.comp_modules <- Tbl.add (Ident.name id) (mty', !pos) c.comp_modules; let comps = components_of_module !env sub path mty in c.comp_components <- Tbl.add (Ident.name id) (comps, !pos) c.comp_components; - env := store_module None id path mty !env !env; + env := store_module None id path md !env !env; incr pos | Sig_modtype(id, decl) -> let decl' = Subst.modtype_declaration sub decl in @@ -1248,14 +1256,14 @@ and store_exception ~check slot id path decl env renv = renv.constrs; summary = Env_exception(env.summary, id, decl) } -and store_module slot id path mty env renv = +and store_module slot id path md env renv = { env with - modules = EnvTbl.add "module" slot id (path, mty) env.modules renv.modules; + modules = EnvTbl.add "module" slot id (path, md) env.modules renv.modules; components = EnvTbl.add "module" slot id - (path, components_of_module env Subst.identity path mty) + (path, components_of_module env Subst.identity path md.md_type) env.components renv.components; - summary = Env_module(env.summary, id, mty) } + summary = Env_module(env.summary, id, md) } and store_modtype slot id path info env renv = { env with @@ -1312,8 +1320,8 @@ 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 ?arg id mty env = - let env = store_module None id (Pident id) mty env env in +and add_module_declaration ?arg id md env = + let env = store_module None id (Pident id) md env env in add_functor_arg ?arg id env and add_modtype id info env = @@ -1325,6 +1333,9 @@ and add_class id ty env = and add_cltype id ty env = store_cltype None id (Pident id) ty env 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 {type_manifest = Some ty; type_newtype_level = Some (lv, _)} -> @@ -1343,13 +1354,16 @@ 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 ?arg name mty env = - let (id, env) = enter store_module name mty env in +and enter_module_declaration ?arg name 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 ?arg s mty env = + enter_module_declaration ?arg s (md mty) env + (* Insertion of all components of a signature *) let add_item comp env = @@ -1357,7 +1371,7 @@ let add_item comp env = Sig_value(id, decl) -> add_value id decl env | Sig_type(id, decl, _) -> add_type ~check:false id decl env | Sig_exception(id, decl) -> add_exception ~check:false id decl env - | Sig_module(id, mty, _) -> add_module id mty env + | Sig_module(id, md, _) -> add_module_declaration id md env | Sig_modtype(id, decl) -> add_modtype id decl env | Sig_class(id, decl, _) -> add_class id decl env | Sig_class_type(id, decl, _) -> add_cltype id decl env @@ -1547,7 +1561,7 @@ let fold_modules f lid env acc = None -> acc | Some ps -> f name (Pident(Ident.create_persistent name)) - (Mty_signature ps.ps_sig) acc) + (md (Mty_signature ps.ps_sig)) acc) persistent_structures acc | Some l -> @@ -1557,7 +1571,7 @@ let fold_modules f lid env acc = Tbl.fold (fun s (data, pos) acc -> f s (Pdot (p, s, pos)) - (EnvLazy.force subst_modtype_maker data) acc) + (md (EnvLazy.force subst_modtype_maker data)) acc) c.comp_modules acc | Functor_comps _ -> diff --git a/typing/env.mli b/typing/env.mli index 03064c41a..7c50ce44c 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -19,7 +19,7 @@ type summary = | Env_value of summary * Ident.t * value_description | Env_type of summary * Ident.t * type_declaration | Env_exception of summary * Ident.t * exception_declaration - | Env_module of summary * Ident.t * module_type + | Env_module of summary * Ident.t * module_declaration | Env_modtype of summary * Ident.t * modtype_declaration | Env_class of summary * Ident.t * class_declaration | Env_cltype of summary * Ident.t * class_type_declaration @@ -48,7 +48,7 @@ val find_shadowed_types: Path.t -> t -> Path.t list val find_value: Path.t -> t -> value_description val find_type: Path.t -> t -> type_declaration val find_type_descrs: Path.t -> t -> type_descriptions -val find_module: Path.t -> t -> module_type +val find_module: Path.t -> t -> module_declaration val find_modtype: Path.t -> t -> modtype_declaration val find_class: Path.t -> t -> class_declaration val find_cltype: Path.t -> t -> class_type_declaration @@ -78,7 +78,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_type +val lookup_module: Longident.t -> t -> Path.t * module_declaration 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 @@ -95,6 +95,7 @@ val add_value: 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: ?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 @@ -121,6 +122,8 @@ val enter_value: val enter_type: string -> type_declaration -> t -> Ident.t * t val enter_exception: string -> exception_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 @@ -224,7 +227,7 @@ val fold_labels: (** Persistent structures are only traversed if they are already loaded. *) val fold_modules: - (string -> Path.t -> module_type -> 'a -> 'a) -> + (string -> Path.t -> module_declaration -> 'a -> 'a) -> Longident.t option -> t -> 'a -> 'a val fold_modtypes: diff --git a/typing/envaux.ml b/typing/envaux.ml index 465c4ac6a..04d6d256f 100644 --- a/typing/envaux.ml +++ b/typing/envaux.ml @@ -52,8 +52,9 @@ let rec env_from_summary sum subst = (Subst.exception_declaration subst desc) (env_from_summary s subst) | Env_module(s, id, desc) -> - Env.add_module id (Subst.modtype subst desc) - (env_from_summary s subst) + Env.add_module_declaration id + (Subst.module_declaration subst desc) + (env_from_summary s subst) | Env_modtype(s, id, desc) -> Env.add_modtype id (Subst.modtype_declaration subst desc) (env_from_summary s subst) @@ -66,16 +67,17 @@ let rec env_from_summary sum subst = | Env_open(s, path) -> let env = env_from_summary s subst in let path' = Subst.module_path subst path in - let mty = + let md = try Env.find_module path' env with Not_found -> raise (Error (Module_not_found path')) in - Env.open_signature Asttypes.Override path' (extract_sig env mty) env + 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 id (Subst.modtype subst desc) ~arg:true - (env_from_summary s subst) + 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; diff --git a/typing/includecore.ml b/typing/includecore.ml index 802dda3b1..0757c73e7 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -157,9 +157,10 @@ let report_type_mismatch first second decl ppf = let rec compare_variants env decl1 decl2 n cstrs1 cstrs2 = match cstrs1, cstrs2 with [], [] -> [] - | [], (cstr2,_,_)::_ -> [Field_missing (true, cstr2)] - | (cstr1,_,_)::_, [] -> [Field_missing (false, cstr1)] - | (cstr1, arg1, ret1)::rem1, (cstr2, arg2,ret2)::rem2 -> + | [], c::_ -> [Field_missing (true, c.Types.cd_id)] + | c::_, [] -> [Field_missing (false, c.Types.cd_id)] + | {Types.cd_id=cstr1; cd_args=arg1; cd_res=ret1}::rem1, + {Types.cd_id=cstr2; cd_args=arg2; cd_res=ret2}::rem2 -> if Ident.name cstr1 <> Ident.name cstr2 then [Field_names (n, cstr1, cstr2)] else if List.length arg1 <> List.length arg2 then @@ -183,9 +184,10 @@ let rec compare_variants env decl1 decl2 n cstrs1 cstrs2 = let rec compare_records env decl1 decl2 n labels1 labels2 = match labels1, labels2 with [], [] -> [] - | [], (lab2,_,_)::_ -> [Field_missing (true, lab2)] - | (lab1,_,_)::_, [] -> [Field_missing (false, lab1)] - | (lab1, mut1, arg1)::rem1, (lab2, mut2, arg2)::rem2 -> + | [], l::_ -> [Field_missing (true, l.ld_id)] + | l::_, [] -> [Field_missing (false, l.ld_id)] + | {Types.ld_id=lab1; ld_mutable=mut1; ld_type=arg1}::rem1, + {Types.ld_id=lab2; ld_mutable=mut2; ld_type=arg2}::rem2 -> if Ident.name lab1 <> Ident.name lab2 then [Field_names (n, lab1, lab2)] else if mut1 <> mut2 then [Field_mutable lab1] else @@ -202,8 +204,8 @@ let type_declarations ?(equality = false) env name decl1 id decl2 = | (Type_variant cstrs1, Type_variant cstrs2) -> let mark cstrs usage name decl = List.iter - (fun (c, _, _) -> - Env.mark_constructor_used usage name decl (Ident.name c)) + (fun c -> + Env.mark_constructor_used usage name decl (Ident.name c.Types.cd_id)) cstrs in let usage = diff --git a/typing/includemod.ml b/typing/includemod.ml index 24858e605..4a508ac04 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -102,7 +102,7 @@ let expand_module_path env cxt path = raise(Error[cxt, env, Unbound_modtype_path path]) let expand_module_alias env cxt path = - try Env.find_module path env + try (Env.find_module path env).md_type with Not_found -> raise(Error[cxt, env, Unbound_module_path path]) @@ -314,7 +314,7 @@ and signature_components env cxt subst = function | (Sig_module(id1, mty1, _), Sig_module(id2, mty2, _), pos) :: rem -> let cc = modtypes env (Module id1::cxt) subst - (Mtype.strengthen env mty1 (Pident id1)) mty2 in + (Mtype.strengthen env mty1.md_type (Pident id1)) mty2.md_type in (pos, cc) :: signature_components env cxt subst rem | (Sig_modtype(id1, info1), Sig_modtype(id2, info2), pos) :: rem -> modtype_infos env cxt subst id1 info1 info2; diff --git a/typing/mtype.ml b/typing/mtype.ml index f717c5465..09316de66 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -25,7 +25,7 @@ let rec normalize_path env path = | _ -> path in try match Env.find_module path env with - Mty_alias path -> normalize_path env path + {md_type=Mty_alias path} -> normalize_path env path | _ -> path with Not_found -> path @@ -73,9 +73,10 @@ and strengthen_sig env sg p = Sig_type(id, newdecl, rs) :: strengthen_sig env rem p | (Sig_exception(id, d) as sigelt) :: rem -> sigelt :: strengthen_sig env rem p - | Sig_module(id, mty, rs) :: rem -> - Sig_module(id, strengthen env mty (Pdot(p, Ident.name id, nopos)), rs) - :: strengthen_sig (Env.add_module id mty env) rem p + | Sig_module(id, md, rs) :: rem -> + let str = strengthen_decl env md (Pdot(p, Ident.name id, nopos)) in + Sig_module(id, str, rs) + :: strengthen_sig (Env.add_module_declaration id md env) rem p (* Need to add the module in case it defines manifest module types *) | Sig_modtype(id, decl) :: rem -> let newdecl = @@ -92,6 +93,10 @@ and strengthen_sig env sg p = | (Sig_class_type(id, decl, rs) as sigelt) :: rem -> sigelt :: strengthen_sig env rem p +and strengthen_decl env md p = + {md with md_type = strengthen env md.md_type p} + + (* 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 traversed. *) @@ -108,7 +113,7 @@ let nondep_supertype env mid mty = else mty | Mty_alias p -> if Path.isfree mid p then - nondep_mty env va (Env.find_module p env) + nondep_mty env va (Env.find_module p env).md_type else mty | Mty_signature sg -> Mty_signature(nondep_sig env va sg) @@ -131,11 +136,15 @@ let nondep_supertype env mid mty = Sig_type(id, Ctype.nondep_type_decl env mid id (va = Co) d, rs) :: rem' | Sig_exception(id, d) -> - let d = {exn_args = List.map (Ctype.nondep_type env mid) d.exn_args; - exn_loc = d.exn_loc} in + let d = + {d with + exn_args = List.map (Ctype.nondep_type env mid) d.exn_args + } + in Sig_exception(id, d) :: rem' - | Sig_module(id, mty, rs) -> - Sig_module(id, nondep_mty env va mty, rs) :: rem' + | Sig_module(id, md, rs) -> + Sig_module(id, {md with md_type=nondep_mty env va md.md_type}, rs) + :: rem' | Sig_modtype(id, d) -> begin try Sig_modtype(id, nondep_modtype_decl env d) :: rem' @@ -182,9 +191,12 @@ and enrich_item env p = function Sig_type(id, decl, rs) -> Sig_type(id, enrich_typedecl env (Pdot(p, Ident.name id, nopos)) decl, rs) - | Sig_module(id, mty, rs) -> + | Sig_module(id, md, rs) -> Sig_module(id, - enrich_modtype env (Pdot(p, Ident.name id, nopos)) mty, rs) + {md with + md_type = enrich_modtype env + (Pdot(p, Ident.name id, nopos)) md.md_type}, + rs) | item -> item let rec type_paths env p mty = @@ -202,9 +214,9 @@ and type_paths_sig env p pos sg = type_paths_sig env p pos' rem | Sig_type(id, decl, _) :: rem -> Pdot(p, Ident.name id, nopos) :: type_paths_sig env p pos rem - | Sig_module(id, mty, _) :: rem -> - type_paths env (Pdot(p, Ident.name id, pos)) mty @ - type_paths_sig (Env.add_module id mty env) p (pos+1) rem + | Sig_module(id, md, _) :: rem -> + type_paths env (Pdot(p, Ident.name id, pos)) md.md_type @ + type_paths_sig (Env.add_module_declaration id md env) p (pos+1) rem | Sig_modtype(id, decl) :: rem -> type_paths_sig (Env.add_modtype id decl env) p pos rem | (Sig_exception _ | Sig_class _) :: rem -> @@ -227,9 +239,9 @@ and no_code_needed_sig env sg = | Val_prim _ -> no_code_needed_sig env rem | _ -> false end - | Sig_module(id, mty, _) :: rem -> - no_code_needed env mty && - no_code_needed_sig (Env.add_module id mty env) rem + | Sig_module(id, md, _) :: rem -> + no_code_needed env md.md_type && + no_code_needed_sig (Env.add_module_declaration id md env) rem | (Sig_type _ | Sig_modtype _ | Sig_class_type _) :: rem -> no_code_needed_sig env rem | (Sig_exception _ | Sig_class _) :: rem -> diff --git a/typing/mtype.mli b/typing/mtype.mli index 90cc06f21..73f295c29 100644 --- a/typing/mtype.mli +++ b/typing/mtype.mli @@ -24,6 +24,7 @@ val freshen: module_type -> module_type val strengthen: Env.t -> module_type -> Path.t -> module_type (* Strengthen abstract type components relative to the given path. *) +val strengthen_decl: Env.t -> module_declaration -> Path.t -> module_declaration val nondep_supertype: Env.t -> Ident.t -> module_type -> module_type (* Return the smallest supertype of the given type in which the given ident does not appear. diff --git a/typing/parmatch.ml b/typing/parmatch.ml index efca42203..73fa785c1 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -143,8 +143,8 @@ let rec get_constr tag ty tenv = let find_label lbl lbls = try - let name,_,_ = List.nth lbls lbl.lbl_pos in - name + let l = List.nth lbls lbl.lbl_pos in + l.Types.ld_id with Failure "nth" -> Ident.create "*Unknown label*" let rec get_record_labels ty tenv = @@ -166,7 +166,7 @@ let get_constr_name tag ty tenv = match tag with | Cstr_exception (path, _) -> Path.name path | _ -> try - let name,_,_ = get_constr tag ty tenv in Ident.name name + let cd = get_constr tag ty tenv in Ident.name cd.cd_id with | Datarepr.Constr_not_found -> "*Unknown constructor*" diff --git a/typing/predef.ml b/typing/predef.ml index e4e96d2de..d83c9cf67 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -99,7 +99,18 @@ let decl_abstr = type_private = Asttypes.Public; type_manifest = None; type_variance = []; - type_newtype_level = None} + type_newtype_level = None; + type_attributes = []; + } + +let cstr id args = + { + cd_id = id; + cd_args = args; + cd_res = None; + cd_loc = Location.none; + cd_attributes = []; + } let ident_false = ident_create "false" and ident_true = ident_create "true" @@ -111,10 +122,10 @@ and ident_some = ident_create "Some" let build_initial_env add_type add_exception empty_env = let decl_bool = {decl_abstr with - type_kind = Type_variant([ident_false, [], None; ident_true, [], None])} + type_kind = Type_variant([cstr ident_false []; cstr ident_true []])} and decl_unit = {decl_abstr with - type_kind = Type_variant([ident_void, [], None])} + type_kind = Type_variant([cstr ident_void []])} and decl_exn = {decl_abstr with type_kind = Type_variant []} @@ -130,8 +141,7 @@ let build_initial_env add_type add_exception empty_env = type_params = [tvar]; type_arity = 1; type_kind = - Type_variant([ident_nil, [], None; ident_cons, [tvar; type_list tvar], - None]); + Type_variant([cstr ident_nil []; cstr ident_cons [tvar; type_list tvar]]); type_variance = [Variance.covariant]} and decl_format6 = let params = List.map newgenvar [();();();();();()] in @@ -144,7 +154,7 @@ let build_initial_env add_type add_exception empty_env = {decl_abstr with type_params = [tvar]; type_arity = 1; - type_kind = Type_variant([ident_none, [], None; ident_some, [tvar], None]); + type_kind = Type_variant([cstr ident_none []; cstr ident_some [tvar]]); type_variance = [Variance.covariant]} and decl_lazy_t = let tvar = newgenvar() in @@ -155,7 +165,9 @@ let build_initial_env add_type add_exception empty_env = in let add_exception id l = - add_exception id { exn_args = l; exn_loc = Location.none } in + add_exception id + { exn_args = l; exn_loc = Location.none; exn_attributes = [] } + in add_exception ident_match_failure [newgenty (Ttuple[type_string; type_int; type_int])] ( add_exception ident_out_of_memory [] ( diff --git a/typing/printtyp.ml b/typing/printtyp.ml index e4ad2be71..121644c07 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -787,12 +787,12 @@ let rec tree_of_type_decl id decl = | Type_abstract -> () | Type_variant cstrs -> List.iter - (fun (_, args,ret_type_opt) -> - List.iter mark_loops args; - may mark_loops ret_type_opt) + (fun c -> + List.iter mark_loops c.cd_args; + may mark_loops c.cd_res) cstrs | Type_record(l, rep) -> - List.iter (fun (_, _, ty) -> mark_loops ty) l + List.iter (fun l -> mark_loops l.ld_type) l end; let type_param = @@ -809,7 +809,7 @@ let rec tree_of_type_decl id decl = decl.type_private = Private | Type_variant tll -> decl.type_private = Private || - List.exists (fun (_,_,ret) -> ret <> None) tll + List.exists (fun cd -> cd.cd_res <> None) tll in let vari = List.map2 @@ -846,15 +846,17 @@ let rec tree_of_type_decl id decl = in (name, args, ty, priv, constraints) -and tree_of_constructor (name, args, ret_type_opt) = - let name = Ident.name name in - if ret_type_opt = None then (name, tree_of_typlist false args, None) else - let nm = !names in - names := []; - let ret = may_map (tree_of_typexp false) ret_type_opt in - let args = tree_of_typlist false args in - names := nm; - (name, args, ret) +and tree_of_constructor cd = + let name = Ident.name cd.cd_id in + match cd.cd_res with + | None -> (name, tree_of_typlist false cd.cd_args, None) + | Some res -> + let nm = !names in + names := []; + let ret = tree_of_typexp false res in + let args = tree_of_typlist false cd.cd_args in + names := nm; + (name, args, Some ret) and tree_of_constructor_ret = @@ -862,8 +864,8 @@ and tree_of_constructor_ret = | None -> None | Some ret_type -> Some (tree_of_typexp false ret_type) -and tree_of_label (name, mut, arg) = - (Ident.name name, mut = Mutable, tree_of_typexp false arg) +and tree_of_label l = + (Ident.name l.ld_id, l.ld_mutable = Mutable, tree_of_typexp false l.ld_type) let tree_of_type_declaration id decl rs = Osig_type (tree_of_type_decl id decl, tree_of_rec rs) @@ -928,16 +930,16 @@ let rec prepare_class_type params = function then prepare_class_type params cty else List.iter mark_loops tyl | Cty_signature sign -> - let sty = repr sign.cty_self in + let sty = repr sign.csig_self in (* Self may have a name *) let px = proxy sty in if List.memq px !visited_objects then add_alias sty else visited_objects := px :: !visited_objects; let (fields, _) = - Ctype.flatten_fields (Ctype.object_fields sign.cty_self) + Ctype.flatten_fields (Ctype.object_fields sign.csig_self) in List.iter (fun met -> mark_loops (fst (method_type met))) fields; - Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.cty_vars + Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.csig_vars | Cty_arrow (_, ty, cty) -> mark_loops ty; prepare_class_type params cty @@ -953,14 +955,14 @@ let rec tree_of_class_type sch params = else Octy_constr (tree_of_path p', tree_of_typlist true tyl) | Cty_signature sign -> - let sty = repr sign.cty_self in + let sty = repr sign.csig_self in let self_ty = if is_aliased sty then Some (Otyp_var (false, name_of_type (proxy sty))) else None in let (fields, _) = - Ctype.flatten_fields (Ctype.object_fields sign.cty_self) + Ctype.flatten_fields (Ctype.object_fields sign.csig_self) in let csil = [] in let csil = @@ -969,7 +971,7 @@ let rec tree_of_class_type sch params = csil (tree_of_constraints params) in let all_vars = - Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.cty_vars [] + Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.csig_vars [] in (* Consequence of PR#3607: order of Map.fold has changed! *) let all_vars = List.rev all_vars in @@ -981,7 +983,7 @@ let rec tree_of_class_type sch params = csil all_vars in let csil = - List.fold_left (tree_of_metho sch sign.cty_concr) csil fields + List.fold_left (tree_of_metho sch sign.csig_concr) csil fields in Octy_signature (self_ty, List.rev csil) | Cty_arrow (l, ty, cty) -> @@ -1051,12 +1053,12 @@ let tree_of_cltype_declaration id cl rs = let virt = let (fields, _) = - Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in + Ctype.flatten_fields (Ctype.object_fields sign.csig_self) in List.exists (fun (lab, _, ty) -> - not (lab = dummy_method || Concr.mem lab sign.cty_concr)) + not (lab = dummy_method || Concr.mem lab sign.csig_concr)) fields - || Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.cty_vars false + || Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.csig_vars false in Osig_class_type @@ -1089,7 +1091,9 @@ let filter_rem_sig item rem = let dummy = { type_params = []; type_arity = 0; type_kind = Type_abstract; type_private = Public; type_manifest = None; type_variance = []; - type_newtype_level = None; type_loc = Location.none; } + type_newtype_level = None; type_loc = Location.none; + type_attributes = []; + } let hide_rec_items = function | Sig_type(id, decl, rs) ::rem @@ -1141,8 +1145,9 @@ and tree_of_signature_rec env' = function [Osig_type(tree_of_type_decl id decl, tree_of_rec rs)] | Sig_exception(id, decl) -> [tree_of_exception_declaration id decl] - | Sig_module(id, mty, rs) -> - [Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs)] + | Sig_module(id, md, rs) -> + [Osig_module (Ident.name id, tree_of_modtype md.md_type, + tree_of_rec rs)] | Sig_modtype(id, decl) -> [tree_of_modtype_declaration id decl] | Sig_class(id, decl, rs) -> diff --git a/typing/subst.ml b/typing/subst.ml index 7848e8784..198c468f7 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -38,6 +38,16 @@ let for_saving s = { s with for_saving = true } let loc s x = if s.for_saving && not !Clflags.keep_locs then Location.none else x +let remove_loc = + let open Ast_mapper in + {default_mapper with location = (fun _this _loc -> Location.none)} + +let attrs s x = + if s.for_saving && not !Clflags.keep_locs + then remove_loc.Ast_mapper.attributes remove_loc x + else x + + let rec module_path s = function Pident id as p -> begin try Tbl.find id s.modules with Not_found -> p end @@ -176,12 +186,28 @@ let type_declaration s decl = | Type_variant cstrs -> Type_variant (List.map - (fun (n, args, ret_type) -> - (n, List.map (typexp s) args, may_map (typexp s) ret_type)) + (fun c -> + { + cd_id = c.cd_id; + cd_args = List.map (typexp s) c.cd_args; + cd_res = may_map (typexp s) c.cd_res; + cd_loc = loc s c.cd_loc; + cd_attributes = attrs s c.cd_attributes; + } + ) cstrs) | Type_record(lbls, rep) -> Type_record - (List.map (fun (n, mut, arg) -> (n, mut, typexp s arg)) lbls, + (List.map (fun l -> + { + ld_id = l.ld_id; + ld_mutable = l.ld_mutable; + ld_type = typexp s l.ld_type; + ld_loc = loc s l.ld_loc; + ld_attributes = attrs s l.ld_attributes; + } + ) + lbls, rep) end; type_manifest = @@ -194,19 +220,20 @@ let type_declaration s decl = type_variance = decl.type_variance; type_newtype_level = None; type_loc = loc s decl.type_loc; + type_attributes = attrs s decl.type_attributes; } in cleanup_types (); decl let class_signature s sign = - { cty_self = typexp s sign.cty_self; - cty_vars = - Vars.map (function (m, v, t) -> (m, v, typexp s t)) sign.cty_vars; - cty_concr = sign.cty_concr; - cty_inher = + { csig_self = typexp s sign.csig_self; + csig_vars = + Vars.map (function (m, v, t) -> (m, v, typexp s t)) sign.csig_vars; + csig_concr = sign.csig_concr; + csig_inher = List.map (fun (p, tl) -> (type_path s p, List.map (typexp s) tl)) - sign.cty_inher + sign.csig_inher; } let rec class_type s = @@ -228,7 +255,10 @@ let class_declaration s decl = begin match decl.cty_new with None -> None | Some ty -> Some (typexp s ty) - end } + end; + cty_loc = loc s decl.cty_loc; + cty_attributes = attrs s decl.cty_attributes; + } in (* Do not clean up if saving: next is cltype_declaration *) if not s.for_saving then cleanup_types (); @@ -239,7 +269,10 @@ let cltype_declaration s decl = { clty_params = List.map (typexp s) decl.clty_params; clty_variance = decl.clty_variance; clty_type = class_type s decl.clty_type; - clty_path = type_path s decl.clty_path } + clty_path = type_path s decl.clty_path; + clty_loc = loc s decl.clty_loc; + clty_attributes = attrs s decl.clty_attributes; + } in (* Do clean up even if saving: type_declaration may be recursive *) cleanup_types (); @@ -250,23 +283,17 @@ let class_type s cty = cleanup_types (); cty -let remove_loc = - let open Ast_mapper in - {default_mapper with location = (fun _this _loc -> Location.none)} - let value_description s descr = { val_type = type_expr s descr.val_type; val_kind = descr.val_kind; val_loc = loc s descr.val_loc; - val_attributes = - if s.for_saving && not !Clflags.keep_locs - then remove_loc.Ast_mapper.attributes remove_loc descr.val_attributes - else descr.val_attributes; + val_attributes = attrs s descr.val_attributes; } let exception_declaration s descr = { exn_args = List.map (type_expr s) descr.exn_args; exn_loc = loc s descr.exn_loc; + exn_attributes = attrs s descr.exn_attributes; } let rec rename_bound_idents s idents = function @@ -321,8 +348,8 @@ and signature_component s comp newid = Sig_type(newid, type_declaration s d, rs) | Sig_exception(id, d) -> Sig_exception(newid, exception_declaration s d) - | Sig_module(id, mty, rs) -> - Sig_module(newid, modtype s mty, rs) + | Sig_module(id, d, rs) -> + Sig_module(newid, module_declaration s d, rs) | Sig_modtype(id, d) -> Sig_modtype(newid, modtype_declaration s d) | Sig_class(id, d, rs) -> @@ -334,6 +361,12 @@ and modtype_declaration s = function Modtype_abstract -> Modtype_abstract | Modtype_manifest mty -> Modtype_manifest(modtype s mty) +and module_declaration s decl = + { + md_type = modtype s decl.md_type; + md_attributes = attrs s decl.md_attributes; + } + (* For every binding k |-> d of m1, add k |-> f d to m2 and return resulting merged map. *) diff --git a/typing/subst.mli b/typing/subst.mli index 18d22ff3e..24a63b3e3 100644 --- a/typing/subst.mli +++ b/typing/subst.mli @@ -50,6 +50,7 @@ val cltype_declaration: t -> class_type_declaration -> class_type_declaration val modtype: t -> module_type -> module_type val signature: t -> signature -> signature val modtype_declaration: t -> modtype_declaration -> modtype_declaration +val module_declaration: t -> module_declaration -> module_declaration (* Composition of substitutions: apply (compose s1 s2) x = apply s2 (apply s1 x) *) diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 9106c2c33..79c8bc7ee 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -90,7 +90,7 @@ let rec generalize_class_type gen = Cty_constr (_, params, cty) -> List.iter gen params; generalize_class_type gen cty - | Cty_signature {cty_self = sty; cty_vars = vars; cty_inher = inher} -> + | Cty_signature {csig_self = sty; csig_vars = vars; csig_inher = inher} -> gen sty; Vars.iter (fun _ (_, _, ty) -> gen ty) vars; List.iter (fun (_,tl) -> List.iter gen tl) inher @@ -104,11 +104,13 @@ let generalize_class_type vars = (* Return the virtual methods of a class type *) let virtual_methods sign = - let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in + let (fields, _) = + Ctype.flatten_fields (Ctype.object_fields sign.Types.csig_self) + in List.fold_left (fun virt (lab, _, _) -> if lab = dummy_method then virt else - if Concr.mem lab sign.cty_concr then virt else + if Concr.mem lab sign.csig_concr then virt else lab::virt) [] fields @@ -133,16 +135,16 @@ let rec class_body cty = let extract_constraints cty = let sign = Ctype.signature_of_class_type cty in - (Vars.fold (fun lab _ vars -> lab :: vars) sign.cty_vars [], + (Vars.fold (fun lab _ vars -> lab :: vars) sign.csig_vars [], begin let (fields, _) = - Ctype.flatten_fields (Ctype.object_fields sign.cty_self) + Ctype.flatten_fields (Ctype.object_fields sign.csig_self) in List.fold_left (fun meths (lab, _, _) -> if lab = dummy_method then meths else lab::meths) [] fields end, - sign.cty_concr) + sign.csig_concr) let rec abbreviate_class_type path params cty = match cty with @@ -156,10 +158,10 @@ let rec closed_class_type = Cty_constr (_, params, _) -> List.for_all Ctype.closed_schema params | Cty_signature sign -> - Ctype.closed_schema sign.cty_self + Ctype.closed_schema sign.csig_self && Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema ty && cc) - sign.cty_vars + sign.csig_vars true | Cty_arrow (_, ty, cty) -> Ctype.closed_schema ty @@ -177,11 +179,11 @@ let rec limited_generalize rv = List.iter (Ctype.limited_generalize rv) params; limited_generalize rv cty | Cty_signature sign -> - Ctype.limited_generalize rv sign.cty_self; + Ctype.limited_generalize rv sign.csig_self; Vars.iter (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty) - sign.cty_vars; + sign.csig_vars; List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl) - sign.cty_inher + sign.csig_inher | Cty_arrow (_, ty, cty) -> Ctype.limited_generalize rv ty; limited_generalize rv cty @@ -250,7 +252,7 @@ let inheritance self_type env ovf concr_meths warn_vals loc parent = (* Methods *) begin try - Ctype.unify env self_type cl_sig.cty_self + Ctype.unify env self_type cl_sig.csig_self with Ctype.Unify trace -> match trace with _::_::_::({desc = Tfield(n, _, _, _)}, _)::rem -> @@ -260,8 +262,8 @@ let inheritance self_type env ovf concr_meths warn_vals loc parent = end; (* Overriding *) - let over_meths = Concr.inter cl_sig.cty_concr concr_meths in - let concr_vals = concr_vals cl_sig.cty_vars in + let over_meths = Concr.inter cl_sig.csig_concr concr_meths in + let concr_vals = concr_vals cl_sig.csig_vars in let over_vals = Concr.inter concr_vals warn_vals in begin match ovf with Some Fresh -> @@ -283,7 +285,7 @@ let inheritance self_type env ovf concr_meths warn_vals loc parent = | _ -> () end; - let concr_meths = Concr.union cl_sig.cty_concr concr_meths + let concr_meths = Concr.union cl_sig.csig_concr concr_meths and warn_vals = Concr.union concr_vals warn_vals in (cl_sig, concr_meths, warn_vals) @@ -382,7 +384,7 @@ let rec class_type_field env self_type meths parent.cltyp_type in let val_sig = - Vars.fold (add_val env sparent.pcty_loc) cl_sig.cty_vars val_sig in + Vars.fold (add_val env sparent.pcty_loc) cl_sig.csig_vars val_sig in (mkctf (Tctf_inherit parent) :: fields, val_sig, concr_meths, inher) @@ -435,10 +437,10 @@ and class_signature env {pcsig_self=sty; pcsig_fields=sign} = ([], Vars.empty, Concr.empty, []) sign in - let cty = {cty_self = self_type; - cty_vars = val_sig; - cty_concr = concr_meths; - cty_inher = inher} + let cty = {csig_self = self_type; + csig_vars = val_sig; + csig_concr = concr_meths; + csig_inher = inher} in { csig_self = self_cty; csig_fields = fields; @@ -532,12 +534,12 @@ let rec class_field self_loc cl_num self_type meths vars sparent.pcl_loc in (val_env, met_env, par_env, (lab, id) :: inh_vars)) - cl_sig.cty_vars (val_env, met_env, par_env, []) + cl_sig.csig_vars (val_env, met_env, par_env, []) in (* Inherited concrete methods *) let inh_meths = Concr.fold (fun lab rem -> (lab, Ident.create lab)::rem) - cl_sig.cty_concr [] + cl_sig.csig_concr [] in (* Super *) let (val_env, met_env, par_env) = @@ -757,10 +759,10 @@ and class_structure cl_num final val_env met_env loc in Ctype.unify val_env self_type (Ctype.newvar ()); let sign = - {cty_self = public_self; - cty_vars = Vars.map (fun (id, mut, vr, ty) -> (mut, vr, ty)) !vars; - cty_concr = concr_meths; - cty_inher = inher} in + {csig_self = public_self; + csig_vars = Vars.map (fun (id, mut, vr, ty) -> (mut, vr, ty)) !vars; + csig_concr = concr_meths; + csig_inher = inher} in let methods = get_methods self_type in let priv_meths = List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind <> Fpresent) @@ -769,11 +771,11 @@ and class_structure cl_num final val_env met_env loc (* Unify private_self and a copy of self_type. self_type will not be modified after this point *) Ctype.close_object self_type; - let mets = virtual_methods {sign with cty_self = self_type} in + let mets = virtual_methods {sign with csig_self = self_type} in let vals = Vars.fold (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l) - sign.cty_vars [] in + sign.csig_vars [] in if mets <> [] || vals <> [] then raise(Error(loc, val_env, Virtual_class(true, final, mets, vals))); let self_methods = @@ -814,7 +816,7 @@ and class_structure cl_num final val_env met_env loc if added <> [] then Location.prerr_warning loc (Warnings.Implicit_public_methods added); let sign = if final then sign else - {sign with cty_self = Ctype.expand_head val_env public_self} in + {sign with csig_self = Ctype.expand_head val_env public_self} in { cstr_self = pat; cstr_fields = fields; @@ -1180,6 +1182,7 @@ let temp_abbrev loc env id arity = type_variance = Misc.replicate_list Variance.full arity; type_newtype_level = None; type_loc = loc; + type_attributes = []; (* or keep attrs from the class decl? *) } env in @@ -1197,31 +1200,40 @@ let initial_env define_class approx if !Clflags.principal then Ctype.generalize_spine constr_type; let dummy_cty = Cty_signature - { cty_self = Ctype.newvar (); - cty_vars = Vars.empty; - cty_concr = Concr.empty; - cty_inher = [] } + { csig_self = Ctype.newvar (); + csig_vars = Vars.empty; + csig_concr = Concr.empty; + csig_inher = [] } in let dummy_class = - {cty_params = []; (* Dummy value *) + {Types.cty_params = []; (* Dummy value *) cty_variance = []; cty_type = dummy_cty; (* Dummy value *) cty_path = unbound_class; cty_new = - match cl.pci_virt with - Virtual -> None - | Concrete -> Some constr_type} + begin match cl.pci_virt with + | Virtual -> None + | Concrete -> Some constr_type + end; + cty_loc = Location.none; + cty_attributes = []; + } in let env = Env.add_cltype ty_id {clty_params = []; (* Dummy value *) clty_variance = []; clty_type = dummy_cty; (* Dummy value *) - clty_path = unbound_class} ( - if define_class then - Env.add_class id dummy_class env - else - env) + clty_path = unbound_class; + clty_loc = Location.none; + clty_attributes = []; + } + ( + if define_class then + Env.add_class id dummy_class env + else + env + ) in ((cl, id, ty_id, obj_id, obj_params, obj_ty, @@ -1337,15 +1349,22 @@ let class_infos define_class kind let cltydef = {clty_params = params; clty_type = class_body typ; clty_variance = cty_variance; - clty_path = Path.Pident obj_id} + clty_path = Path.Pident obj_id; + clty_loc = cl.pci_loc; + clty_attributes = cl.pci_attributes; + } and clty = {cty_params = params; cty_type = typ; cty_variance = cty_variance; cty_path = Path.Pident obj_id; cty_new = - match cl.pci_virt with - Virtual -> None - | Concrete -> Some constr_type} + begin match cl.pci_virt with + | Virtual -> None + | Concrete -> Some constr_type + end; + cty_loc = cl.pci_loc; + cty_attributes = cl.pci_attributes; + } in dummy_class.cty_type <- typ; let env = @@ -1359,7 +1378,7 @@ let class_infos define_class kind let vals = Vars.fold (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l) - sign.cty_vars [] in + sign.csig_vars [] in if mets <> [] || vals <> [] then raise(Error(cl.pci_loc, env, Virtual_class(define_class, false, mets, vals))); end; @@ -1378,15 +1397,22 @@ let class_infos define_class kind let cltydef = {clty_params = params'; clty_type = class_body typ'; clty_variance = cty_variance; - clty_path = Path.Pident obj_id} + clty_path = Path.Pident obj_id; + clty_loc = cl.pci_loc; + clty_attributes = cl.pci_attributes; + } and clty = {cty_params = params'; cty_type = typ'; cty_variance = cty_variance; cty_path = Path.Pident obj_id; cty_new = - match cl.pci_virt with - Virtual -> None - | Concrete -> Some (Ctype.instance env constr_type)} + begin match cl.pci_virt with + | Virtual -> None + | Concrete -> Some (Ctype.instance env constr_type) + end; + cty_loc = cl.pci_loc; + cty_attributes = cl.pci_attributes; + } in let obj_abbr = {type_params = obj_params; @@ -1396,7 +1422,9 @@ let class_infos define_class kind type_manifest = Some obj_ty; type_variance = List.map (fun _ -> Variance.full) obj_params; type_newtype_level = None; - type_loc = cl.pci_loc} + type_loc = cl.pci_loc; + type_attributes = []; (* or keep attrs from cl? *) + } in let (cl_params, cl_ty) = Ctype.instance_parameterized_type params (Ctype.self_type typ) @@ -1411,7 +1439,9 @@ let class_infos define_class kind type_manifest = Some cl_ty; type_variance = List.map (fun _ -> Variance.full) cl_params; type_newtype_level = None; - type_loc = cl.pci_loc} + type_loc = cl.pci_loc; + type_attributes = []; (* or keep attrs from cl? *) + } in ((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, arity, pub_meths, List.rev !coercion_locs, expr) :: res, @@ -1603,11 +1633,11 @@ let type_object env loc s = incr class_num; let (desc, sign) = class_structure (string_of_int !class_num) true env env loc s in - let sty = Ctype.expand_head env sign.cty_self in + let sty = Ctype.expand_head env sign.csig_self in Ctype.hide_private_methods sty; let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in let meths = List.map (fun (s,_,_) -> s) fields in - unify_parents_struct env sign.cty_self desc; + unify_parents_struct env sign.csig_self desc; (desc, sign, meths) let () = diff --git a/typing/typecore.ml b/typing/typecore.ml index 42b1da7c4..fee74fd6b 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -285,7 +285,7 @@ let extract_concrete_variant env ty = let extract_label_names sexp env ty = try let (_, _,fields) = extract_concrete_record env ty in - List.map (fun (name, _, _) -> name) fields + List.map (fun l -> l.Types.ld_id) fields with Not_found -> assert false @@ -1013,6 +1013,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = (Constructor.disambiguate lid !env opath ~check_lk) constrs in Env.mark_constructor Env.Pattern !env (Longident.last lid.txt) constr; + Typetexp.check_deprecated loc constr.cstr_attributes constr.cstr_name; if no_existentials && constr.cstr_existentials <> [] then raise (Error (loc, !env, Unexpected_existential)); (* if constructor is gadt, we must verify that the expected type has the @@ -1378,7 +1379,7 @@ let rec is_nonexpansive exp = true (* Note: nonexpansive only means no _observable_ side effects *) | Texp_lazy e -> is_nonexpansive e - | Texp_object ({cstr_fields=fields; cstr_type = { cty_vars=vars}}, _) -> + | Texp_object ({cstr_fields=fields; cstr_type = { csig_vars=vars}}, _) -> let count = ref 0 in List.for_all (fun field -> match field.cf_desc with @@ -1913,13 +1914,6 @@ and type_expect_ ?in_function env sexp ty_expected = let name = Path.name ~paren:Oprint.parenthesized_ident path in Stypes.record (Stypes.An_ident (loc, name, annot)) end; - if - List.exists - (function ({txt = "deprecated"; _}, _) -> true | _ -> false) - desc.val_attributes - then - Location.prerr_warning loc (Warnings.Deprecated (Path.name path)); - rue { exp_desc = begin match desc.val_kind with @@ -2533,7 +2527,7 @@ and type_expect_ ?in_function env sexp ty_expected = end | Pexp_new cl -> let (cl_path, cl_decl) = Typetexp.find_class env loc cl.txt in - begin match cl_decl.cty_new with + begin match cl_decl.cty_new with None -> raise(Error(loc, env, Virtual_class cl.txt)) | Some ty -> @@ -2668,7 +2662,7 @@ and type_expect_ ?in_function env sexp ty_expected = rue { exp_desc = Texp_object (desc, (*sign,*) meths); exp_loc = loc; exp_extra = []; - exp_type = sign.cty_self; + exp_type = sign.csig_self; exp_attributes = sexp.pexp_attributes; exp_env = env; } @@ -2728,6 +2722,7 @@ and type_expect_ ?in_function env sexp ty_expected = type_variance = []; type_newtype_level = Some (level, level); type_loc = loc; + type_attributes = []; } in Ident.set_current_time ty.level; @@ -3195,6 +3190,7 @@ and type_construct env loc lid sarg ty_expected attrs = wrap_disambiguate "This variant expression is expected to have" ty_expected (Constructor.disambiguate lid env opath) constrs in Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr; + Typetexp.check_deprecated loc constr.cstr_attributes constr.cstr_name; let sargs = match sarg with None -> [] diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 025113d85..214a0b1c2 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -61,6 +61,7 @@ let enter_type env sdecl id = type_variance = List.map (fun _ -> Variance.full) sdecl.ptype_params; type_newtype_level = None; type_loc = sdecl.ptype_loc; + type_attributes = sdecl.ptype_attributes; } in Env.add_type ~check:true id decl env @@ -191,8 +192,11 @@ let transl_declaration env sdecl id = {cd_id = name; cd_name = lid; cd_args = ctys; cd_res = res; cd_loc = loc; cd_attributes = attrs} ) cstrs), - Type_variant (List.map (fun (name, name_loc, ctys, _, option, loc, _attrs) -> - name, List.map (fun cty -> cty.ctyp_type) ctys, option) cstrs) + Type_variant (List.map (fun (name, name_loc, ctys, _, option, loc, attrs) -> + {Types.cd_id = name; cd_args = List.map (fun cty -> cty.ctyp_type) ctys; + cd_res = option; + cd_loc = loc; cd_attributes = attrs} + ) cstrs) | Ptype_record lbls -> let all_labels = ref StringSet.empty in @@ -212,10 +216,17 @@ let transl_declaration env sdecl id = List.map (fun ld -> let ty = ld.ld_type.ctyp_type in - ld.ld_id, ld.ld_mutable, match ty.desc with Tpoly(t,[]) -> t | _ -> ty) + let ty = match ty.desc with Tpoly(t,[]) -> t | _ -> ty in + {Types.ld_id = ld.ld_id; + ld_mutable = ld.ld_mutable; + ld_type = ty; + ld_loc = ld.ld_loc; + ld_attributes = ld.ld_attributes + } + ) lbls in let rep = - if List.for_all (fun (name, mut, arg) -> is_float env arg) lbls' + if List.for_all (fun l -> is_float env l.Types.ld_type) lbls' then Record_float else Record_regular in Ttype_record lbls, Type_record(lbls', rep) @@ -236,6 +247,7 @@ let transl_declaration env sdecl id = type_variance = List.map (fun _ -> Variance.full) params; type_newtype_level = None; type_loc = sdecl.ptype_loc; + type_attributes = sdecl.ptype_attributes; } in (* Check constraints *) @@ -282,12 +294,12 @@ let generalize_decl decl = () | Type_variant v -> List.iter - (fun (_, tyl, ret_type) -> - List.iter Ctype.generalize tyl; - may Ctype.generalize ret_type) + (fun c -> + List.iter Ctype.generalize c.Types.cd_args; + may Ctype.generalize c.Types.cd_res) v | Type_record(r, rep) -> - List.iter (fun (_, _, ty) -> Ctype.generalize ty) r + List.iter (fun l -> Ctype.generalize l.Types.ld_type) r end; begin match decl.type_manifest with | None -> () @@ -339,7 +351,7 @@ let check_constraints env sdecl (_, decl) = List.fold_left foldf SMap.empty pl in List.iter - (fun (name, tyl, ret_type) -> + (fun {Types.cd_id=name; cd_args=tyl; cd_res=ret_type} -> let {pcd_args = styl; pcd_res = sret_type; _} = try SMap.find (Ident.name name) pl_index with Not_found -> assert false in @@ -365,7 +377,7 @@ let check_constraints env sdecl (_, decl) = if name = pld.pld_name.txt then pld.pld_type.ptyp_loc else get_loc name tl in List.iter - (fun (name, _, ty) -> + (fun {Types.ld_id=name; ld_type=ty} -> check_constraints_rec env (get_loc (Ident.name name) pl) visited ty) l end; @@ -577,18 +589,6 @@ let compute_variance env visited vari ty = compute_variance_rec vari ty let make_variance ty = (ty, ref Variance.null) -let whole_type decl = - match decl.type_kind with - Type_variant tll -> - Btype.newgenty - (Ttuple (List.map (fun (_, tl, _) -> Btype.newgenty (Ttuple tl)) tll)) - | Type_record (ftl, _) -> - Btype.newgenty - (Ttuple (List.map (fun (_, _, ty) -> ty) ftl)) - | Type_abstract -> - match decl.type_manifest with - Some ty -> ty - | _ -> Btype.newgenty (Ttuple []) let make p n i = let open Variance in @@ -699,7 +699,7 @@ let constrained env vars ty = | _ -> true let compute_variance_gadt env check (required, loc as rloc) decl - (_, tl, ret_type_opt) = + (tl, ret_type_opt) = match ret_type_opt with | None -> compute_variance_type env check rloc {decl with type_private = Private} @@ -742,13 +742,13 @@ let compute_variance_decl env check decl (required, loc as rloc) = Type_abstract -> compute_variance_type env check rloc decl mn | Type_variant tll -> - if List.for_all (fun (_,_,ret) -> ret = None) tll then + if List.for_all (fun c -> c.Types.cd_res = None) tll then compute_variance_type env check rloc decl - (mn @ add_false (List.flatten (List.map (fun (_,tyl,_) -> tyl) tll))) + (mn @ add_false (List.flatten (List.map (fun c -> c.Types.cd_args) tll))) else begin let mn = - List.map (fun (_,ty) -> (Ident.create_persistent"",[ty],None)) mn in - let tll = mn @ tll in + List.map (fun (_,ty) -> ([ty],None)) mn in + let tll = mn @ List.map (fun c -> c.Types.cd_args, c.Types.cd_res) tll in match List.map (compute_variance_gadt env check rloc decl) tll with | vari :: rem -> let varl = List.fold_left (List.map2 Variance.union) vari rem in @@ -759,7 +759,8 @@ let compute_variance_decl env check decl (required, loc as rloc) = end | Type_record (ftl, _) -> compute_variance_type env check rloc decl - (mn @ List.map (fun (_, mut, ty) -> (mut = Mutable, ty)) ftl) + (mn @ List.map (fun {Types.ld_mutable; ld_type} -> + (ld_mutable = Mutable, ld_type)) ftl) let is_sharp id = let s = Ident.name id in @@ -1014,7 +1015,13 @@ let transl_exception env excdecl = Ctype.end_def(); let types = List.map (fun cty -> cty.ctyp_type) ttypes in List.iter Ctype.generalize types; - let exn_decl = { exn_args = types; Types.exn_loc = loc } in + let exn_decl = + { + exn_args = types; + exn_attributes = excdecl.pcd_attributes; + Types.exn_loc = loc; + } + in let (id, newenv) = Env.enter_exception excdecl.pcd_name.txt exn_decl env in let cd = { cd_id = id; @@ -1037,7 +1044,9 @@ let transl_exn_rebind env loc lid = Env.mark_constructor Env.Positive env (Longident.last lid) cdescr; match cdescr.cstr_tag with Cstr_exception (path, _) -> - (path, {exn_args = cdescr.cstr_args; Types.exn_loc = loc}) + (path, {exn_args = cdescr.cstr_args; + exn_attributes = []; + Types.exn_loc = loc}) | _ -> raise(Error(loc, Not_an_exception lid)) (* Translate a value declaration *) @@ -1126,6 +1135,7 @@ let transl_with_constraint env id row_path orig_decl sdecl = type_variance = []; type_newtype_level = None; type_loc = sdecl.ptype_loc; + type_attributes = sdecl.ptype_attributes; } in begin match row_path with None -> () @@ -1169,6 +1179,7 @@ let abstract_type_decl arity = type_variance = replicate_list Variance.full arity; type_newtype_level = None; type_loc = Location.none; + type_attributes = []; } in Ctype.end_def(); generalize_decl decl; @@ -1282,12 +1293,12 @@ let report_error ppf = function let ty = Ctype.repr ty in begin match decl.type_kind, decl.type_manifest with | Type_variant tl, _ -> - explain_unbound ppf ty tl (fun (_,tl,_) -> - Btype.newgenty (Ttuple tl)) - "case" (fun (lab,_,_) -> Ident.name lab ^ " of ") + explain_unbound ppf ty tl (fun c -> + Btype.newgenty (Ttuple c.Types.cd_args)) + "case" (fun c -> Ident.name c.Types.cd_id ^ " of ") | Type_record (tl, _), _ -> - explain_unbound ppf ty tl (fun (_,_,t) -> t) - "field" (fun (lab,_,_) -> Ident.name lab ^ ": ") + explain_unbound ppf ty tl (fun l -> l.Types.ld_type) + "field" (fun l -> Ident.name l.Types.ld_id ^ ": ") | Type_abstract, Some ty' -> explain_unbound_single ppf ty ty' | _ -> () diff --git a/typing/typemod.ml b/typing/typemod.ml index d3aba0914..c6267ccb9 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -67,8 +67,8 @@ let extract_sig_open env loc mty = (* Compute the environment after opening a module *) let type_open ?toplevel ovf env loc lid = - let (path, mty) = Typetexp.find_module env loc lid.txt in - let sg = extract_sig_open env loc mty in + let (path, md) = Typetexp.find_module env loc lid.txt in + let sg = extract_sig_open env loc md.md_type in path, Env.open_signature ~loc ?toplevel ovf path sg env (* Record a module type *) @@ -157,7 +157,9 @@ let merge_constraint initial_env loc sg constr = ) sdecl.ptype_params; type_loc = sdecl.ptype_loc; - type_newtype_level = None } + type_newtype_level = None; + type_attributes = []; + } and id_row = Ident.create (s^"#row") in let initial_env = Env.add_type ~check:true id_row decl_row initial_env @@ -190,27 +192,27 @@ let merge_constraint initial_env loc sg constr = real_id := Some id; (Pident id, lid, Twith_typesubst tdecl), make_next_first rs rem - | (Sig_module(id, mty, rs) :: rem, [s], Pwith_module (_, lid)) + | (Sig_module(id, md, rs) :: rem, [s], Pwith_module (_, lid)) when Ident.name id = s -> - let (path, mty') = Typetexp.find_module initial_env loc lid.txt in - let newmty = Mtype.strengthen env mty' path in - ignore(Includemod.modtypes env newmty mty); + let (path, md') = Typetexp.find_module initial_env loc lid.txt 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, newmty, rs) :: rem - | (Sig_module(id, mty, rs) :: rem, [s], Pwith_modsubst (_, lid)) + Sig_module(id, newmd, rs) :: rem + | (Sig_module(id, md, rs) :: rem, [s], Pwith_modsubst (_, lid)) when Ident.name id = s -> - let (path, mty') = Typetexp.find_module initial_env loc lid.txt in - let newmty = Mtype.strengthen env mty' path in - ignore(Includemod.modtypes env newmty mty); + let (path, md') = Typetexp.find_module initial_env loc lid.txt in + let newmd = Mtype.strengthen_decl env md' path in + ignore(Includemod.modtypes env newmd.md_type md.md_type); real_id := Some id; (Pident id, lid, Twith_modsubst (path, lid)), make_next_first rs rem - | (Sig_module(id, mty, rs) :: rem, s :: namelist, _) + | (Sig_module(id, md, rs) :: rem, s :: namelist, _) when Ident.name id = s -> let ((path, path_loc, tcstr), newsg) = - merge env (extract_sig env loc mty) namelist None in + merge env (extract_sig env loc md.md_type) namelist None in (path_concat id path, lid, tcstr), - Sig_module(id, Mty_signature newsg, rs) :: rem + Sig_module(id, {md with md_type=Mty_signature newsg}, rs) :: rem | (item :: rem, _, _) -> let (cstr, items) = merge (Env.add_item item env) rem namelist row_id in @@ -322,19 +324,33 @@ and approx_sig env ssg = let rem = approx_sig env srem in map_rec' (fun rs (id, info) -> Sig_type(id, info, rs)) decls rem | Psig_module pmd -> - let mty = approx_modtype env pmd.pmd_type in - let (id, newenv) = Env.enter_module pmd.pmd_name.txt mty env in - Sig_module(id, mty, Trec_not) :: approx_sig newenv srem + let md = + { + Types.md_type = approx_modtype env pmd.pmd_type; + md_attributes = pmd.pmd_attributes; + } + in + let (id, newenv) = + Env.enter_module_declaration pmd.pmd_name.txt md env + in + Sig_module(id, md, Trec_not) :: approx_sig newenv srem | Psig_recmodule sdecls -> let decls = List.map (fun pmd -> - (Ident.create pmd.pmd_name.txt, approx_modtype env pmd.pmd_type)) - sdecls in + (Ident.create pmd.pmd_name.txt, + { + md_type = approx_modtype env pmd.pmd_type; + md_attributes = pmd.pmd_attributes; + } + ) + ) + sdecls + in let newenv = - List.fold_left (fun env (id, mty) -> Env.add_module id mty env) + List.fold_left (fun env (id, md) -> Env.add_module_declaration id md env) env decls in - map_rec (fun rs (id, mty) -> Sig_module(id, mty, rs)) decls + map_rec (fun rs (id, md) -> Sig_module(id, md, rs)) decls (approx_sig newenv srem) | Psig_modtype d -> let info = approx_modtype_info env d.pmtd_type in @@ -537,13 +553,18 @@ and transl_signature env sg = | Psig_module pmd -> check "module" item.psig_loc module_names pmd.pmd_name.txt; let tmty = transl_modtype env pmd.pmd_type in - let mty = tmty.mty_type in - let (id, newenv) = Env.enter_module pmd.pmd_name.txt mty env in + let md = { + md_type=tmty.mty_type; + md_attributes=pmd.pmd_attributes + } + 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, - Sig_module(id, mty, Trec_not) :: rem, + Sig_module(id, md, Trec_not) :: rem, final_env | Psig_recmodule sdecls -> List.iter @@ -554,7 +575,10 @@ and transl_signature env sg = transl_recmodule_modtypes item.psig_loc env sdecls in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_recmodule decls) env loc :: trem, - map_rec (fun rs md -> Sig_module(md.md_id, md.md_type.mty_type, rs)) + map_rec (fun rs md -> + let d = {Types.md_type = md.md_type.mty_type; + md_attributes = md.md_attributes} in + Sig_module(md.md_id, d, rs)) decls rem, final_env | Psig_modtype pmtd -> @@ -712,7 +736,8 @@ and transl_recmodule_modtypes loc env sdecls = let dcl2 = List.map2 (fun pmd (id, id_loc, mty) -> - {md_id=id; md_name=id_loc; md_type=mty; md_attributes=pmd.pmd_attributes}) + {md_id=id; md_name=id_loc; md_type=mty; + md_attributes=pmd.pmd_attributes}) sdecls dcl2 in (dcl2, env2) @@ -738,7 +763,7 @@ let rec closed_modtype = function and closed_signature_item = function Sig_value(id, desc) -> Ctype.closed_schema desc.val_type - | Sig_module(id, mty, _) -> closed_modtype mty + | Sig_module(id, md, _) -> closed_modtype md.md_type | _ -> true let check_nongen_scheme env str = @@ -877,14 +902,19 @@ let rec package_constraints env loc mty constrs = when List.mem_assoc [Ident.name id] constrs -> let ty = List.assoc [Ident.name id] constrs in Sig_type (id, {td with type_manifest = Some ty}, rs) - | Sig_module (id, mty, rs) -> + | Sig_module (id, md, rs) -> let rec aux = function | (m :: ((_ :: _) as l), t) :: rest when m = Ident.name id -> (l, t) :: aux rest | _ :: rest -> aux rest | [] -> [] in - Sig_module (id, package_constraints env loc mty (aux constrs), rs) + let md = + {md with + md_type = package_constraints env loc md.md_type (aux constrs) + } + in + Sig_module (id, md, rs) | item -> item ) sg @@ -920,7 +950,8 @@ let wrap_constraint env arg mty explicit = let rec type_module ?(alias=false) sttn funct_body anchor env smod = match smod.pmod_desc with Pmod_ident lid -> - let (path, mty) = Typetexp.find_module env smod.pmod_loc lid.txt in + let (path, md) = Typetexp.find_module env smod.pmod_loc lid.txt in + let mty = md.md_type in let mty = if alias && not (Env.is_functor_arg path env) then Mty_alias path else if sttn then Mtype.strengthen env mty path else mty in @@ -1080,10 +1111,16 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = let modl = type_module ~alias:true true funct_body (anchor_submodule name.txt anchor) env smodl in - let mty = enrich_module_type anchor name.txt modl.mod_type env in - let (id, newenv) = Env.enter_module name.txt mty env in + let md = + { md_type = enrich_module_type anchor name.txt modl.mod_type env; + md_attributes = attrs; + } + in + let (id, newenv) = Env.enter_module_declaration name.txt md env in Tstr_module {mb_id=id; mb_name=name; mb_expr=modl;mb_attributes=attrs}, - [Sig_module(id, modl.mod_type, Trec_not)], + [Sig_module(id, + {md_type = modl.mod_type; + md_attributes = attrs}, Trec_not)], newenv | Pstr_recmodule sbind -> let sbind = @@ -1101,7 +1138,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = sbind; let (decls, newenv) = transl_recmodule_modtypes loc env - (List.map (fun (name, smty, smodl, attrs) -> {pmd_name=name; pmd_type=smty; pmd_attributes=attrs}) sbind) in + (List.map (fun (name, smty, smodl, attrs) -> + {pmd_name=name; pmd_type=smty; pmd_attributes=attrs}) sbind + ) in let bindings1 = List.map2 (fun {md_id=id; md_type=mty} (name, _, smodl, attrs) -> @@ -1116,7 +1155,11 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = let bindings2 = check_recmodule_inclusion newenv bindings1 in Tstr_recmodule bindings2, - map_rec (fun rs mb -> Sig_module(mb.mb_id, mb.mb_expr.mod_type, rs)) + map_rec (fun rs mb -> + Sig_module(mb.mb_id, { + md_type=mb.mb_expr.mod_type; + md_attributes=mb.mb_attributes + }, rs)) bindings2 [], newenv | Pstr_modtype pmtd -> @@ -1231,7 +1274,7 @@ and normalize_signature env = List.iter (normalize_signature_item env) and normalize_signature_item env = function Sig_value(id, desc) -> Ctype.normalize_type env desc.val_type - | Sig_module(id, mty, _) -> normalize_modtype env mty + | Sig_module(id, md, _) -> normalize_modtype env md.md_type | _ -> () (* Simplify multiple specifications of a value or an exception in a signature. @@ -1259,9 +1302,10 @@ and simplify_signature sg = simplif val_names (StringSet.add name exn_names) (if StringSet.mem name exn_names then res else component :: res) sg - | Sig_module(id, mty, rs) :: sg -> + | Sig_module(id, md, rs) :: sg -> + let md = {md with md_type = simplify_modtype md.md_type} in simplif val_names exn_names - (Sig_module(id, simplify_modtype mty, rs) :: res) sg + (Sig_module(id, md, rs) :: res) sg | component :: sg -> simplif val_names exn_names (component :: res) sg in @@ -1273,9 +1317,9 @@ 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, mty) = Typetexp.find_module env smod.pmod_loc lid.txt in + let (path, md) = Typetexp.find_module env smod.pmod_loc lid.txt in rm { mod_desc = Tmod_ident (path, lid); - mod_type = mty; + mod_type = md.md_type; mod_env = env; mod_attributes = smod.pmod_attributes; mod_loc = smod.pmod_loc } @@ -1416,7 +1460,9 @@ let rec package_signatures subst = function let sg' = Subst.signature subst sg in let oldid = Ident.create_persistent name and newid = Ident.create name in - Sig_module(newid, Mty_signature sg', Trec_not) :: + Sig_module(newid, {md_type=Mty_signature sg'; + md_attributes=[]}, + Trec_not) :: package_signatures (Subst.add_module oldid (Pident newid) subst) rem let package_units objfiles cmifile modulename = diff --git a/typing/types.ml b/typing/types.ml index 268045af6..fa3dcfc88 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -116,7 +116,10 @@ type constructor_description = cstr_nonconsts: int; (* Number of non-const constructors *) cstr_normal: int; (* Number of non generalized constrs *) cstr_generalized: bool; (* Constrained return type? *) - cstr_private: private_flag } (* Read-only constructor? *) + cstr_private: private_flag; (* Read-only constructor? *) + cstr_loc: Location.t; + cstr_attributes: Parsetree.attributes; + } and constructor_tag = Cstr_constant of int (* Constant constructor (an int) *) @@ -133,7 +136,10 @@ type label_description = lbl_pos: int; (* Position in block *) lbl_all: label_description array; (* All the labels in this type *) lbl_repres: record_representation; (* Representation for this record *) - lbl_private: private_flag } (* Read-only field? *) + lbl_private: private_flag; (* Read-only field? *) + lbl_loc: Location.t; + lbl_attributes: Parsetree.attributes; + } and record_representation = Record_regular (* All fields are boxed / tagged *) @@ -179,13 +185,33 @@ type type_declaration = type_manifest: type_expr option; type_variance: Variance.t list; type_newtype_level: (int * int) option; - type_loc: Location.t } + type_loc: Location.t; + type_attributes: Parsetree.attributes; + } and type_kind = Type_abstract - | Type_record of - (Ident.t * mutable_flag * type_expr) list * record_representation - | Type_variant of (Ident.t * type_expr list * type_expr option) list + | Type_record of label_declaration list * record_representation + | Type_variant of constructor_declaration list + +and label_declaration = + { + ld_id: Ident.t; + ld_mutable: mutable_flag; + ld_type: type_expr; + ld_loc: Location.t; + ld_attributes: Parsetree.attributes; + } + +and constructor_declaration = + { + cd_id: Ident.t; + cd_args: type_expr list; + cd_res: type_expr option; + cd_loc: Location.t; + cd_attributes: Parsetree.attributes; + } + and type_transparence = Type_public (* unrestricted expansion *) @@ -194,7 +220,9 @@ and type_transparence = type exception_declaration = { exn_args: type_expr list; - exn_loc: Location.t } + exn_loc: Location.t; + exn_attributes: Parsetree.attributes; + } (* Type expressions for the class language *) @@ -206,24 +234,30 @@ type class_type = | Cty_arrow of label * type_expr * class_type and class_signature = - { cty_self: type_expr; - cty_vars: + { csig_self: type_expr; + csig_vars: (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t; - cty_concr: Concr.t; - cty_inher: (Path.t * type_expr list) list } + csig_concr: Concr.t; + csig_inher: (Path.t * type_expr list) list } type class_declaration = { cty_params: type_expr list; mutable cty_type: class_type; cty_path: Path.t; cty_new: type_expr option; - cty_variance: Variance.t list } + cty_variance: Variance.t list; + cty_loc: Location.t; + cty_attributes: Parsetree.attributes; + } type class_type_declaration = { clty_params: type_expr list; clty_type: class_type; clty_path: Path.t; - clty_variance: Variance.t list } + clty_variance: Variance.t list; + clty_loc: Location.t; + clty_attributes: Parsetree.attributes; + } (* Type expressions for the module language *) @@ -239,11 +273,16 @@ and signature_item = Sig_value of Ident.t * value_description | Sig_type of Ident.t * type_declaration * rec_status | Sig_exception of Ident.t * exception_declaration - | Sig_module of Ident.t * module_type * rec_status + | Sig_module of Ident.t * module_declaration * rec_status | Sig_modtype of Ident.t * modtype_declaration | Sig_class of Ident.t * class_declaration * rec_status | Sig_class_type of Ident.t * class_type_declaration * rec_status +and module_declaration = + { + md_type: module_type; + md_attributes: Parsetree.attributes; + } and modtype_declaration = Modtype_abstract | Modtype_manifest of module_type diff --git a/typing/types.mli b/typing/types.mli index 04ec2d7dd..dab96f95b 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -113,7 +113,10 @@ type constructor_description = cstr_nonconsts: int; (* Number of non-const constructors *) cstr_normal: int; (* Number of non generalized constrs *) cstr_generalized: bool; (* Constrained return type? *) - cstr_private: private_flag } (* Read-only constructor? *) + cstr_private: private_flag; (* Read-only constructor? *) + cstr_loc: Location.t; + cstr_attributes: Parsetree.attributes; + } and constructor_tag = Cstr_constant of int (* Constant constructor (an int) *) @@ -130,7 +133,10 @@ type label_description = lbl_pos: int; (* Position in block *) lbl_all: label_description array; (* All the labels in this type *) lbl_repres: record_representation; (* Representation for this record *) - lbl_private: private_flag } (* Read-only field? *) + lbl_private: private_flag; (* Read-only field? *) + lbl_loc: Location.t; + lbl_attributes: Parsetree.attributes; + } and record_representation = Record_regular (* All fields are boxed / tagged *) @@ -167,13 +173,32 @@ type type_declaration = (* covariant, contravariant, weakly contravariant, injective *) type_newtype_level: (int * int) option; (* definition level * expansion level *) - type_loc: Location.t } + type_loc: Location.t; + type_attributes: Parsetree.attributes; + } and type_kind = Type_abstract - | Type_record of - (Ident.t * mutable_flag * type_expr) list * record_representation - | Type_variant of (Ident.t * type_expr list * type_expr option) list + | Type_record of label_declaration list * record_representation + | Type_variant of constructor_declaration list + +and label_declaration = + { + ld_id: Ident.t; + ld_mutable: mutable_flag; + ld_type: type_expr; + ld_loc: Location.t; + ld_attributes: Parsetree.attributes; + } + +and constructor_declaration = + { + cd_id: Ident.t; + cd_args: type_expr list; + cd_res: type_expr option; + cd_loc: Location.t; + cd_attributes: Parsetree.attributes; + } and type_transparence = Type_public (* unrestricted expansion *) @@ -182,7 +207,9 @@ and type_transparence = type exception_declaration = { exn_args: type_expr list; - exn_loc: Location.t } + exn_loc: Location.t; + exn_attributes: Parsetree.attributes; + } (* Type expressions for the class language *) @@ -194,23 +221,30 @@ type class_type = | Cty_arrow of label * type_expr * class_type and class_signature = - { cty_self: type_expr; - cty_vars: (mutable_flag * virtual_flag * type_expr) Vars.t; - cty_concr: Concr.t; - cty_inher: (Path.t * type_expr list) list } + { csig_self: type_expr; + csig_vars: + (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t; + csig_concr: Concr.t; + csig_inher: (Path.t * type_expr list) list } type class_declaration = { cty_params: type_expr list; mutable cty_type: class_type; cty_path: Path.t; cty_new: type_expr option; - cty_variance: Variance.t list } + cty_variance: Variance.t list; + cty_loc: Location.t; + cty_attributes: Parsetree.attributes; + } type class_type_declaration = { clty_params: type_expr list; clty_type: class_type; clty_path: Path.t; - clty_variance: Variance.t list } + clty_variance: Variance.t list; + clty_loc: Location.t; + clty_attributes: Parsetree.attributes; + } (* Type expressions for the module language *) @@ -226,11 +260,17 @@ and signature_item = Sig_value of Ident.t * value_description | Sig_type of Ident.t * type_declaration * rec_status | Sig_exception of Ident.t * exception_declaration - | Sig_module of Ident.t * module_type * rec_status - | Sig_modtype of Ident.t * modtype_declaration + | Sig_module of Ident.t * module_declaration * rec_status + | Sig_modtype of Ident.t * modtype_declaration (* todo: attributes *) | Sig_class of Ident.t * class_declaration * rec_status | Sig_class_type of Ident.t * class_type_declaration * rec_status +and module_declaration = + { + md_type: module_type; + md_attributes: Parsetree.attributes; + } + and modtype_declaration = Modtype_abstract | Modtype_manifest of module_type diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 5f1b20d4a..560bcec73 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -55,6 +55,15 @@ type error = exception Error of Location.t * Env.t * error +let check_deprecated loc attrs s = + if + List.exists + (function ({txt = "deprecated"; _}, _) -> true | _ -> false) + attrs + then + Location.prerr_warning loc (Warnings.Deprecated s) + + type variable_context = int * (string, type_expr) Tbl.t (* Local definitions *) @@ -94,8 +103,14 @@ let find_component lookup make_error env loc lid = | Env.Recmodule -> raise (Error (loc, env, Illegal_reference_to_recursive_module)) -let find_type = - find_component Env.lookup_type (fun lid -> Unbound_type_constructor lid) +let find_type env loc lid = + let (path, decl) as r = + find_component Env.lookup_type (fun lid -> Unbound_type_constructor lid) + env loc lid + in + check_deprecated loc decl.type_attributes (Path.name path); + r + let find_constructor = find_component Env.lookup_constructor (fun lid -> Unbound_constructor lid) let find_all_constructors = @@ -105,16 +120,38 @@ let find_label = find_component Env.lookup_label (fun lid -> Unbound_label lid) let find_all_labels = find_component Env.lookup_all_labels (fun lid -> Unbound_label lid) -let find_class = - find_component Env.lookup_class (fun lid -> Unbound_class lid) -let find_value = - find_component Env.lookup_value (fun lid -> Unbound_value lid) -let find_module = - find_component Env.lookup_module (fun lid -> Unbound_module lid) + +let find_class env loc lid = + let (path, decl) as r = + find_component Env.lookup_class (fun lid -> Unbound_class lid) env loc lid + in + check_deprecated loc decl.cty_attributes (Path.name path); + r + +let find_value env loc lid = + let (path, decl) as r = + find_component Env.lookup_value (fun lid -> Unbound_value lid) env loc lid + in + check_deprecated loc decl.val_attributes (Path.name path); + r + +let find_module env loc lid = + let (path, decl) as r = + find_component Env.lookup_module (fun lid -> Unbound_module lid) env loc lid + in + check_deprecated loc decl.md_attributes (Path.name path); + r + let find_modtype = find_component Env.lookup_modtype (fun lid -> Unbound_modtype lid) -let find_class_type = - find_component Env.lookup_cltype (fun lid -> Unbound_cltype lid) + +let find_class_type env loc lid = + let (path, decl) as r = + find_component Env.lookup_cltype (fun lid -> Unbound_cltype lid) + env loc lid + in + check_deprecated loc decl.clty_attributes (Path.name path); + r let unbound_constructor_error env lid = narrow_unbound_lid_error env lid.loc lid.txt diff --git a/typing/typetexp.mli b/typing/typetexp.mli index eb78d1ae1..a661e23fb 100644 --- a/typing/typetexp.mli +++ b/typing/typetexp.mli @@ -83,19 +83,19 @@ val find_type: val find_constructor: Env.t -> Location.t -> Longident.t -> constructor_description val find_all_constructors: - Env.t -> Location.t -> Longident.t -> + Env.t -> Location.t -> Longident.t -> (constructor_description * (unit -> unit)) list val find_label: Env.t -> Location.t -> Longident.t -> label_description val find_all_labels: - Env.t -> Location.t -> Longident.t -> + Env.t -> Location.t -> Longident.t -> (label_description * (unit -> unit)) list val find_value: Env.t -> Location.t -> Longident.t -> Path.t * value_description 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_type + Env.t -> Location.t -> Longident.t -> Path.t * module_declaration val find_modtype: Env.t -> Location.t -> Longident.t -> Path.t * modtype_declaration val find_class_type: @@ -109,3 +109,6 @@ val spellcheck_simple: Format.formatter -> (('a -> cd -> cd) -> Longident.t option -> 'b -> cd -> cd) -> ('a -> string) -> 'b -> Longident.t -> unit + +val check_deprecated: Location.t -> Parsetree.attributes -> string -> unit + |