aboutsummaryrefslogtreecommitdiff
path: root/library
diff options
context:
space:
mode:
Diffstat (limited to 'library')
-rw-r--r--library/global.ml2
-rw-r--r--library/global.mli6
-rw-r--r--library/globnames.ml2
-rw-r--r--library/lib.ml49
-rw-r--r--library/lib.mli11
-rw-r--r--library/library.ml4
-rw-r--r--library/nametab.ml9
7 files changed, 52 insertions, 31 deletions
diff --git a/library/global.ml b/library/global.ml
index ce37dfecff..ed847b7cdb 100644
--- a/library/global.ml
+++ b/library/global.ml
@@ -81,7 +81,7 @@ let globalize_with_summary fs f =
let i2l = Label.of_id
let push_named_assum a = globalize0 (Safe_typing.push_named_assum a)
-let push_named_def d = globalize (Safe_typing.push_named_def d)
+let push_named_def d = globalize0 (Safe_typing.push_named_def d)
let add_constraints c = globalize0 (Safe_typing.add_constraints c)
let push_context_set b c = globalize0 (Safe_typing.push_context_set b c)
let push_context b c = globalize0 (Safe_typing.push_context b c)
diff --git a/library/global.mli b/library/global.mli
index 324181e79e..03bc945dad 100644
--- a/library/global.mli
+++ b/library/global.mli
@@ -32,11 +32,11 @@ 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.ContextSet.t
+val push_named_def : (Id.t * Entries.section_def_entry) -> unit
val export_private_constants : in_section:bool ->
- Safe_typing.private_constants Entries.constant_entry ->
- unit Entries.constant_entry * Safe_typing.exported_private_constant list
+ Safe_typing.private_constants Entries.definition_entry ->
+ unit Entries.definition_entry * Safe_typing.exported_private_constant list
val add_constant :
DirPath.t -> Id.t -> Safe_typing.global_declaration -> Constant.t
diff --git a/library/globnames.ml b/library/globnames.ml
index 9d7ab2db8d..a6e75fdb6a 100644
--- a/library/globnames.ml
+++ b/library/globnames.ml
@@ -30,7 +30,7 @@ let eq_gr gr1 gr2 =
| IndRef kn1, IndRef kn2 -> eq_ind kn1 kn2
| ConstructRef kn1, ConstructRef kn2 -> eq_constructor kn1 kn2
| VarRef v1, VarRef v2 -> Id.equal v1 v2
- | _ -> false
+ | (ConstRef _ | IndRef _ | ConstructRef _ | VarRef _), _ -> false
let destVarRef = function VarRef ind -> ind | _ -> failwith "destVarRef"
let destConstRef = function ConstRef ind -> ind | _ -> failwith "destConstRef"
diff --git a/library/lib.ml b/library/lib.ml
index 499e2ae21f..971089c171 100644
--- a/library/lib.ml
+++ b/library/lib.ml
@@ -417,8 +417,11 @@ let find_opening_node id =
type variable_info = Context.Named.Declaration.t * Decl_kinds.binding_kind
type variable_context = variable_info list
-type abstr_info = variable_context * Univ.universe_level_subst * Univ.AUContext.t
-
+type abstr_info = {
+ abstr_ctx : variable_context;
+ abstr_subst : Univ.Instance.t;
+ abstr_uctx : Univ.AUContext.t;
+}
type abstr_list = abstr_info Names.Cmap.t * abstr_info Names.Mindmap.t
type secentry =
@@ -483,8 +486,12 @@ let add_section_replacement f g poly hyps =
let inst = Univ.UContext.instance ctx in
let subst, ctx = Univ.abstract_universes ctx in
let args = instance_from_variable_context (List.rev sechyps) in
- sectab := (vars,f (inst,args) exps,
- g (sechyps,subst,ctx) abs)::sl
+ let info = {
+ abstr_ctx = sechyps;
+ abstr_subst = subst;
+ abstr_uctx = ctx;
+ } in
+ sectab := (vars,f (inst,args) exps, g info abs) :: sl
let add_section_kn poly kn =
let f x (l1,l2) = (l1,Names.Mindmap.add kn x l2) in
@@ -502,12 +509,21 @@ let section_segment_of_constant con =
let section_segment_of_mutual_inductive kn =
Names.Mindmap.find kn (snd (pi3 (List.hd !sectab)))
-let variable_section_segment_of_reference = function
- | ConstRef con -> pi1 (section_segment_of_constant con)
- | IndRef (kn,_) | ConstructRef ((kn,_),_) ->
- pi1 (section_segment_of_mutual_inductive kn)
- | _ -> []
-
+let empty_segment = {
+ abstr_ctx = [];
+ abstr_subst = Univ.Instance.empty;
+ abstr_uctx = Univ.AUContext.empty;
+}
+
+let section_segment_of_reference = function
+| ConstRef c -> section_segment_of_constant c
+| IndRef (kn,_) | ConstructRef ((kn,_),_) ->
+ section_segment_of_mutual_inductive kn
+| VarRef _ -> empty_segment
+
+let variable_section_segment_of_reference gr =
+ (section_segment_of_reference gr).abstr_ctx
+
let section_instance = function
| VarRef id ->
let eq = function
@@ -654,15 +670,10 @@ let discharge_con cst =
let discharge_inductive (kn,i) =
(discharge_kn kn,i)
-let discharge_abstract_universe_context (_, subst, abs_ctx) auctx =
+let discharge_abstract_universe_context { abstr_subst = subst; abstr_uctx = abs_ctx } auctx =
let open Univ in
- let len = LMap.cardinal subst in
- let rec gen_subst i acc =
- if i < 0 then acc
- else
- let acc = LMap.add (Level.var i) (Level.var (i + len)) acc in
- gen_subst (pred i) acc
- in
- let subst = gen_subst (AUContext.size auctx - 1) subst in
+ let ainst = make_abstract_instance auctx in
+ let subst = Instance.append subst ainst in
+ let subst = make_instance_subst subst in
let auctx = Univ.subst_univs_level_abstract_universe_context subst auctx in
subst, AUContext.union abs_ctx auctx
diff --git a/library/lib.mli b/library/lib.mli
index 721e2896f7..cf75d5f8cf 100644
--- a/library/lib.mli
+++ b/library/lib.mli
@@ -153,13 +153,22 @@ val init : unit -> unit
(** {6 Section management for discharge } *)
type variable_info = Context.Named.Declaration.t * Decl_kinds.binding_kind
type variable_context = variable_info list
-type abstr_info = variable_context * Univ.universe_level_subst * Univ.AUContext.t
+type abstr_info = private {
+ abstr_ctx : variable_context;
+ (** Section variables of this prefix *)
+ abstr_subst : Univ.Instance.t;
+ (** Actual names of the abstracted variables *)
+ abstr_uctx : Univ.AUContext.t;
+ (** Universe quantification, same length as the substitution *)
+}
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.t -> abstr_info
val section_segment_of_mutual_inductive: Names.MutInd.t -> abstr_info
+val section_segment_of_reference : Globnames.global_reference -> abstr_info
+
val variable_section_segment_of_reference : Globnames.global_reference -> variable_context
val section_instance : Globnames.global_reference -> Univ.Instance.t * Names.Id.t array
diff --git a/library/library.ml b/library/library.ml
index 88470d121b..868e26684d 100644
--- a/library/library.ml
+++ b/library/library.ml
@@ -170,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
@@ -738,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/nametab.ml b/library/nametab.ml
index 84225f8639..08881d6d7a 100644
--- a/library/nametab.ml
+++ b/library/nametab.ml
@@ -81,8 +81,9 @@ struct
Module F (X : S). Module X.
The argument X of the functor F is masked by the inner module X.
*)
- let masking_absolute n =
- Flags.if_verbose Feedback.msg_info (str ("Trying to mask the absolute name \"" ^ U.to_string n ^ "\"!"))
+ let warn_masking_absolute =
+ CWarnings.create ~name:"masking-absolute-name" ~category:"deprecated"
+ (fun n -> str ("Trying to mask the absolute name \"" ^ U.to_string n ^ "\"!"))
type user_name = U.t
@@ -121,7 +122,7 @@ struct
| Absolute (n,_) ->
(* This is an absolute name, we must keep it
otherwise it may become unaccessible forever *)
- masking_absolute n; tree.path
+ warn_masking_absolute n; tree.path
| Nothing
| Relative _ -> Relative (uname,o)
else tree.path
@@ -154,7 +155,7 @@ let rec push_exactly uname o level tree = function
| Absolute (n,_) ->
(* This is an absolute name, we must keep it
otherwise it may become unaccessible forever *)
- masking_absolute n; tree.path
+ warn_masking_absolute n; tree.path
| Nothing
| Relative _ -> Relative (uname,o)
in
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-03 10:44:32 +0000