aboutsummaryrefslogtreecommitdiffhomepage
path: root/library
diff options
context:
space:
mode:
Diffstat (limited to 'library')
-rw-r--r--library/coqlib.ml14
-rw-r--r--library/coqlib.mli8
-rw-r--r--library/declaremods.ml62
-rw-r--r--library/declaremods.mli18
-rw-r--r--library/decls.ml2
-rw-r--r--library/decls.mli8
-rw-r--r--library/global.ml23
-rw-r--r--library/global.mli69
-rw-r--r--library/globnames.ml34
-rw-r--r--library/globnames.mli21
-rw-r--r--library/heads.ml8
-rw-r--r--library/heads.mli2
-rw-r--r--library/kindops.ml48
-rw-r--r--library/kindops.mli2
-rw-r--r--library/lib.ml88
-rw-r--r--library/lib.mli32
-rw-r--r--library/libnames.ml31
-rw-r--r--library/libnames.mli42
-rw-r--r--library/library.ml35
-rw-r--r--library/library.mli4
-rw-r--r--library/library.mllib2
-rw-r--r--library/loadpath.ml6
-rw-r--r--library/nameops.ml215
-rw-r--r--library/nameops.mli135
-rw-r--r--library/nametab.ml65
-rw-r--r--library/nametab.mli31
-rw-r--r--library/summary.ml203
-rw-r--r--library/summary.mli41
-rw-r--r--library/univops.ml40
-rw-r--r--library/univops.mli15
30 files changed, 478 insertions, 826 deletions
diff --git a/library/coqlib.ml b/library/coqlib.ml
index 8787738af..4a2390985 100644
--- a/library/coqlib.ml
+++ b/library/coqlib.ml
@@ -14,7 +14,7 @@ open Libnames
open Globnames
open Nametab
-let coq = Nameops.coq_string (* "Coq" *)
+let coq = Libnames.coq_string (* "Coq" *)
(************************************************************************)
(* Generic functions to find Coq objects *)
@@ -32,7 +32,7 @@ let find_reference locstr dir s =
of not found errors here *)
user_err ~hdr:locstr
Pp.(str "cannot find " ++ Libnames.pr_path sp ++
- str "; maybe library " ++ Libnames.pr_dirpath dp ++
+ str "; maybe library " ++ DirPath.print dp ++
str " has to be required first.")
let coq_reference locstr dir s = find_reference locstr (coq::dir) s
@@ -52,14 +52,14 @@ let gen_reference_in_modules locstr dirs s =
| [] ->
anomaly ~label:locstr (str "cannot find " ++ str s ++
str " in module" ++ str (if List.length dirs > 1 then "s " else " ") ++
- prlist_with_sep pr_comma pr_dirpath dirs ++ str ".")
+ prlist_with_sep pr_comma DirPath.print dirs ++ str ".")
| l ->
anomaly ~label:locstr
(str "ambiguous name " ++ str s ++ str " can represent " ++
prlist_with_sep pr_comma
(fun x -> Libnames.pr_path (Nametab.path_of_global x)) l ++
str " in module" ++ str (if List.length dirs > 1 then "s " else " ") ++
- prlist_with_sep pr_comma pr_dirpath dirs ++ str ".")
+ prlist_with_sep pr_comma DirPath.print dirs ++ str ".")
(* For tactics/commands requiring vernacular libraries *)
@@ -79,7 +79,7 @@ let check_required_library d =
*)
(* or failing ...*)
user_err ~hdr:"Coqlib.check_required_library"
- (str "Library " ++ pr_dirpath dir ++ str " has to be required first.")
+ (str "Library " ++ DirPath.print dir ++ str " has to be required first.")
(************************************************************************)
(* Specific Coq objects *)
@@ -377,7 +377,3 @@ let coq_sumbool_ref = lazy (init_reference ["Specif"] "sumbool")
let coq_sig_ref = lazy (init_reference ["Specif"] "sig")
let coq_or_ref = lazy (init_reference ["Logic"] "or")
let coq_iff_ref = lazy (init_reference ["Logic"] "iff")
-
-(* Deprecated *)
-let gen_reference = coq_reference
-
diff --git a/library/coqlib.mli b/library/coqlib.mli
index 1e3c37a9e..cc22f1635 100644
--- a/library/coqlib.mli
+++ b/library/coqlib.mli
@@ -71,8 +71,8 @@ val jmeq_module_name : string list
val datatypes_module_name : string list
(** Identity *)
-val id : constant
-val type_of_id : constant
+val id : Constant.t
+val type_of_id : Constant.t
(** Natural numbers *)
val nat_path : full_path
@@ -205,7 +205,3 @@ val coq_sig_ref : global_reference lazy_t
val coq_or_ref : global_reference lazy_t
val coq_iff_ref : global_reference lazy_t
-
-(* Deprecated functions *)
-val gen_reference : message -> string list -> string -> global_reference
-[@@ocaml.deprecated "Please use Coqlib.find_reference"]
diff --git a/library/declaremods.ml b/library/declaremods.ml
index 6d9295bde..41e00a41c 100644
--- a/library/declaremods.ml
+++ b/library/declaremods.ml
@@ -39,7 +39,7 @@ let inl2intopt = function
type algebraic_objects =
| Objs of Lib.lib_objects
- | Ref of module_path * substitution
+ | Ref of ModPath.t * substitution
type substitutive_objects = MBId.t list * algebraic_objects
@@ -62,9 +62,9 @@ type substitutive_objects = MBId.t list * algebraic_objects
module ModSubstObjs :
sig
- val set : module_path -> substitutive_objects -> unit
- val get : module_path -> substitutive_objects
- val set_missing_handler : (module_path -> substitutive_objects) -> unit
+ val set : ModPath.t -> substitutive_objects -> unit
+ val get : ModPath.t -> substitutive_objects
+ val set_missing_handler : (ModPath.t -> substitutive_objects) -> unit
end =
struct
let table =
@@ -126,8 +126,8 @@ type module_objects = object_prefix * Lib.lib_objects * Lib.lib_objects
module ModObjs :
sig
- val set : module_path -> module_objects -> unit
- val get : module_path -> module_objects (* may raise Not_found *)
+ val set : ModPath.t -> module_objects -> unit
+ val get : ModPath.t -> module_objects (* may raise Not_found *)
val all : unit -> module_objects MPmap.t
end =
struct
@@ -143,11 +143,11 @@ module ModObjs :
(** {6 Name management}
Auxiliary functions to transform full_path and kernel_name given
- by Lib into module_path and DirPath.t needed for modules
+ by Lib into ModPath.t and DirPath.t needed for modules
*)
let mp_of_kn kn =
- let mp,sec,l = repr_kn kn in
+ let mp,sec,l = KerName.repr kn in
assert (DirPath.is_empty sec);
MPdot (mp,l)
@@ -167,29 +167,29 @@ let consistency_checks exists dir dirinfo =
try Nametab.locate_dir (qualid_of_dirpath dir)
with Not_found ->
user_err ~hdr:"consistency_checks"
- (pr_dirpath dir ++ str " should already exist!")
+ (DirPath.print dir ++ str " should already exist!")
in
assert (eq_global_dir_reference globref dirinfo)
else
if Nametab.exists_dir dir then
user_err ~hdr:"consistency_checks"
- (pr_dirpath dir ++ str " already exists")
+ (DirPath.print dir ++ str " already exists")
let compute_visibility exists i =
if exists then Nametab.Exactly i else Nametab.Until i
(** Iterate some function [iter_objects] on all components of a module *)
-let do_module exists iter_objects i dir mp sobjs kobjs =
- let prefix = (dir,(mp,DirPath.empty)) in
+let do_module exists iter_objects i obj_dir obj_mp sobjs kobjs =
+ let prefix = { obj_dir ; obj_mp; obj_sec = DirPath.empty } in
let dirinfo = DirModule prefix in
- consistency_checks exists dir dirinfo;
- Nametab.push_dir (compute_visibility exists i) dir dirinfo;
- ModSubstObjs.set mp sobjs;
+ consistency_checks exists obj_dir dirinfo;
+ Nametab.push_dir (compute_visibility exists i) obj_dir dirinfo;
+ ModSubstObjs.set obj_mp sobjs;
(* If we're not a functor, let's iter on the internal components *)
if sobjs_no_functor sobjs then begin
let objs = expand_sobjs sobjs in
- ModObjs.set mp (prefix,objs,kobjs);
+ ModObjs.set obj_mp (prefix,objs,kobjs);
iter_objects (i+1) prefix objs;
iter_objects (i+1) prefix kobjs
end
@@ -222,20 +222,20 @@ let cache_keep _ = anomaly (Pp.str "This module should not be cached!")
let load_keep i ((sp,kn),kobjs) =
(* Invariant : seg isn't empty *)
- let dir = dir_of_sp sp and mp = mp_of_kn kn in
- let prefix = (dir,(mp,DirPath.empty)) in
+ let obj_dir = dir_of_sp sp and obj_mp = mp_of_kn kn in
+ let prefix = { obj_dir ; obj_mp; obj_sec = DirPath.empty } in
let prefix',sobjs,kobjs0 =
- try ModObjs.get mp
+ try ModObjs.get obj_mp
with Not_found -> assert false (* a substobjs should already be loaded *)
in
assert (eq_op prefix' prefix);
assert (List.is_empty kobjs0);
- ModObjs.set mp (prefix,sobjs,kobjs);
+ ModObjs.set obj_mp (prefix,sobjs,kobjs);
Lib.load_objects i prefix kobjs
let open_keep i ((sp,kn),kobjs) =
- let dir = dir_of_sp sp and mp = mp_of_kn kn in
- let prefix = (dir,(mp,DirPath.empty)) in
+ let obj_dir = dir_of_sp sp and obj_mp = mp_of_kn kn in
+ let prefix = { obj_dir; obj_mp; obj_sec = DirPath.empty } in
Lib.open_objects i prefix kobjs
let in_modkeep : Lib.lib_objects -> obj =
@@ -284,9 +284,9 @@ let (in_modtype : substitutive_objects -> obj),
(** {6 Declaration of substitutive objects for Include} *)
let do_include do_load do_open i ((sp,kn),aobjs) =
- let dir = Libnames.dirpath sp in
- let mp = KerName.modpath kn in
- let prefix = (dir,(mp,DirPath.empty)) in
+ let obj_dir = Libnames.dirpath sp in
+ let obj_mp = KerName.modpath kn in
+ let prefix = { obj_dir; obj_mp; obj_sec = DirPath.empty } in
let o = expand_aobjs aobjs in
if do_load then Lib.load_objects i prefix o;
if do_open then Lib.open_objects i prefix o
@@ -336,8 +336,8 @@ let () = ModSubstObjs.set_missing_handler handle_missing_substobjs
(** {6 From module expression to substitutive objects} *)
-(** Turn a chain of [MSEapply] into the head module_path and the
- list of module_path parameters (deepest param coming first).
+(** Turn a chain of [MSEapply] into the head ModPath.t and the
+ list of ModPath.t parameters (deepest param coming first).
The left part of a [MSEapply] must be either [MSEident] or
another [MSEapply]. *)
@@ -577,7 +577,7 @@ let start_module interp_modast export id args res fs =
in
openmod_info := { cur_typ = res_entry_o; cur_typs = subtyps };
let prefix = Lib.start_module export id mp fs in
- Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModule prefix);
+ Nametab.push_dir (Nametab.Until 1) (prefix.obj_dir) (DirOpenModule prefix);
mp
let end_module () =
@@ -684,7 +684,7 @@ let start_modtype interp_modast id args mtys fs =
let sub_mty_l = build_subtypes interp_modast env mp arg_entries_r mtys in
openmodtype_info := sub_mty_l;
let prefix = Lib.start_modtype id mp fs in
- Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModtype prefix);
+ Nametab.push_dir (Nametab.Until 1) (prefix.obj_dir) (DirOpenModtype prefix);
mp
let end_modtype () =
@@ -911,7 +911,7 @@ let subst_import (subst,(export,mp as obj)) =
let mp' = subst_mp subst mp in
if mp'==mp then obj else (export,mp')
-let in_import : bool * module_path -> obj =
+let in_import : bool * ModPath.t -> obj =
declare_object {(default_object "IMPORT MODULE") with
cache_function = cache_import;
open_function = open_import;
@@ -961,7 +961,7 @@ let debug_print_modtab _ =
| l -> str "[." ++ int (List.length l) ++ str ".]"
in
let pr_modinfo mp (prefix,substobjs,keepobjs) s =
- s ++ str (string_of_mp mp) ++ (spc ())
+ s ++ str (ModPath.to_string mp) ++ (spc ())
++ (pr_seg (Lib.segment_of_objects prefix (substobjs@keepobjs)))
in
let modules = MPmap.fold pr_modinfo (ModObjs.all ()) (mt ()) in
diff --git a/library/declaremods.mli b/library/declaremods.mli
index 9d750b616..42e5f4b13 100644
--- a/library/declaremods.mli
+++ b/library/declaremods.mli
@@ -30,15 +30,15 @@ val declare_module :
Id.t ->
'modast module_params ->
('modast * inline) module_signature ->
- ('modast * inline) list -> module_path
+ ('modast * inline) list -> ModPath.t
val start_module :
'modast module_interpretor ->
bool option -> Id.t ->
'modast module_params ->
- ('modast * inline) module_signature -> module_path
+ ('modast * inline) module_signature -> ModPath.t
-val end_module : unit -> module_path
+val end_module : unit -> ModPath.t
@@ -53,15 +53,15 @@ val declare_modtype :
'modast module_params ->
('modast * inline) list ->
('modast * inline) list ->
- module_path
+ ModPath.t
val start_modtype :
'modast module_interpretor ->
Id.t ->
'modast module_params ->
- ('modast * inline) list -> module_path
+ ('modast * inline) list -> ModPath.t
-val end_modtype : unit -> module_path
+val end_modtype : unit -> ModPath.t
(** {6 Libraries i.e. modules on disk } *)
@@ -72,7 +72,7 @@ type library_objects
val register_library :
library_name ->
Safe_typing.compiled_library -> library_objects -> Safe_typing.vodigest ->
- Univ.universe_context_set -> unit
+ Univ.ContextSet.t -> unit
val get_library_native_symbols : library_name -> Nativecode.symbols
@@ -90,13 +90,13 @@ val append_end_library_hook : (unit -> unit) -> unit
every object of the module. Raises [Not_found] when [mp] is unknown
or when [mp] corresponds to a functor. *)
-val really_import_module : module_path -> unit
+val really_import_module : ModPath.t -> unit
(** [import_module export mp] is a synchronous version of
[really_import_module]. If [export] is [true], the module is also
opened every time the module containing it is. *)
-val import_module : bool -> module_path -> unit
+val import_module : bool -> ModPath.t -> unit
(** Include *)
diff --git a/library/decls.ml b/library/decls.ml
index 973fe144d..a4259f6ca 100644
--- a/library/decls.ml
+++ b/library/decls.ml
@@ -19,7 +19,7 @@ module NamedDecl = Context.Named.Declaration
(** Datas associated to section variables and local definitions *)
type variable_data =
- DirPath.t * bool (* opacity *) * Univ.universe_context_set * polymorphic * logical_kind
+ DirPath.t * bool (* opacity *) * Univ.ContextSet.t * polymorphic * logical_kind
let vartab =
Summary.ref (Id.Map.empty : variable_data Id.Map.t) ~name:"VARIABLE"
diff --git a/library/decls.mli b/library/decls.mli
index 478f0bca0..1b7f137a4 100644
--- a/library/decls.mli
+++ b/library/decls.mli
@@ -17,21 +17,21 @@ open Decl_kinds
(** Registration and access to the table of variable *)
type variable_data =
- DirPath.t * bool (** opacity *) * Univ.universe_context_set * polymorphic * logical_kind
+ DirPath.t * bool (** opacity *) * Univ.ContextSet.t * polymorphic * logical_kind
val add_variable_data : variable -> variable_data -> unit
val variable_path : variable -> DirPath.t
val variable_secpath : variable -> qualid
val variable_kind : variable -> logical_kind
val variable_opacity : variable -> bool
-val variable_context : variable -> Univ.universe_context_set
+val variable_context : variable -> Univ.ContextSet.t
val variable_polymorphic : variable -> polymorphic
val variable_exists : variable -> bool
(** Registration and access to the table of constants *)
-val add_constant_kind : constant -> logical_kind -> unit
-val constant_kind : constant -> logical_kind
+val add_constant_kind : Constant.t -> logical_kind -> unit
+val constant_kind : Constant.t -> logical_kind
(* Prepare global named context for proof session: remove proofs of
opaque section definitions and remove vm-compiled code *)
diff --git a/library/global.ml b/library/global.ml
index 28b9e66f8..ce37dfecf 100644
--- a/library/global.ml
+++ b/library/global.ml
@@ -8,7 +8,6 @@
open Names
open Environ
-open Decl_kinds
(** We introduce here the global environment of the system,
and we declare it as a synchronized table. *)
@@ -21,6 +20,7 @@ module GlobalSafeEnv : sig
val set_safe_env : Safe_typing.safe_environment -> unit
val join_safe_environment : ?except:Future.UUIDSet.t -> unit -> unit
val is_joined_environment : unit -> bool
+ val global_env_summary_tag : Safe_typing.safe_environment Summary.Dyn.tag
end = struct
@@ -31,9 +31,9 @@ let join_safe_environment ?except () =
let is_joined_environment () =
Safe_typing.is_joined_environment !global_env
-
-let () =
- Summary.declare_summary global_env_summary_name
+
+let global_env_summary_tag =
+ Summary.declare_summary_tag global_env_summary_name
{ Summary.freeze_function = (function
| `Yes -> join_safe_environment (); !global_env
| `No -> !global_env
@@ -52,6 +52,8 @@ let set_safe_env e = global_env := e
end
+let global_env_summary_tag = GlobalSafeEnv.global_env_summary_tag
+
let safe_env = GlobalSafeEnv.safe_env
let join_safe_environment ?except () =
GlobalSafeEnv.join_safe_environment ?except ()
@@ -231,18 +233,7 @@ let universes_of_global env r =
let universes_of_global gr =
universes_of_global (env ()) gr
-(** Global universe names *)
-type universe_names =
- (polymorphic * Univ.universe_level) Id.Map.t * Id.t Univ.LMap.t
-
-let global_universes =
- Summary.ref ~name:"Global universe names"
- ((Id.Map.empty, Univ.LMap.empty) : universe_names)
-
-let global_universe_names () = !global_universes
-let set_global_universe_names s = global_universes := s
-
-let is_polymorphic r =
+let is_polymorphic r =
let env = env() in
match r with
| VarRef id -> false
diff --git a/library/global.mli b/library/global.mli
index 15bf58f82..324181e79 100644
--- a/library/global.mli
+++ b/library/global.mli
@@ -32,44 +32,44 @@ val set_typing_flags : Declarations.typing_flags -> unit
(** Variables, Local definitions, constants, inductive types *)
val push_named_assum : (Id.t * Constr.types * bool) Univ.in_universe_context_set -> unit
-val push_named_def : (Id.t * Safe_typing.private_constants Entries.definition_entry) -> Univ.universe_context_set
+val push_named_def : (Id.t * Safe_typing.private_constants Entries.definition_entry) -> Univ.ContextSet.t
val export_private_constants : in_section:bool ->
Safe_typing.private_constants Entries.constant_entry ->
unit Entries.constant_entry * Safe_typing.exported_private_constant list
val add_constant :
- DirPath.t -> Id.t -> Safe_typing.global_declaration -> constant
+ DirPath.t -> Id.t -> Safe_typing.global_declaration -> Constant.t
val add_mind :
- DirPath.t -> Id.t -> Entries.mutual_inductive_entry -> mutual_inductive
+ DirPath.t -> Id.t -> Entries.mutual_inductive_entry -> MutInd.t
(** Extra universe constraints *)
-val add_constraints : Univ.constraints -> unit
+val add_constraints : Univ.Constraint.t -> unit
-val push_context : bool -> Univ.universe_context -> unit
-val push_context_set : bool -> Univ.universe_context_set -> unit
+val push_context : bool -> Univ.UContext.t -> unit
+val push_context_set : bool -> Univ.ContextSet.t -> unit
(** Non-interactive modules and module types *)
val add_module :
Id.t -> Entries.module_entry -> Declarations.inline ->
- module_path * Mod_subst.delta_resolver
+ ModPath.t * Mod_subst.delta_resolver
val add_modtype :
- Id.t -> Entries.module_type_entry -> Declarations.inline -> module_path
+ Id.t -> Entries.module_type_entry -> Declarations.inline -> ModPath.t
val add_include :
Entries.module_struct_entry -> bool -> Declarations.inline ->
Mod_subst.delta_resolver
(** Interactive modules and module types *)
-val start_module : Id.t -> module_path
-val start_modtype : Id.t -> module_path
+val start_module : Id.t -> ModPath.t
+val start_modtype : Id.t -> ModPath.t
val end_module : Summary.frozen -> Id.t ->
(Entries.module_struct_entry * Declarations.inline) option ->
- module_path * MBId.t list * Mod_subst.delta_resolver
+ ModPath.t * MBId.t list * Mod_subst.delta_resolver
-val end_modtype : Summary.frozen -> Id.t -> module_path * MBId.t list
+val end_modtype : Summary.frozen -> Id.t -> ModPath.t * MBId.t list
val add_module_parameter :
MBId.t -> Entries.module_struct_entry -> Declarations.inline ->
@@ -78,45 +78,38 @@ val add_module_parameter :
(** {6 Queries in the global environment } *)
val lookup_named : variable -> Context.Named.Declaration.t
-val lookup_constant : constant -> Declarations.constant_body
+val lookup_constant : Constant.t -> Declarations.constant_body
val lookup_inductive : inductive ->
Declarations.mutual_inductive_body * Declarations.one_inductive_body
val lookup_pinductive : Constr.pinductive ->
Declarations.mutual_inductive_body * Declarations.one_inductive_body
-val lookup_mind : mutual_inductive -> Declarations.mutual_inductive_body
-val lookup_module : module_path -> Declarations.module_body
-val lookup_modtype : module_path -> Declarations.module_type_body
+val lookup_mind : MutInd.t -> Declarations.mutual_inductive_body
+val lookup_module : ModPath.t -> Declarations.module_body
+val lookup_modtype : ModPath.t -> Declarations.module_type_body
val exists_objlabel : Label.t -> bool
-val constant_of_delta_kn : kernel_name -> constant
-val mind_of_delta_kn : kernel_name -> mutual_inductive
+val constant_of_delta_kn : KerName.t -> Constant.t
+val mind_of_delta_kn : KerName.t -> MutInd.t
val opaque_tables : unit -> Opaqueproof.opaquetab
-val body_of_constant : constant -> (Term.constr * Univ.AUContext.t) option
+val body_of_constant : Constant.t -> (Constr.constr * Univ.AUContext.t) option
(** Returns the body of the constant if it has any, and the polymorphic context
it lives in. For monomorphic constant, the latter is empty, and for
polymorphic constants, the term contains De Bruijn universe variables that
need to be instantiated. *)
-val body_of_constant_body : Declarations.constant_body -> (Term.constr * Univ.AUContext.t) option
+val body_of_constant_body : Declarations.constant_body -> (Constr.constr * Univ.AUContext.t) option
(** Same as {!body_of_constant} but on {!Declarations.constant_body}. *)
-(** Global universe name <-> level mapping *)
-type universe_names =
- (Decl_kinds.polymorphic * Univ.universe_level) Id.Map.t * Id.t Univ.LMap.t
-
-val global_universe_names : unit -> universe_names
-val set_global_universe_names : universe_names -> unit
-
(** {6 Compiled libraries } *)
-val start_library : DirPath.t -> module_path
+val start_library : DirPath.t -> ModPath.t
val export : ?except:Future.UUIDSet.t -> DirPath.t ->
- module_path * Safe_typing.compiled_library * Safe_typing.native_library
+ ModPath.t * Safe_typing.compiled_library * Safe_typing.native_library
val import :
- Safe_typing.compiled_library -> Univ.universe_context_set -> Safe_typing.vodigest ->
- module_path
+ Safe_typing.compiled_library -> Univ.ContextSet.t -> Safe_typing.vodigest ->
+ ModPath.t
(** {6 Misc } *)
@@ -147,23 +140,23 @@ val type_of_global_in_context : Environ.env ->
constants, it does not matter. *)
(** Returns the universe context of the global reference (whatever its polymorphic status is). *)
-val universes_of_global : Globnames.global_reference -> Univ.abstract_universe_context
+val universes_of_global : Globnames.global_reference -> Univ.AUContext.t
(** {6 Retroknowledge } *)
val register :
- Retroknowledge.field -> Term.constr -> Term.constr -> unit
+ Retroknowledge.field -> Constr.constr -> Constr.constr -> unit
-val register_inline : constant -> unit
+val register_inline : Constant.t -> unit
(** {6 Oracle } *)
-val set_strategy : Names.constant Names.tableKey -> Conv_oracle.level -> unit
+val set_strategy : Constant.t Names.tableKey -> Conv_oracle.level -> unit
(* Modifies the global state, registering new universes *)
-val current_dirpath : unit -> Names.dir_path
+val current_dirpath : unit -> DirPath.t
-val with_global : (Environ.env -> Names.dir_path -> 'a Univ.in_universe_context_set) -> 'a
+val with_global : (Environ.env -> DirPath.t -> 'a Univ.in_universe_context_set) -> 'a
-val global_env_summary_name : string
+val global_env_summary_tag : Safe_typing.safe_environment Summary.Dyn.tag
diff --git a/library/globnames.ml b/library/globnames.ml
index 5c75994dd..9d7ab2db8 100644
--- a/library/globnames.ml
+++ b/library/globnames.ml
@@ -8,14 +8,14 @@
open CErrors
open Names
-open Term
+open Constr
open Mod_subst
open Libnames
(*s Global reference is a kernel side type for all references together *)
type global_reference =
| VarRef of variable (** A reference to the section-context. *)
- | ConstRef of constant (** A reference to the environment. *)
+ | ConstRef of Constant.t (** A reference to the environment. *)
| IndRef of inductive (** A reference to an inductive type. *)
| ConstructRef of constructor (** A reference to a constructor of an inductive type. *)
@@ -26,7 +26,7 @@ let isConstructRef = function ConstructRef _ -> true | _ -> false
let eq_gr gr1 gr2 =
gr1 == gr2 || match gr1,gr2 with
- | ConstRef con1, ConstRef con2 -> eq_constant con1 con2
+ | ConstRef con1, ConstRef con2 -> Constant.equal con1 con2
| IndRef kn1, IndRef kn2 -> eq_ind kn1 kn2
| ConstructRef kn1, ConstructRef kn2 -> eq_constructor kn1 kn2
| VarRef v1, VarRef v2 -> Id.equal v1 v2
@@ -67,12 +67,12 @@ let subst_global subst ref = match ref with
if c'==c then ref,t else ConstructRef c', t
let canonical_gr = function
- | ConstRef con -> ConstRef(constant_of_kn(canonical_con con))
- | IndRef (kn,i) -> IndRef(mind_of_kn(canonical_mind kn),i)
- | ConstructRef ((kn,i),j )-> ConstructRef((mind_of_kn(canonical_mind kn),i),j)
+ | ConstRef con -> ConstRef(Constant.make1 (Constant.canonical con))
+ | IndRef (kn,i) -> IndRef(MutInd.make1(MutInd.canonical kn),i)
+ | ConstructRef ((kn,i),j )-> ConstructRef((MutInd.make1(MutInd.canonical kn),i),j)
| VarRef id -> VarRef id
-let global_of_constr c = match kind_of_term c with
+let global_of_constr c = match kind c with
| Const (sp,u) -> ConstRef sp
| Ind (ind_sp,u) -> IndRef ind_sp
| Construct (cstr_cp,u) -> ConstructRef cstr_cp
@@ -80,8 +80,8 @@ let global_of_constr c = match kind_of_term c with
| _ -> raise Not_found
let is_global c t =
- match c, kind_of_term t with
- | ConstRef c, Const (c', _) -> eq_constant c c'
+ match c, kind t with
+ | ConstRef c, Const (c', _) -> Constant.equal c c'
| IndRef i, Ind (i', _) -> eq_ind i i'
| ConstructRef i, Construct (i', _) -> eq_constructor i i'
| VarRef id, Var id' -> Id.equal id id'
@@ -157,7 +157,7 @@ module Refset_env = Refmap_env.Set
(* Extended global references *)
-type syndef_name = kernel_name
+type syndef_name = KerName.t
type extended_global_reference =
| TrueGlobal of global_reference
@@ -180,7 +180,7 @@ module ExtRefOrdered = struct
if x == y then 0
else match x, y with
| TrueGlobal rx, TrueGlobal ry -> RefOrdered_env.compare rx ry
- | SynDef knx, SynDef kny -> kn_ord knx kny
+ | SynDef knx, SynDef kny -> KerName.compare knx kny
| TrueGlobal _, SynDef _ -> -1
| SynDef _, TrueGlobal _ -> 1
@@ -215,12 +215,12 @@ let decode_mind kn =
id::(DirPath.repr dp)
| MPdot(mp,l) -> (Label.to_id l)::(dir_of_mp mp)
in
- let mp,sec_dir,l = repr_mind kn in
+ let mp,sec_dir,l = MutInd.repr3 kn in
check_empty_section sec_dir;
(DirPath.make (dir_of_mp mp)),Label.to_id l
let decode_con kn =
- let mp,sec_dir,l = repr_con kn in
+ let mp,sec_dir,l = Constant.repr3 kn in
check_empty_section sec_dir;
match mp with
| MPfile dir -> (dir,Label.to_id l)
@@ -231,12 +231,12 @@ let decode_con kn =
user and canonical kernel names must be equal. *)
let pop_con con =
- let (mp,dir,l) = repr_con con in
- Names.make_con mp (pop_dirpath dir) l
+ let (mp,dir,l) = Constant.repr3 con in
+ Constant.make3 mp (pop_dirpath dir) l
let pop_kn kn =
- let (mp,dir,l) = repr_mind kn in
- Names.make_mind mp (pop_dirpath dir) l
+ let (mp,dir,l) = MutInd.repr3 kn in
+ MutInd.make3 mp (pop_dirpath dir) l
let pop_global_reference = function
| ConstRef con -> ConstRef (pop_con con)
diff --git a/library/globnames.mli b/library/globnames.mli
index 0b5971b6e..2e0cd62db 100644
--- a/library/globnames.mli
+++ b/library/globnames.mli
@@ -8,13 +8,13 @@
open Util
open Names
-open Term
+open Constr
open Mod_subst
(** {6 Global reference is a kernel side type for all references together } *)
type global_reference =
| VarRef of variable (** A reference to the section-context. *)
- | ConstRef of constant (** A reference to the environment. *)
+ | ConstRef of Constant.t (** A reference to the environment. *)
| IndRef of inductive (** A reference to an inductive type. *)
| ConstructRef of constructor (** A reference to a constructor of an inductive type. *)
@@ -27,7 +27,7 @@ val eq_gr : global_reference -> global_reference -> bool
val canonical_gr : global_reference -> global_reference
val destVarRef : global_reference -> variable
-val destConstRef : global_reference -> constant
+val destConstRef : global_reference -> Constant.t
val destIndRef : global_reference -> inductive
val destConstructRef : global_reference -> constructor
@@ -47,6 +47,7 @@ val global_of_constr : constr -> global_reference
(** Obsolete synonyms for constr_of_global and global_of_constr *)
val reference_of_constr : constr -> global_reference
+[@@ocaml.deprecated "Alias of Globnames.global_of_constr"]
module RefOrdered : sig
type t = global_reference
@@ -72,7 +73,7 @@ module Refmap_env : Map.ExtS
(** {6 Extended global references } *)
-type syndef_name = kernel_name
+type syndef_name = KerName.t
type extended_global_reference =
| TrueGlobal of global_reference
@@ -91,13 +92,13 @@ type global_reference_or_constr =
(** {6 Temporary function to brutally form kernel names from section paths } *)
-val encode_mind : DirPath.t -> Id.t -> mutual_inductive
-val decode_mind : mutual_inductive -> DirPath.t * Id.t
-val encode_con : DirPath.t -> Id.t -> constant
-val decode_con : constant -> DirPath.t * Id.t
+val encode_mind : DirPath.t -> Id.t -> MutInd.t
+val decode_mind : MutInd.t -> DirPath.t * Id.t
+val encode_con : DirPath.t -> Id.t -> Constant.t
+val decode_con : Constant.t -> DirPath.t * Id.t
(** {6 Popping one level of section in global names } *)
-val pop_con : constant -> constant
-val pop_kn : mutual_inductive-> mutual_inductive
+val pop_con : Constant.t -> Constant.t
+val pop_kn : MutInd.t-> MutInd.t
val pop_global_reference : global_reference -> global_reference
diff --git a/library/heads.ml b/library/heads.ml
index c12fa9479..ee3bfe1bd 100644
--- a/library/heads.ml
+++ b/library/heads.ml
@@ -8,7 +8,7 @@
open Util
open Names
-open Term
+open Constr
open Vars
open Mod_subst
open Environ
@@ -25,7 +25,7 @@ open Context.Named.Declaration
the evaluation of [phi(0)] and the head of [h] is declared unknown). *)
type rigid_head_kind =
-| RigidParameter of constant (* a Const without body *)
+| RigidParameter of Constant.t (* a Const without body *)
| RigidVar of variable (* a Var without body *)
| RigidType (* an inductive, a product or a sort *)
@@ -57,7 +57,7 @@ let variable_head id = Evalrefmap.find (EvalVarRef id) !head_map
let constant_head cst = Evalrefmap.find (EvalConstRef cst) !head_map
let kind_of_head env t =
- let rec aux k l t b = match kind_of_term (Reduction.whd_betaiotazeta env t) with
+ let rec aux k l t b = match kind (Reduction.whd_betaiotazeta env t) with
| Rel n when n > k -> NotImmediatelyComputableHead
| Rel n -> FlexibleHead (k,k+1-n,List.length l,b)
| Var id ->
@@ -156,7 +156,7 @@ let cache_head o =
let subst_head_approximation subst = function
| RigidHead (RigidParameter cst) as k ->
let cst,c = subst_con_kn subst cst in
- if isConst c && eq_constant (fst (destConst c)) cst then
+ if isConst c && Constant.equal (fst (destConst c)) cst then
(* A change of the prefix of the constant *)
k
else
diff --git a/library/heads.mli b/library/heads.mli
index 1ce66c841..8ad5c0f14 100644
--- a/library/heads.mli
+++ b/library/heads.mli
@@ -7,7 +7,7 @@
(************************************************************************)
open Names
-open Term
+open Constr
open Environ
(** This module is about the computation of an approximation of the
diff --git a/library/kindops.ml b/library/kindops.ml
index 882f62086..83985ce97 100644
--- a/library/kindops.ml
+++ b/library/kindops.ml
@@ -23,45 +23,13 @@ let string_of_theorem_kind = function
| Proposition -> "Proposition"
| Corollary -> "Corollary"
-let string_of_definition_kind def =
- let (locality, poly, kind) = def in
- let error () = CErrors.anomaly (Pp.str "Internal definition kind.") in
- match kind with
- | Definition ->
- begin match locality with
- | Discharge -> "Let"
- | Local -> "Local Definition"
- | Global -> "Definition"
- end
- | Example ->
- begin match locality with
- | Discharge -> error ()
- | Local -> "Local Example"
- | Global -> "Example"
- end
- | Coercion ->
- begin match locality with
- | Discharge -> error ()
- | Local -> "Local Coercion"
- | Global -> "Coercion"
- end
- | SubClass ->
- begin match locality with
- | Discharge -> error ()
- | Local -> "Local SubClass"
- | Global -> "SubClass"
- end
- | CanonicalStructure ->
- begin match locality with
- | Discharge -> error ()
- | Local -> error ()
- | Global -> "Canonical Structure"
- end
- | Instance ->
- begin match locality with
- | Discharge -> error ()
- | Local -> "Instance"
- | Global -> "Global Instance"
- end
+let string_of_definition_object_kind = function
+ | Definition -> "Definition"
+ | Example -> "Example"
+ | Coercion -> "Coercion"
+ | SubClass -> "SubClass"
+ | CanonicalStructure -> "Canonical Structure"
+ | Instance -> "Instance"
+ | Let -> "Let"
| (StructureComponent|Scheme|CoFixpoint|Fixpoint|IdentityCoercion|Method) ->
CErrors.anomaly (Pp.str "Internal definition kind.")
diff --git a/library/kindops.mli b/library/kindops.mli
index 77979c915..06f873e85 100644
--- a/library/kindops.mli
+++ b/library/kindops.mli
@@ -12,4 +12,4 @@ open Decl_kinds
val logical_kind_of_goal_kind : goal_object_kind -> logical_kind
val string_of_theorem_kind : theorem_kind -> string
-val string_of_definition_kind : definition_kind -> string
+val string_of_definition_object_kind : definition_object_kind -> string
diff --git a/library/lib.ml b/library/lib.ml
index e95bb47f2..499e2ae21 100644
--- a/library/lib.ml
+++ b/library/lib.ml
@@ -9,9 +9,9 @@
open Pp
open CErrors
open Util
+open Names
open Libnames
open Globnames
-open Nameops
open Libobject
open Context.Named.Declaration
@@ -62,7 +62,7 @@ let classify_segment seg =
let rec clean ((substl,keepl,anticipl) as acc) = function
| (_,CompilingLibrary _) :: _ | [] -> acc
| ((sp,kn),Leaf o) :: stk ->
- let id = Names.Label.to_id (Names.label kn) in
+ let id = Names.Label.to_id (Names.KerName.label kn) in
(match classify_object o with
| Dispose -> clean acc stk
| Keep o' ->
@@ -93,12 +93,16 @@ let segment_of_objects prefix =
sections, but on the contrary there are many constructions of section
paths based on the library path. *)
-let initial_prefix = default_library,(Names.initial_path,Names.DirPath.empty)
+let initial_prefix = {
+ obj_dir = default_library;
+ obj_mp = ModPath.initial;
+ obj_sec = DirPath.empty;
+}
type lib_state = {
- comp_name : Names.DirPath.t option;
+ comp_name : DirPath.t option;
lib_stk : library_segment;
- path_prefix : Names.DirPath.t * (Names.module_path * Names.DirPath.t);
+ path_prefix : object_prefix;
}
let initial_lib_state = {
@@ -115,10 +119,9 @@ let library_dp () =
(* [path_prefix] is a pair of absolute dirpath and a pair of current
module path and relative section path *)
-let cwd () = fst !lib_state.path_prefix
-let current_prefix () = snd !lib_state.path_prefix
-let current_mp () = fst (snd !lib_state.path_prefix)
-let current_sections () = snd (snd !lib_state.path_prefix)
+let cwd () = !lib_state.path_prefix.obj_dir
+let current_mp () = !lib_state.path_prefix.obj_mp
+let current_sections () = !lib_state.path_prefix.obj_sec
let sections_depth () = List.length (Names.DirPath.repr (current_sections ()))
let sections_are_opened () = not (Names.DirPath.is_empty (current_sections ()))
@@ -136,8 +139,8 @@ let make_path_except_section id =
Libnames.make_path (cwd_except_section ()) id
let make_kn id =
- let mp,dir = current_prefix () in
- Names.make_kn mp dir (Names.Label.of_id id)
+ let mp, dir = current_mp (), current_sections () in
+ Names.KerName.make mp dir (Names.Label.of_id id)
let make_oname id = Libnames.make_oname !lib_state.path_prefix id
@@ -152,8 +155,11 @@ let recalc_path_prefix () =
lib_state := { !lib_state with path_prefix = recalc !lib_state.lib_stk }
let pop_path_prefix () =
- let dir,(mp,sec) = !lib_state.path_prefix in
- lib_state := { !lib_state with path_prefix = pop_dirpath dir, (mp, pop_dirpath sec)}
+ let op = !lib_state.path_prefix in
+ lib_state := { !lib_state
+ with path_prefix = { op with obj_dir = pop_dirpath op.obj_dir;
+ obj_sec = pop_dirpath op.obj_sec;
+ } }
let find_entry_p p =
let rec find = function
@@ -226,7 +232,7 @@ let add_anonymous_entry node =
add_entry (make_oname (anonymous_id ())) node
let add_leaf id obj =
- if Names.ModPath.equal (current_mp ()) Names.initial_path then
+ if ModPath.equal (current_mp ()) ModPath.initial then
user_err Pp.(str "No session module started (use -top dir)");
let oname = make_oname id in
cache_object (oname,obj);
@@ -278,14 +284,14 @@ let current_mod_id () =
let start_mod is_type export id mp fs =
- let dir = add_dirpath_suffix (cwd ()) id in
- let prefix = dir,(mp,Names.DirPath.empty) in
+ let dir = add_dirpath_suffix (!lib_state.path_prefix.obj_dir) id in
+ let prefix = { obj_dir = dir; obj_mp = mp; obj_sec = Names.DirPath.empty } in
let exists =
if is_type then Nametab.exists_cci (make_path id)
else Nametab.exists_module dir
in
if exists then
- user_err ~hdr:"open_module" (pr_id id ++ str " already exists");
+ user_err ~hdr:"open_module" (Id.print id ++ str " already exists");
add_entry (make_oname id) (OpenedModule (is_type,export,prefix,fs));
lib_state := { !lib_state with path_prefix = prefix} ;
prefix
@@ -296,7 +302,7 @@ let start_modtype = start_mod true None
let error_still_opened string oname =
let id = basename (fst oname) in
user_err
- (str "The " ++ str string ++ str " " ++ pr_id id ++ str " is still opened.")
+ (str "The " ++ str string ++ str " " ++ Id.print id ++ str " is still opened.")
let end_mod is_type =
let oname,fs =
@@ -328,17 +334,17 @@ let contents_after sp = let (after,_,_) = split_lib sp in after
let start_compilation s mp =
if !lib_state.comp_name != None then
user_err Pp.(str "compilation unit is already started");
- if not (Names.DirPath.is_empty (current_sections ())) then
+ if not (Names.DirPath.is_empty (!lib_state.path_prefix.obj_sec)) then
user_err Pp.(str "some sections are already opened");
- let prefix = s, (mp, Names.DirPath.empty) in
- let () = add_anonymous_entry (CompilingLibrary prefix) in
+ let prefix = Libnames.{ obj_dir = s; obj_mp = mp; obj_sec = DirPath.empty } in
+ add_anonymous_entry (CompilingLibrary prefix);
lib_state := { !lib_state with comp_name = Some s;
path_prefix = prefix }
let open_blocks_message es =
let open_block_name = function
- | oname, OpenedSection _ -> str "section " ++ pr_id (basename (fst oname))
- | oname, OpenedModule (ty,_,_,_) -> str (module_kind ty) ++ spc () ++ pr_id (basename (fst oname))
+ | oname, OpenedSection _ -> str "section " ++ Id.print (basename (fst oname))
+ | oname, OpenedModule (ty,_,_,_) -> str (module_kind ty) ++ spc () ++ Id.print (basename (fst oname))
| _ -> assert false in
str "The " ++ pr_enum open_block_name es ++ spc () ++
str "need" ++ str (if List.length es == 1 then "s" else "") ++ str " to be closed."
@@ -360,8 +366,8 @@ let end_compilation_checks dir =
| None -> anomaly (Pp.str "There should be a module name...")
| Some m ->
if not (Names.DirPath.equal m dir) then anomaly
- (str "The current open module has name" ++ spc () ++ pr_dirpath m ++
- spc () ++ str "and not" ++ spc () ++ pr_dirpath m ++ str ".");
+ (str "The current open module has name" ++ spc () ++ DirPath.print m ++
+ spc () ++ str "and not" ++ spc () ++ DirPath.print m ++ str ".");
in
oname
@@ -395,7 +401,7 @@ let find_opening_node id =
let id' = basename (fst oname) in
if not (Names.Id.equal id id') then
user_err ~hdr:"Lib.find_opening_node"
- (str "Last block to end has name " ++ pr_id id' ++ str ".");
+ (str "Last block to end has name " ++ Id.print id' ++ str ".");
entry
with Not_found -> user_err Pp.(str "There is nothing to end.")
@@ -417,8 +423,8 @@ type abstr_list = abstr_info Names.Cmap.t * abstr_info Names.Mindmap.t
type secentry =
| Variable of (Names.Id.t * Decl_kinds.binding_kind *
- Decl_kinds.polymorphic * Univ.universe_context_set)
- | Context of Univ.universe_context_set
+ Decl_kinds.polymorphic * Univ.ContextSet.t)
+ | Context of Univ.ContextSet.t
let sectab =
Summary.ref ([] : (secentry list * Opaqueproof.work_list * abstr_list) list)
@@ -522,15 +528,15 @@ let is_in_section ref =
(*************)
(* Sections. *)
let open_section id =
- let olddir,(mp,oldsec) = !lib_state.path_prefix in
- let dir = add_dirpath_suffix olddir id in
- let prefix = dir, (mp, add_dirpath_suffix oldsec id) in
- if Nametab.exists_section dir then
- user_err ~hdr:"open_section" (pr_id id ++ str " already exists.");
+ let opp = !lib_state.path_prefix in
+ let obj_dir = add_dirpath_suffix opp.obj_dir id in
+ let prefix = { obj_dir; obj_mp = opp.obj_mp; obj_sec = add_dirpath_suffix opp.obj_sec id } in
+ if Nametab.exists_section obj_dir then
+ user_err ~hdr:"open_section" (Id.print id ++ str " already exists.");
let fs = Summary.freeze_summaries ~marshallable:`No in
add_entry (make_oname id) (OpenedSection (prefix, fs));
(*Pushed for the lifetime of the section: removed by unfrozing the summary*)
- Nametab.push_dir (Nametab.Until 1) dir (DirOpenSection prefix);
+ Nametab.push_dir (Nametab.Until 1) obj_dir (DirOpenSection prefix);
lib_state := { !lib_state with path_prefix = prefix };
add_section ()
@@ -556,7 +562,7 @@ let close_section () =
in
let (secdecls,mark,before) = split_lib_at_opening oname in
lib_state := { !lib_state with lib_stk = before };
- let full_olddir = fst !lib_state.path_prefix in
+ let full_olddir = !lib_state.path_prefix.obj_dir in
pop_path_prefix ();
add_entry oname (ClosedSection (List.rev (mark::secdecls)));
let newdecls = List.map discharge_item secdecls in
@@ -596,10 +602,10 @@ let init () =
(* Misc *)
let mp_of_global = function
- |VarRef id -> current_mp ()
- |ConstRef cst -> Names.con_modpath cst
- |IndRef ind -> Names.ind_modpath ind
- |ConstructRef constr -> Names.constr_modpath constr
+ | VarRef id -> !lib_state.path_prefix.obj_mp
+ | ConstRef cst -> Names.Constant.modpath cst
+ | IndRef ind -> Names.ind_modpath ind
+ | ConstructRef constr -> Names.constr_modpath constr
let rec dp_of_mp = function
|Names.MPfile dp -> dp
@@ -621,12 +627,12 @@ let library_part = function
(* Discharging names *)
let con_defined_in_sec kn =
- let _,dir,_ = Names.repr_con kn in
+ let _,dir,_ = Names.Constant.repr3 kn in
not (Names.DirPath.is_empty dir) &&
Names.DirPath.equal (pop_dirpath dir) (current_sections ())
let defined_in_sec kn =
- let _,dir,_ = Names.repr_mind kn in
+ let _,dir,_ = Names.MutInd.repr3 kn in
not (Names.DirPath.is_empty dir) &&
Names.DirPath.equal (pop_dirpath dir) (current_sections ())
diff --git a/library/lib.mli b/library/lib.mli
index 3dcec1d53..721e2896f 100644
--- a/library/lib.mli
+++ b/library/lib.mli
@@ -81,8 +81,8 @@ val make_path : Names.Id.t -> Libnames.full_path
val make_path_except_section : Names.Id.t -> Libnames.full_path
(** Kernel-side names *)
-val current_mp : unit -> Names.module_path
-val make_kn : Names.Id.t -> Names.kernel_name
+val current_mp : unit -> Names.ModPath.t
+val make_kn : Names.Id.t -> Names.KerName.t
(** Are we inside an opened section *)
val sections_are_opened : unit -> bool
@@ -103,11 +103,11 @@ val find_opening_node : Names.Id.t -> node
(** {6 Modules and module types } *)
val start_module :
- export -> Names.module_ident -> Names.module_path ->
+ export -> Names.module_ident -> Names.ModPath.t ->
Summary.frozen -> Libnames.object_prefix
val start_modtype :
- Names.module_ident -> Names.module_path ->
+ Names.module_ident -> Names.ModPath.t ->
Summary.frozen -> Libnames.object_prefix
val end_module :
@@ -122,7 +122,7 @@ val end_modtype :
(** {6 Compilation units } *)
-val start_compilation : Names.DirPath.t -> Names.module_path -> unit
+val start_compilation : Names.DirPath.t -> Names.ModPath.t -> unit
val end_compilation_checks : Names.DirPath.t -> Libnames.object_name
val end_compilation :
Libnames.object_name-> Libnames.object_prefix * library_segment
@@ -132,8 +132,8 @@ val end_compilation :
val library_dp : unit -> Names.DirPath.t
(** Extract the library part of a name even if in a section *)
-val dp_of_mp : Names.module_path -> Names.DirPath.t
-val split_modpath : Names.module_path -> Names.DirPath.t * Names.Id.t list
+val dp_of_mp : Names.ModPath.t -> Names.DirPath.t
+val split_modpath : Names.ModPath.t -> Names.DirPath.t * Names.Id.t list
val library_part : Globnames.global_reference -> Names.DirPath.t
(** {6 Sections } *)
@@ -158,25 +158,25 @@ type abstr_info = variable_context * Univ.universe_level_subst * Univ.AUContext.
val instance_from_variable_context : variable_context -> Names.Id.t array
val named_of_variable_context : variable_context -> Context.Named.t
-val section_segment_of_constant : Names.constant -> abstr_info
-val section_segment_of_mutual_inductive: Names.mutual_inductive -> abstr_info
+val section_segment_of_constant : Names.Constant.t -> abstr_info
+val section_segment_of_mutual_inductive: Names.MutInd.t -> abstr_info
val variable_section_segment_of_reference : Globnames.global_reference -> variable_context
-val section_instance : Globnames.global_reference -> Univ.universe_instance * Names.Id.t array
+val section_instance : Globnames.global_reference -> Univ.Instance.t * Names.Id.t array
val is_in_section : Globnames.global_reference -> bool
-val add_section_variable : Names.Id.t -> Decl_kinds.binding_kind -> Decl_kinds.polymorphic -> Univ.universe_context_set -> unit
-val add_section_context : Univ.universe_context_set -> unit
+val add_section_variable : Names.Id.t -> Decl_kinds.binding_kind -> Decl_kinds.polymorphic -> Univ.ContextSet.t -> unit
+val add_section_context : Univ.ContextSet.t -> unit
val add_section_constant : Decl_kinds.polymorphic ->
- Names.constant -> Context.Named.t -> unit
+ Names.Constant.t -> Context.Named.t -> unit
val add_section_kn : Decl_kinds.polymorphic ->
- Names.mutual_inductive -> Context.Named.t -> unit
+ Names.MutInd.t -> Context.Named.t -> unit
val replacement_context : unit -> Opaqueproof.work_list
(** {6 Discharge: decrease the section level if in the current section } *)
-val discharge_kn : Names.mutual_inductive -> Names.mutual_inductive
-val discharge_con : Names.constant -> Names.constant
+val discharge_kn : Names.MutInd.t -> Names.MutInd.t
+val discharge_con : Names.Constant.t -> Names.Constant.t
val discharge_global : Globnames.global_reference -> Globnames.global_reference
val discharge_inductive : Names.inductive -> Names.inductive
val discharge_abstract_universe_context :
diff --git a/library/libnames.ml b/library/libnames.ml
index 0453f15e8..a471d8396 100644
--- a/library/libnames.ml
+++ b/library/libnames.ml
@@ -13,7 +13,7 @@ open Names
(**********************************************)
-let pr_dirpath sl = str (DirPath.to_string sl)
+let pr_dirpath sl = DirPath.print sl
(*s Operations on dirpaths *)
@@ -154,12 +154,17 @@ let qualid_of_dirpath dir =
let (l,a) = split_dirpath dir in
make_qualid l a
-type object_name = full_path * kernel_name
+type object_name = full_path * KerName.t
-type object_prefix = DirPath.t * (module_path * DirPath.t)
+type object_prefix = {
+ obj_dir : DirPath.t;
+ obj_mp : ModPath.t;
+ obj_sec : DirPath.t;
+}
-let make_oname (dirpath,(mp,dir)) id =
- make_path dirpath id, make_kn mp dir (Label.of_id id)
+(* let make_oname (dirpath,(mp,dir)) id = *)
+let make_oname { obj_dir; obj_mp; obj_sec } id =
+ make_path obj_dir id, KerName.make obj_mp obj_sec (Label.of_id id)
(* to this type are mapped DirPath.t's in the nametab *)
type global_dir_reference =
@@ -170,10 +175,10 @@ type global_dir_reference =
| DirClosedSection of DirPath.t
(* this won't last long I hope! *)
-let eq_op (d1, (mp1, p1)) (d2, (mp2, p2)) =
- DirPath.equal d1 d2 &&
- DirPath.equal p1 p2 &&
- mp_eq mp1 mp2
+let eq_op op1 op2 =
+ DirPath.equal op1.obj_dir op2.obj_dir &&
+ DirPath.equal op1.obj_sec op2.obj_sec &&
+ ModPath.equal op1.obj_mp op2.obj_mp
let eq_global_dir_reference r1 r2 = match r1, r2 with
| DirOpenModule op1, DirOpenModule op2 -> eq_op op1 op2
@@ -232,6 +237,14 @@ let join_reference ns r =
Qualid (loc, make_qualid
(dirpath_of_string (Names.Id.to_string id1)) id2)
+(* Default paths *)
+let default_library = Names.DirPath.initial (* = ["Top"] *)
+
+(*s Roots of the space of absolute names *)
+let coq_string = "Coq"
+let coq_root = Id.of_string coq_string
+let default_root_prefix = DirPath.empty
+
(* Deprecated synonyms *)
let make_short_qualid = qualid_of_ident
diff --git a/library/libnames.mli b/library/libnames.mli
index 1b351290a..71f542240 100644
--- a/library/libnames.mli
+++ b/library/libnames.mli
@@ -11,12 +11,13 @@ open Loc
open Names
(** {6 Dirpaths } *)
-(** FIXME: ought to be in Names.dir_path *)
+val dirpath_of_string : string -> DirPath.t
val pr_dirpath : DirPath.t -> Pp.t
+[@@ocaml.deprecated "Alias for DirPath.print"]
-val dirpath_of_string : string -> DirPath.t
val string_of_dirpath : DirPath.t -> string
+[@@ocaml.deprecated "Alias for DirPath.to_string"]
(** Pop the suffix of a [DirPath.t]. Raises a [Failure] for an empty path *)
val pop_dirpath : DirPath.t -> DirPath.t
@@ -91,9 +92,27 @@ val qualid_of_ident : Id.t -> qualid
can be substituted and a "syntactic" [full_path] which can be printed
*)
-type object_name = full_path * kernel_name
+type object_name = full_path * KerName.t
+
+(** Object prefix morally contains the "prefix" naming of an object to
+ be stored by [library], where [obj_dir] is the "absolute" path,
+ [obj_mp] is the current "module" prefix and [obj_sec] is the
+ "section" prefix.
+
+ Thus, for an object living inside [Module A. Section B.] the
+ prefix would be:
+
+ [ { obj_dir = "A.B"; obj_mp = "A"; obj_sec = "B" } ]
+
+ Note that both [obj_dir] and [obj_sec] are "paths" that is to say,
+ as opposed to [obj_mp] which is a single module name.
-type object_prefix = DirPath.t * (module_path * DirPath.t)
+ *)
+type object_prefix = {
+ obj_dir : DirPath.t;
+ obj_mp : ModPath.t;
+ obj_sec : DirPath.t;
+}
val eq_op : object_prefix -> object_prefix -> bool
@@ -127,7 +146,20 @@ val pr_reference : reference -> Pp.t
val loc_of_reference : reference -> Loc.t option
val join_reference : reference -> reference -> reference
-(** Deprecated synonyms *)
+(** some preset paths *)
+val default_library : DirPath.t
+
+(** This is the root of the standard library of Coq *)
+val coq_root : module_ident (** "Coq" *)
+val coq_string : string (** "Coq" *)
+
+(** This is the default root prefix for developments which doesn't
+ mention a root *)
+val default_root_prefix : DirPath.t
+(** Deprecated synonyms *)
val make_short_qualid : Id.t -> qualid (** = qualid_of_ident *)
+[@@ocaml.deprecated "Alias for qualid_of_ident"]
+
val qualid_of_sp : full_path -> qualid (** = qualid_of_path *)
+[@@ocaml.deprecated "Alias for qualid_of_sp"]
diff --git a/library/library.ml b/library/library.ml
index e2832ecdc..868e26684 100644
--- a/library/library.ml
+++ b/library/library.ml
@@ -12,9 +12,8 @@ open Util
open Names
open Libnames
-open Nameops
-open Libobject
open Lib
+open Libobject
(************************************************************************)
(*s Low-level interning/externing of libraries to files *)
@@ -97,7 +96,7 @@ type library_t = {
library_deps : (compilation_unit_name * Safe_typing.vodigest) array;
library_imports : compilation_unit_name array;
library_digests : Safe_typing.vodigest;
- library_extra_univs : Univ.universe_context_set;
+ library_extra_univs : Univ.ContextSet.t;
}
type library_summary = {
@@ -132,7 +131,7 @@ let try_find_library dir =
try find_library dir
with Not_found ->
user_err ~hdr:"Library.find_library"
- (str "Unknown library " ++ pr_dirpath dir)
+ (str "Unknown library " ++ DirPath.print dir)
let register_library_filename dir f =
(* Not synchronized: overwrite the previous binding if one existed *)
@@ -171,7 +170,7 @@ let register_loaded_library m =
let prefix = Nativecode.mod_uid_of_dirpath libname ^ "." in
let f = prefix ^ "cmo" in
let f = Dynlink.adapt_filename f in
- if not Coq_config.no_native_compiler then
+ if Coq_config.native_compiler then
Nativelib.link_library ~prefix ~dirname ~basename:f
in
let rec aux = function
@@ -331,7 +330,7 @@ let error_unmapped_dir qid =
let prefix, _ = repr_qualid qid in
user_err ~hdr:"load_absolute_library_from"
(str "Cannot load " ++ pr_qualid qid ++ str ":" ++ spc () ++
- str "no physical path bound to" ++ spc () ++ pr_dirpath prefix ++ fnl ())
+ str "no physical path bound to" ++ spc () ++ DirPath.print prefix ++ fnl ())
let error_lib_not_found qid =
user_err ~hdr:"load_absolute_library_from"
@@ -360,9 +359,9 @@ type 'a table_status =
| Fetched of 'a Future.computation array
let opaque_tables =
- ref (LibraryMap.empty : (Term.constr table_status) LibraryMap.t)
+ ref (LibraryMap.empty : (Constr.constr table_status) LibraryMap.t)
let univ_tables =
- ref (LibraryMap.empty : (Univ.universe_context_set table_status) LibraryMap.t)
+ ref (LibraryMap.empty : (Univ.ContextSet.t table_status) LibraryMap.t)
let add_opaque_table dp st =
opaque_tables := LibraryMap.add dp st !opaque_tables
@@ -408,9 +407,9 @@ let () =
type seg_sum = summary_disk
type seg_lib = library_disk
type seg_univ = (* true = vivo, false = vi *)
- Univ.universe_context_set Future.computation array * Univ.universe_context_set * bool
+ Univ.ContextSet.t Future.computation array * Univ.ContextSet.t * bool
type seg_discharge = Opaqueproof.cooking_info list array
-type seg_proofs = Term.constr Future.computation array
+type seg_proofs = Constr.constr Future.computation array
let mk_library sd md digests univs =
{
@@ -465,8 +464,8 @@ let rec intern_library (needed, contents) (dir, f) from =
if not (DirPath.equal dir m.library_name) then
user_err ~hdr:"load_physical_library"
(str "The file " ++ str f ++ str " contains library" ++ spc () ++
- pr_dirpath m.library_name ++ spc () ++ str "and not library" ++
- spc() ++ pr_dirpath dir);
+ DirPath.print m.library_name ++ spc () ++ str "and not library" ++
+ spc() ++ DirPath.print dir);
Feedback.feedback (Feedback.FileLoaded(DirPath.to_string dir, f));
m.library_digests, intern_library_deps (needed, contents) dir m f
@@ -477,9 +476,9 @@ and intern_library_deps libs dir m from =
and intern_mandatory_library caller from libs (dir,d) =
let digest, libs = intern_library libs (dir, None) (Some from) in
if not (Safe_typing.digest_match ~actual:digest ~required:d) then
- user_err (str "Compiled library " ++ pr_dirpath caller ++
+ user_err (str "Compiled library " ++ DirPath.print caller ++
str " (in file " ++ str from ++ str ") makes inconsistent assumptions \
- over library " ++ pr_dirpath dir);
+ over library " ++ DirPath.print dir);
libs
let rec_intern_library libs (dir, f) =
@@ -617,7 +616,7 @@ let check_coq_overwriting p id =
let is_empty = match l with [] -> true | _ -> false in
if not !Flags.boot && not is_empty && Id.equal (List.last l) coq_root then
user_err
- (str "Cannot build module " ++ pr_dirpath p ++ str "." ++ pr_id id ++ str "." ++ spc () ++
+ (str "Cannot build module " ++ DirPath.print p ++ str "." ++ Id.print id ++ str "." ++ spc () ++
str "it starts with prefix \"Coq\" which is reserved for the Coq library.")
let start_library fo =
@@ -625,7 +624,7 @@ let start_library fo =
try
let lp = Loadpath.find_load_path (Filename.dirname fo) in
Loadpath.logical lp
- with Not_found -> Nameops.default_root_prefix
+ with Not_found -> Libnames.default_root_prefix
in
let file = Filename.chop_extension (Filename.basename fo) in
let id = Id.of_string file in
@@ -665,7 +664,7 @@ let current_reexports () = !libraries_exports_list
let error_recursively_dependent_library dir =
user_err
- (strbrk "Unable to use logical name " ++ pr_dirpath dir ++
+ (strbrk "Unable to use logical name " ++ DirPath.print dir ++
strbrk " to save current library because" ++
strbrk " it already depends on a library of this name.")
@@ -739,7 +738,7 @@ let save_library_to ?todo dir f otab =
System.marshal_out_segment f' ch (opaque_table : seg_proofs);
close_out ch;
(* Writing native code files *)
- if !Flags.native_compiler then
+ if !Flags.output_native_objects then
let fn = Filename.dirname f'^"/"^Nativecode.mod_uid_of_dirpath dir in
if not (Nativelib.compile_library dir ast fn) then
user_err Pp.(str "Could not compile the library to native code.")
diff --git a/library/library.mli b/library/library.mli
index 6c624ce52..63e7b95bb 100644
--- a/library/library.mli
+++ b/library/library.mli
@@ -29,9 +29,9 @@ val require_library_from_dirpath : (DirPath.t * string) list -> bool option -> u
type seg_sum
type seg_lib
type seg_univ = (* cst, all_cst, finished? *)
- Univ.universe_context_set Future.computation array * Univ.universe_context_set * bool
+ Univ.ContextSet.t Future.computation array * Univ.ContextSet.t * bool
type seg_discharge = Opaqueproof.cooking_info list array
-type seg_proofs = Term.constr Future.computation array
+type seg_proofs = Constr.constr Future.computation array
(** Open a module (or a library); if the boolean is true then it's also
an export otherwise just a simple import *)
diff --git a/library/library.mllib b/library/library.mllib
index d94fc2291..e43bfb5a1 100644
--- a/library/library.mllib
+++ b/library/library.mllib
@@ -1,5 +1,3 @@
-Univops
-Nameops
Libnames
Globnames
Libobject
diff --git a/library/loadpath.ml b/library/loadpath.ml
index 757e972b1..eb6dae84a 100644
--- a/library/loadpath.ml
+++ b/library/loadpath.ml
@@ -54,8 +54,8 @@ let warn_overriding_logical_loadpath =
CWarnings.create ~name:"overriding-logical-loadpath" ~category:"loadpath"
(fun (phys_path, old_path, coq_path) ->
str phys_path ++ strbrk " was previously bound to " ++
- pr_dirpath old_path ++ strbrk "; it is remapped to " ++
- pr_dirpath coq_path)
+ DirPath.print old_path ++ strbrk "; it is remapped to " ++
+ DirPath.print coq_path)
let add_load_path phys_path coq_path ~implicit =
let phys_path = CUnix.canonical_path_name phys_path in
@@ -75,7 +75,7 @@ let add_load_path phys_path coq_path ~implicit =
else
let () =
(* Do not warn when overriding the default "-I ." path *)
- if not (DirPath.equal old_path Nameops.default_root_prefix) then
+ if not (DirPath.equal old_path Libnames.default_root_prefix) then
warn_overriding_logical_loadpath (phys_path, old_path, coq_path)
in
true in
diff --git a/library/nameops.ml b/library/nameops.ml
deleted file mode 100644
index d598a63b8..000000000
--- a/library/nameops.ml
+++ /dev/null
@@ -1,215 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Util
-open Names
-
-(* Identifiers *)
-
-let pr_id id = Id.print id
-
-(* Utilities *)
-
-let code_of_0 = Char.code '0'
-let code_of_9 = Char.code '9'
-
-let cut_ident skip_quote s =
- let s = Id.to_string s in
- let slen = String.length s in
- (* [n'] is the position of the first non nullary digit *)
- let rec numpart n n' =
- if Int.equal n 0 then
- (* ident made of _ and digits only [and ' if skip_quote]: don't cut it *)
- slen
- else
- let c = Char.code (String.get s (n-1)) in
- if Int.equal c code_of_0 && not (Int.equal n slen) then
- numpart (n-1) n'
- else if code_of_0 <= c && c <= code_of_9 then
- numpart (n-1) (n-1)
- else if skip_quote && (Int.equal c (Char.code '\'') || Int.equal c (Char.code '_')) then
- numpart (n-1) (n-1)
- else
- n'
- in
- numpart slen slen
-
-let repr_ident s =
- let numstart = cut_ident false s in
- let s = Id.to_string s in
- let slen = String.length s in
- if Int.equal numstart slen then
- (s, None)
- else
- (String.sub s 0 numstart,
- Some (int_of_string (String.sub s numstart (slen - numstart))))
-
-let make_ident sa = function
- | Some n ->
- let c = Char.code (String.get sa (String.length sa -1)) in
- let s =
- if c < code_of_0 || c > code_of_9 then sa ^ (string_of_int n)
- else sa ^ "_" ^ (string_of_int n) in
- Id.of_string s
- | None -> Id.of_string sa
-
-let root_of_id id =
- let suffixstart = cut_ident true id in
- Id.of_string (String.sub (Id.to_string id) 0 suffixstart)
-
-(* Return the same identifier as the original one but whose {i subscript} is incremented.
- If the original identifier does not have a suffix, [0] is appended to it.
-
- Example mappings:
-
- [bar] ↦ [bar0]
- [bar0] ↦ [bar1]
- [bar00] ↦ [bar01]
- [bar1] ↦ [bar2]
- [bar01] ↦ [bar01]
- [bar9] ↦ [bar10]
- [bar09] ↦ [bar10]
- [bar99] ↦ [bar100]
-*)
-let increment_subscript id =
- let id = Id.to_string id in
- let len = String.length id in
- let rec add carrypos =
- let c = id.[carrypos] in
- if is_digit c then
- if Int.equal (Char.code c) (Char.code '9') then begin
- assert (carrypos>0);
- add (carrypos-1)
- end
- else begin
- let newid = Bytes.of_string id in
- Bytes.fill newid (carrypos+1) (len-1-carrypos) '0';
- Bytes.set newid carrypos (Char.chr (Char.code c + 1));
- newid
- end
- else begin
- let newid = Bytes.of_string (id^"0") in
- if carrypos < len-1 then begin
- Bytes.fill newid (carrypos+1) (len-1-carrypos) '0';
- Bytes.set newid (carrypos+1) '1'
- end;
- newid
- end
- in Id.of_bytes (add (len-1))
-
-let has_subscript id =
- let id = Id.to_string id in
- is_digit (id.[String.length id - 1])
-
-let forget_subscript id =
- let numstart = cut_ident false id in
- let newid = Bytes.make (numstart+1) '0' in
- String.blit (Id.to_string id) 0 newid 0 numstart;
- (Id.of_bytes newid)
-
-let add_suffix id s = Id.of_string (Id.to_string id ^ s)
-let add_prefix s id = Id.of_string (s ^ Id.to_string id)
-
-let atompart_of_id id = fst (repr_ident id)
-
-(* Names *)
-
-module type ExtName =
-sig
-
- include module type of struct include Names.Name end
-
- exception IsAnonymous
-
- val fold_left : ('a -> Id.t -> 'a) -> 'a -> t -> 'a
- val fold_right : (Id.t -> 'a -> 'a) -> t -> 'a -> 'a
- val iter : (Id.t -> unit) -> t -> unit
- val map : (Id.t -> Id.t) -> t -> t
- val fold_left_map : ('a -> Id.t -> 'a * Id.t) -> 'a -> t -> 'a * t
- val fold_right_map : (Id.t -> 'a -> Id.t * 'a) -> Name.t -> 'a -> Name.t * 'a
- val get_id : t -> Id.t
- val pick : t -> t -> t
- val cons : t -> Id.t list -> Id.t list
- val to_option : Name.t -> Id.t option
-
-end
-
-module Name : ExtName =
-struct
-
- include Names.Name
-
- exception IsAnonymous
-
- let fold_left f a = function
- | Name id -> f a id
- | Anonymous -> a
-
- let fold_right f na a =
- match na with
- | Name id -> f id a
- | Anonymous -> a
-
- let iter f na = fold_right (fun x () -> f x) na ()
-
- let map f = function
- | Name id -> Name (f id)
- | Anonymous -> Anonymous
-
- let fold_left_map f a = function
- | Name id -> let (a, id) = f a id in (a, Name id)
- | Anonymous -> a, Anonymous
-
- let fold_right_map f na a = match na with
- | Name id -> let (id, a) = f id a in (Name id, a)
- | Anonymous -> Anonymous, a
-
- let get_id = function
- | Name id -> id
- | Anonymous -> raise IsAnonymous
-
- let pick na1 na2 =
- match na1 with
- | Name _ -> na1
- | Anonymous -> na2
-
- let cons na l =
- match na with
- | Anonymous -> l
- | Name id -> id::l
-
- let to_option = function
- | Anonymous -> None
- | Name id -> Some id
-
-end
-
-open Name
-
-(* Compatibility *)
-let out_name = get_id
-let name_fold = fold_right
-let name_iter = iter
-let name_app = map
-let name_fold_map = fold_left_map
-let name_cons = cons
-let name_max = pick
-let pr_name = print
-
-let pr_lab l = Label.print l
-
-let default_library = Names.DirPath.initial (* = ["Top"] *)
-
-(*s Roots of the space of absolute names *)
-let coq_string = "Coq"
-let coq_root = Id.of_string coq_string
-let default_root_prefix = DirPath.empty
-
-(* Metavariables *)
-let pr_meta = Pp.int
-let string_of_meta = string_of_int
diff --git a/library/nameops.mli b/library/nameops.mli
deleted file mode 100644
index 58cd6ed4e..000000000
--- a/library/nameops.mli
+++ /dev/null
@@ -1,135 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Names
-
-(** Identifiers and names *)
-
-val make_ident : string -> int option -> Id.t
-val repr_ident : Id.t -> string * int option
-
-val atompart_of_id : Id.t -> string (** remove trailing digits *)
-val root_of_id : Id.t -> Id.t (** remove trailing digits, ' and _ *)
-
-val add_suffix : Id.t -> string -> Id.t
-val add_prefix : string -> Id.t -> Id.t
-
-(** Below, by {i subscript} we mean a suffix composed solely from (decimal) digits. *)
-
-val has_subscript : Id.t -> bool
-
-val increment_subscript : Id.t -> Id.t
-(** Return the same identifier as the original one but whose {i subscript} is incremented.
- If the original identifier does not have a suffix, [0] is appended to it.
-
- Example mappings:
-
- [bar] ↦ [bar0]
-
- [bar0] ↦ [bar1]
-
- [bar00] ↦ [bar01]
-
- [bar1] ↦ [bar2]
-
- [bar01] ↦ [bar01]
-
- [bar9] ↦ [bar10]
-
- [bar09] ↦ [bar10]
-
- [bar99] ↦ [bar100]
-*)
-
-val forget_subscript : Id.t -> Id.t
-
-module Name : sig
-
- include module type of struct include Names.Name end
-
- exception IsAnonymous
-
- val fold_left : ('a -> Id.t -> 'a) -> 'a -> Name.t -> 'a
- (** [fold_left f na a] is [f id a] if [na] is [Name id], and [a] otherwise. *)
-
- val fold_right : (Id.t -> 'a -> 'a) -> Name.t -> 'a -> 'a
- (** [fold_right f a na] is [f a id] if [na] is [Name id], and [a] otherwise. *)
-
- val iter : (Id.t -> unit) -> Name.t -> unit
- (** [iter f na] does [f id] if [na] equals [Name id], nothing otherwise. *)
-
- val map : (Id.t -> Id.t) -> Name.t -> t
- (** [map f na] is [Anonymous] if [na] is [Anonymous] and [Name (f id)] if [na] is [Name id]. *)
-
- val fold_left_map : ('a -> Id.t -> 'a * Id.t) -> 'a -> Name.t -> 'a * Name.t
- (** [fold_left_map f a na] is [a',Name id'] when [na] is [Name id] and [f a id] is [(a',id')].
- It is [a,Anonymous] otherwise. *)
-
- val fold_right_map : (Id.t -> 'a -> Id.t * 'a) -> Name.t -> 'a -> Name.t * 'a
- (** [fold_right_map f na a] is [Name id',a'] when [na] is [Name id] and [f id a] is [(id',a')].
- It is [Anonymous,a] otherwise. *)
-
- val get_id : Name.t -> Id.t
- (** [get_id] associates [id] to [Name id]. @raise IsAnonymous otherwise. *)
-
- val pick : Name.t -> Name.t -> Name.t
- (** [pick na na'] returns [Anonymous] if both names are [Anonymous].
- Pick one of [na] or [na'] otherwise. *)
-
- val cons : Name.t -> Id.t list -> Id.t list
- (** [cons na l] returns [id::l] if [na] is [Name id] and [l] otherwise. *)
-
- val to_option : Name.t -> Id.t option
- (** [to_option Anonymous] is [None] and [to_option (Name id)] is [Some id] *)
-
-end
-
-val out_name : Name.t -> Id.t
-(** @deprecated Same as [Name.get_id] *)
-
-val name_fold : (Id.t -> 'a -> 'a) -> Name.t -> 'a -> 'a
-(** @deprecated Same as [Name.fold_right] *)
-
-val name_iter : (Id.t -> unit) -> Name.t -> unit
-(** @deprecated Same as [Name.iter] *)
-
-val name_app : (Id.t -> Id.t) -> Name.t -> Name.t
-(** @deprecated Same as [Name.map] *)
-
-val name_fold_map : ('a -> Id.t -> 'a * Id.t) -> 'a -> Name.t -> 'a * Name.t
-(** @deprecated Same as [Name.fold_left_map] *)
-
-val name_max : Name.t -> Name.t -> Name.t
-(** @deprecated Same as [Name.pick] *)
-
-val name_cons : Name.t -> Id.t list -> Id.t list
-(** @deprecated Same as [Name.cons] *)
-
-val pr_name : Name.t -> Pp.t
-(** @deprecated Same as [Name.print] *)
-
-val pr_id : Id.t -> Pp.t
-(** @deprecated Same as [Names.Id.print] *)
-
-val pr_lab : Label.t -> Pp.t
-
-(** some preset paths *)
-
-val default_library : DirPath.t
-
-(** This is the root of the standard library of Coq *)
-val coq_root : module_ident (** "Coq" *)
-val coq_string : string (** "Coq" *)
-
-(** This is the default root prefix for developments which doesn't
- mention a root *)
-val default_root_prefix : DirPath.t
-
-(** Metavariables *)
-val pr_meta : Term.metavariable -> Pp.t
-val string_of_meta : Term.metavariable -> string
diff --git a/library/nametab.ml b/library/nametab.ml
index 0ec4a37cd..84225f863 100644
--- a/library/nametab.ml
+++ b/library/nametab.ml
@@ -302,6 +302,16 @@ module DirTab = Make(DirPath')(GlobDir)
type dirtab = DirTab.t
let the_dirtab = ref (DirTab.empty : dirtab)
+type universe_id = DirPath.t * int
+
+module UnivIdEqual =
+struct
+ type t = universe_id
+ let equal (d, i) (d', i') = DirPath.equal d d' && Int.equal i i'
+end
+module UnivTab = Make(FullPath)(UnivIdEqual)
+type univtab = UnivTab.t
+let the_univtab = ref (UnivTab.empty : univtab)
(* Reversed name tables ***************************************************)
@@ -318,6 +328,21 @@ let the_modrevtab = ref (MPmap.empty : mprevtab)
type mptrevtab = full_path MPmap.t
let the_modtyperevtab = ref (MPmap.empty : mptrevtab)
+module UnivIdOrdered =
+struct
+ type t = universe_id
+ let hash (d, i) = i + DirPath.hash d
+ let compare (d, i) (d', i') =
+ let c = Int.compare i i' in
+ if Int.equal c 0 then DirPath.compare d d'
+ else c
+end
+
+module UnivIdMap = HMap.Make(UnivIdOrdered)
+
+type univrevtab = full_path UnivIdMap.t
+let the_univrevtab = ref (UnivIdMap.empty : univrevtab)
+
(* Push functions *********************************************************)
(* This is for permanent constructions (never discharged -- but with
@@ -359,9 +384,14 @@ let push_modtype vis sp kn =
let push_dir vis dir dir_ref =
the_dirtab := DirTab.push vis dir dir_ref !the_dirtab;
match dir_ref with
- DirModule (_,(mp,_)) -> the_modrevtab := MPmap.add mp dir !the_modrevtab
- | _ -> ()
+ | DirModule { obj_mp; _ } -> the_modrevtab := MPmap.add obj_mp dir !the_modrevtab
+ | _ -> ()
+
+(* This is for global universe names *)
+let push_universe vis sp univ =
+ the_univtab := UnivTab.push vis sp univ !the_univtab;
+ the_univrevtab := UnivIdMap.add univ sp !the_univrevtab
(* Locate functions *******************************************************)
@@ -382,21 +412,23 @@ let locate_syndef qid = match locate_extended qid with
let locate_modtype qid = MPTab.locate qid !the_modtypetab
let full_name_modtype qid = MPTab.user_name qid !the_modtypetab
+let locate_universe qid = UnivTab.locate qid !the_univtab
+
let locate_dir qid = DirTab.locate qid !the_dirtab
let locate_module qid =
match locate_dir qid with
- | DirModule (_,(mp,_)) -> mp
+ | DirModule { obj_mp ; _} -> obj_mp
| _ -> raise Not_found
let full_name_module qid =
match locate_dir qid with
- | DirModule (dir,_) -> dir
+ | DirModule { obj_dir ; _} -> obj_dir
| _ -> raise Not_found
let locate_section qid =
match locate_dir qid with
- | DirOpenSection (dir, _)
+ | DirOpenSection { obj_dir; _ } -> obj_dir
| DirClosedSection dir -> dir
| _ -> raise Not_found
@@ -447,6 +479,8 @@ let exists_module = exists_dir
let exists_modtype sp = MPTab.exists sp !the_modtypetab
+let exists_universe kn = UnivTab.exists kn !the_univtab
+
(* Reverse locate functions ***********************************************)
let path_of_global ref =
@@ -469,6 +503,9 @@ let dirpath_of_module mp =
let path_of_modtype mp =
MPmap.find mp !the_modtyperevtab
+let path_of_universe mp =
+ UnivIdMap.find mp !the_univrevtab
+
(* Shortest qualid functions **********************************************)
let shortest_qualid_of_global ctx ref =
@@ -490,6 +527,10 @@ let shortest_qualid_of_modtype kn =
let sp = MPmap.find kn !the_modtyperevtab in
MPTab.shortest_qualid Id.Set.empty sp !the_modtypetab
+let shortest_qualid_of_universe kn =
+ let sp = UnivIdMap.find kn !the_univrevtab in
+ UnivTab.shortest_qualid Id.Set.empty sp !the_univtab
+
let pr_global_env env ref =
try pr_qualid (shortest_qualid_of_global env ref)
with Not_found as e ->
@@ -508,24 +549,28 @@ let global_inductive r =
(********************************************************************)
(* Registration of tables as a global table and rollback *)
-type frozen = ccitab * dirtab * mptab
- * globrevtab * mprevtab * mptrevtab
+type frozen = ccitab * dirtab * mptab * univtab
+ * globrevtab * mprevtab * mptrevtab * univrevtab
let freeze _ : frozen =
!the_ccitab,
!the_dirtab,
!the_modtypetab,
+ !the_univtab,
!the_globrevtab,
!the_modrevtab,
- !the_modtyperevtab
+ !the_modtyperevtab,
+ !the_univrevtab
-let unfreeze (ccit,dirt,mtyt,globr,modr,mtyr) =
+let unfreeze (ccit,dirt,mtyt,univt,globr,modr,mtyr,univr) =
the_ccitab := ccit;
the_dirtab := dirt;
the_modtypetab := mtyt;
+ the_univtab := univt;
the_globrevtab := globr;
the_modrevtab := modr;
- the_modtyperevtab := mtyr
+ the_modtyperevtab := mtyr;
+ the_univrevtab := univr
let _ =
Summary.declare_summary "names"
diff --git a/library/nametab.mli b/library/nametab.mli
index 3a380637c..77fafa100 100644
--- a/library/nametab.mli
+++ b/library/nametab.mli
@@ -74,10 +74,16 @@ val error_global_not_found : ?loc:Loc.t -> qualid -> 'a
type visibility = Until of int | Exactly of int
val push : visibility -> full_path -> global_reference -> unit
-val push_modtype : visibility -> full_path -> module_path -> unit
+val push_modtype : visibility -> full_path -> ModPath.t -> unit
val push_dir : visibility -> DirPath.t -> global_dir_reference -> unit
val push_syndef : visibility -> full_path -> syndef_name -> unit
+type universe_id = DirPath.t * int
+
+module UnivIdMap : CMap.ExtS with type key = universe_id
+
+val push_universe : visibility -> full_path -> universe_id -> unit
+
(** {6 The following functions perform globalization of qualified names } *)
(** These functions globalize a (partially) qualified name or fail with
@@ -85,12 +91,13 @@ val push_syndef : visibility -> full_path -> syndef_name -> unit
val locate : qualid -> global_reference
val locate_extended : qualid -> extended_global_reference
-val locate_constant : qualid -> constant
+val locate_constant : qualid -> Constant.t
val locate_syndef : qualid -> syndef_name
-val locate_modtype : qualid -> module_path
+val locate_modtype : qualid -> ModPath.t
val locate_dir : qualid -> global_dir_reference
-val locate_module : qualid -> module_path
+val locate_module : qualid -> ModPath.t
val locate_section : qualid -> DirPath.t
+val locate_universe : qualid -> universe_id
(** These functions globalize user-level references into global
references, like [locate] and co, but raise a nice error message
@@ -105,7 +112,7 @@ val global_inductive : reference -> inductive
val locate_all : qualid -> global_reference list
val locate_extended_all : qualid -> extended_global_reference list
val locate_extended_all_dir : qualid -> global_dir_reference list
-val locate_extended_all_modtype : qualid -> module_path list
+val locate_extended_all_modtype : qualid -> ModPath.t list
(** Mapping a full path to a global reference *)
@@ -119,6 +126,7 @@ val exists_modtype : full_path -> bool
val exists_dir : DirPath.t -> bool
val exists_section : DirPath.t -> bool (** deprecated synonym of [exists_dir] *)
val exists_module : DirPath.t -> bool (** deprecated synonym of [exists_dir] *)
+val exists_universe : full_path -> bool
(** {6 These functions locate qualids into full user names } *)
@@ -135,8 +143,12 @@ val full_name_module : qualid -> DirPath.t
val path_of_syndef : syndef_name -> full_path
val path_of_global : global_reference -> full_path
-val dirpath_of_module : module_path -> DirPath.t
-val path_of_modtype : module_path -> full_path
+val dirpath_of_module : ModPath.t -> DirPath.t
+val path_of_modtype : ModPath.t -> full_path
+
+(** A universe_id might not be registered with a corresponding user name.
+ @raise Not_found if the universe was not introduced by the user. *)
+val path_of_universe : universe_id -> full_path
(** Returns in particular the dirpath or the basename of the full path
associated to global reference *)
@@ -156,8 +168,9 @@ val pr_global_env : Id.Set.t -> global_reference -> Pp.t
val shortest_qualid_of_global : Id.Set.t -> global_reference -> qualid
val shortest_qualid_of_syndef : Id.Set.t -> syndef_name -> qualid
-val shortest_qualid_of_modtype : module_path -> qualid
-val shortest_qualid_of_module : module_path -> qualid
+val shortest_qualid_of_modtype : ModPath.t -> qualid
+val shortest_qualid_of_module : ModPath.t -> qualid
+val shortest_qualid_of_universe : universe_id -> qualid
(** Deprecated synonyms *)
diff --git a/library/summary.ml b/library/summary.ml
index 9f49d1f83..6df17476b 100644
--- a/library/summary.ml
+++ b/library/summary.ml
@@ -13,17 +13,22 @@ open Util
module Dyn = Dyn.Make ()
type marshallable = [ `Yes | `No | `Shallow ]
+
type 'a summary_declaration = {
freeze_function : marshallable -> 'a;
unfreeze_function : 'a -> unit;
init_function : unit -> unit }
-let summaries = ref Int.Map.empty
+let sum_mod = ref None
+let sum_map = ref String.Map.empty
let mangle id = id ^ "-SUMMARY"
+let unmangle id = String.(sub id 0 (length id - 8))
+
+let ml_modules = "ML-MODULES"
-let internal_declare_summary hash sumname sdecl =
- let (infun, outfun) = Dyn.Easy.make_dyn (mangle sumname) in
+let internal_declare_summary fadd sumname sdecl =
+ let infun, outfun, tag = Dyn.Easy.make_dyn_tag (mangle sumname) in
let dyn_freeze b = infun (sdecl.freeze_function b)
and dyn_unfreeze sum = sdecl.unfreeze_function (outfun sum)
and dyn_init = sdecl.init_function in
@@ -32,140 +37,116 @@ let internal_declare_summary hash sumname sdecl =
unfreeze_function = dyn_unfreeze;
init_function = dyn_init }
in
- summaries := Int.Map.add hash (sumname, ddecl) !summaries
+ fadd sumname ddecl;
+ tag
-let all_declared_summaries = ref Int.Set.empty
+let declare_ml_modules_summary decl =
+ let ml_add _ ddecl = sum_mod := Some ddecl in
+ internal_declare_summary ml_add ml_modules decl
-let summary_names = ref []
-let name_of_summary name =
- try List.assoc name !summary_names
- with Not_found -> "summary name not found"
+let declare_ml_modules_summary decl =
+ ignore(declare_ml_modules_summary decl)
-let declare_summary sumname decl =
- let hash = String.hash sumname in
- let () = if Int.Map.mem hash !summaries then
- let (name, _) = Int.Map.find hash !summaries in
- anomaly ~label:"Summary.declare_summary"
- (str "Colliding summary names: " ++ str sumname ++ str " vs. " ++ str name ++ str ".")
+let declare_summary_tag sumname decl =
+ let fadd name ddecl = sum_map := String.Map.add name ddecl !sum_map in
+ let () = if String.Map.mem sumname !sum_map then
+ anomaly ~label:"Summary.declare_summary"
+ (str "Colliding summary names: " ++ str sumname ++ str " vs. " ++ str sumname ++ str ".")
in
- all_declared_summaries := Int.Set.add hash !all_declared_summaries;
- summary_names := (hash, sumname) :: !summary_names;
- internal_declare_summary hash sumname decl
+ internal_declare_summary fadd sumname decl
+
+let declare_summary sumname decl =
+ ignore(declare_summary_tag sumname decl)
type frozen = {
- summaries : (int * Dyn.t) list;
+ summaries : Dyn.t String.Map.t;
(** Ordered list w.r.t. the first component. *)
ml_module : Dyn.t option;
(** Special handling of the ml_module summary. *)
}
-let empty_frozen = { summaries = []; ml_module = None; }
-
-let ml_modules = "ML-MODULES"
-let ml_modules_summary = String.hash ml_modules
+let empty_frozen = { summaries = String.Map.empty; ml_module = None }
let freeze_summaries ~marshallable : frozen =
- let fold id (_, decl) accu =
- (* to debug missing Lazy.force
- if marshallable <> `No then begin
- let id, _ = Int.Map.find id !summaries in
- prerr_endline ("begin marshalling " ^ id);
- ignore(Marshal.to_string (decl.freeze_function marshallable) []);
- prerr_endline ("end marshalling " ^ id);
- end;
- /debug *)
- let state = decl.freeze_function marshallable in
- if Int.equal id ml_modules_summary then { accu with ml_module = Some state }
- else { accu with summaries = (id, state) :: accu.summaries }
+ let smap decl = decl.freeze_function marshallable in
+ { summaries = String.Map.map smap !sum_map;
+ ml_module = Option.map (fun decl -> decl.freeze_function marshallable) !sum_mod;
+ }
+
+let unfreeze_single name state =
+ let decl =
+ try String.Map.find name !sum_map
+ with
+ | Not_found ->
+ CErrors.anomaly Pp.(str "trying to unfreeze unregistered summary " ++ str name)
in
- Int.Map.fold_right fold !summaries empty_frozen
-
-let unfreeze_summaries fs =
+ try decl.unfreeze_function state
+ with e when CErrors.noncritical e ->
+ let e = CErrors.push e in
+ Feedback.msg_warning
+ Pp.(seq [str "Error unfreezing summary "; str name; fnl (); CErrors.iprint e]);
+ iraise e
+
+let unfreeze_summaries ?(partial=false) { summaries; ml_module } =
(* The unfreezing of [ml_modules_summary] has to be anticipated since it
- * may modify the content of [summaries] ny loading new ML modules *)
- let (_, decl) =
- try Int.Map.find ml_modules_summary !summaries
- with Not_found -> anomaly (str "Undeclared summary " ++ str ml_modules ++ str ".")
- in
- let () = match fs.ml_module with
+ * may modify the content of [summaries] by loading new ML modules *)
+ begin match !sum_mod with
| None -> anomaly (str "Undeclared summary " ++ str ml_modules ++ str ".")
- | Some state -> decl.unfreeze_function state
- in
- let fold id (_, decl) states =
- if Int.equal id ml_modules_summary then states
- else match states with
- | [] ->
- let () = decl.init_function () in
- []
- | (nid, state) :: rstates ->
- if Int.equal id nid then
- let () = decl.unfreeze_function state in rstates
- else
- let () = decl.init_function () in states
+ | Some decl -> Option.iter (fun state -> decl.unfreeze_function state) ml_module
+ end;
+ (** We must be independent on the order of the map! *)
+ let ufz name decl =
+ try decl.unfreeze_function String.Map.(find name summaries)
+ with Not_found ->
+ if not partial then begin
+ Feedback.msg_warning Pp.(str "Summary was captured out of module scope for entry " ++ str name);
+ decl.init_function ()
+ end;
in
- let fold id decl state =
- try fold id decl state
- with e when CErrors.noncritical e ->
- let e = CErrors.push e in
- Feedback.msg_error
- Pp.(seq [str "Error unfreezing summary %s\n%s\n%!";
- str (name_of_summary id);
- CErrors.iprint e]);
- iraise e
- in
- (** We rely on the order of the frozen list, and the order of folding *)
- ignore (Int.Map.fold_left fold !summaries fs.summaries)
+ (* String.Map.iter unfreeze_single !sum_map *)
+ String.Map.iter ufz !sum_map
let init_summaries () =
- Int.Map.iter (fun _ (_, decl) -> decl.init_function ()) !summaries
+ String.Map.iter (fun _ decl -> decl.init_function ()) !sum_map
(** For global tables registered statically before the end of coqtop
launch, the following empty [init_function] could be used. *)
let nop () = ()
-(** Selective freeze *)
+(** Summary projection *)
+let project_from_summary { summaries } tag =
+ let id = unmangle (Dyn.repr tag) in
+ let state = String.Map.find id summaries in
+ Option.get (Dyn.Easy.prj state tag)
+
+let modify_summary st tag v =
+ let id = unmangle (Dyn.repr tag) in
+ let summaries = String.Map.set id (Dyn.Easy.inj v tag) st.summaries in
+ {st with summaries}
-type frozen_bits = (int * Dyn.t) list
+let remove_from_summary st tag =
+ let id = unmangle (Dyn.repr tag) in
+ let summaries = String.Map.remove id st.summaries in
+ {st with summaries}
+
+(** Selective freeze *)
-let ids_of_string_list complement ids =
- if not complement then List.map String.hash ids
- else
- let fold accu id =
- let id = String.hash id in
- Int.Set.remove id accu
- in
- let ids = List.fold_left fold !all_declared_summaries ids in
- Int.Set.elements ids
+type frozen_bits = Dyn.t String.Map.t
let freeze_summary ~marshallable ?(complement=false) ids =
- let ids = ids_of_string_list complement ids in
- List.map (fun id ->
- let (_, summary) = Int.Map.find id !summaries in
- id, summary.freeze_function marshallable)
- ids
-
-let unfreeze_summary datas =
- List.iter
- (fun (id, data) ->
- let (name, summary) = Int.Map.find id !summaries in
- try summary.unfreeze_function data
- with e ->
- let e = CErrors.push e in
- prerr_endline ("Exception unfreezing " ^ name);
- iraise e)
- datas
+ let sub_map = String.Map.filter (fun id _ -> complement <> List.(mem id ids)) !sum_map in
+ String.Map.map (fun decl -> decl.freeze_function marshallable) sub_map
+
+let unfreeze_summary = String.Map.iter unfreeze_single
let surgery_summary { summaries; ml_module } bits =
- let summaries = List.map (fun (id, _ as orig) ->
- try id, List.assoc id bits
- with Not_found -> orig)
- summaries in
+ let summaries =
+ String.Map.fold (fun hash state sum -> String.Map.set hash state sum ) summaries bits in
{ summaries; ml_module }
let project_summary { summaries; ml_module } ?(complement=false) ids =
- let ids = ids_of_string_list complement ids in
- List.filter (fun (id, _) -> List.mem id ids) summaries
+ String.Map.filter (fun name _ -> complement <> List.(mem name ids)) summaries
let pointer_equal l1 l2 =
let ptr_equal d1 d2 =
@@ -174,19 +155,22 @@ let pointer_equal l1 l2 =
match Dyn.eq t1 t2 with
| None -> false
| Some Refl -> x1 == x2
- in
+ in
+ let l1, l2 = String.Map.bindings l1, String.Map.bindings l2 in
CList.for_all2eq
(fun (id1,v1) (id2,v2) -> id1 = id2 && ptr_equal v1 v2) l1 l2
(** All-in-one reference declaration + registration *)
-let ref ?(freeze=fun _ r -> r) ~name x =
+let ref_tag ?(freeze=fun _ r -> r) ~name x =
let r = ref x in
- declare_summary name
+ let tag = declare_summary_tag name
{ freeze_function = (fun b -> freeze b !r);
unfreeze_function = ((:=) r);
- init_function = (fun () -> r := x) };
- r
+ init_function = (fun () -> r := x) } in
+ r, tag
+
+let ref ?freeze ~name x = fst @@ ref_tag ?freeze ~name x
module Local = struct
@@ -198,8 +182,7 @@ let (!) r =
let key, name = !r in
try CEphemeron.get key
with CEphemeron.InvalidKey ->
- let _, { init_function } =
- Int.Map.find (String.hash (mangle name)) !summaries in
+ let { init_function } = String.Map.find name !sum_map in
init_function ();
CEphemeron.get (fst !r)
diff --git a/library/summary.mli b/library/summary.mli
index d093d95f2..09447199e 100644
--- a/library/summary.mli
+++ b/library/summary.mli
@@ -36,6 +36,12 @@ type 'a summary_declaration = {
val declare_summary : string -> 'a summary_declaration -> unit
+(** We provide safe projection from the summary to the types stored in
+ it.*)
+module Dyn : Dyn.S
+
+val declare_summary_tag : string -> 'a summary_declaration -> 'a Dyn.tag
+
(** All-in-one reference declaration + summary registration.
It behaves just as OCaml's standard [ref] function, except
that a [declare_summary] is done, with [name] as string.
@@ -43,6 +49,7 @@ val declare_summary : string -> 'a summary_declaration -> unit
The [freeze_function] can be overridden *)
val ref : ?freeze:(marshallable -> 'a -> 'a) -> name:string -> 'a -> 'a ref
+val ref_tag : ?freeze:(marshallable -> 'a -> 'a) -> name:string -> 'a -> 'a ref * 'a Dyn.tag
(* As [ref] but the value is local to a process, i.e. not sent to, say, proof
* workers. It is useful to implement a local cache for example. *)
@@ -55,10 +62,11 @@ module Local : sig
end
-(** Special name for the summary of ML modules. This summary entry is
- special because its unfreeze may load ML code and hence add summary
- entries. Thus is has to be recognizable, and handled appropriately *)
-val ml_modules : string
+(** Special summary for ML modules. This summary entry is special
+ because its unfreeze may load ML code and hence add summary
+ entries. Thus is has to be recognizable, and handled properly.
+ *)
+val declare_ml_modules_summary : 'a summary_declaration -> unit
(** For global tables registered statically before the end of coqtop
launch, the following empty [init_function] could be used. *)
@@ -72,19 +80,34 @@ type frozen
val empty_frozen : frozen
val freeze_summaries : marshallable:marshallable -> frozen
-val unfreeze_summaries : frozen -> unit
+val unfreeze_summaries : ?partial:bool -> frozen -> unit
val init_summaries : unit -> unit
-(** The type [frozen_bits] is a snapshot of some of the registered tables *)
+(** Typed projection of the summary. Experimental API, use with CARE *)
+
+val modify_summary : frozen -> 'a Dyn.tag -> 'a -> frozen
+val project_from_summary : frozen -> 'a Dyn.tag -> 'a
+val remove_from_summary : frozen -> 'a Dyn.tag -> frozen
+
+(** The type [frozen_bits] is a snapshot of some of the registered
+ tables. It is DEPRECATED in favor of the typed projection
+ version. *)
+
type frozen_bits
+[@@ocaml.deprecated "Please use the typed version of summary projection"]
-val freeze_summary :
- marshallable:marshallable -> ?complement:bool -> string list -> frozen_bits
+[@@@ocaml.warning "-3"]
+val freeze_summary : marshallable:marshallable -> ?complement:bool -> string list -> frozen_bits
+[@@ocaml.deprecated "Please use the typed version of summary projection"]
val unfreeze_summary : frozen_bits -> unit
+[@@ocaml.deprecated "Please use the typed version of summary projection"]
val surgery_summary : frozen -> frozen_bits -> frozen
+[@@ocaml.deprecated "Please use the typed version of summary projection"]
val project_summary : frozen -> ?complement:bool -> string list -> frozen_bits
+[@@ocaml.deprecated "Please use the typed version of summary projection"]
val pointer_equal : frozen_bits -> frozen_bits -> bool
+[@@ocaml.deprecated "Please use the typed version of summary projection"]
+[@@@ocaml.warning "+3"]
(** {6 Debug} *)
-
val dump : unit -> (int * string) list
diff --git a/library/univops.ml b/library/univops.ml
deleted file mode 100644
index 3bafb824d..000000000
--- a/library/univops.ml
+++ /dev/null
@@ -1,40 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Term
-open Univ
-
-let universes_of_constr c =
- let rec aux s c =
- match kind_of_term c with
- | Const (_, u) | Ind (_, u) | Construct (_, u) ->
- LSet.fold LSet.add (Instance.levels u) s
- | Sort u when not (Sorts.is_small u) ->
- let u = univ_of_sort u in
- LSet.fold LSet.add (Universe.levels u) s
- | _ -> fold_constr aux s c
- in aux LSet.empty c
-
-let restrict_universe_context (univs,csts) s =
- (* Universes that are not necessary to typecheck the term.
- E.g. univs introduced by tactics and not used in the proof term. *)
- let diff = LSet.diff univs s in
- let rec aux diff candid univs ness =
- let (diff', candid', univs', ness') =
- Constraint.fold
- (fun (l, d, r as c) (diff, candid, univs, csts) ->
- if not (LSet.mem l diff) then
- (LSet.remove r diff, candid, univs, Constraint.add c csts)
- else if not (LSet.mem r diff) then
- (LSet.remove l diff, candid, univs, Constraint.add c csts)
- else (diff, Constraint.add c candid, univs, csts))
- candid (diff, Constraint.empty, univs, ness)
- in
- if ness' == ness then (LSet.diff univs diff', ness)
- else aux diff' candid' univs' ness'
- in aux diff csts univs Constraint.empty
diff --git a/library/univops.mli b/library/univops.mli
deleted file mode 100644
index 09147cb41..000000000
--- a/library/univops.mli
+++ /dev/null
@@ -1,15 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Term
-open Univ
-
-(** Shrink a universe context to a restricted set of variables *)
-
-val universes_of_constr : constr -> universe_set
-val restrict_universe_context : universe_context_set -> universe_set -> universe_context_set
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-06 15:19:24 +0000