aboutsummaryrefslogtreecommitdiff
path: root/plugins/setoid_ring
diff options
context:
space:
mode:
Diffstat (limited to 'plugins/setoid_ring')
-rw-r--r--plugins/setoid_ring/ArithRing.v19
-rw-r--r--plugins/setoid_ring/g_newring.ml410
-rw-r--r--plugins/setoid_ring/newring.ml30
3 files changed, 36 insertions, 23 deletions
diff --git a/plugins/setoid_ring/ArithRing.v b/plugins/setoid_ring/ArithRing.v
index 447acb9057..8e4d8b0d34 100644
--- a/plugins/setoid_ring/ArithRing.v
+++ b/plugins/setoid_ring/ArithRing.v
@@ -41,9 +41,12 @@ Ltac Ss_to_add f acc :=
| _ => constr:((acc + f)%nat)
end.
+(* For internal use only *)
+Local Definition protected_to_nat := N.to_nat.
+
Ltac natprering :=
match goal with
- |- context C [S ?p] =>
+ |- context C [S ?p] =>
match p with
O => fail 1 (* avoid replacing 1 with 1+0 ! *)
| p => match isnatcst p with
@@ -52,9 +55,19 @@ Ltac natprering :=
fold v; natprering
end
end
- | _ => idtac
+ | _ => change N.to_nat with protected_to_nat
+ end.
+
+Ltac natpostring :=
+ match goal with
+ | |- context [N.to_nat ?x] =>
+ let v := eval cbv in (N.to_nat x) in
+ change (N.to_nat x) with v;
+ natpostring
+ | _ => change protected_to_nat with N.to_nat
end.
Add Ring natr : natSRth
- (morphism nat_morph_N, constants [natcst], preprocess [natprering]).
+ (morphism nat_morph_N, constants [natcst],
+ preprocess [natprering], postprocess [natpostring]).
diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.ml4
index 05ab8ab326..a7d6d5bb20 100644
--- a/plugins/setoid_ring/g_newring.ml4
+++ b/plugins/setoid_ring/g_newring.ml4
@@ -82,10 +82,11 @@ VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF
| [ "Print" "Rings" ] => [Vernac_classifier.classify_as_query] -> [
Feedback.msg_notice (strbrk "The following ring structures have been declared:");
Spmap.iter (fun fn fi ->
+ let sigma, env = Pfedit.get_current_context () in
Feedback.msg_notice (hov 2
(Ppconstr.pr_id (Libnames.basename fn)++spc()++
- str"with carrier "++ pr_constr fi.ring_carrier++spc()++
- str"and equivalence relation "++ pr_constr fi.ring_req))
+ str"with carrier "++ pr_constr_env env sigma fi.ring_carrier++spc()++
+ str"and equivalence relation "++ pr_constr_env env sigma fi.ring_req))
) !from_name ]
END
@@ -117,10 +118,11 @@ VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF
| [ "Print" "Fields" ] => [Vernac_classifier.classify_as_query] -> [
Feedback.msg_notice (strbrk "The following field structures have been declared:");
Spmap.iter (fun fn fi ->
+ let sigma, env = Pfedit.get_current_context () in
Feedback.msg_notice (hov 2
(Ppconstr.pr_id (Libnames.basename fn)++spc()++
- str"with carrier "++ pr_constr fi.field_carrier++spc()++
- str"and equivalence relation "++ pr_constr fi.field_req))
+ str"with carrier "++ pr_constr_env env sigma fi.field_carrier++spc()++
+ str"and equivalence relation "++ pr_constr_env env sigma fi.field_req))
) !field_from_name ]
END
diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml
index 9e4b896f8e..f22f00839a 100644
--- a/plugins/setoid_ring/newring.ml
+++ b/plugins/setoid_ring/newring.ml
@@ -150,13 +150,13 @@ let ic_unsafe c = (*FIXME remove *)
let sigma = Evd.from_env env in
EConstr.of_constr (fst (Constrintern.interp_constr env sigma c))
-let decl_constant na ctx c =
+let decl_constant na univs c =
let open Constr in
let vars = Univops.universes_of_constr c in
- let ctx = Univops.restrict_universe_context (Univ.ContextSet.of_context ctx) vars in
+ let univs = Univops.restrict_universe_context univs vars in
+ let univs = Monomorphic_const_entry univs in
mkConst(declare_constant (Id.of_string na)
- (DefinitionEntry (definition_entry ~opaque:true
- ~univs:(Univ.ContextSet.to_context ctx) c),
+ (DefinitionEntry (definition_entry ~opaque:true ~univs c),
IsProof Lemma))
(* Calling a global tactic *)
@@ -220,7 +220,7 @@ let exec_tactic env evd n f args =
let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic_ist ist (ltac_call f (args@[getter]))) gl in
let evd, nf = Evarutil.nf_evars_and_universes (Refiner.project gls) in
let nf c = nf (constr_of c) in
- Array.map nf !tactic_res, snd (Evd.universe_context ~names:[] ~extensible:true evd)
+ Array.map nf !tactic_res, Evd.universe_context_set evd
let stdlib_modules =
[["Coq";"Setoids";"Setoid"];
@@ -344,8 +344,6 @@ let _ = add_map "ring"
(****************************************************************************)
(* Ring database *)
-let pr_constr c = pr_econstr c
-
module Cmap = Map.Make(Constr)
let from_carrier = Summary.ref Cmap.empty ~name:"ring-tac-carrier-table"
@@ -368,7 +366,7 @@ let find_ring_structure env sigma l =
with Not_found ->
CErrors.user_err ~hdr:"ring"
(str"cannot find a declared ring structure over"++
- spc()++str"\""++pr_constr ty++str"\""))
+ spc() ++ str"\"" ++ pr_econstr_env env sigma ty ++ str"\""))
| [] -> assert false
let add_entry (sp,_kn) e =
@@ -529,19 +527,19 @@ let ring_equality env evd (r,add,mul,opp,req) =
op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in
Flags.if_verbose
Feedback.msg_info
- (str"Using setoid \""++pr_constr req++str"\""++spc()++
- str"and morphisms \""++pr_constr add_m_lem ++
- str"\","++spc()++ str"\""++pr_constr mul_m_lem++
- str"\""++spc()++str"and \""++pr_constr opp_m_lem++
+ (str"Using setoid \""++ pr_econstr_env env !evd req++str"\""++spc()++
+ str"and morphisms \""++pr_econstr_env env !evd add_m_lem ++
+ str"\","++spc()++ str"\""++pr_econstr_env env !evd mul_m_lem++
+ str"\""++spc()++str"and \""++pr_econstr_env env !evd opp_m_lem++
str"\"");
op_morph)
| None ->
(Flags.if_verbose
Feedback.msg_info
- (str"Using setoid \""++pr_constr req ++str"\"" ++ spc() ++
- str"and morphisms \""++pr_constr add_m_lem ++
+ (str"Using setoid \""++pr_econstr_env env !evd req ++str"\"" ++ spc() ++
+ str"and morphisms \""++pr_econstr_env env !evd add_m_lem ++
str"\""++spc()++str"and \""++
- pr_constr mul_m_lem++str"\"");
+ pr_econstr_env env !evd mul_m_lem++str"\"");
op_smorph r add mul req add_m_lem mul_m_lem) in
(setoid,op_morph)
@@ -861,7 +859,7 @@ let find_field_structure env sigma l =
with Not_found ->
CErrors.user_err ~hdr:"field"
(str"cannot find a declared field structure over"++
- spc()++str"\""++pr_constr ty++str"\""))
+ spc()++str"\""++pr_econstr_env env sigma ty++str"\""))
| [] -> assert false
let add_field_entry (sp,_kn) e =
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-03 13:15:44 +0000