diff --git a/boot/ocamlc b/boot/ocamlc index 28462542afe..dd9bdb053c5 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamllex b/boot/ocamllex index 393b538915b..a70a85deb3f 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/driver/compile_common.ml b/driver/compile_common.ml index bdd89f0019e..1a4583f9375 100644 --- a/driver/compile_common.ml +++ b/driver/compile_common.ml @@ -63,7 +63,7 @@ let typecheck_intf info ast = Profile.(record_call typing) @@ fun () -> let tsg = ast - |> Typemod.type_interface info.env + |> Typemod.type_interface info.module_name info.env |> print_if info.ppf_dump Clflags.dump_typedtree Printtyped.interface in let sg = tsg.Typedtree.sig_type in @@ -80,9 +80,15 @@ let typecheck_intf info ast = let emit_signature info ast tsg = let sg = + let kind : Cmi_format.kind = + if !Clflags.as_parameter then + Parameter + else + Normal + in let alerts = Builtin_attributes.alerts_of_sig ast in Env.save_signature ~alerts tsg.Typedtree.sig_type - info.module_name (info.output_prefix ^ ".cmi") + info.module_name kind (info.output_prefix ^ ".cmi") in Typemod.save_signature info.module_name tsg info.output_prefix info.source_file info.env sg diff --git a/driver/main_args.ml b/driver/main_args.ml index d545df86b83..a956fca040b 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -631,6 +631,11 @@ let mk_match_context_rows f = Printf.sprintf " (advanced, see manual section %d.%d.)" chapter section +let mk_as_parameter f = + "-as-parameter", Arg.Unit f, + " Compiles the interface as a parameter for an open module." +;; + let mk_use_prims f = "-use-prims", Arg.String f, " (undocumented)" @@ -918,6 +923,7 @@ end module type Compiler_options = sig val _a : unit -> unit val _annot : unit -> unit + val _as_parameter : unit -> unit val _binannot : unit -> unit val _binannot_cms : unit -> unit val _c : unit -> unit @@ -1116,6 +1122,7 @@ struct mk_absname F._absname; mk_no_absname F._no_absname; mk_annot F._annot; + mk_as_parameter F._as_parameter; mk_binannot F._binannot; mk_binannot_cms F._binannot_cms; mk_c F._c; @@ -1324,6 +1331,7 @@ struct mk_afl_instrument F._afl_instrument; mk_afl_inst_ratio F._afl_inst_ratio; mk_annot F._annot; + mk_as_parameter F._as_parameter; mk_binannot F._binannot; mk_binannot_cms F._binannot_cms; mk_inline_branch_factor F._inline_branch_factor; @@ -1880,6 +1888,7 @@ module Default = struct let _annot = set annotations let _args = Arg.read_arg let _args0 = Arg.read_arg0 + let _as_parameter = set as_parameter let _binannot = set binary_annotations let _binannot_cms = set binary_annotations_cms let _c = set compile_only diff --git a/driver/main_args.mli b/driver/main_args.mli index c6b66bfe9e7..671285df090 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -84,6 +84,7 @@ end module type Compiler_options = sig val _a : unit -> unit val _annot : unit -> unit + val _as_parameter : unit -> unit val _binannot : unit -> unit val _binannot_cms : unit -> unit val _c : unit -> unit diff --git a/file_formats/cmi_format.ml b/file_formats/cmi_format.ml index 278e2a2d8dc..b135c6a1ee5 100644 --- a/file_formats/cmi_format.ml +++ b/file_formats/cmi_format.ml @@ -20,6 +20,10 @@ type pers_flags = | Alerts of alerts | Opaque +type kind = + | Normal + | Parameter + type error = | Not_an_interface of filepath | Wrong_version_interface of filepath * string @@ -53,10 +57,15 @@ module Serialized = Types.Make_wrapped(struct type 'a t = int end) input_value and output_value usage. *) type crcs = Import_info.t array (* smaller on disk than using a list *) type flags = pers_flags list -type header = Compilation_unit.t * Serialized.signature +type header = { + header_name : Compilation_unit.t; + header_kind : kind; + header_sign : Serialized.signature; +} type 'sg cmi_infos_generic = { cmi_name : Compilation_unit.t; + cmi_kind : kind; cmi_sign : 'sg; cmi_crcs : crcs; cmi_flags : flags; @@ -108,11 +117,16 @@ let input_cmi_lazy ic = in let data_len = Bytes.get_int64_ne (read_bytes 8) 0 |> Int64.to_int in let data = read_bytes data_len in - let (name, sign) = (input_value ic : header) in + let { + header_name = name; + header_kind = kind; + header_sign = sign; + } = (input_value ic : header) in let crcs = (input_value ic : crcs) in let flags = (input_value ic : flags) in { cmi_name = name; + cmi_kind = kind; cmi_sign = deserialize data sign; cmi_crcs = crcs; cmi_flags = flags; @@ -169,7 +183,12 @@ let output_cmi filename oc cmi = (* BACKPORT BEGIN *) (* CR ocaml 5 compressed-marshal mshinwell: upstream uses [Compression] here *) - output_value oc ((cmi.cmi_name, sign) : header); + output_value oc + { + header_name = cmi.cmi_name; + header_kind = cmi.cmi_kind; + header_sign = sign; + }; (* BACKPORT END *) flush oc; let crc = Digest.file filename in diff --git a/file_formats/cmi_format.mli b/file_formats/cmi_format.mli index 137b235021b..87df56780ab 100644 --- a/file_formats/cmi_format.mli +++ b/file_formats/cmi_format.mli @@ -20,8 +20,13 @@ type pers_flags = | Alerts of alerts | Opaque +type kind = + | Normal + | Parameter + type 'sg cmi_infos_generic = { cmi_name : Compilation_unit.t; + cmi_kind : kind; cmi_sign : 'sg; cmi_crcs : Import_info.t array; cmi_flags : pers_flags list; diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index 826eee6d4bc..67ca9bd0309 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -122,7 +122,7 @@ let process_interface_file sourcefile = Pparse.file ~tool_name inputfile (no_docstring Parse.interface) Pparse.Signature in - let sg = Typemod.type_interface (initial_env()) ast in + let sg = Typemod.type_interface compilation_unit (initial_env()) ast in Warnings.check_fatal (); (ast, sg, inputfile) diff --git a/testsuite/tests/self-contained-toplevel/main.ml b/testsuite/tests/self-contained-toplevel/main.ml index 46cb4377627..a36007a43b1 100644 --- a/testsuite/tests/self-contained-toplevel/main.ml +++ b/testsuite/tests/self-contained-toplevel/main.ml @@ -26,11 +26,12 @@ let () = Persistent_signature.load := (fun ~allow_hidden ~unit_name -> match unit_name |> Compilation_unit.Name.to_string with | "Foo" -> - let {Cmi_format.cmi_name; cmi_sign; cmi_crcs; cmi_flags} = + let {Cmi_format.cmi_name; cmi_kind; cmi_sign; cmi_crcs; cmi_flags} = Marshal.from_string Cached_cmi.foo 0 in let cmi = { Cmi_format.cmi_name; + cmi_kind; cmi_sign = Subst.Lazy.of_signature cmi_sign; cmi_crcs; cmi_flags diff --git a/testsuite/tests/templates/basic/bad_impl_as_param.ml b/testsuite/tests/templates/basic/bad_impl_as_param.ml new file mode 100644 index 00000000000..cca9e55a775 --- /dev/null +++ b/testsuite/tests/templates/basic/bad_impl_as_param.ml @@ -0,0 +1,12 @@ +(* TEST + +readonly_files = "bad_impl_as_param.reference" + +* setup-ocamlc.byte-build-env +** ocamlc.byte +flags = "-as-parameter" +modules = "bad_impl_as_param.ml" +ocamlc_byte_exit_status = "2" +compiler_output = "bad_impl_as_param.output" +*** check-ocamlc.byte-output +compiler_reference = "bad_impl_as_param.reference" *) diff --git a/testsuite/tests/templates/basic/bad_impl_as_param.reference b/testsuite/tests/templates/basic/bad_impl_as_param.reference new file mode 100644 index 00000000000..6eebbb92710 --- /dev/null +++ b/testsuite/tests/templates/basic/bad_impl_as_param.reference @@ -0,0 +1,2 @@ +File "bad_impl_as_param.ml", line 1: +Error: Cannot compile an implementation with -as-parameter. diff --git a/testsuite/tests/templates/basic/bad_param_impl.ml b/testsuite/tests/templates/basic/bad_param_impl.ml new file mode 100644 index 00000000000..ee64d8a90f7 --- /dev/null +++ b/testsuite/tests/templates/basic/bad_param_impl.ml @@ -0,0 +1,16 @@ +(* TEST + +readonly_files = "bad_param_impl.mli bad_param_impl.reference" + +* setup-ocamlc.byte-build-env +** ocamlc.byte +flags = "-as-parameter" +module = "bad_param_impl.mli" +*** ocamlc.byte +flags = "" +module = "bad_param_impl.ml" +ocamlc_byte_exit_status = "2" +compiler_output = "bad_param_impl.output" +**** check-ocamlc.byte-output +compiler_reference = "bad_param_impl.reference" +*) diff --git a/testsuite/tests/templates/basic/bad_param_impl.mli b/testsuite/tests/templates/basic/bad_param_impl.mli new file mode 100644 index 00000000000..6f01572d835 --- /dev/null +++ b/testsuite/tests/templates/basic/bad_param_impl.mli @@ -0,0 +1 @@ +(* To be compiled with [-as-parameter] *) diff --git a/testsuite/tests/templates/basic/bad_param_impl.reference b/testsuite/tests/templates/basic/bad_param_impl.reference new file mode 100644 index 00000000000..14b23e01ca7 --- /dev/null +++ b/testsuite/tests/templates/basic/bad_param_impl.reference @@ -0,0 +1,3 @@ +File "bad_param_impl.ml", line 1: +Error: The interface for Bad_param_impl was compiled with -as-parameter. + It cannot be implemented directly. diff --git a/testsuite/tests/templates/basic/bad_param_packed.mli b/testsuite/tests/templates/basic/bad_param_packed.mli new file mode 100644 index 00000000000..bcb0c67b92f --- /dev/null +++ b/testsuite/tests/templates/basic/bad_param_packed.mli @@ -0,0 +1,13 @@ +(* TEST + +readonly_files = "bad_param_packed.reference" + +* setup-ocamlc.byte-build-env +** ocamlc.byte +flags = "-as-parameter -for-pack Pack" +module = "bad_param_packed.mli" +compiler_output = "bad_param_packed.output" +ocamlc_byte_exit_status = "2" +*** check-ocamlc.byte-output +compiler_reference = "bad_param_packed.reference" +*) diff --git a/testsuite/tests/templates/basic/bad_param_packed.reference b/testsuite/tests/templates/basic/bad_param_packed.reference new file mode 100644 index 00000000000..b998e345645 --- /dev/null +++ b/testsuite/tests/templates/basic/bad_param_packed.reference @@ -0,0 +1,2 @@ +File "_none_", line 1: +Error: Cannot compile a parameter with -for-pack. diff --git a/testsuite/tests/templates/basic/bad_ref_direct.ml b/testsuite/tests/templates/basic/bad_ref_direct.ml new file mode 100644 index 00000000000..7fbd0d0b73d --- /dev/null +++ b/testsuite/tests/templates/basic/bad_ref_direct.ml @@ -0,0 +1,3 @@ +(* [Monoid] is not a parameter *) + +let empty = Monoid.id diff --git a/testsuite/tests/templates/basic/bad_ref_direct.reference b/testsuite/tests/templates/basic/bad_ref_direct.reference new file mode 100644 index 00000000000..41b081e6997 --- /dev/null +++ b/testsuite/tests/templates/basic/bad_ref_direct.reference @@ -0,0 +1,3 @@ +File "bad_ref_direct.ml", line 1: +Error: The file monoid.cmi contains the interface of a parameter. + Monoid is not declared as a parameter for the current unit (-parameter Monoid). diff --git a/testsuite/tests/templates/basic/monoid.mli b/testsuite/tests/templates/basic/monoid.mli new file mode 100644 index 00000000000..1abe7d4d943 --- /dev/null +++ b/testsuite/tests/templates/basic/monoid.mli @@ -0,0 +1,4 @@ +type t + +val empty : t +val append : t -> t -> t diff --git a/testsuite/tests/templates/basic/test.ml b/testsuite/tests/templates/basic/test.ml new file mode 100644 index 00000000000..cc335ddb2e1 --- /dev/null +++ b/testsuite/tests/templates/basic/test.ml @@ -0,0 +1,18 @@ +(* TEST + +readonly_files = "\ + bad_ref_direct.ml bad_ref_direct.reference \ + monoid.mli \ +" + +* setup-ocamlc.byte-build-env +** ocamlc.byte +flags = "-as-parameter" +module = "monoid.mli" +*** ocamlc.byte +module = "bad_ref_direct.ml" +compiler_output = "bad_ref_direct.output" +ocamlc_byte_exit_status = "2" +**** check-ocamlc.byte-output +compiler_reference = "bad_ref_direct.reference" +*) diff --git a/tools/objinfo.ml b/tools/objinfo.ml index 2e20960d9a3..2c5cb2ac6d8 100644 --- a/tools/objinfo.ml +++ b/tools/objinfo.ml @@ -93,8 +93,15 @@ let print_cma_infos (lib : Cmo_format.library) = printf "\n"; List.iter print_cmo_infos lib.lib_units -let print_cmi_infos name crcs = +let print_cmi_infos name crcs kind = + let open Cmi_format in printf "Unit name: %a\n" Compilation_unit.output name; + let is_param = + match kind with + | Normal -> false + | Parameter -> true + in + printf "Is parameter: %s\n" (if is_param then "YES" else "no"); printf "Interfaces imported:\n"; Array.iter print_intf_import crcs @@ -340,6 +347,7 @@ let dump_obj_by_kind filename ic obj_kind = | None -> () | Some cmi -> print_cmi_infos cmi.Cmi_format.cmi_name cmi.Cmi_format.cmi_crcs + cmi.Cmi_format.cmi_kind end; begin match cmt with | None -> () diff --git a/typing/env.ml b/typing/env.ml index 7849f12efc3..59d703aea66 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -1037,6 +1037,9 @@ let is_imported_opaque modname = let register_import_as_opaque modname = Persistent_env.register_import_as_opaque !persistent_env modname +let is_parameter_unit modname = + Persistent_env.is_registered_parameter_import !persistent_env modname + let reset_declaration_caches () = Types.Uid.Tbl.clear !value_declarations; Types.Uid.Tbl.clear !type_declarations; @@ -2685,7 +2688,8 @@ let persistent_structures_of_dir dir = |> String.Set.of_seq (* Save a signature to a file *) -let save_signature_with_transform cmi_transform ~alerts sg modname filename = +let save_signature_with_transform cmi_transform ~alerts sg modname kind + filename = Btype.cleanup_abbrev (); Subst.reset_additional_action_type_id (); let sg = Subst.Lazy.of_signature sg @@ -2693,7 +2697,7 @@ let save_signature_with_transform cmi_transform ~alerts sg modname filename = (Subst.with_additional_action Prepare_for_saving Subst.identity) in let cmi = - Persistent_env.make_cmi !persistent_env modname sg alerts + Persistent_env.make_cmi !persistent_env modname kind sg alerts |> cmi_transform in let pers_sig = Persistent_env.Persistent_signature.{ filename; cmi; visibility = Visible } @@ -2701,14 +2705,12 @@ let save_signature_with_transform cmi_transform ~alerts sg modname filename = Persistent_env.save_cmi !persistent_env pers_sig; cmi -let save_signature ~alerts sg modname filename = - save_signature_with_transform (fun cmi -> cmi) - ~alerts sg modname filename +let save_signature ~alerts sg modname cu filename = + save_signature_with_transform (fun cmi -> cmi) ~alerts sg modname cu filename -let save_signature_with_imports ~alerts sg modname filename imports = +let save_signature_with_imports ~alerts sg modname cu filename imports = let with_imports cmi = { cmi with cmi_crcs = imports } in - save_signature_with_transform with_imports - ~alerts sg modname filename + save_signature_with_transform with_imports ~alerts sg modname cu filename (* Make the initial environment, without language extensions *) let initial = diff --git a/typing/env.mli b/typing/env.mli index a2229374e28..d706978d2af 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -474,15 +474,14 @@ val read_signature: Results: signature. If [add_binding] is true, creates an entry for the module in the environment. *) val save_signature: - alerts:alerts -> signature -> Compilation_unit.t -> filepath - -> Cmi_format.cmi_infos_lazy - (* Arguments: signature, module name, file name. *) + alerts:alerts -> signature -> Compilation_unit.t -> Cmi_format.kind + -> filepath -> Cmi_format.cmi_infos_lazy + (* Arguments: signature, module name, module kind, file name. *) val save_signature_with_imports: - alerts:alerts -> signature -> Compilation_unit.t -> filepath - -> Import_info.t array - -> Cmi_format.cmi_infos_lazy - (* Arguments: signature, module name, file name, - imported units with their CRCs. *) + alerts:alerts -> signature -> Compilation_unit.t -> Cmi_format.kind + -> filepath -> Import_info.t array -> Cmi_format.cmi_infos_lazy + (* Arguments: signature, module name, module kind, + file name, imported units with their CRCs. *) (* Return the CRC of the interface of the given compilation unit *) val crc_of_unit: Compilation_unit.Name.t -> Digest.t @@ -499,6 +498,10 @@ val is_imported_opaque: Compilation_unit.Name.t -> bool (* [register_import_as_opaque md] registers [md] as an opaque imported module *) val register_import_as_opaque: Compilation_unit.Name.t -> unit +(* [is_parameter_unit md] returns true if [md] was compiled with + -as-parameter *) +val is_parameter_unit: Compilation_unit.Name.t -> bool + (* Summaries -- compact representation of an environment, to be exported in debugging information. *) diff --git a/typing/persistent_env.ml b/typing/persistent_env.ml index fd32d09c6da..fa07500ab99 100644 --- a/typing/persistent_env.ml +++ b/typing/persistent_env.ml @@ -33,6 +33,9 @@ type error = filepath * CU.t * CU.t | Direct_reference_from_wrong_package of CU.t * filepath * CU.Prefix.t + | Illegal_import_of_parameter of CU.Name.t * filepath + | Not_compiled_as_parameter of CU.Name.t * filepath + | Cannot_implement_parameter of CU.Name.t * filepath exception Error of error let error err = raise (Error err) @@ -60,6 +63,7 @@ type can_load_cmis = type pers_struct = { ps_name: CU.t; + ps_is_param: bool; ps_crcs: Import_info.t array; ps_filename: string; ps_flags: pers_flags list; @@ -77,6 +81,7 @@ type 'a t = { (CU.Name.t, 'a pers_struct_info) Hashtbl.t; imported_units: CU.Name.Set.t ref; imported_opaque_units: CU.Name.Set.t ref; + param_imports : CU.Name.Set.t ref; crc_units: Consistbl.t; can_load_cmis: can_load_cmis ref; } @@ -85,6 +90,7 @@ let empty () = { persistent_structures = Hashtbl.create 17; imported_units = ref CU.Name.Set.empty; imported_opaque_units = ref CU.Name.Set.empty; + param_imports = ref CU.Name.Set.empty; crc_units = Consistbl.create (); can_load_cmis = ref Can_load_cmis; } @@ -94,12 +100,14 @@ let clear penv = persistent_structures; imported_units; imported_opaque_units; + param_imports; crc_units; can_load_cmis; } = penv in Hashtbl.clear persistent_structures; imported_units := CU.Name.Set.empty; imported_opaque_units := CU.Name.Set.empty; + param_imports := CU.Name.Set.empty; Consistbl.clear crc_units; can_load_cmis := Can_load_cmis; () @@ -118,11 +126,25 @@ let add_import {imported_units; _} s = let register_import_as_opaque {imported_opaque_units; _} s = imported_opaque_units := CU.Name.Set.add s !imported_opaque_units -let find_in_cache {persistent_structures; _} s = +let find_info_in_cache {persistent_structures; _} s = match Hashtbl.find persistent_structures s with | exception Not_found -> None | Missing -> None - | Found (_ps, pm) -> Some pm + | Found (ps, pm) -> Some (ps, pm) + +let find_in_cache penv name = + find_info_in_cache penv name |> Option.map (fun (_ps, pm) -> pm) + +let register_parameter_import ({param_imports; _} as penv) import = + begin match find_info_in_cache penv import with + | None -> + (* Not loaded yet; if it's wrong, we'll get an error at load time *) + () + | Some (ps, _) -> + if not ps.ps_is_param then + raise (Error (Not_compiled_as_parameter(import, ps.ps_filename))) + end; + param_imports := CU.Name.Set.add import !param_imports let import_crcs penv ~source crcs = let {crc_units; _} = penv in @@ -150,6 +172,9 @@ let check_consistency penv ps = else error (Inconsistent_package_declaration_between_imports( ps.ps_filename, auth_unit, source_unit)) +let is_registered_parameter_import {param_imports; _} import = + CU.Name.Set.mem import !param_imports + let can_load_cmis penv = !(penv.can_load_cmis) let set_can_load_cmis penv setting = @@ -188,9 +213,16 @@ let save_pers_struct penv crc comp_unit flags filename = let process_pers_struct penv check modname pers_sig = let { Persistent_signature.filename; cmi; visibility } = pers_sig in let name = cmi.cmi_name in + let kind = cmi.cmi_kind in let crcs = cmi.cmi_crcs in let flags = cmi.cmi_flags in + let is_param = + match kind with + | Normal -> false + | Parameter -> true + in let ps = { ps_name = name; + ps_is_param = is_param; ps_crcs = crcs; ps_filename = filename; ps_flags = flags; @@ -218,6 +250,17 @@ let process_pers_struct penv check modname pers_sig = error (Direct_reference_from_wrong_package (name, filename, prefix)); | None -> () end; + begin match is_param, is_registered_parameter_import penv modname with + | true, false -> + if CU.is_current name then + error (Cannot_implement_parameter (modname, filename)) + else + error (Illegal_import_of_parameter(modname, filename)) + | false, true -> + error (Not_compiled_as_parameter(modname, filename)) + | true, true + | false, false -> () + end; ps let bind_pers_struct penv modname ps pm = @@ -302,6 +345,9 @@ let check_pers_struct ~allow_hidden penv f ~loc name = Format.asprintf "%a is inaccessible from %a" CU.print unit describe_prefix prefix + | Illegal_import_of_parameter _ -> assert false + | Not_compiled_as_parameter _ -> assert false + | Cannot_implement_parameter _ -> assert false in let warn = Warnings.No_cmi_file(name_as_string, Some msg) in Location.prerr_warning loc warn @@ -371,7 +417,7 @@ let is_imported {imported_units; _} s = let is_imported_opaque {imported_opaque_units; _} s = CU.Name.Set.mem s !imported_opaque_units -let make_cmi penv modname sign alerts = +let make_cmi penv modname kind sign alerts = let flags = List.concat [ if !Clflags.recursive_types then [Cmi_format.Rectypes] else []; @@ -382,6 +428,7 @@ let make_cmi penv modname sign alerts = let crcs = imports penv in { cmi_name = modname; + cmi_kind = kind; cmi_sign = sign; cmi_crcs = Array.of_list crcs; cmi_flags = flags @@ -430,6 +477,19 @@ let report_error ppf = "@[The interface %a@ is compiled for package %s.@ %s@]" CU.print intf_package intf_filename "The compilation flag -for-pack with the same package is required" + | Illegal_import_of_parameter(modname, filename) -> + fprintf ppf + "@[The file %a@ contains the interface of a parameter.@ \ + %a is not declared as a parameter for the current unit (-parameter %a).@]" + Location.print_filename filename + CU.Name.print modname + CU.Name.print modname + | Not_compiled_as_parameter(modname, filename) -> + fprintf ppf + "@[The module %a@ is specified as a parameter, but %a@ \ + was not compiled with -as-parameter.@]" + CU.Name.print modname + Location.print_filename filename | Inconsistent_package_declaration_between_imports (filename, unit1, unit2) -> fprintf ppf "@[The file %s@ is imported both as %a@ and as %a.@]" @@ -443,6 +503,11 @@ let report_error ppf = filename describe_prefix prefix "Can only access members of this library's package or a containing package" + | Cannot_implement_parameter(modname, _filename) -> + fprintf ppf + "@[The interface for %a@ was compiled with -as-parameter.@ \ + It cannot be implemented directly.@]" + CU.Name.print modname let () = Location.register_error_of_exn diff --git a/typing/persistent_env.mli b/typing/persistent_env.mli index 4e4e8a2cbea..54ccffcd60e 100644 --- a/typing/persistent_env.mli +++ b/typing/persistent_env.mli @@ -29,6 +29,9 @@ type error = filepath * Compilation_unit.t * Compilation_unit.t | Direct_reference_from_wrong_package of Compilation_unit.t * filepath * Compilation_unit.Prefix.t + | Illegal_import_of_parameter of Compilation_unit.Name.t * filepath + | Not_compiled_as_parameter of Compilation_unit.Name.t * filepath + | Cannot_implement_parameter of Compilation_unit.Name.t * filepath exception Error of error @@ -74,6 +77,16 @@ val find_in_cache : 'a t -> Compilation_unit.Name.t -> 'a option val check : allow_hidden:bool -> 'a t -> (Persistent_signature.t -> 'a) -> loc:Location.t -> Compilation_unit.Name.t -> unit +(* Lets it be known that the given module is a parameter and thus is expected + to have been compiled as such. It may or may not be a parameter to _this_ + module (see the forthcoming [register_exported_parameter]). Raises an + exception if the module has already been imported as a non-parameter. *) +val register_parameter_import : 'a t -> Compilation_unit.Name.t -> unit + +(* [is_registered_parameter_import penv md] checks if [md] has been passed to + [register_parameter_import penv] *) +val is_registered_parameter_import : 'a t -> Compilation_unit.Name.t -> bool + (* [looked_up penv md] checks if one has already tried to read the signature for [md] in the environment [penv] (it may have failed) *) @@ -91,7 +104,11 @@ val is_imported_opaque : 'a t -> Compilation_unit.Name.t -> bool opaque module *) val register_import_as_opaque : 'a t -> Compilation_unit.Name.t -> unit -val make_cmi : 'a t -> Compilation_unit.t -> Subst.Lazy.signature -> alerts +val make_cmi : 'a t + -> Compilation_unit.t + -> Cmi_format.kind + -> Subst.Lazy.signature + -> alerts -> Cmi_format.cmi_infos_lazy val save_cmi : 'a t -> Persistent_signature.t -> unit diff --git a/typing/typemod.ml b/typing/typemod.ml index b12439ed6a5..1699a133e97 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -87,6 +87,8 @@ type error = | With_cannot_remove_packed_modtype of Path.t * module_type | Toplevel_nonvalue of string * Jkind.sort | Strengthening_mismatch of Longident.t * Includemod.explanation + | Cannot_pack_parameter + | Cannot_compile_implementation_as_parameter exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -3306,6 +3308,9 @@ let gen_annot outputprefix sourcefile annots = ~sourcefile:(Some sourcefile) ~use_summaries:false annots let type_implementation sourcefile outputprefix modulename initial_env ast = + let error e = + raise (Error (Location.in_file sourcefile, initial_env, e)) + in Cmt_format.clear (); Misc.try_finally (fun () -> Typecore.reset_delayed_checks (); @@ -3338,6 +3343,8 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = signature = simple_sg } (* result is ignored by Compile.implementation *) end else begin + if !Clflags.as_parameter then + error Cannot_compile_implementation_as_parameter; let sourceintf = Filename.remove_extension sourcefile ^ !Config.interface_suffix in if !Clflags.cmi_file <> None || Sys.file_exists sourceintf then begin @@ -3379,6 +3386,8 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = signature = dclsig } end else begin + if !Clflags.as_parameter then + error Cannot_compile_implementation_as_parameter; Location.prerr_warning (Location.in_file sourcefile) Warnings.Missing_mli; let coercion, shape = @@ -3397,10 +3406,11 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = let shape = Shape.local_reduce shape in if not !Clflags.dont_write_files then begin let alerts = Builtin_attributes.alerts_of_str ast in + let kind = Cmi_format.Normal in let cmi = Profile.record_call "save_cmi" (fun () -> Env.save_signature ~alerts - simple_sg modulename (outputprefix ^ ".cmi")) + simple_sg modulename kind (outputprefix ^ ".cmi")) in Profile.record_call "save_cmt" (fun () -> let annots = Cmt_format.Implementation str in @@ -3437,7 +3447,10 @@ let save_signature modname tsg outputprefix source_file initial_env cmi = Cms_format.save_cms (outputprefix ^ ".cmsi") modname (Some source_file) None -let type_interface env ast = +let type_interface modulename env ast = + if !Clflags.as_parameter && Compilation_unit.is_packed modulename then begin + raise(Error(Location.none, Env.empty, Cannot_pack_parameter)) + end; transl_signature env ast (* "Packaging" of several compilation units into one unit @@ -3537,9 +3550,10 @@ let package_units initial_env objfiles cmifile modulename = (Env.imports()) in (* Write packaged signature *) if not !Clflags.dont_write_files then begin + let kind = Cmi_format.Normal in let cmi = Env.save_signature_with_imports ~alerts:Misc.Stdlib.String.Map.empty - sg modulename + sg modulename kind (prefix ^ ".cmi") (Array.of_list imports) in let sign = Subst.Lazy.force_signature cmi.Cmi_format.cmi_sign in @@ -3771,6 +3785,12 @@ let report_error ~loc _env = function does not match the underlying type@]@ \ %t@]" longident lid main + | Cannot_pack_parameter -> + Location.errorf ~loc + "Cannot compile a parameter with -for-pack." + | Cannot_compile_implementation_as_parameter -> + Location.errorf ~loc + "Cannot compile an implementation with -as-parameter." let report_error env ~loc err = Printtyp.wrap_printing_env ~error:true env diff --git a/typing/typemod.mli b/typing/typemod.mli index 1bbb3044db0..b85b60a2fbe 100644 --- a/typing/typemod.mli +++ b/typing/typemod.mli @@ -42,7 +42,7 @@ val type_implementation: string -> string -> Compilation_unit.t -> Env.t -> Parsetree.structure -> Typedtree.implementation val type_interface: - Env.t -> Parsetree.signature -> Typedtree.signature + Compilation_unit.t -> Env.t -> Parsetree.signature -> Typedtree.signature val transl_signature: Env.t -> Parsetree.signature -> Typedtree.signature val check_nongen_signature: @@ -146,6 +146,8 @@ type error = | With_cannot_remove_packed_modtype of Path.t * module_type | Toplevel_nonvalue of string * Jkind.sort | Strengthening_mismatch of Longident.t * Includemod.explanation + | Cannot_pack_parameter + | Cannot_compile_implementation_as_parameter exception Error of Location.t * Env.t * error exception Error_forward of Location.error diff --git a/utils/clflags.ml b/utils/clflags.ml index e34c9fba21a..ba1a7db2c28 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -104,6 +104,7 @@ and float_const_prop = ref true (* -no-float-const-prop *) and transparent_modules = ref false (* -trans-mod *) let unique_ids = ref true (* -d(no-)unique-ds *) let locations = ref true (* -d(no-)locations *) +let as_parameter = ref false (* -as-parameter *) let dump_source = ref false (* -dsource *) let dump_parsetree = ref false (* -dparsetree *) and dump_typedtree = ref false (* -dtypedtree *) diff --git a/utils/clflags.mli b/utils/clflags.mli index c7857f53340..715d6969962 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -115,6 +115,7 @@ val float_const_prop : bool ref val transparent_modules : bool ref val unique_ids : bool ref val locations : bool ref +val as_parameter : bool ref val dump_source : bool ref val dump_parsetree : bool ref val dump_typedtree : bool ref